home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / bwidget1.3.0 / spinbox.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  11.6 KB  |  343 lines
  1. # spinbox.tcl --
  2. #
  3. #    BWidget SpinBox implementation.
  4. #
  5. # Copyright (c) 1999 by Unifix
  6. # Copyright (c) 2000 by Ajuba Solutions
  7. # All rights reserved.
  8. # 
  9. # RCS: @(#) $Id: spinbox.tcl,v 1.10 2000/05/30 23:44:46 ericm Exp $
  10. # -----------------------------------------------------------------------------
  11. #  Index of commands:
  12. #     - SpinBox::create
  13. #     - SpinBox::configure
  14. #     - SpinBox::cget
  15. #     - SpinBox::setvalue
  16. #     - SpinBox::_destroy
  17. #     - SpinBox::_modify_value
  18. #     - SpinBox::_test_options
  19. # -----------------------------------------------------------------------------
  20.  
  21. namespace eval SpinBox {
  22.     ArrowButton::use
  23.     Entry::use
  24.  
  25.     Widget::tkinclude SpinBox frame :cmd \
  26.         include {-background -borderwidth -bg -bd -relief} \
  27.         initialize {-relief sunken -borderwidth 2}
  28.  
  29.     Widget::bwinclude SpinBox Entry .e \
  30.         remove {-relief -bd -borderwidth -fg -bg} \
  31.         rename {-foreground -entryfg -background -entrybg}
  32.  
  33.     Widget::declare SpinBox {
  34.         {-range          String ""  0}
  35.         {-values         String ""  0}
  36.         {-modifycmd      String ""  0}
  37.         {-repeatdelay    Int    400 0 {%d >= 0}}
  38.         {-repeatinterval Int    100 0 {%d >= 0}}
  39.     {-foreground     TkResource black 0 {button}}
  40.     }
  41.  
  42.     Widget::addmap SpinBox "" :cmd {-background {}}
  43.     Widget::addmap SpinBox ArrowButton .arrup {
  44.         -foreground {} -background {} -disabledforeground {} -state {} \
  45.         -repeatinterval {} -repeatdelay {}
  46.     }
  47.     Widget::addmap SpinBox ArrowButton .arrdn {
  48.         -foreground {} -background {} -disabledforeground {} -state {} \
  49.         -repeatinterval {} -repeatdelay {}
  50.     }
  51.  
  52.     ::bind SpinBox <FocusIn> [list after idle {BWidget::refocus %W %W.e}]
  53.     ::bind SpinBox <Destroy> {SpinBox::_destroy %W}
  54.  
  55.     interp alias {} ::SpinBox {} ::SpinBox::create
  56.     proc use {} {}
  57.  
  58.     variable _widget
  59. }
  60.  
  61.  
  62. # -----------------------------------------------------------------------------
  63. #  Command SpinBox::create
  64. # -----------------------------------------------------------------------------
  65. proc SpinBox::create { path args } {
  66.     array set maps [list SpinBox {} :cmd {} .e {} .arrup {} .arrdn {}]
  67.     array set maps [Widget::parseArgs SpinBox $args]
  68.     eval frame $path $maps(:cmd) -highlightthickness 0 \
  69.         -takefocus 0 -class SpinBox
  70.     Widget::initFromODB SpinBox $path $maps(SpinBox)
  71.  
  72.     set entry [eval Entry::create $path.e $maps(.e) -relief flat -bd 0]
  73.     bindtags $path.e [linsert [bindtags $path.e] 1 SpinBoxEntry]
  74.  
  75.     set farr   [frame $path.farr -relief flat -bd 0 -highlightthickness 0]
  76.     set height [expr {[winfo reqheight $path.e]/2-2}]
  77.     set width  11
  78.     set arrup  [eval ArrowButton::create $path.arrup -dir top \
  79.         $maps(.arrup) \
  80.         -highlightthickness 0 -borderwidth 1 -takefocus 0 \
  81.         -type button \
  82.         -width $width -height $height \
  83.         -armcommand    [list "SpinBox::_modify_value $path next arm"] \
  84.         -disarmcommand [list "SpinBox::_modify_value $path next disarm"]]
  85.     set arrdn  [eval ArrowButton::create $path.arrdn -dir bottom \
  86.         $maps(.arrdn) \
  87.         -highlightthickness 0 -borderwidth 1 -takefocus 0 \
  88.         -type button \
  89.         -width $width -height $height \
  90.         -armcommand    [list "SpinBox::_modify_value $path previous arm"] \
  91.         -disarmcommand [list "SpinBox::_modify_value $path previous disarm"]]
  92.  
  93.     # --- update SpinBox value ---
  94.     _test_options $path
  95.     set val [Entry::cget $path.e -text]
  96.     if { [string equal $val ""] } {
  97.     Entry::configure $path.e -text $::SpinBox::_widget($path,curval)
  98.     } else {
  99.     set ::SpinBox::_widget($path,curval) $val
  100.     }
  101.  
  102.     grid $arrup -in $farr -column 0 -row 0 -sticky nsew
  103.     grid $arrdn -in $farr -column 0 -row 2 -sticky nsew
  104.     grid rowconfigure $farr 0 -weight 1
  105.     grid rowconfigure $farr 2 -weight 1
  106.  
  107.     pack $farr  -side right -fill y
  108.     pack $entry -side left  -fill both -expand yes
  109.  
  110.     ::bind $entry <Key-Up>    "SpinBox::_modify_value $path next activate"
  111.     ::bind $entry <Key-Down>  "SpinBox::_modify_value $path previous activate"
  112.     ::bind $entry <Key-Prior> "SpinBox::_modify_value $path last activate"
  113.     ::bind $entry <Key-Next>  "SpinBox::_modify_value $path first activate"
  114.  
  115.     ::bind $farr <Configure> {grid rowconfigure %W 1 -minsize [expr {%h%%2}]}
  116.  
  117.     rename $path ::$path:cmd
  118.     proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]"
  119.  
  120.     return $path
  121. }
  122.  
  123. # -----------------------------------------------------------------------------
  124. #  Command SpinBox::configure
  125. # -----------------------------------------------------------------------------
  126. proc SpinBox::configure { path args } {
  127.     set res [Widget::configure $path $args]
  128.     if { [Widget::hasChangedX $path -values] ||
  129.          [Widget::hasChangedX $path -range] } {
  130.         _test_options $path
  131.     }
  132.     return $res
  133. }
  134.  
  135.  
  136. # -----------------------------------------------------------------------------
  137. #  Command SpinBox::cget
  138. # -----------------------------------------------------------------------------
  139. proc SpinBox::cget { path option } {
  140.     return [Widget::cget $path $option]
  141. }
  142.  
  143.  
  144. # -----------------------------------------------------------------------------
  145. #  Command SpinBox::setvalue
  146. # -----------------------------------------------------------------------------
  147. proc SpinBox::setvalue { path index } {
  148.     variable _widget
  149.  
  150.     set values [Widget::getMegawidgetOption $path -values]
  151.     set value  [Entry::cget $path.e -text]
  152.     
  153.     if { [llength $values] } {
  154.         # --- -values SpinBox ---
  155.         switch -- $index {
  156.             next {
  157.                 if { [set idx [lsearch $values $value]] != -1 } {
  158.                     incr idx
  159.                 } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
  160.                     set idx [lsearch $values $_widget($path,curval)]
  161.                 }
  162.             }
  163.             previous {
  164.                 if { [set idx [lsearch $values $value]] != -1 } {
  165.                     incr idx -1
  166.                 } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
  167.                     set idx [lsearch $values $_widget($path,curval)]
  168.                 }
  169.             }
  170.             first {
  171.                 set idx 0
  172.             }
  173.             last {
  174.                 set idx [expr {[llength $values]-1}]
  175.             }
  176.             default {
  177.                 if { [string index $index 0] == "@" } {
  178.                     set idx [string range $index 1 end]
  179.                     if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
  180.                         return -code error "bad index \"$index\""
  181.                     }
  182.                 } else {
  183.                     return -code error "bad index \"$index\""
  184.                 }
  185.             }
  186.         }
  187.         if { $idx >= 0 && $idx < [llength $values] } {
  188.             set newval [lindex $values $idx]
  189.         } else {
  190.             return 0
  191.         }
  192.     } else {
  193.         # --- -range SpinBox ---
  194.     foreach {vmin vmax incr} [Widget::getMegawidgetOption $path -range] {
  195.         break
  196.     }
  197.     # Allow zero padding on the value; strip it out for calculation by
  198.     # scanning the value into a floating point number.
  199.     scan $value %f value
  200.         switch -- $index {
  201.             next {
  202.                 if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
  203.                     set newval $_widget($path,curval)
  204.                 } else {
  205.                     set newval [expr {$vmin+(round($idx)+1)*$incr}]
  206.                     if { $newval < $vmin } {
  207.                         set newval $vmin
  208.                     } elseif { $newval > $vmax } {
  209.                         set newval $vmax
  210.                     }
  211.                 }
  212.             }
  213.             previous {
  214.                 if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
  215.                     set newval $_widget($path,curval)
  216.                 } else {
  217.                     set newval [expr {$vmin+(round($idx)-1)*$incr}]
  218.                     if { $newval < $vmin } {
  219.                         set newval $vmin
  220.                     } elseif { $newval > $vmax } {
  221.                         set newval $vmax
  222.                     }
  223.                 }
  224.             }
  225.             first {
  226.                 set newval $vmin
  227.             }
  228.             last {
  229.                 set newval $vmax
  230.             }
  231.             default {
  232.                 if { [string index $index 0] == "@" } {
  233.                     set idx [string range $index 1 end]
  234.                     if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
  235.                         return -code error "bad index \"$index\""
  236.                     }
  237.                     set newval [expr {$vmin+int($idx)*$incr}]
  238.                     if { $newval < $vmin || $newval > $vmax } {
  239.                         return 0
  240.                     }
  241.                 } else {
  242.                     return -code error "bad index \"$index\""
  243.                 }
  244.             }
  245.         }
  246.     }
  247.     set _widget($path,curval) $newval
  248.     Entry::configure $path.e -text $newval
  249.     return 1
  250. }
  251.  
  252.  
  253. # -----------------------------------------------------------------------------
  254. #  Command SpinBox::getvalue
  255. # -----------------------------------------------------------------------------
  256. proc SpinBox::getvalue { path } {
  257.     variable _widget
  258.  
  259.     set values [Widget::getMegawidgetOption $path -values]
  260.     set value  [Entry::cget $path.e -text]
  261.  
  262.     if { [llength $values] } {
  263.         # --- -values SpinBox ---
  264.         return  [lsearch $values $value]
  265.     } else {
  266.     foreach {vmin vmax incr} [Widget::getMegawidgetOption $path -range] {
  267.         break
  268.     }
  269.         if { ![catch {expr {double($value-$vmin)/$incr}} idx] &&
  270.              $idx == int($idx) } {
  271.             return [expr {int($idx)}]
  272.         }
  273.         return -1
  274.     }
  275. }
  276.  
  277.  
  278. # -----------------------------------------------------------------------------
  279. #  Command SpinBox::bind
  280. # -----------------------------------------------------------------------------
  281. proc SpinBox::bind { path args } {
  282.     return [eval ::bind $path.e $args]
  283. }
  284.  
  285.  
  286. # -----------------------------------------------------------------------------
  287. #  Command SpinBox::_destroy
  288. # -----------------------------------------------------------------------------
  289. proc SpinBox::_destroy { path } {
  290.     variable _widget
  291.  
  292.     unset _widget($path,curval)
  293.     Widget::destroy $path
  294.     rename $path {}
  295. }
  296.  
  297.  
  298. # -----------------------------------------------------------------------------
  299. #  Command SpinBox::_modify_value
  300. # -----------------------------------------------------------------------------
  301. proc SpinBox::_modify_value { path direction reason } {
  302.     if { $reason == "arm" || $reason == "activate" } {
  303.         SpinBox::setvalue $path $direction
  304.     }
  305.     if { ($reason == "disarm" || $reason == "activate") &&
  306.          [set cmd [Widget::getMegawidgetOption $path -modifycmd]] != "" } {
  307.         uplevel \#0 $cmd
  308.     }
  309. }
  310.  
  311. # -----------------------------------------------------------------------------
  312. #  Command SpinBox::_test_options
  313. # -----------------------------------------------------------------------------
  314. proc SpinBox::_test_options { path } {
  315.     set values [Widget::getMegawidgetOption $path -values]
  316.     if { [llength $values] } {
  317.         set ::SpinBox::_widget($path,curval) [lindex $values 0]
  318.     } else {
  319.     foreach {vmin vmax incr} [Widget::getMegawidgetOption $path -range] {
  320.         break
  321.     }
  322.     set update 0
  323.         if { [catch {expr {int($vmin)}}] } {
  324.             set vmin 0
  325.         set update 1
  326.         }
  327.         if { [catch {expr {$vmax<$vmin}} res] || $res } {
  328.             set vmax $vmin
  329.         set update 1
  330.         }
  331.         if { [catch {expr {$incr<0}} res] || $res } {
  332.             set incr 1
  333.         set update 1
  334.         }
  335.     # Only do the set back (which is expensive) if we changed a value
  336.     if { $update } {
  337.         Widget::setMegawidgetOption $path -range [list $vmin $vmax $incr]
  338.     }
  339.         set ::SpinBox::_widget($path,curval) $vmin
  340.     }
  341. }
  342.  
  343.