# ------------------------------------------------------------------------------ # arrow.tcl # This file is part of Unifix BWidget Toolkit # ------------------------------------------------------------------------------ # Index of commands: # Public commands # - ArrowButton::create # - ArrowButton::configure # - ArrowButton::cget # - ArrowButton::invoke # Private commands (redraw commands) # - ArrowButton::_redraw # - ArrowButton::_redraw_state # - ArrowButton::_redraw_relief # - ArrowButton::_redraw_whole # Private commands (event bindings) # - ArrowButton::_destroy # - ArrowButton::_enter # - ArrowButton::_leave # - ArrowButton::_press # - ArrowButton::_release # - ArrowButton::_repeat # ------------------------------------------------------------------------------ namespace eval ArrowButton { Widget::tkinclude ArrowButton button .c \ include [list \ -borderwidth -bd \ -relief -highlightbackground \ -highlightcolor -highlightthickness -takefocus] Widget::declare ArrowButton [list \ [list -type Enum button 0 [list arrow button]] \ [list -dir Enum top 0 [list top bottom left right]] \ [list -width Int 15 0 "%d >= 0"] \ [list -height Int 15 0 "%d >= 0"] \ [list -ipadx Int 0 0 "%d >= 0"] \ [list -ipady Int 0 0 "%d >= 0"] \ [list -clean Int 2 0 "%d >= 0 && %d <= 2"] \ [list -activeforeground TkResource "" 0 button] \ [list -activebackground TkResource "" 0 button] \ [list -disabledforeground TkResource "" 0 button] \ [list -foreground TkResource "" 0 button] \ [list -background TkResource "" 0 button] \ [list -state TkResource "" 0 button] \ [list -troughcolor TkResource "" 0 scrollbar] \ [list -arrowbd Int 1 0 "%d >= 0 && %d <= 2"] \ [list -arrowrelief Enum raised 0 [list raised sunken]] \ [list -command String "" 0] \ [list -armcommand String "" 0] \ [list -disarmcommand String "" 0] \ [list -repeatdelay Int 0 0 "%d >= 0"] \ [list -repeatinterval Int 0 0 "%d >= 0"] \ [list -fg Synonym -foreground] \ [list -bg Synonym -background] \ ] DynamicHelp::include ArrowButton balloon proc ::ArrowButton { path args } { return [eval ArrowButton::create $path $args] } proc use {} {} bind BwArrowButtonC {ArrowButton::_enter %W} bind BwArrowButtonC {ArrowButton::_leave %W} bind BwArrowButtonC {ArrowButton::_press %W} bind BwArrowButtonC {ArrowButton::_release %W} bind BwArrowButtonC {ArrowButton::invoke %W; break} bind BwArrowButtonC {ArrowButton::invoke %W; break} bind BwArrowButton {ArrowButton::_redraw_whole %W %w %h} bind BwArrowButton {ArrowButton::_destroy %W} variable _grab variable _moved array set _grab {current "" pressed "" oldstate "" oldrelief ""} } # ----------------------------------------------------------------------------- # Command ArrowButton::create # ----------------------------------------------------------------------------- proc ArrowButton::create { path args } { # Initialize configuration mappings and parse arguments array set submaps [list ArrowButton [list ] .c [list ]] array set submaps [Widget::parseArgs ArrowButton $args] # Create the class frame (so we can do the option db queries) frame $path -class ArrowButton Widget::initFromODB ArrowButton $path $submaps(ArrowButton) # Create the canvas with the initial options eval canvas $path.c $submaps(.c) # Compute the width and height of the canvas from the width/height # of the ArrowButton and the borderwidth/hightlightthickness. set w [Widget::cget $path -width] set h [Widget::cget $path -height] set bd [Widget::cget $path -borderwidth] set ht [Widget::cget $path -highlightthickness] set pad [expr {2*($bd+$ht)}] $path.c configure -width [expr {$w-$pad}] -height [expr {$h-$pad}] bindtags $path [list $path BwArrowButton [winfo toplevel $path] all] bindtags $path.c [list $path.c BwArrowButtonC [winfo toplevel $path.c] all] pack $path.c -expand yes -fill both DynamicHelp::sethelp $path $path.c 1 set ::ArrowButton::_moved($path) 0 rename $path ::$path:cmd proc ::$path { cmd args } "return \[eval ArrowButton::\$cmd $path \$args\]" return $path } # ----------------------------------------------------------------------------- # Command ArrowButton::configure # ----------------------------------------------------------------------------- proc ArrowButton::configure { path args } { set res [Widget::configure $path $args] set ch1 [expr {[Widget::hasChanged $path -width w] | [Widget::hasChanged $path -height h] | [Widget::hasChanged $path -borderwidth bd] | [Widget::hasChanged $path -highlightthickness ht]}] set ch2 [expr {[Widget::hasChanged $path -type val] | [Widget::hasChanged $path -ipadx val] | [Widget::hasChanged $path -ipady val] | [Widget::hasChanged $path -arrowbd val] | [Widget::hasChanged $path -clean val] | [Widget::hasChanged $path -dir val]}] if { $ch1 } { set pad [expr {2*($bd+$ht)}] $path.c configure \ -width [expr {$w-$pad}] -height [expr {$h-$pad}] \ -borderwidth $bd -highlightthickness $ht set ch2 1 } if { $ch2 } { _redraw_whole $path [winfo width $path] [winfo height $path] } else { _redraw_relief $path _redraw_state $path } DynamicHelp::sethelp $path $path.c return $res } # ----------------------------------------------------------------------------- # Command ArrowButton::cget # ----------------------------------------------------------------------------- proc ArrowButton::cget { path option } { return [Widget::cget $path $option] } # ------------------------------------------------------------------------------ # Command ArrowButton::invoke # ------------------------------------------------------------------------------ proc ArrowButton::invoke { path } { set path [winfo parent $path] if { [string compare [Widget::getoption $path -state] "disabled"] } { set oldstate [Widget::getoption $path -state] if { ![string compare [Widget::getoption $path -type] "button"] } { set oldrelief [Widget::getoption $path -relief] configure $path -state active -relief sunken } else { set oldrelief [Widget::getoption $path -arrowrelief] configure $path -state active -arrowrelief sunken } update idletasks if { [set cmd [Widget::getoption $path -armcommand]] != "" } { uplevel \#0 $cmd } after 10 if { ![string compare [Widget::getoption $path -type] "button"] } { configure $path -state $oldstate -relief $oldrelief } else { configure $path -state $oldstate -arrowrelief $oldrelief } if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } { uplevel \#0 $cmd } if { [set cmd [Widget::getoption $path -command]] != "" } { uplevel \#0 $cmd } } } # ------------------------------------------------------------------------------ # Command ArrowButton::_redraw # ------------------------------------------------------------------------------ proc ArrowButton::_redraw { path width height } { variable _moved set _moved($path) 0 set type [Widget::getoption $path -type] set dir [Widget::getoption $path -dir] set bd [expr {[$path.c cget -borderwidth] + [$path.c cget -highlightthickness] + 1}] set clean [Widget::getoption $path -clean] if { ![string compare $type "arrow"] } { if { [set id [$path.c find withtag rect]] == "" } { $path.c create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect } else { $path.c coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] } $path.c lower rect set arrbd [Widget::getoption $path -arrowbd] set bd [expr {$bd+$arrbd-1}] } else { $path.c delete rect } # w and h are max width and max height of arrow set w [expr {$width - 2*([Widget::getoption $path -ipadx]+$bd)}] set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}] if { $w < 2 } {set w 2} if { $h < 2 } {set h 2} if { $clean > 0 } { # arrange for base to be odd if { ![string compare $dir "top"] || ![string compare $dir "bottom"] } { if { !($w % 2) } { incr w -1 } if { $clean == 2 } { # arrange for h = (w+1)/2 set h2 [expr {($w+1)/2}] if { $h2 > $h } { set w [expr {2*$h-1}] } else { set h $h2 } } } else { if { !($h % 2) } { incr h -1 } if { $clean == 2 } { # arrange for w = (h+1)/2 set w2 [expr {($h+1)/2}] if { $w2 > $w } { set h [expr {2*$w-1}] } else { set w $w2 } } } } set x0 [expr {($width-$w)/2}] set y0 [expr {($height-$h)/2}] set x1 [expr {$x0+$w-1}] set y1 [expr {$y0+$h-1}] switch $dir { top { set xd [expr {($x0+$x1)/2}] if { [set id [$path.c find withtag poly]] == "" } { $path.c create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly } else { $path.c coords $id $x0 $y1 $x1 $y1 $xd $y0 } if { ![string compare $type "arrow"] } { if { [set id [$path.c find withtag bot]] == "" } { $path.c create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot } else { $path.c coords $id $x0 $y1 $x1 $y1 $xd $y0 } if { [set id [$path.c find withtag top]] == "" } { $path.c create line $x0 $y1 $xd $y0 -tags top } else { $path.c coords $id $x0 $y1 $xd $y0 } $path.c itemconfigure top -width $arrbd $path.c itemconfigure bot -width $arrbd } else { $path.c delete top $path.c delete bot } } bottom { set xd [expr {($x0+$x1)/2}] if { [set id [$path.c find withtag poly]] == "" } { $path.c create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly } else { $path.c coords $id $x1 $y0 $x0 $y0 $xd $y1 } if { ![string compare $type "arrow"] } { if { [set id [$path.c find withtag top]] == "" } { $path.c create line $x1 $y0 $x0 $y0 $xd $y1 -tags top } else { $path.c coords $id $x1 $y0 $x0 $y0 $xd $y1 } if { [set id [$path.c find withtag bot]] == "" } { $path.c create line $x1 $y0 $xd $y1 -tags bot } else { $path.c coords $id $x1 $y0 $xd $y1 } $path.c itemconfigure top -width $arrbd $path.c itemconfigure bot -width $arrbd } else { $path.c delete top $path.c delete bot } } left { set yd [expr {($y0+$y1)/2}] if { [set id [$path.c find withtag poly]] == "" } { $path.c create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly } else { $path.c coords $id $x1 $y0 $x1 $y1 $x0 $yd } if { ![string compare $type "arrow"] } { if { [set id [$path.c find withtag bot]] == "" } { $path.c create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot } else { $path.c coords $id $x1 $y0 $x1 $y1 $x0 $yd } if { [set id [$path.c find withtag top]] == "" } { $path.c create line $x1 $y0 $x0 $yd -tags top } else { $path.c coords $id $x1 $y0 $x0 $yd } $path.c itemconfigure top -width $arrbd $path.c itemconfigure bot -width $arrbd } else { $path.c delete top $path.c delete bot } } right { set yd [expr {($y0+$y1)/2}] if { [set id [$path.c find withtag poly]] == "" } { $path.c create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly } else { $path.c coords $id $x0 $y1 $x0 $y0 $x1 $yd } if { ![string compare $type "arrow"] } { if { [set id [$path.c find withtag top]] == "" } { $path.c create line $x0 $y1 $x0 $y0 $x1 $yd -tags top } else { $path.c coords $id $x0 $y1 $x0 $y0 $x1 $yd } if { [set id [$path.c find withtag bot]] == "" } { $path.c create line $x0 $y1 $x1 $yd -tags bot } else { $path.c coords $id $x0 $y1 $x1 $yd } $path.c itemconfigure top -width $arrbd $path.c itemconfigure bot -width $arrbd } else { $path.c delete top $path.c delete bot } } } } # ------------------------------------------------------------------------------ # Command ArrowButton::_redraw_state # ------------------------------------------------------------------------------ proc ArrowButton::_redraw_state { path } { set state [Widget::getoption $path -state] if { ![string compare [Widget::getoption $path -type] "button"] } { switch $state { normal {set bg -background; set fg -foreground} active {set bg -activebackground; set fg -activeforeground} disabled {set bg -background; set fg -disabledforeground} } set fg [Widget::getoption $path $fg] $path.c configure -background [Widget::getoption $path $bg] $path.c itemconfigure poly -fill $fg -outline $fg } else { switch $state { normal {set stipple ""; set bg [Widget::getoption $path -background] } active {set stipple ""; set bg [Widget::getoption $path -activebackground] } disabled {set stipple gray50; set bg black } } set thrc [Widget::getoption $path -troughcolor] $path.c configure -background [Widget::getoption $path -background] $path.c itemconfigure rect -fill $thrc -outline $thrc $path.c itemconfigure poly -fill $bg -outline $bg -stipple $stipple } } # ------------------------------------------------------------------------------ # Command ArrowButton::_redraw_relief # ------------------------------------------------------------------------------ proc ArrowButton::_redraw_relief { path } { variable _moved if { ![string compare [Widget::getoption $path -type] "button"] } { if { ![string compare [Widget::getoption $path -relief] "sunken"] } { if { !$_moved($path) } { $path.c move poly 1 1 set _moved($path) 1 } } else { if { $_moved($path) } { $path.c move poly -1 -1 set _moved($path) 0 } } } else { set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]] switch [Widget::getoption $path -arrowrelief] { raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]} sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]} } $path.c itemconfigure top -fill $top $path.c itemconfigure bot -fill $bot } } # ------------------------------------------------------------------------------ # Command ArrowButton::_redraw_whole # ------------------------------------------------------------------------------ proc ArrowButton::_redraw_whole { path width height } { _redraw $path $width $height _redraw_relief $path _redraw_state $path } # ------------------------------------------------------------------------------ # Command ArrowButton::_destroy # ------------------------------------------------------------------------------ proc ArrowButton::_destroy { path } { variable _moved Widget::destroy $path unset _moved($path) rename $path {} } # ------------------------------------------------------------------------------ # Command ArrowButton::_enter # ------------------------------------------------------------------------------ proc ArrowButton::_enter { path } { variable _grab set path [winfo parent $path] set _grab(current) $path if { [string compare [Widget::getoption $path -state] "disabled"] } { set _grab(oldstate) [Widget::getoption $path -state] configure $path -state active if { $_grab(pressed) == $path } { if { ![string compare [Widget::getoption $path -type] "button"] } { set _grab(oldrelief) [Widget::getoption $path -relief] configure $path -relief sunken } else { set _grab(oldrelief) [Widget::getoption $path -arrowrelief] configure $path -arrowrelief sunken } } } } # ------------------------------------------------------------------------------ # Command ArrowButton::_leave # ------------------------------------------------------------------------------ proc ArrowButton::_leave { path } { variable _grab set path [winfo parent $path] set _grab(current) "" if { [string compare [Widget::getoption $path -state] "disabled"] } { configure $path -state $_grab(oldstate) if { $_grab(pressed) == $path } { if { ![string compare [Widget::getoption $path -type] "button"] } { configure $path -relief $_grab(oldrelief) } else { configure $path -arrowrelief $_grab(oldrelief) } } } } # ------------------------------------------------------------------------------ # Command ArrowButton::_press # ------------------------------------------------------------------------------ proc ArrowButton::_press { path } { variable _grab set path [winfo parent $path] if { [string compare [Widget::getoption $path -state] "disabled"] } { set _grab(pressed) $path if { ![string compare [Widget::getoption $path -type] "button"] } { set _grab(oldrelief) [Widget::getoption $path -relief] configure $path -relief sunken } else { set _grab(oldrelief) [Widget::getoption $path -arrowrelief] configure $path -arrowrelief sunken } if { [set cmd [Widget::getoption $path -armcommand]] != "" } { uplevel \#0 $cmd if { [set delay [Widget::getoption $path -repeatdelay]] > 0 || [set delay [Widget::getoption $path -repeatinterval]] > 0 } { after $delay "ArrowButton::_repeat $path" } } } } # ------------------------------------------------------------------------------ # Command ArrowButton::_release # ------------------------------------------------------------------------------ proc ArrowButton::_release { path } { variable _grab set path [winfo parent $path] if { $_grab(pressed) == $path } { set _grab(pressed) "" if { ![string compare [Widget::getoption $path -type] "button"] } { configure $path -relief $_grab(oldrelief) } else { configure $path -arrowrelief $_grab(oldrelief) } if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } { uplevel \#0 $cmd } if { $_grab(current) == $path && [string compare [Widget::getoption $path -state] "disabled"] && [set cmd [Widget::getoption $path -command]] != "" } { uplevel \#0 $cmd } } } # ------------------------------------------------------------------------------ # Command ArrowButton::_repeat # ------------------------------------------------------------------------------ proc ArrowButton::_repeat { path } { variable _grab if { $_grab(current) == $path && $_grab(pressed) == $path && [string compare [Widget::getoption $path -state] "disabled"] && [set cmd [Widget::getoption $path -armcommand]] != "" } { uplevel \#0 $cmd } if { $_grab(pressed) == $path && ([set delay [Widget::getoption $path -repeatinterval]] > 0 || [set delay [Widget::getoption $path -repeatdelay]] > 0) } { after $delay "ArrowButton::_repeat $path" } }