home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / spinbox.tcl < prev    next >
Encoding:
Text File  |  2000-11-02  |  12.6 KB  |  352 lines
  1. # ------------------------------------------------------------------------------
  2. #  spinbox.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. # ------------------------------------------------------------------------------
  5. #  Index of commands:
  6. #     - SpinBox::create
  7. #     - SpinBox::configure
  8. #     - SpinBox::cget
  9. #     - SpinBox::setvalue
  10. #     - SpinBox::_destroy
  11. #     - SpinBox::_modify_value
  12. #     - SpinBox::_test_options
  13. # ------------------------------------------------------------------------------
  14.  
  15. namespace eval SpinBox {
  16.     ArrowButton::use
  17.     Entry::use
  18.     LabelFrame::use
  19.  
  20.     Widget::bwinclude SpinBox LabelFrame .labf \
  21.         rename     {-text -label} \
  22.         prefix     {label -justify -width -anchor -height -font} \
  23.         remove     {-focus} \
  24.         initialize {-relief sunken -borderwidth 2}
  25.  
  26.     Widget::bwinclude SpinBox Entry .e \
  27.         remove {-relief -bd -borderwidth -fg -bg} \
  28.         rename {-foreground -entryfg -background -entrybg}
  29.  
  30.     Widget::declare SpinBox {
  31.         {-range     String "" 0}
  32.         {-values    String "" 0}
  33.         {-modifycmd String "" 0}
  34.     }
  35.  
  36.     Widget::addmap SpinBox "" :cmd {-background {}}
  37.     Widget::addmap SpinBox ArrowButton .arrup \
  38.         {-foreground {} -background {} -disabledforeground {} -state {}}
  39.     Widget::addmap SpinBox ArrowButton .arrdn \
  40.         {-foreground {} -background {} -disabledforeground {} -state {}}
  41.  
  42.     Widget::syncoptions SpinBox Entry .e {-text {}}
  43.     Widget::syncoptions SpinBox LabelFrame .labf {-label -text -underline {}}
  44.  
  45.     ::bind BwSpinBox <FocusIn> {focus %W.labf}
  46.     ::bind BwSpinBox <Destroy> {SpinBox::_destroy %W}
  47.  
  48.     proc ::SpinBox { path args } { return [eval SpinBox::create $path $args] }
  49.     proc use {} {}
  50.  
  51.     variable _widget
  52. }
  53.  
  54.  
  55. # ------------------------------------------------------------------------------
  56. #  Command SpinBox::create
  57. # ------------------------------------------------------------------------------
  58. proc SpinBox::create { path args } {
  59.     variable _widget
  60.  
  61.     Widget::init SpinBox $path $args
  62.  
  63.     _test_options $path
  64.     eval frame $path [Widget::subcget $path :cmd] \
  65.         -highlightthickness 0 -bd 0 -relief flat -takefocus 0
  66.     set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
  67.                   -borderwidth 2 -relief sunken -focus $path.e]
  68.     set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
  69.                    -relief flat -borderwidth 0]
  70.  
  71.     bindtags $path [list $path BwSpinBox [winfo toplevel $path] all]
  72.  
  73.     set farr   [frame $path.farr -relief flat -bd 0 -highlightthickness 0]
  74.     set height [expr {[winfo reqheight $path.e]/2-2}]
  75.     set width  11
  76.     set arrup  [eval ArrowButton::create $path.arrup -dir top \
  77.                     [Widget::subcget $path .arrup] \
  78.                     -highlightthickness 0 -borderwidth 1 -takefocus 0\
  79.                     -type button \
  80.                     -width $width -height $height \
  81.                     -armcommand    [list "SpinBox::_modify_value $path next arm"] \
  82.                     -disarmcommand [list "SpinBox::_modify_value $path next disarm"] \
  83.                     -repeatdelay 400 \
  84.                     -repeatinterval 50]
  85.     set arrdn  [eval ArrowButton::create $path.arrdn -dir bottom \
  86.                     [Widget::subcget $path .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.                     -repeatdelay 400 \
  93.                     -repeatinterval 50]
  94.     set frame [LabelFrame::getframe $path.labf]
  95.  
  96.     # --- update -value ---
  97.     if { [set val [Entry::cget $path.e -text]] != "" } {
  98.         set _widget($path,curval) $val
  99.     } else {
  100.         if { [set var [Widget::getoption $path -textvariable]] != "" } {
  101.             GlobalVar::setvar $var $_widget($path,curval)
  102.         } else {
  103.             Entry::configure $path.e -text $_widget($path,curval)
  104.         }
  105.     }
  106.     Widget::setoption $path -text $_widget($path,curval)
  107.  
  108.     grid $arrup -in $farr -column 0 -row 0 -sticky nsew
  109.     grid $arrdn -in $farr -column 0 -row 2 -sticky nsew
  110.     grid rowconfigure $farr 0 -weight 1
  111.     grid rowconfigure $farr 2 -weight 1
  112.  
  113.     pack $farr  -in $frame -side right -fill y
  114.     pack $entry -in $frame -side left  -fill both -expand yes
  115.     pack $labf  -fill both -expand yes
  116.  
  117.     ::bind $entry <Key-Up>    "SpinBox::_modify_value $path next activate"
  118.     ::bind $entry <Key-Down>  "SpinBox::_modify_value $path previous activate"
  119.     ::bind $entry <Key-Prior> "SpinBox::_modify_value $path last activate"
  120.     ::bind $entry <Key-Next>  "SpinBox::_modify_value $path first activate"
  121.  
  122.     ::bind $farr <Configure> {grid rowconfigure %W 1 -minsize [expr {%h%%2}]}
  123.  
  124.     rename $path ::$path:cmd
  125.     proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]"
  126.  
  127.     return $path
  128. }
  129.  
  130.  
  131. # ------------------------------------------------------------------------------
  132. #  Command SpinBox::configure
  133. # ------------------------------------------------------------------------------
  134. proc SpinBox::configure { path args } {
  135.     set res [Widget::configure $path $args]
  136.     if { [Widget::hasChanged $path -values val] ||
  137.          [Widget::hasChanged $path -range  val] } {
  138.         _test_options $path
  139.     }
  140.     return $res
  141. }
  142.  
  143.  
  144. # ------------------------------------------------------------------------------
  145. #  Command SpinBox::cget
  146. # ------------------------------------------------------------------------------
  147. proc SpinBox::cget { path option } {
  148.     return [Widget::cget $path $option]
  149. }
  150.  
  151.  
  152. # ------------------------------------------------------------------------------
  153. #  Command SpinBox::setvalue
  154. # ------------------------------------------------------------------------------
  155. proc SpinBox::setvalue { path index } {
  156.     variable _widget
  157.  
  158.     set values [Widget::getoption $path -values]
  159.     set value  [Entry::cget $path.e -text]
  160.  
  161.     if { [llength $values] } {
  162.         # --- -values SpinBox ---
  163.         switch -- $index {
  164.             next {
  165.                 if { [set idx [lsearch $values $value]] != -1 } {
  166.                     incr idx
  167.                 } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
  168.                     set idx [lsearch $values $_widget($path,curval)]
  169.                 }
  170.             }
  171.             previous {
  172.                 if { [set idx [lsearch $values $value]] != -1 } {
  173.                     incr idx -1
  174.                 } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
  175.                     set idx [lsearch $values $_widget($path,curval)]
  176.                 }
  177.             }
  178.             first {
  179.                 set idx 0
  180.             }
  181.             last {
  182.                 set idx [expr {[llength $values]-1}]
  183.             }
  184.             default {
  185.                 if { [string index $index 0] == "@" } {
  186.                     set idx [string range $index 1 end]
  187.                     if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
  188.                         return -code error "bad index \"$index\""
  189.                     }
  190.                 } else {
  191.                     return -code error "bad index \"$index\""
  192.                 }
  193.             }
  194.         }
  195.         if { $idx >= 0 && $idx < [llength $values] } {
  196.             set newval [lindex $values $idx]
  197.         } else {
  198.             return 0
  199.         }
  200.     } else {
  201.         # --- -range SpinBox ---
  202.         set range [Widget::getoption $path -range]
  203.         set vmin  [lindex $range 0]
  204.         set vmax  [lindex $range 1]
  205.         set incr  [lindex $range 2]
  206.         switch -- $index {
  207.             next {
  208.                 if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
  209.                     set newval $_widget($path,curval)
  210.                 } else {
  211.                     set newval [expr {$vmin+(round($idx)+1)*$incr}]
  212.                     if { $newval < $vmin } {
  213.                         set newval $vmin
  214.                     } elseif { $newval > $vmax } {
  215.                         set newval $vmax
  216.                     }
  217.                 }
  218.             }
  219.             previous {
  220.                 if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
  221.                     set newval $_widget($path,curval)
  222.                 } else {
  223.                     set newval [expr {$vmin+(round($idx)-1)*$incr}]
  224.                     if { $newval < $vmin } {
  225.                         set newval $vmin
  226.                     } elseif { $newval > $vmax } {
  227.                         set newval $vmax
  228.                     }
  229.                 }
  230.             }
  231.             first {
  232.                 set newval $vmin
  233.             }
  234.             last {
  235.                 set newval $vmax
  236.             }
  237.             default {
  238.                 if { [string index $index 0] == "@" } {
  239.                     set idx [string range $index 1 end]
  240.                     if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
  241.                         return -code error "bad index \"$index\""
  242.                     }
  243.                     set newval [expr {$vmin+int($idx)*$incr}]
  244.                     if { $newval < $vmin || $newval > $vmax } {
  245.                         return 0
  246.                     }
  247.                 } else {
  248.                     return -code error "bad index \"$index\""
  249.                 }
  250.             }
  251.         }
  252.     }
  253.     set _widget($path,curval) $newval
  254.     Widget::setoption $path -text $newval
  255.     if { [set varname [Entry::cget $path.e -textvariable]] != "" } {
  256.         GlobalVar::setvar $varname $newval
  257.     } else {
  258.         Entry::configure $path.e -text $newval
  259.     }
  260.     return 1
  261. }
  262.  
  263.  
  264. # ------------------------------------------------------------------------------
  265. #  Command SpinBox::getvalue
  266. # ------------------------------------------------------------------------------
  267. proc SpinBox::getvalue { path } {
  268.     variable _widget
  269.  
  270.     set values [Widget::getoption $path -values]
  271.     set value  [Entry::cget $path.e -text]
  272.  
  273.     if { [llength $values] } {
  274.         # --- -values SpinBox ---
  275.         return  [lsearch $values $value]
  276.     } else {
  277.         set range [Widget::getoption $path -range]
  278.         set vmin  [lindex $range 0]
  279.         set vmax  [lindex $range 1]
  280.         set incr  [lindex $range 2]
  281.         if { ![catch {expr {double($value-$vmin)/$incr}} idx] &&
  282.              $idx == int($idx) } {
  283.             return [expr {int($idx)}]
  284.         }
  285.         return -1
  286.     }
  287. }
  288.  
  289.  
  290. # ------------------------------------------------------------------------------
  291. #  Command SpinBox::bind
  292. # ------------------------------------------------------------------------------
  293. proc SpinBox::bind { path args } {
  294.     return [eval ::bind $path.e $args]
  295. }
  296.  
  297.  
  298. # ------------------------------------------------------------------------------
  299. #  Command SpinBox::_destroy
  300. # ------------------------------------------------------------------------------
  301. proc SpinBox::_destroy { path } {
  302.     variable _widget
  303.  
  304.     unset _widget($path,curval)
  305.     Widget::destroy $path
  306.     rename $path {}
  307. }
  308.  
  309.  
  310. # ------------------------------------------------------------------------------
  311. #  Command SpinBox::_modify_value
  312. # ------------------------------------------------------------------------------
  313. proc SpinBox::_modify_value { path direction reason } {
  314.     if { $reason == "arm" || $reason == "activate" } {
  315.         SpinBox::setvalue $path $direction
  316.     }
  317.     if { ($reason == "disarm" || $reason == "activate") &&
  318.          [set cmd [Widget::getoption $path -modifycmd]] != "" } {
  319.         uplevel \#0 $cmd
  320.     }
  321. }
  322.  
  323.  
  324. # ------------------------------------------------------------------------------
  325. #  Command SpinBox::_test_options
  326. # ------------------------------------------------------------------------------
  327. proc SpinBox::_test_options { path } {
  328.     variable _widget
  329.  
  330.     set values [Widget::getoption $path -values]
  331.     if { [llength $values] } {
  332.         set _widget($path,curval) [lindex $values 0]
  333.     } else {
  334.         set range [Widget::getoption $path -range]
  335.         set vmin  [lindex $range 0]
  336.         set vmax  [lindex $range 1]
  337.         set incr  [lindex $range 2]
  338.         if { [catch {expr {int($vmin)}}] } {
  339.             set vmin 0
  340.         }
  341.         if { [catch {expr {$vmax<$vmin}} res] || $res } {
  342.             set vmax $vmin
  343.         }
  344.         if { [catch {expr {$incr<0}} res] || $res } {
  345.             set incr 1
  346.         }
  347.         Widget::setoption $path -range [list $vmin $vmax $incr]
  348.         set _widget($path,curval) $vmin
  349.     }
  350. }
  351.  
  352.