"Fossies" - the Fresh Open Source Software Archive

Member "Pansophica-src-1.3/BAF_modules/tcl/src/NVR_BWidgets/arrow.tcl" (10 Apr 2007, 20839 Bytes) of package /linux/www/old/Pansophica-src-1.3-1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "arrow.tcl" see the Fossies "Dox" file reference documentation.

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