home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / arrow.tcl next >
Text File  |  2000-11-02  |  21KB  |  549 lines
  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.  
  549.