# ------------------------------------------------------------------
# Utility Procs
# ------------------------------------------------------------------


# ------------------------------------------------------------------
# BrightenColor: used to turn a background color into an active
# background color
# ------------------------------------------------------------------
proc BrightenColor {color} {
    scan $color {#%2s%2s%2s} r g b

    foreach elem "r g b" {
	set $elem [expr round(0x[set $elem] * 1.2)]
	if {[set $elem] > 255} {set $elem 255}
    }
    format {#%x%x%x} $r $g $b
}

# ------------------------------------------------------------------
# DarkenColor: used to turn a background color into a disabled
# background color
# ------------------------------------------------------------------
proc DarkenColor {color} {
    scan $color {#%2s%2s%2s} r g b

    foreach elem "r g b" {
	set $elem [expr round(0x[set $elem] * 0.8)]
	if {[set $elem] > 255} {set $elem 255}
    }
    format {#%x%x%x} $r $g $b
}

# ------------------------------------------------------------------
# SetupColorOptions: setup the colors for a given tool
# ------------------------------------------------------------------
proc SetupColorOptions {color} {
    set light [BrightenColor $color]
    set dark [DarkenColor $color]

    option add *background $color
    option add *activeBackground $light
    option add *selectBackground $light
    option add *disabledForeground $dark
    option add *Scrollbar.foreground $color
    option add *Scrollbar.activeForeground $dark
}

# ------------------------------------------------------------------
# "ListboxButtonActivate" activates the given button whenever
# something is selected from the list
# ------------------------------------------------------------------

proc ListboxButtonActivate {list button} {
    set old [bind $list <Button-1>]
    if {$old == ""} {
	set old [bind Listbox <Button-1>]
    }
    bind $list <Button-1> [format {
	%s
	set index [lindex [%s curselection] 0]
    	if {$index != ""} {
	    %s configure -state normal
	}
    } $old $list $button]
}

proc ListboxBindVariable {list varname} {
    set bindings {<Button-1> <Shift-Button-1> <B1-Motion> <Shift-B1-Motion>}

    foreach elem $bindings {
	set old [bind $list $elem]
	if {$old == ""} {
	    set old [bind Listbox $elem]
	}
	bind $list $elem [format {
	    %s
	    set index [lindex [%s curselection] 0]
	    if {$index != ""} {
		set %s [%s get $index]
	    } else {
		set %s {}
	    }
	} $old $list $varname $list $varname]
    }
}

proc AdjustLabelState {label var} {
    global label_state_normal label_state_disabled

    if {[info exists label_state_normal] == 0} {
	button .lblb
	set label_state_normal \
	    [lindex [.lblb configure -foreground] 4]
	set label_state_disabled \
	    [lindex [.lblb configure -disabledforeground] 4]
	destroy .lblb
    }

    if {[info command $label] == ""} {return}

    if {$var == ""} {
	$label configure -foreground $label_state_disabled
    } else {
	$label configure -foreground $label_state_normal
    }
}

# ------------------------------------------------------------------
# The HyperLink command is used to either load an object into an
# already running tool, or launch a new tool if necessary.
# ------------------------------------------------------------------

proc HyperLink {name sendCommand execCommand} {
    busy {
    	foreach i [winfo interps] {
	    if [string match *${name}* $i] {
		catch {send $i {expr 999}} retval
		if {$retval == "999"} {
		    set code [catch {send $i $sendCommand} err]
		    if {$code != 0} {
			puts "HyperLink Error: $err"
		    }
		    return
		} else {
		    removeinterp $i
		}
	    }
	}
	eval exec $execCommand &
	after 1200
    }
}

# ------------------------------------------------------------------
# "tabbind" is used to bind two entries together so that they can
# be traversed with the TAB key.
# ------------------------------------------------------------------

proc tabbind {w1 w2} {
    bind $w1 <Tab> "focus $w2 ; $w2 select from 0 ; $w2 select to end"
    bind $w1 <Return> "focus $w2"
    bind $w2 <Shift-Tab> "focus $w1 ; $w1 select from 0 ; $w1 select to end"
}

# ------------------------------------------------------------------
# "PopupMenu" sets bindings on a menu such that it will behave as a
# popup menu on the given parent.
# ------------------------------------------------------------------

proc PopupMenu {menu {parent .}} {
    if {$parent == "."} {set parent all}

    bind $menu <ButtonRelease-1> {
	tk_invokeMenu %W
	if {[set %W-pinned] == 0} { %W unpost }
    }

    bind $parent <Button-2> "$menu post %X %Y ; set $menu-pinned 1"
    bind $parent <B2-Motion> "$menu post %X %Y ; set $menu-pinned 1"

    bind $parent <ButtonPress-3> "$menu post %X %Y ; set $menu-pinned 0"
    bind $parent <B3-Motion> "PopupMenu-B3-Motion $menu %X %Y"
    bind $parent <ButtonRelease-3> "PopupMenu-B3-Release $menu %X %Y"
}

proc PopupMenu-B3-Motion {menu rx ry} {
    scan [winfo geometry $menu] %dx%d+%d+%d w h x y
    if {$rx > $x && $rx < [expr $x+$w] &&
	$ry > $y && $ry < [expr $y+$h]} {
	set index [$menu index @[expr $ry-$y]]
	$menu activate $index
    } else {
	$menu activate none
    }
}

proc PopupMenu-B3-Release {menu rx ry} {
    scan [winfo geometry $menu] %dx%d+%d+%d w h x y
    set margin 3

    if {$x > [expr $rx-$margin] && $x < [expr $rx+$margin] &&
	$y > [expr $ry-$margin] && $y < [expr $ry+$margin]} {
	return
    } elseif {$rx > $x && $rx < [expr $x+$w] &&
    	      $ry > $y && $ry < [expr $y+$h]} {
	set index [$menu index @[expr $ry-$y]]
	$menu invoke $index
    }
    $menu unpost
}
