#
# Copyright (c) 1993 Eric Schenk.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
# 
# IN NO EVENT SHALL ERIC SCHENK BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF ERIC
# SCHENK HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# ERIC SCHENK SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND ERIC SCHENK HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

# Decoration widgets.

# These are two demonstration decoration widgets:
# tkwm_client_frame and tkwm_icon_frame. The tkwm_client_frame
# widget depends on the motif_button and motif_menubutton widgets.

# Utility to allow use to modify the client frame's set of widgets

set tkwm_client_frame::buttons {}

proc tkwm_client_frame::new_button {name widget args} {
    global tkwm_client_frame::buttons
    lappend tkwm_client_frame::buttons $name
    set body "uplevel $widget \[list \"\$path\"\] $args \$args"
    proc tkwm_client_frame::button_$name {path args} $body
}

tkwm_client_frame::new_button menu motif_menubutton \
    {-menu .client_menu -command {handleError {$current_client.plug delete} {destroy $current_client}} -geometry ${d}x$d -insidegeometry [expr "$d-6"]x6}


tkwm_client_frame::new_button zoom motif_button \
    {-command "zoom $client" -geometry ${d}x$d \
    -insidegeometry [expr "$d-6"]x[expr "$d-6"]}

tkwm_client_frame::new_button iconify motif_button \
    {-command "iconify $client" -geometry ${d}x$d -insidegeometry 6x6}

# set up the default values for the widgets configuration

tkwm_widget::setdefaults frame tkwm_client_frame {
	{-geometry geometry Geometry {}}
	{-font font Font -Adobe-Helvetica-Bold-R-Normal--*-120-*}
	{-background background Background white}
	{-foreground foreground Foreground black}
	{-activeBackground activeBackground ActiveBackground black}
	{-activeForeground activeForeground ActiveForeground white}
	{-cursor cursor Cursor {}}
	{-title title Title {}}
	{-borderwidth borderWidth BorderWidth 6}
	{-leftbuttons leftButtons LeftButtons {menu}}
	{-rightbuttons rightButtons RightButtons {zoom iconify}}
	{-titlebar titlebar Titlebar 1}}

# Widget constructor

proc tkwm_client_frame {var args} {
    upvar "#0" $var data

    # Do the intial configuration
    tkwm_widget::initialconfigure tkwm_client_frame TkwmClientFrame $var args

    # return the inside frame of the widget
    # this is where things inside the widget should be "packed".
    return $data(inframe)
}

# Create the widget's internal hierarchy

proc tkwm_client_frame::create {var} {
    global tkwm_client_frame::buttons
    upvar "#0" $var data
    set w $var

    set data(active) 0

    # widgets
    set wd1 [expr {$data(-borderwidth)>=1?($data(-borderwidth)>=4?2:1):0}]
    set wd3 [expr {$data(-borderwidth)>=4?1:0}]
    set wd4 [expr {$data(-borderwidth)>=2?1:0}]
    set wd2 [expr {$data(-borderwidth)-($wd1+$wd3+$wd4)}]
    $w config -borderwidth $wd1 -relief raised -background $data(-background) \
	-cursor $data(-cursor) -geometry $data(-geometry)
    frame $w.f     -borderwidth $wd2 -relief flat -background $data(-background)
    frame $w.f.b   -borderwidth $wd3 -relief sunken -background $data(-background)
    frame $w.f.b.i -borderwidth $wd4 -relief sunken -background $data(-background)
    frame $w.h -borderwidth 0

    label $w.name -text "" -rel raised -border 1 -padx 2\
	-font $data(-font) -text $data(-title) \
	-background $data(-background) -foreground $data(-foreground)
    set d [expr "([winfo reqheight $w.name]/2+1)*2"]
    frame $w.titlebar -borderwidth 0 -geometry 1x$d
    raise $w.name

    # Create the titlebar buttons
    set client [winfo toplevel $w]
    foreach i [concat ${tkwm_client_frame::buttons}] {
	tkwm_client_frame::button_$i $w.$i -background $data(-background)
    }

    # pack the titlebar
    foreach i $data(-leftbuttons) {
    	handleError {
	    pack $w.$i    -in $w.h -side left -anchor nw -padx 0
	} {
	    tkerror "Button type $i does not exist."
	}
    }
    foreach i $data(-rightbuttons) {
    	handleError {
	    pack $w.$i    -in $w.h -side right -anchor nw -padx 0
	} {
	    tkerror "Button type $i does not exist."
	}
    }
    pack $w.name    -in $w.h -side left -anchor n  -expand 1 -fill both

    # pack the rest of the frame widgets

    pack $w.f.b.i  -side bottom -anchor nw -expand 1 -fill both
    pack $w.f.b    -anchor nw -expand 1 -fill both
    pack $w.f	   -anchor nw -expand 1 -fill both

    if $data(-titlebar) {
        place $w.h      -in $w.titlebar -x 0 -y 0 -anchor nw \
		    -relwidth 1.0 -relheight 1.0
    	pack $w.titlebar -in $w.f.b -fill x -anchor nw
    }

    set data(inframe)  $w.f.b.i
}

proc tkwm_client_frame::command-activate {var args} {
    upvar "#0" $var data
    set data(active) 1
    tkwm_client_frame::setcolors $var 1
}

proc tkwm_client_frame::command-deactivate {var args} {
    upvar "#0" $var data
    set data(active) 0
    tkwm_client_frame::setcolors $var 1
}

proc tkwm_client_frame::command-invoke {var args} {
    $var.menu invoke
}


proc tkwm_client_frame::config-cursor {var option} {
    global tkwm_client_frame::buttons
    upvar "#0" $var data
    $var.root config -cursor $option
    $var.f config -cursor $option
    $var.f.b config -cursor $option
    $var.f.b.i config -cursor $option
    $var.name config -cursor $option
    foreach i ${tkwm_client_frame::buttons} {
        $var.$i config -cursor $option
    }
}

proc tkwm_client_frame::setcolors {var change} {
    global tkwm_client_frame::buttons
    upvar "#0" $var data

    if $data(active) {
	if {[winfo screendepth .]=="1"} {
	    if !$change {
		$var.name config -background $data(-background) -foreground $data(-foreground)
    		foreach i ${tkwm_client_frame::buttons} {
		    $var.$i config -background $data(-background)
		}
		$var.f.b.i config -background $data(-background)
		$var.f.b config -background $data(-background)
		$var.root config -background $data(-background)
	    }
	    $var.f config -background $data(-activeBackground)
	} else {
	    $var.name config -background $data(-activeBackground) -foreground $data(-activeForeground)
	    foreach i ${tkwm_client_frame::buttons} {
		$var.$i config -background $data(-activeBackground)
	    }
	    $var.f.b.i config -background $data(-activeBackground)
	    $var.f.b config -background $data(-activeBackground)
	    $var.f config -background $data(-activeBackground)
	    $var.root config -background $data(-activeBackground)
	}
    } else {
	if {!$change || [winfo screendepth .]>"1"} {
	    $var.name config -background $data(-background) -foreground $data(-foreground)
	    foreach i ${tkwm_client_frame::buttons} {
		$var.$i config -background $data(-background)
	    }
	    $var.f.b.i config -background $data(-background)
	    $var.f.b config -background $data(-background)
	    $var.root config -background $data(-background)
	}
	$var.f config -background $data(-background)
    }
}

proc tkwm_client_frame::config-background {var option} {
    upvar "#0" $var data
    set data(-background) $option
    tkwm_client_frame::setcolors $var 0
}
proc tkwm_client_frame::config-foreground {var option} {
    upvar "#0" $var data
    set data(-foreground) $option
    tkwm_client_frame::setcolors $var 0
}
proc tkwm_client_frame::config-activeBackground {var option} {
    upvar "#0" $var data
    set data(-activeBackground) $option
    tkwm_client_frame::setcolors $var 0
}
proc tkwm_client_frame::config-activeForeground {var option} {
    upvar "#0" $var data
    set data(-activeFackground) $option
    tkwm_client_frame::setcolors $var 0
}

proc tkwm_client_frame::config-borderwidth {var option} {
    upvar "#0" $var data
    set wd1 [expr {$option>=1?($option>=4?2:1):0}]
    set wd3 [expr {$option>=4?1:0}]
    set wd4 [expr {$option>=2?1:0}]
    set wd2 [expr {$option-($wd1+$wd3+$wd4)}]
    $var.root config -borderwidth $wd1
    $var.f config -borderwidth $wd2
    $var.f.b config -borderwidth $wd3
    $var.f.b.i config -borderwidth $wd4
}

proc tkwm_client_frame::config-leftbuttons {var option} {
    upvar "#0" $var data
    # forget the old titlebar packing
    foreach i [concat {name} $data(-leftbuttons) $data(-rightbuttons)] {
	catch { pack forget $var.$i}
    }
    # repack the titlebar
    foreach i $option {
    	handleError {
	    pack $var.$i    -in $var.h -side left -anchor nw -padx 0
	} {
	    tkerror "Button type $i does not exist."
	}
    }
    foreach i $data(-rightbuttons) {
    	catch {pack $var.$i    -in $var.h -side right -anchor nw -padx 0}
    }
    pack $var.name    -in $var.h -side left -anchor n  -expand 1 -fill both
}

proc tkwm_client_frame::config-rightbuttons {var option} {
    upvar "#0" $var data
    # forget the old titlebar packing
    foreach i [concat {name} $data(-leftbuttons) $data(-rightbuttons)] {
	catch {pack forget $var.$i}
    }
    # repack the titlebar
    foreach i $data(-leftbuttons) {
    	catch {pack $var.$i    -in $var.h -side left -anchor nw -padx 0}
    }
    foreach i $option {
    	handleError {
	    pack $var.$i    -in $var.h -side right -anchor nw -padx 0
	} {
	    tkerror "Button type $i does not exist."
	}
    }
    pack $var.name    -in $var.h -side left -anchor n  -expand 1 -fill both
}

proc tkwm_client_frame::config-geometry {var option} {
    $var.root config -geometry $option
}

proc tkwm_client_frame::config-font {var option} {
    $var.name config -font $option
}

proc tkwm_client_frame::config-title {var option} {
    $var.name config -text $option
}

proc tkwm_client_frame::config-titlebar {var option} {
    if $option {
	place $var.h      -in $var.titlebar -x 0 -y 0 -anchor nw \
	    -relwidth 1.0 -relheight 1.0
	pack $var.titlebar -in $var.f.b -fill x -anchor nw
    } else {
	catch {place forget $var.h; pack forget $var.titlebar}
    }
}

# Widget: tkwm_icon_frame

tkwm_widget::setdefaults frame tkwm_icon_frame {
	{-geometry geometry Geometry {}}
	{-font font Font -Adobe-Helvetica-Bold-R-Normal--*-120-*}
	{-background background Background white}
	{-foreground foreground Foreground black}
	{-activeBackground activeBackground ActiveBackground black}
	{-activeForeground activeForeground ActiveForeground white}
	{-cursor cursor Cursor {}}
	{-borderwidth borderWidth BorderWidth 6}
	{-title title Title {}}
	{-titlebar titlebar Titlebar 1}}

# Widget constructor

proc tkwm_icon_frame {var args} {
    upvar "#0" $var data

    # Do the intial configuration
    tkwm_widget::initialconfigure tkwm_icon_frame TkwmIconFrame $var args

    # return the inside frame of the widget
    # this is where things inside the widget should be "packed".
    return $data(inframe)
}

# Create the widget's internal hierarchy

proc tkwm_icon_frame::create {var} {
    upvar "#0" $var data
    set w $var
    
    # Set up the widget data structures
    set data(active) 0

    # widgets
    $w config -borderwidth 1 -relief raised -background $data(-background) \
	-cursor $data(-cursor) -geometry $data(-geometry)
    frame $w.f     -borderwidth 1 -relief raised -background $data(-background)
    frame $w.f.b   -borderwidth 2 -relief flat -background $data(-background)
    frame $w.f.b.i -borderwidth 1 -relief sunken -background $data(-background)
    frame $w.h -borderwidth 0
    label $w.name -rel raised -border 1 -text $data(-title) \
	-background $data(-background) \
	-foreground $data(-foreground) -font $data(-font)
    set d [winfo reqheight $w.name]
    frame $w.titlebar -borderwidth 0 -geometry 1x$d
    raise $w.name

    # pack the titlebar
    pack $w.name    -in $w.h -side left -anchor n  -expand 1 -fill both

    # pack the rest of the frame widgets

    pack $w.f.b.i  -side top -anchor nw -expand 1 -fill both
    pack $w.f.b    -anchor nw -expand 1 -fill both
    pack $w.f	   -anchor nw -expand 1 -fill both

    if $data(-titlebar) {
        place $w.h      -in $w.titlebar -x 0 -y 0 -anchor nw \
		    -relwidth 1.0 -relheight 1.0
    	pack $w.titlebar -in $w -fill x -anchor nw
    }

    set data(inframe)  $w.f.b.i
}

# The widget commands

proc tkwm_icon_frame::command-activate {var args} {
    upvar "#0" $var data
    set data(active) 1
    tkwm_icon_frame::setcolors $var 1
}

proc tkwm_icon_frame::command-deactivate {var args} {
    upvar "#0" $var data
    set data(active) 0
    tkwm_icon_frame::setcolors $var 1
}

proc tkwm_icon_frame::command-invoke {var args} {
    $var.menu invoke
}

proc tkwm_icon_frame::config-background {var option} {
    upvar "#0" $var data
    set data(-background) $option
    tkwm_icon_frame::setcolors $var 0
}
proc tkwm_icon_frame::config-foreground {var option} {
    upvar "#0" $var data
    set data(-foreground) $option
    tkwm_icon_frame::setcolors $var 0
}
proc tkwm_icon_frame::config-activeBackground {var option} {
    upvar "#0" $var data
    set data(-activeBackground) $option
    tkwm_icon_frame::setcolors $var 0
}
proc tkwm_icon_frame::config-activeForeground {var option} {
    upvar "#0" $var data
    set data(-activeForeground) $option
    tkwm_icon_frame::setcolors $var 0
}

proc tkwm_icon_frame::config-geometry {var option} {
    $var.root config -geometry $option
}

proc tkwm_icon_frame::config-font {var option} {
    $var.name config -font $option
}

proc tkwm_icon_frame::config-title {var option} {
    $var.name config -text $option
}

proc tkwm_icon_frame::config-cursor {var option} {
    $var.root config -cursor $option
    $var.f config -cursor $option
    $var.f.b config -cursor $option
    $var.f.b.i config -cursor $option
    $var.name config -cursor $option
}

proc tkwm_icon_frame::config-titlebar {var option} {
    if $option {
	place $var.h -in $var.titlebar -x 0 -y 0 -anchor nw \
	    -relwidth 1.0 -relheight 1.0
	pack $var.titlebar -in $var -fill x -anchor nw
    } else {
	catch {place forget $var.h; pack forget $var.titlebar}
    }
}

proc tkwm_icon_frame::setcolors {var change} {
    upvar "#0" $var data
    if $data(active) {
	if {[winfo screendepth .]=="1"} {
	    if !$change {
	        $var.root config -background $data(-background)
	        $var.f config -background $data(-background)
	        $var.f.b.i config -background $data(-background)
	        $var.name config -background $data(-background)
	        $var.name config -foreground $data(-foreground)
            }
	    $var.f.b config -background $data(-activeBackground)
	} else {
	    $var.root config -background $data(-activeBackground)
	    $var.f config -background $data(-activeBackground)
	    $var.f.b config -background $data(-activeBackground)
	    $var.f.b.i config -background $data(-activeBackground)
	    $var.name config -background $data(-activeBackground)
	    $var.name config -foreground $data(-activeForeground)
	}
    } else {
        if {!$change || [winfo screendepth .]>"1"} {
	    $var.root config -background $data(-background)
	    $var.f config -background $data(-background)
	    $var.f.b.i config -background $data(-background)
	    $var.name config -background $data(-background)
	    $var.name config -foreground $data(-foreground)
        }
        $var.f.b config -background $data(-background)
    }
    set data(setcolors) 0
}