1# ------------------------------------------------------------------------------ 2# arrow.tcl 3# This file is part of Unifix BWidget Toolkit 4# $Id: arrow.tcl,v 1.11 2009/09/06 21:03:04 oberdorfer Exp $ 5# ------------------------------------------------------------------------------ 6# Index of commands: 7# Public commands 8# - ArrowButton::create 9# - ArrowButton::configure 10# - ArrowButton::cget 11# - ArrowButton::invoke 12# Private commands (redraw commands) 13# - ArrowButton::_redraw 14# - ArrowButton::_redraw_state 15# - ArrowButton::_redraw_relief 16# - ArrowButton::_redraw_whole 17# Private commands (event bindings) 18# - ArrowButton::_destroy 19# - ArrowButton::_enter 20# - ArrowButton::_leave 21# - ArrowButton::_press 22# - ArrowButton::_release 23# - ArrowButton::_repeat 24# - ArrowButton::_themechanged 25# ------------------------------------------------------------------------------ 26 27namespace eval ArrowButton { 28 Widget::define ArrowButton arrow DynamicHelp 29 30 Widget::tkinclude ArrowButton button .c \ 31 include [list \ 32 -borderwidth -bd \ 33 -relief -highlightbackground \ 34 -highlightcolor -highlightthickness -takefocus] 35 36 Widget::declare ArrowButton [list \ 37 [list -type Enum button 0 [list arrow button]] \ 38 [list -dir Enum top 0 [list top bottom left right]] \ 39 [list -width Int 15 0 "%d >= 0"] \ 40 [list -height Int 15 0 "%d >= 0"] \ 41 [list -ipadx Int 0 0 "%d >= 0"] \ 42 [list -ipady Int 0 0 "%d >= 0"] \ 43 [list -clean Int 2 0 "%d >= 0 && %d <= 2"] \ 44 \ 45 [list -foreground Color "SystemWindowText" 0] \ 46 [list -background Color "SystemWindowFrame" 0] \ 47 [list -activeforeground Color "SystemButtonText" 0] \ 48 [list -activebackground Color "SystemButtonFace" 0] \ 49 [list -disabledforeground Color "SystemDisabledText" 0] \ 50 [list -troughcolor Color "SystemScrollbar" 0] \ 51 \ 52 [list -state TkResource "" 0 button] \ 53 [list -arrowbd Int 1 0 "%d >= 0 && %d <= 2"] \ 54 [list -arrowrelief Enum raised 0 [list raised sunken]] \ 55 [list -command String "" 0] \ 56 [list -armcommand String "" 0] \ 57 [list -disarmcommand String "" 0] \ 58 [list -repeatdelay Int 0 0 "%d >= 0"] \ 59 [list -repeatinterval Int 0 0 "%d >= 0"] \ 60 [list -fg Synonym -foreground] \ 61 [list -bg Synonym -background] \ 62 ] 63 DynamicHelp::include ArrowButton balloon 64 65 bind BwArrowButtonC <Enter> {ArrowButton::_enter %W} 66 bind BwArrowButtonC <Leave> {ArrowButton::_leave %W} 67 bind BwArrowButtonC <ButtonPress-1> {ArrowButton::_press %W} 68 bind BwArrowButtonC <ButtonRelease-1> {ArrowButton::_release %W} 69 bind BwArrowButtonC <Key-space> {ArrowButton::invoke %W; break} 70 bind BwArrowButtonC <Return> {ArrowButton::invoke %W; break} 71 bind BwArrowButton <Configure> {ArrowButton::_redraw_whole %W %w %h} 72 bind BwArrowButton <Destroy> {ArrowButton::_destroy %W} 73 74 if {[lsearch [bindtags .] ArrowButtonThemeChanged] < 0} { 75 bindtags . [linsert [bindtags .] 1 ArrowButtonThemeChanged] 76 } 77 78 variable _grab 79 variable _moved 80 81 array set _grab {current "" pressed "" oldstate "" oldrelief ""} 82} 83 84 85# ----------------------------------------------------------------------------- 86# Command ArrowButton::create 87# ----------------------------------------------------------------------------- 88proc ArrowButton::create { path args } { 89 # Initialize configuration mappings and parse arguments 90 array set submaps [list ArrowButton [list ] .c [list ]] 91 array set submaps [Widget::parseArgs ArrowButton $args] 92 93 # Create the class frame (so we can do the option db queries) 94 frame $path -class ArrowButton -borderwidth 0 -highlightthickness 0 95 Widget::initFromODB ArrowButton $path $submaps(ArrowButton) 96 97 # Create the canvas with the initial options 98 eval [list canvas $path.c] $submaps(.c) 99 100 # Compute the width and height of the canvas from the width/height 101 # of the ArrowButton and the borderwidth/hightlightthickness. 102 set w [Widget::getMegawidgetOption $path -width] 103 set h [Widget::getMegawidgetOption $path -height] 104 set bd [Widget::cget $path -borderwidth] 105 set ht [Widget::cget $path -highlightthickness] 106 set pad [expr {2*($bd+$ht)}] 107 108 $path.c configure -width [expr {$w-$pad}] -height [expr {$h-$pad}] 109 bindtags $path [list $path BwArrowButton [winfo toplevel $path] all] 110 bindtags $path.c [list $path.c BwArrowButtonC [winfo toplevel $path.c] all] 111 pack $path.c -expand yes -fill both 112 113 bind ArrowButtonThemeChanged <<ThemeChanged>> \ 114 "+ [namespace current]::_themechanged $path" 115 116 DynamicHelp::sethelp $path $path.c 1 117 118 set ::ArrowButton::_moved($path) 0 119 120 return [Widget::create ArrowButton $path] 121} 122 123 124# ----------------------------------------------------------------------------- 125# Command ArrowButton::configure 126# ----------------------------------------------------------------------------- 127proc ArrowButton::configure { path args } { 128 set res [Widget::configure $path $args] 129 130 set ch1 [expr {[Widget::hasChanged $path -width w] | 131 [Widget::hasChanged $path -height h] | 132 [Widget::hasChanged $path -borderwidth bd] | 133 [Widget::hasChanged $path -highlightthickness ht]}] 134 set ch2 [expr {[Widget::hasChanged $path -type val] | 135 [Widget::hasChanged $path -ipadx val] | 136 [Widget::hasChanged $path -ipady val] | 137 [Widget::hasChanged $path -arrowbd val] | 138 [Widget::hasChanged $path -clean val] | 139 [Widget::hasChanged $path -dir val]}] 140 141 if { $ch1 } { 142 set pad [expr {2*($bd+$ht)}] 143 $path.c configure \ 144 -width [expr {$w-$pad}] -height [expr {$h-$pad}] \ 145 -borderwidth $bd -highlightthickness $ht 146 set ch2 1 147 } 148 if { $ch2 } { 149 _redraw_whole $path [winfo width $path] [winfo height $path] 150 } else { 151 _redraw_relief $path 152 _redraw_state $path 153 } 154 DynamicHelp::sethelp $path $path.c 155 156 return $res 157} 158 159 160# ----------------------------------------------------------------------------- 161# Command ArrowButton::cget 162# ----------------------------------------------------------------------------- 163proc ArrowButton::cget { path option } { 164 return [Widget::cget $path $option] 165} 166 167 168# ------------------------------------------------------------------------------ 169# Command ArrowButton::invoke 170# ------------------------------------------------------------------------------ 171proc ArrowButton::invoke { path } { 172 if { ![string equal [winfo class $path] "ArrowButton"] } { 173 set path [winfo parent $path] 174 } 175 if { ![string equal [Widget::getoption $path -state] "disabled"] } { 176 set oldstate [Widget::getoption $path -state] 177 if { [string equal [Widget::getoption $path -type] "button"] } { 178 set oldrelief [Widget::getoption $path -relief] 179 configure $path -state active -relief sunken 180 } else { 181 set oldrelief [Widget::getoption $path -arrowrelief] 182 configure $path -state active -arrowrelief sunken 183 } 184 update idletasks 185 if {[llength [set cmd [Widget::getoption $path -armcommand]]]} { 186 uplevel \#0 $cmd 187 } 188 after 10 189 if { [string equal [Widget::getoption $path -type] "button"] } { 190 configure $path -state $oldstate -relief $oldrelief 191 } else { 192 configure $path -state $oldstate -arrowrelief $oldrelief 193 } 194 if {[llength [set cmd [Widget::getoption $path -disarmcommand]]]} { 195 uplevel \#0 $cmd 196 } 197 if {[llength [set cmd [Widget::getoption $path -command]]]} { 198 uplevel \#0 $cmd 199 } 200 } 201} 202 203 204# ------------------------------------------------------------------------------ 205# Command ArrowButton::_redraw 206# ------------------------------------------------------------------------------ 207proc ArrowButton::_redraw { path width height } { 208 variable _moved 209 210 set _moved($path) 0 211 set type [Widget::getoption $path -type] 212 set dir [Widget::getoption $path -dir] 213 set bd [expr {[$path.c cget -borderwidth] + [$path.c cget -highlightthickness] + 1}] 214 set clean [Widget::getoption $path -clean] 215 if { [string equal $type "arrow"] } { 216 if { [set id [$path.c find withtag rect]] == "" } { 217 $path.c create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect 218 } else { 219 $path.c coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] 220 } 221 $path.c lower rect 222 set arrbd [Widget::getoption $path -arrowbd] 223 set bd [expr {$bd+$arrbd-1}] 224 } else { 225 $path.c delete rect 226 } 227 # w and h are max width and max height of arrow 228 set w [expr {$width - 2*([Widget::getoption $path -ipadx]+$bd)}] 229 set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}] 230 231 if { $w < 2 } {set w 2} 232 if { $h < 2 } {set h 2} 233 234 if { $clean > 0 } { 235 # arrange for base to be odd 236 if { [string equal $dir "top"] || [string equal $dir "bottom"] } { 237 if { !($w % 2) } { 238 incr w -1 239 } 240 if { $clean == 2 } { 241 # arrange for h = (w+1)/2 242 set h2 [expr {($w+1)/2}] 243 if { $h2 > $h } { 244 set w [expr {2*$h-1}] 245 } else { 246 set h $h2 247 } 248 } 249 } else { 250 if { !($h % 2) } { 251 incr h -1 252 } 253 if { $clean == 2 } { 254 # arrange for w = (h+1)/2 255 set w2 [expr {($h+1)/2}] 256 if { $w2 > $w } { 257 set h [expr {2*$w-1}] 258 } else { 259 set w $w2 260 } 261 } 262 } 263 } 264 265 set x0 [expr {($width-$w)/2}] 266 set y0 [expr {($height-$h)/2}] 267 set x1 [expr {$x0+$w-1}] 268 set y1 [expr {$y0+$h-1}] 269 270 switch $dir { 271 top { 272 set xd [expr {($x0+$x1)/2}] 273 if { [set id [$path.c find withtag poly]] == "" } { 274 $path.c create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly 275 } else { 276 $path.c coords $id $x0 $y1 $x1 $y1 $xd $y0 277 } 278 if { [string equal $type "arrow"] } { 279 if { [set id [$path.c find withtag bot]] == "" } { 280 $path.c create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot 281 } else { 282 $path.c coords $id $x0 $y1 $x1 $y1 $xd $y0 283 } 284 if { [set id [$path.c find withtag top]] == "" } { 285 $path.c create line $x0 $y1 $xd $y0 -tags top 286 } else { 287 $path.c coords $id $x0 $y1 $xd $y0 288 } 289 $path.c itemconfigure top -width $arrbd 290 $path.c itemconfigure bot -width $arrbd 291 } else { 292 $path.c delete top 293 $path.c delete bot 294 } 295 } 296 bottom { 297 set xd [expr {($x0+$x1)/2}] 298 if { [set id [$path.c find withtag poly]] == "" } { 299 $path.c create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly 300 } else { 301 $path.c coords $id $x1 $y0 $x0 $y0 $xd $y1 302 } 303 if { [string equal $type "arrow"] } { 304 if { [set id [$path.c find withtag top]] == "" } { 305 $path.c create line $x1 $y0 $x0 $y0 $xd $y1 -tags top 306 } else { 307 $path.c coords $id $x1 $y0 $x0 $y0 $xd $y1 308 } 309 if { [set id [$path.c find withtag bot]] == "" } { 310 $path.c create line $x1 $y0 $xd $y1 -tags bot 311 } else { 312 $path.c coords $id $x1 $y0 $xd $y1 313 } 314 $path.c itemconfigure top -width $arrbd 315 $path.c itemconfigure bot -width $arrbd 316 } else { 317 $path.c delete top 318 $path.c delete bot 319 } 320 } 321 left { 322 set yd [expr {($y0+$y1)/2}] 323 if { [set id [$path.c find withtag poly]] == "" } { 324 $path.c create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly 325 } else { 326 $path.c coords $id $x1 $y0 $x1 $y1 $x0 $yd 327 } 328 if { [string equal $type "arrow"] } { 329 if { [set id [$path.c find withtag bot]] == "" } { 330 $path.c create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot 331 } else { 332 $path.c coords $id $x1 $y0 $x1 $y1 $x0 $yd 333 } 334 if { [set id [$path.c find withtag top]] == "" } { 335 $path.c create line $x1 $y0 $x0 $yd -tags top 336 } else { 337 $path.c coords $id $x1 $y0 $x0 $yd 338 } 339 $path.c itemconfigure top -width $arrbd 340 $path.c itemconfigure bot -width $arrbd 341 } else { 342 $path.c delete top 343 $path.c delete bot 344 } 345 } 346 right { 347 set yd [expr {($y0+$y1)/2}] 348 if { [set id [$path.c find withtag poly]] == "" } { 349 $path.c create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly 350 } else { 351 $path.c coords $id $x0 $y1 $x0 $y0 $x1 $yd 352 } 353 if { [string equal $type "arrow"] } { 354 if { [set id [$path.c find withtag top]] == "" } { 355 $path.c create line $x0 $y1 $x0 $y0 $x1 $yd -tags top 356 } else { 357 $path.c coords $id $x0 $y1 $x0 $y0 $x1 $yd 358 } 359 if { [set id [$path.c find withtag bot]] == "" } { 360 $path.c create line $x0 $y1 $x1 $yd -tags bot 361 } else { 362 $path.c coords $id $x0 $y1 $x1 $yd 363 } 364 $path.c itemconfigure top -width $arrbd 365 $path.c itemconfigure bot -width $arrbd 366 } else { 367 $path.c delete top 368 $path.c delete bot 369 } 370 } 371 } 372} 373 374 375# ------------------------------------------------------------------------------ 376# Command ArrowButton::_redraw_state 377# ------------------------------------------------------------------------------ 378proc ArrowButton::_redraw_state { path } { 379 set state [Widget::getoption $path -state] 380 if { [string equal [Widget::getoption $path -type] "button"] } { 381 switch $state { 382 normal {set bg -background; set fg -foreground} 383 active {set bg -activebackground; set fg -activeforeground} 384 disabled {set bg -background; set fg -disabledforeground} 385 } 386 set fg [Widget::getoption $path $fg] 387 $path.c configure -background [Widget::getoption $path $bg] 388 $path.c itemconfigure poly -fill $fg -outline $fg 389 } else { 390 switch $state { 391 normal {set stipple ""; set bg [Widget::getoption $path -background] } 392 active {set stipple ""; set bg [Widget::getoption $path -activebackground] } 393 disabled {set stipple gray50; set bg black } 394 } 395 set thrc [Widget::getoption $path -troughcolor] 396 $path.c configure -background [Widget::getoption $path -background] 397 $path.c itemconfigure rect -fill $thrc -outline $thrc 398 $path.c itemconfigure poly -fill $bg -outline $bg -stipple $stipple 399 } 400} 401 402 403# ------------------------------------------------------------------------------ 404# Command ArrowButton::_redraw_relief 405# ------------------------------------------------------------------------------ 406proc ArrowButton::_redraw_relief { path } { 407 variable _moved 408 409 if { [string equal [Widget::getoption $path -type] "button"] } { 410 if { [string equal [Widget::getoption $path -relief] "sunken"] } { 411 if { !$_moved($path) } { 412 $path.c move poly 1 1 413 set _moved($path) 1 414 } 415 } else { 416 if { $_moved($path) } { 417 $path.c move poly -1 -1 418 set _moved($path) 0 419 } 420 } 421 } else { 422 set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]] 423 switch [Widget::getoption $path -arrowrelief] { 424 raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]} 425 sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]} 426 } 427 $path.c itemconfigure top -fill $top 428 $path.c itemconfigure bot -fill $bot 429 } 430} 431 432 433# ------------------------------------------------------------------------------ 434# Command ArrowButton::_redraw_whole 435# ------------------------------------------------------------------------------ 436proc ArrowButton::_redraw_whole { path width height } { 437 _redraw $path $width $height 438 _redraw_relief $path 439 _redraw_state $path 440} 441 442 443# ------------------------------------------------------------------------------ 444# Command ArrowButton::_enter 445# ------------------------------------------------------------------------------ 446proc ArrowButton::_enter { path } { 447 variable _grab 448 set path [winfo parent $path] 449 set _grab(current) $path 450 if { ![string equal [Widget::getoption $path -state] "disabled"] } { 451 set _grab(oldstate) [Widget::getoption $path -state] 452 configure $path -state active 453 if { $_grab(pressed) == $path } { 454 if { [string equal [Widget::getoption $path -type] "button"] } { 455 set _grab(oldrelief) [Widget::getoption $path -relief] 456 configure $path -relief sunken 457 } else { 458 set _grab(oldrelief) [Widget::getoption $path -arrowrelief] 459 configure $path -arrowrelief sunken 460 } 461 } 462 } 463} 464 465 466# ------------------------------------------------------------------------------ 467# Command ArrowButton::_leave 468# ------------------------------------------------------------------------------ 469proc ArrowButton::_leave { path } { 470 variable _grab 471 set path [winfo parent $path] 472 set _grab(current) "" 473 if { ![string equal [Widget::getoption $path -state] "disabled"] } { 474 configure $path -state $_grab(oldstate) 475 if { $_grab(pressed) == $path } { 476 if { [string equal [Widget::getoption $path -type] "button"] } { 477 configure $path -relief $_grab(oldrelief) 478 } else { 479 configure $path -arrowrelief $_grab(oldrelief) 480 } 481 } 482 } 483} 484 485 486# ------------------------------------------------------------------------------ 487# Command ArrowButton::_press 488# ------------------------------------------------------------------------------ 489proc ArrowButton::_press { path } { 490 variable _grab 491 set path [winfo parent $path] 492 if { ![string equal [Widget::getoption $path -state] "disabled"] } { 493 set _grab(pressed) $path 494 if { [string equal [Widget::getoption $path -type] "button"] } { 495 set _grab(oldrelief) [Widget::getoption $path -relief] 496 configure $path -relief sunken 497 } else { 498 set _grab(oldrelief) [Widget::getoption $path -arrowrelief] 499 configure $path -arrowrelief sunken 500 } 501 if {[llength [set cmd [Widget::getoption $path -armcommand]]]} { 502 uplevel \#0 $cmd 503 if { [set delay [Widget::getoption $path -repeatdelay]] > 0 || 504 [set delay [Widget::getoption $path -repeatinterval]] > 0 } { 505 after $delay [list ArrowButton::_repeat $path] 506 } 507 } 508 } 509} 510 511 512# ------------------------------------------------------------------------------ 513# Command ArrowButton::_release 514# ------------------------------------------------------------------------------ 515proc ArrowButton::_release { path } { 516 variable _grab 517 set path [winfo parent $path] 518 if { $_grab(pressed) == $path } { 519 set _grab(pressed) "" 520 if { [string equal [Widget::getoption $path -type] "button"] } { 521 configure $path -relief $_grab(oldrelief) 522 } else { 523 configure $path -arrowrelief $_grab(oldrelief) 524 } 525 if {[llength [set cmd [Widget::getoption $path -disarmcommand]]]} { 526 uplevel \#0 $cmd 527 } 528 if { $_grab(current) == $path && 529 ![string equal [Widget::getoption $path -state] "disabled"] && 530 [llength [set cmd [Widget::getoption $path -command]]]} { 531 uplevel \#0 $cmd 532 } 533 } 534} 535 536 537# ------------------------------------------------------------------------------ 538# Command ArrowButton::_repeat 539# ------------------------------------------------------------------------------ 540proc ArrowButton::_repeat { path } { 541 variable _grab 542 if { $_grab(current) == $path && $_grab(pressed) == $path && 543 ![string equal [Widget::getoption $path -state] "disabled"] && 544 [llength [set cmd [Widget::getoption $path -armcommand]]]} { 545 uplevel \#0 $cmd 546 } 547 if { $_grab(pressed) == $path && 548 ([set delay [Widget::getoption $path -repeatinterval]] > 0 || 549 [set delay [Widget::getoption $path -repeatdelay]] > 0) } { 550 after $delay [list ArrowButton::_repeat $path] 551 } 552} 553 554 555# ------------------------------------------------------------------------------ 556# Command ArrowButton::_destroy 557# ------------------------------------------------------------------------------ 558proc ArrowButton::_destroy { path } { 559 variable _moved 560 Widget::destroy $path 561 unset _moved($path) 562} 563 564# ---------------------------------------------------------------------------- 565# Command Tree::_themechanged 566# ---------------------------------------------------------------------------- 567proc ArrowButton::_themechanged { path } { 568 569 if { ![winfo exists $path] } { return } 570 BWidget::set_themedefaults 571 572 $path configure \ 573 -foreground $BWidget::colors(SystemWindowText) \ 574 -background $BWidget::colors(SystemWindowFrame) \ 575 -activeforeground $BWidget::colors(SystemButtonText) \ 576 -activebackground $BWidget::colors(SystemButtonFace) \ 577 -disabledforeground $BWidget::colors(SystemDisabledText) \ 578 -troughcolor $BWidget::colors(SystemScrollbar) 579} 580