#
# 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


proc tkwm_client_frame::new_left_button {name widget args} {
    global tkwm_client_frame::left_buttons

    lappend tkwm_client_frame::left_buttons $name
    set body "uplevel $widget \$path $args \$args"
    proc tkwm_client_frame::button_$name {path args} $body
}

proc tkwm_client_frame::new_right_button {name widget args} {
    global tkwm_client_frame::right_buttons

    lappend tkwm_client_frame::right_buttons $name
    set body "uplevel $widget \$path $args \$args"
    proc tkwm_client_frame::button_$name {path args} $body
}

set tkwm_client_frame::left_buttons {}
tkwm_client_frame::new_left_button menu motif_menubutton \
    {-menu .client_menu -geometry ${d}x$d -insidegeometry [expr "$d-6"]x6}

set tkwm_client_frame::right_buttons {}

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

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

# Widget: tkwm_client_frame
# options:
#	-background
#	-foreground
#       -activeBackground
#       -activeForeground
#
#	-cursor
#
#       -bordergap
#
#	-geometry
#
#	-font
#	-title text
#	-titlevar textvar
#
#	-titlebar boolean
#
# widget commands:
#	config
#	activate
#	deactivate
#	invoke		- invoke the menu

# set up the default values for the widgets configuration

tkwm_widget::setdefaults tkwm_client_frame TkwmClientFrame {
	{-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 {}}
	{-titlevar titlevar Titlevar {}}
	{-titlebar titlebar Titlebar 1}}

# Widget constructor

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

    # Set up the widget data structures
    set data(type) tkwm_client_frame
    set data(active) 0
    set data(setcolors) 0

    # Do the intial configuration
    eval tkwm_widget::initialconfigure $var args

    # Create the widget (must not refer to configuration information)
    tkwm_client_frame::create $var

    # Create the widget command
    tkwm_widget::makecommand $var tkwm_client_frame::command

    # Default bindings
    bind $w <Destroy>     "tkwm_widget::destroy $var"

    # 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::left_buttons tkwm_client_frame::right_buttons
    upvar "#0" $var data
    set w $var

    # widgets
    $w config -borderwidth 2 -relief raised -background $data(-background) \
	-cursor $data(-cursor) -geometry $data(-geometry)
    frame $w.f     -borderwidth 2 -relief flat -background $data(-background)
    frame $w.f.b   -borderwidth 1 -relief sunken -background $data(-background)
    frame $w.f.b.i -borderwidth 1 -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) \
	-textvar $data(-titlevar) \
	-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::left_buttons} ${tkwm_client_frame::right_buttons}] {
	tkwm_client_frame::button_$i $w.$i -background $data(-background)
    }

    # pack the titlebar
    foreach i ${tkwm_client_frame::left_buttons} {
    	pack $w.$i    -in $w.h -side left -anchor nw -padx 0
    }
    foreach i ${tkwm_client_frame::right_buttons} {
    	pack $w.$i    -in $w.h -side right -anchor nw -padx 0
    }
    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
}


# The widget command

proc tkwm_client_frame::command {option args} {
    # the name of the data structure is the same as the procedure
    #------------------------------------------------------------
    set var [lindex [info level 0] 0]
    upvar "#0" $var data

    set w $var

    case $option in {
	{config configure} {
	    set result [eval tkwm_widget::configure tkwm_client_frame::configure $var args]
	    if $data(setcolors) {tkwm_client_frame::setcolors $var 0}
	    return $result
	}
	activate {
	    set data(active) 1
	    tkwm_client_frame::setcolors $w 1
	}
	deactivate {
	    set data(active) 0
	    tkwm_client_frame::setcolors $w 1
	}
	invoke {
	    $w.menu invoke
	}
	default {
	    error "Unknown widget command $option. Must be one of: configure"
	}
    }
}

proc tkwm_client_frame::setcolors {var change} {
    global tkwm_client_frame::left_buttons tkwm_client_frame::right_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 [concat ${tkwm_client_frame::left_buttons} \
				  ${tkwm_client_frame::right_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 [concat ${tkwm_client_frame::left_buttons} \
			      ${tkwm_client_frame::right_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 [concat ${tkwm_client_frame::left_buttons} \
			      ${tkwm_client_frame::right_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)
    }
    set data(setcolors) 0
}

proc tkwm_client_frame::configure {var flag option} {
    global tkwm_client_frame::left_buttons tkwm_client_frame::right_buttons
    upvar "#0" $var data
    switch -- $flag {
	-background -
	-foreground -
	-activeBackground -
	-activeForeground { set data(setcolors) 1 }
	-cursor {
	    $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 [concat ${tkwm_client_frame::left_buttons} \
			      ${tkwm_client_frame::right_buttons}] {
		$var.$i config -cursor $option
	    }
	}
	-geometry { $var.root config -geometry $option }
	-font { $var.name config -font $option }
	-title { $var.name config -text $option }
	-titlevar { $var.name config -textvar $option }
        -titlebar {
            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}
            }
        }
	default {
	    error "Unknown option. Must be one of: -background, -foreground, -activeBackground, -activeForeground, -cursor, -geometry, -font, -title, -titlevar, or -titlebar"
	}
    }
    set data($flag) $option
}

# Widget: tkwm_icon_frame

tkwm_widget::setdefaults tkwm_icon_frame TkwmIconFrame {
	{-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 {}}
	{-titlevar titlevar Titlevar {}}
	{-titlebar titlebar Titlebar 1}}

# Widget constructor

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

    # Set up the widget data structures
    set data(type) tkwm_icon_frame
    set data(active) 0
    set data(setcolors) 0

    # Do the intial configuration
    eval tkwm_widget::initialconfigure $var args

    # Create the widget
    tkwm_icon_frame::create $var

    # Create the widget command
    tkwm_widget::makecommand $var tkwm_icon_frame::command

    # Default bindings
    bind $w <Destroy>     "tkwm_widget::destroy $var"

    # 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
    
    # 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) \
	-textvar $data(-titlevar) -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 command

proc tkwm_icon_frame::command {option args} {
    # the name of the data structure is the same as the procedure
    #------------------------------------------------------------
    set var [lindex [info level 0] 0]
    upvar "#0" $var data

    set w $var

    case $option in {
	{config configure} {
	    set result [eval tkwm_widget::configure tkwm_icon_frame::configure $var args]
	    if $data(setcolors) {tkwm_icon_frame::setcolors $var 0}
	    return $result
	}
	activate {
	    set data(active) 1
	    tkwm_icon_frame::setcolors $w 1
	}
	deactivate {
	    set data(active) 0
	    tkwm_icon_frame::setcolors $w 1
	}
	default {
	    error "Unknown widget command $option. Must be one of: configure"
	}
    }
}

proc tkwm_icon_frame::configure {var flag option} {
     upvar "#0" $var data
     switch -- $flag {
	-background -
	-foreground -
	-activeBackground -
	-activeForeground { set data(setcolors) 1 }
	-cursor {
	    $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 [concat ${tkwm_client_frame::left_buttons} \
			      ${tkwm_client_frame::right_buttons}] {
		$var.$i config -cursor $option
	    }
	}
	-geometry { $var.root config -geometry $option }
	-font { $var.name config -font $option }
	-title { $var.name config -text $option }
	-titlevar { $var.name config -textvar $option }
        -titlebar {
            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}
            }
        }
	default {
	    error "Unknown option. Must be one of: -background, -foreground, -activeBackground, -activeForeground, -cursor, -geometry, -font, -title, -titlevar, or -titlebar"
	}
    }
    set data($flag) $option
}

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
}