home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / itcl1_30.z / itcl1_30 / usr / lib / itcl / SelectBox.tcl < prev    next >
Encoding:
Text File  |  1993-11-16  |  10.3 KB  |  377 lines
  1. #
  2. # SelectBox
  3. # ----------------------------------------------------------------------
  4. # Implements a selection box widget using primitive widgets as the
  5. # building blocks.  A selection box widget displays a list of items
  6. # and allows the user to scroll through the list and select single
  7. # or multiple items.  This class is derived from ListBox, and so
  8. # it inherits the basic listbox display behavior.
  9. #
  10. #   PUBLIC ATTRIBUTES:
  11. #
  12. #     -mode .......... single/multi selection
  13. #     -action ........ callback invoked whenever entry is selected/unselected
  14. #
  15. #     -list .......... list of items to be displayed
  16. #     -width ......... width of displayed list in characters or "expand"
  17. #     -height ........ height of displayed list in lines or "expand"
  18. #
  19. #   METHODS:
  20. #
  21. #     config ....... used to change public attributes
  22. #     get .......... returns "all" or "selected" list
  23. #     select ....... select/unselect entries programmatically
  24. #
  25. #   X11 OPTION DATABASE ATTRIBUTES
  26. #
  27. #     selectBackground ... background color for selected entries
  28. #     selectForeground ... foreground color for selected entries
  29. #
  30. #     listBackground ..... background color for entries
  31. #     listForeground ..... foreground color for entries
  32. #
  33. #     ...and the rest of the usual widget attributes
  34. #
  35. # ----------------------------------------------------------------------
  36. #   AUTHOR:  Michael J. McLennan       Phone: (215)770-2842
  37. #            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  38. #
  39. #     SCCS:  @(#)SelectBox.tcl    1.4 (10/14/93)
  40. # ----------------------------------------------------------------------
  41. #            Copyright (c) 1993  AT&T  All Rights Reserved
  42. # ======================================================================
  43.  
  44. itcl_class SelectBox {
  45.     inherit ListBox
  46.  
  47.     # ------------------------------------------------------------------
  48.     #  CONSTRUCTOR - create new selectbox
  49.     # ------------------------------------------------------------------
  50.     constructor {config} {
  51.         ListBox::constructor
  52.  
  53.         set normalbg [option get $this listBackground SelectBox]
  54.         if {$normalbg == ""} {set normalbg white}
  55.         set normalfg [option get $this listForeground SelectBox]
  56.         if {$normalfg == ""} {set normalfg black}
  57.         $this.list config -bg $normalbg -fg $normalfg
  58.  
  59.         set selectfg [option get $this selectForeground SelectBox]
  60.         set selectbg [option get $this selectBackground SelectBox]
  61.  
  62.         switch [tk colormodel $this] {
  63.             monochrome {
  64.                 if {$selectbg == ""} {set selectbg black}
  65.                 if {$selectfg == ""} {set selectfg white}
  66.             }
  67.             color {
  68.                 if {$selectbg == ""} {set selectbg LightSteelBlue}
  69.                 if {$selectfg == ""} {set selectfg black}
  70.             }
  71.         }
  72.         set focusbg [option get $this focusBackground SelectBox]
  73.         if {$focusbg == ""} {set focusbg $normalfg}
  74.         set focusfg [option get $this focusForeground SelectBox]
  75.         if {$focusfg == ""} {set focusfg $normalbg}
  76.  
  77.         bind $this.list <1> "$this _clickStart \[%W index @%x,%y\]"
  78.         bind $this.list <Double-1> { }
  79.         bind $this.list <Triple-1> { }
  80.         bind $this.list <Shift-1> { }
  81.         bind $this.list <Shift-B1-Motion> { }
  82.         bind $this.list <Any-Key> { }
  83.  
  84.         _resetArray active
  85.         config -mode $mode
  86.  
  87.         #
  88.         #  Explicitly handle config's that may have been ignored earlier
  89.         #
  90.         foreach attr $config {
  91.             config -$attr [set $attr]
  92.         }
  93.     }
  94.  
  95.     # ------------------------------------------------------------------
  96.     #  METHOD:  config - used to change public attributes
  97.     # ------------------------------------------------------------------
  98.     method config {config} {}
  99.  
  100.     # ------------------------------------------------------------------
  101.     #  DESTRUCTOR - destroy window containing widget
  102.     # ------------------------------------------------------------------
  103.     destructor {
  104.         ::rename $this-win- {}
  105.         destroy $this
  106.     }
  107.  
  108.     # ------------------------------------------------------------------
  109.     #  METHOD:  get - returns "all" or "selected" list
  110.     # ------------------------------------------------------------------
  111.     method get {{what all}} {
  112.         switch $what {
  113.             all {
  114.                 return $list
  115.             }
  116.             selected {
  117.                 set selns {}
  118.                 foreach tag [array names active] {
  119.                     lappend selns $active($tag)
  120.                 }
  121.                 return [lsort $selns]
  122.             }
  123.             default {
  124.                 error "invalid arg \"$what\": should be all or selected"
  125.             }
  126.         }
  127.     }
  128.  
  129.     # ------------------------------------------------------------------
  130.     #  METHOD:  select - public access for highlighting entries
  131.     #   USAGE:  select all
  132.     #           select reset
  133.     #           select entry label state
  134.     # ------------------------------------------------------------------
  135.     method select {how args} {
  136.         switch $how {
  137.             reset {
  138.                 foreach tag [array names active] {
  139.                     _deactivate $tag
  140.                 }
  141.             }
  142.             all {
  143.                 foreach item $list {
  144.                     _activate $tags($item)
  145.                 }
  146.             }
  147.             entry {
  148.                 if {[llength $args] != 2} {
  149.                     error "improper usage: should be \"select entry label state\""
  150.                 }
  151.                 set label [lindex $args 0]
  152.                 set state [lindex $args 1]
  153.                 if {[info exists tags($label)]} {
  154.                     set tag $tags($label)
  155.                     switch $state {
  156.                         on {
  157.                             if {$mode == "single"} {
  158.                                 foreach old [array names active] {
  159.                                     if {$old != $tag} {
  160.                                         _deactivate $old
  161.                                     }
  162.                                 }
  163.                             }
  164.                             _activate $tag
  165.                         }
  166.                         off {
  167.                             _deactivate $tag
  168.                         }
  169.                         default {
  170.                             error "improper state: should be \"on\" or \"off\""
  171.                         }
  172.                     }
  173.                 } else {
  174.                     error "entry not found in SelectBox $this: $label"
  175.                 }
  176.             }
  177.             default {
  178.                 error "wrong # args: should be \"select type ?args?\""
  179.             }
  180.         }
  181.     }
  182.  
  183.     # ------------------------------------------------------------------
  184.     #  METHOD:  _hilite - temporary highlight when pointer is over entry
  185.     # ------------------------------------------------------------------
  186.     method _hilite {tag state} {
  187.         switch $state {
  188.             on {
  189.                 $this.list tag config $tag \
  190.                     -background $focusbg -foreground $focusfg
  191.             }
  192.             off {
  193.                 if {[info exists active($tag)]} {
  194.                     $this.list tag config $tag -relief raised \
  195.                         -background $selectbg -foreground $selectfg
  196.                 } else {
  197.                     $this.list tag config $tag -relief flat \
  198.                         -background $normalbg -foreground $normalfg
  199.                 }
  200.             }
  201.         }
  202.     }
  203.  
  204.     # ------------------------------------------------------------------
  205.     #  METHOD:  _activate - add item to "active" list
  206.     # ------------------------------------------------------------------
  207.     method _activate {tag} {
  208.         if {$tag != ""} {
  209.             if {![info exists active($tag)]} {
  210.                 set active($tag) $items($tag)
  211.             }
  212.             $this.list tag config $tag -relief raised \
  213.                 -background $selectbg -foreground $selectfg
  214.  
  215.             if {$action != ""} {
  216.                 eval $action [list $items($tag)] on
  217.             }
  218.         }
  219.     }
  220.  
  221.     # ------------------------------------------------------------------
  222.     #  METHOD:  _deactivate - remove item from "active" list
  223.     # ------------------------------------------------------------------
  224.     method _deactivate {tag} {
  225.         if {$tag != ""} {
  226.             $this.list tag config $tag -relief flat \
  227.                 -background $normalbg -foreground $normalfg
  228.  
  229.             if {[info exists active($tag)]} {
  230.                 unset active($tag)
  231.  
  232.                 if {$action != ""} {
  233.                     eval $action [list $items($tag)] off
  234.                 }
  235.             }
  236.         }
  237.     }
  238.  
  239.     # ------------------------------------------------------------------
  240.     #  METHOD:  _clickStart - invoked for button-press selection
  241.     # ------------------------------------------------------------------
  242.     method _clickStart {current} {
  243.         $this.list mark set selstart current
  244.         $this.list mark set sellast current
  245.         set tag [$this.list tag names $current]
  246.  
  247.         if {$mode == "single"} {
  248.             foreach old [array names active] {
  249.                 if {$old != $tag} {
  250.                     _deactivate $old
  251.                 }
  252.             }
  253.         } else {
  254.             set snapshot [array names active]
  255.         }
  256.  
  257.         if {[info exists active($tag)]} {
  258.             set sweep unselect
  259.             _deactivate $tag
  260.         } else {
  261.             set sweep select
  262.             _activate $tag
  263.         }
  264.     }
  265.  
  266.     # ------------------------------------------------------------------
  267.     #  METHOD:  _clickSweep - invoked for button-press movement
  268.     # ------------------------------------------------------------------
  269.     method _clickSweep {current} {
  270.         set start [$this.list index selstart]
  271.         set dist [expr abs($current-$start)]
  272.         set last [expr abs([$this.list index sellast]-$start)]
  273.  
  274.         set op $sweep
  275.         if {$dist < $last} {
  276.             set op restore
  277.         }
  278.  
  279.         set cline [lindex [split $current "."] 0]
  280.         set lline [lindex [split [$this.list index sellast] "."] 0]
  281.         if {$lline < $cline} {
  282.             set inc 1
  283.         } else {
  284.             set inc -1
  285.         }
  286.  
  287.         for {set line $lline} {$line != [expr $cline+$inc]} {incr line $inc} {
  288.             set tag [$this.list tag names $line.0]
  289.             switch $op {
  290.                 select {
  291.                     _activate $tag
  292.                 }
  293.                 unselect {
  294.                     _deactivate $tag
  295.                 }
  296.                 restore {
  297.                     if {[lsearch $snapshot $tag] >= 0} {
  298.                         _activate $tag
  299.                     } else {
  300.                         _deactivate $tag
  301.                     }
  302.                 }
  303.             }
  304.         }
  305.         _hilite $current on
  306.         $this.list mark set sellast $current
  307.     }
  308.  
  309.     # ------------------------------------------------------------------
  310.     #  METHOD:  _resetArray - clear array to empty state
  311.     # ------------------------------------------------------------------
  312.     method _resetArray {name} {
  313.         catch "unset $name"
  314.         set ${name}(0) "make-this-an-array"
  315.         unset ${name}(0)
  316.     }
  317.  
  318.     #
  319.     #  PUBLIC DATA
  320.     #
  321.     public list {} {
  322.         if {[winfo exists $this]} {
  323.             foreach tag [array names active] {
  324.                 if {$action != ""} {
  325.                     eval $action [list $active($tag)] off
  326.                 }
  327.             }
  328.             ListBox::config -list $list
  329.             _resetArray active
  330.  
  331.             foreach item [array names tags] {
  332.                 set tag $tags($item)
  333.                 $this.list tag bind $tag <Enter> "$this _hilite $tag on"
  334.                 $this.list tag bind $tag <Leave> "$this _hilite $tag off"
  335.             }
  336.         }
  337.     }
  338.     public mode multi {
  339.         if {[winfo exists $this]} {
  340.             set skip 1
  341.             if {$mode == "single"} {
  342.                 foreach tag [array names active] {
  343.                     if {!$skip} {
  344.                         _deactivate $tag
  345.                     }
  346.                     set skip 0
  347.                 }
  348.                 bind $this.list <B1-Motion> { }
  349.             } else {
  350.                 bind $this.list <B1-Motion> \
  351.                     "$this _clickSweep \[%W index @%x,%y\]"
  352.             }
  353.         }
  354.     }
  355.     public action {}
  356.  
  357.     #
  358.     #  PROTECTED DATA
  359.     #    active ......... array of tags for selected entries
  360.     #    snapshot ....... snapshot of "active" list used during click-drag
  361.     #    sweep .......... select/unselect type of click-drag sweep
  362.     #
  363.     #    selectbg ....... background color for selected entries
  364.     #    selectfg ....... foreground color for selected entries
  365.     #    focusbg ........ background color when pointer is over entry
  366.     #    focusfg ........ foreground color when pointer is over entry
  367.     #
  368.     protected active
  369.     protected snapshot {}
  370.     protected sweep {}
  371.  
  372.     protected selectbg {}
  373.     protected selectfg {}
  374.     protected focusbg {}
  375.     protected focusfg {}
  376. }
  377.