home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / TCL / ITCL / _ITCL.TAR / usr / lib / itcl / demos / widgets / SelectBox.tcl < prev    next >
Encoding:
Text File  |  1994-04-08  |  11.3 KB  |  393 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: (610)712-2842
  37. #            AT&T Bell Laboratories   E-mail: michael.mclennan@att.com
  38. #
  39. #      RCS:  SelectBox.tcl,v 1.3 1994/04/08 13:39:21 mmc Exp
  40. # ----------------------------------------------------------------------
  41. #               Copyright (c) 1993  AT&T Bell Laboratories
  42. # ======================================================================
  43. # Permission to use, copy, modify, and distribute this software and its
  44. # documentation for any purpose and without fee is hereby granted,
  45. # provided that the above copyright notice appear in all copies and that
  46. # both that the copyright notice and warranty disclaimer appear in
  47. # supporting documentation, and that the names of AT&T Bell Laboratories
  48. # any of their entities not be used in advertising or publicity
  49. # pertaining to distribution of the software without specific, written
  50. # prior permission.
  51. #
  52. # AT&T disclaims all warranties with regard to this software, including
  53. # all implied warranties of merchantability and fitness.  In no event
  54. # shall AT&T be liable for any special, indirect or consequential
  55. # damages or any damages whatsoever resulting from loss of use, data or
  56. # profits, whether in an action of contract, negligence or other
  57. # tortuous action, arising out of or in connection with the use or
  58. # performance of this software.
  59. # ======================================================================
  60.  
  61. itcl_class SelectBox {
  62.     inherit ListBox
  63.  
  64.     # ------------------------------------------------------------------
  65.     #  CONSTRUCTOR - create new selectbox
  66.     # ------------------------------------------------------------------
  67.     constructor {config} {
  68.         ListBox::constructor
  69.  
  70.         set normalbg [option get $this listBackground SelectBox]
  71.         if {$normalbg == ""} {set normalbg white}
  72.         set normalfg [option get $this listForeground SelectBox]
  73.         if {$normalfg == ""} {set normalfg black}
  74.         $this.list config -bg $normalbg -fg $normalfg
  75.  
  76.         set selectfg [option get $this selectForeground SelectBox]
  77.         set selectbg [option get $this selectBackground SelectBox]
  78.  
  79.         switch [tk colormodel $this] {
  80.             monochrome {
  81.                 if {$selectbg == ""} {set selectbg black}
  82.                 if {$selectfg == ""} {set selectfg white}
  83.             }
  84.             color {
  85.                 if {$selectbg == ""} {set selectbg LightSteelBlue}
  86.                 if {$selectfg == ""} {set selectfg black}
  87.             }
  88.         }
  89.         set focusbg [option get $this focusBackground SelectBox]
  90.         if {$focusbg == ""} {set focusbg $normalfg}
  91.         set focusfg [option get $this focusForeground SelectBox]
  92.         if {$focusfg == ""} {set focusfg $normalbg}
  93.  
  94.         bind $this.list <1> "$this _clickStart \[%W index @%x,%y\]"
  95.         bind $this.list <Double-1> { }
  96.         bind $this.list <Triple-1> { }
  97.         bind $this.list <Shift-1> { }
  98.         bind $this.list <Shift-B1-Motion> { }
  99.         bind $this.list <Any-Key> { }
  100.  
  101.         _resetArray active
  102.         config -mode $mode
  103.  
  104.         #
  105.         #  Explicitly handle config's that may have been ignored earlier
  106.         #
  107.         foreach attr $config {
  108.             config -$attr [set $attr]
  109.         }
  110.     }
  111.  
  112.     # ------------------------------------------------------------------
  113.     #  METHOD:  config - used to change public attributes
  114.     # ------------------------------------------------------------------
  115.     method config {config} {}
  116.  
  117.     # ------------------------------------------------------------------
  118.     #  DESTRUCTOR - destroy window containing widget
  119.     # ------------------------------------------------------------------
  120.     #  Nothing to do--ListBox destructor will clean up
  121.     destructor {
  122.     }
  123.  
  124.     # ------------------------------------------------------------------
  125.     #  METHOD:  get - returns "all" or "selected" list
  126.     # ------------------------------------------------------------------
  127.     method get {{what all}} {
  128.         switch $what {
  129.             all {
  130.                 return $list
  131.             }
  132.             selected {
  133.                 set selns {}
  134.                 foreach tag [array names active] {
  135.                     lappend selns $active($tag)
  136.                 }
  137.                 return [lsort $selns]
  138.             }
  139.             default {
  140.                 error "invalid arg \"$what\": should be all or selected"
  141.             }
  142.         }
  143.     }
  144.  
  145.     # ------------------------------------------------------------------
  146.     #  METHOD:  select - public access for highlighting entries
  147.     #   USAGE:  select all
  148.     #           select reset
  149.     #           select entry label state
  150.     # ------------------------------------------------------------------
  151.     method select {how args} {
  152.         switch $how {
  153.             reset {
  154.                 foreach tag [array names active] {
  155.                     _deactivate $tag
  156.                 }
  157.             }
  158.             all {
  159.                 foreach item $list {
  160.                     _activate $tags($item)
  161.                 }
  162.             }
  163.             entry {
  164.                 if {[llength $args] != 2} {
  165.                     error "improper usage: should be \"select entry label state\""
  166.                 }
  167.                 set label [lindex $args 0]
  168.                 set state [lindex $args 1]
  169.                 if {[info exists tags($label)]} {
  170.                     set tag $tags($label)
  171.                     switch $state {
  172.                         on {
  173.                             if {$mode == "single"} {
  174.                                 foreach old [array names active] {
  175.                                     if {$old != $tag} {
  176.                                         _deactivate $old
  177.                                     }
  178.                                 }
  179.                             }
  180.                             _activate $tag
  181.                         }
  182.                         off {
  183.                             _deactivate $tag
  184.                         }
  185.                         default {
  186.                             error "improper state: should be \"on\" or \"off\""
  187.                         }
  188.                     }
  189.                 } else {
  190.                     error "entry not found in SelectBox $this: $label"
  191.                 }
  192.             }
  193.             default {
  194.                 error "wrong # args: should be \"select type ?args?\""
  195.             }
  196.         }
  197.     }
  198.  
  199.     # ------------------------------------------------------------------
  200.     #  METHOD:  _hilite - temporary highlight when pointer is over entry
  201.     # ------------------------------------------------------------------
  202.     method _hilite {tag state} {
  203.         switch $state {
  204.             on {
  205.                 $this.list tag config $tag \
  206.                     -background $focusbg -foreground $focusfg
  207.             }
  208.             off {
  209.                 if {[info exists active($tag)]} {
  210.                     $this.list tag config $tag -relief raised \
  211.                         -background $selectbg -foreground $selectfg
  212.                 } else {
  213.                     $this.list tag config $tag -relief flat \
  214.                         -background $normalbg -foreground $normalfg
  215.                 }
  216.             }
  217.         }
  218.     }
  219.  
  220.     # ------------------------------------------------------------------
  221.     #  METHOD:  _activate - add item to "active" list
  222.     # ------------------------------------------------------------------
  223.     method _activate {tag} {
  224.         if {$tag != ""} {
  225.             if {![info exists active($tag)]} {
  226.                 set active($tag) $items($tag)
  227.             }
  228.             $this.list tag config $tag -relief raised \
  229.                 -background $selectbg -foreground $selectfg
  230.  
  231.             if {$action != ""} {
  232.                 eval $action [list $items($tag)] on
  233.             }
  234.         }
  235.     }
  236.  
  237.     # ------------------------------------------------------------------
  238.     #  METHOD:  _deactivate - remove item from "active" list
  239.     # ------------------------------------------------------------------
  240.     method _deactivate {tag} {
  241.         if {$tag != ""} {
  242.             $this.list tag config $tag -relief flat \
  243.                 -background $normalbg -foreground $normalfg
  244.  
  245.             if {[info exists active($tag)]} {
  246.                 unset active($tag)
  247.  
  248.                 if {$action != ""} {
  249.                     eval $action [list $items($tag)] off
  250.                 }
  251.             }
  252.         }
  253.     }
  254.  
  255.     # ------------------------------------------------------------------
  256.     #  METHOD:  _clickStart - invoked for button-press selection
  257.     # ------------------------------------------------------------------
  258.     method _clickStart {current} {
  259.         $this.list mark set selstart current
  260.         $this.list mark set sellast current
  261.         set tag [$this.list tag names $current]
  262.  
  263.         if {$mode == "single"} {
  264.             foreach old [array names active] {
  265.                 if {$old != $tag} {
  266.                     _deactivate $old
  267.                 }
  268.             }
  269.         } else {
  270.             set snapshot [array names active]
  271.         }
  272.  
  273.         if {[info exists active($tag)]} {
  274.             set sweep unselect
  275.             _deactivate $tag
  276.         } else {
  277.             set sweep select
  278.             _activate $tag
  279.         }
  280.     }
  281.  
  282.     # ------------------------------------------------------------------
  283.     #  METHOD:  _clickSweep - invoked for button-press movement
  284.     # ------------------------------------------------------------------
  285.     method _clickSweep {current} {
  286.         set start [$this.list index selstart]
  287.         set dist [expr abs($current-$start)]
  288.         set last [expr abs([$this.list index sellast]-$start)]
  289.  
  290.         set op $sweep
  291.         if {$dist < $last} {
  292.             set op restore
  293.         }
  294.  
  295.         set cline [lindex [split $current "."] 0]
  296.         set lline [lindex [split [$this.list index sellast] "."] 0]
  297.         if {$lline < $cline} {
  298.             set inc 1
  299.         } else {
  300.             set inc -1
  301.         }
  302.  
  303.         for {set line $lline} {$line != [expr $cline+$inc]} {incr line $inc} {
  304.             set tag [$this.list tag names $line.0]
  305.             switch $op {
  306.                 select {
  307.                     _activate $tag
  308.                 }
  309.                 unselect {
  310.                     _deactivate $tag
  311.                 }
  312.                 restore {
  313.                     if {[lsearch $snapshot $tag] >= 0} {
  314.                         _activate $tag
  315.                     } else {
  316.                         _deactivate $tag
  317.                     }
  318.                 }
  319.             }
  320.         }
  321.         _hilite $current on
  322.         $this.list mark set sellast $current
  323.     }
  324.  
  325.     # ------------------------------------------------------------------
  326.     #  METHOD:  _resetArray - clear array to empty state
  327.     # ------------------------------------------------------------------
  328.     method _resetArray {name} {
  329.         catch "unset $name"
  330.         set ${name}(0) "make-this-an-array"
  331.         unset ${name}(0)
  332.     }
  333.  
  334.     #
  335.     #  PUBLIC DATA
  336.     #
  337.     public list {} {
  338.         if {[winfo exists $this]} {
  339.             foreach tag [array names active] {
  340.                 if {$action != ""} {
  341.                     eval $action [list $active($tag)] off
  342.                 }
  343.             }
  344.             config -ListBox::list $list
  345.             _resetArray active
  346.  
  347.             foreach item [array names tags] {
  348.                 set tag $tags($item)
  349.                 $this.list tag bind $tag <Enter> "$this _hilite $tag on"
  350.                 $this.list tag bind $tag <Leave> "$this _hilite $tag off"
  351.             }
  352.         }
  353.     }
  354.     public mode multi {
  355.         if {[winfo exists $this]} {
  356.             set skip 1
  357.             if {$mode == "single"} {
  358.                 foreach tag [array names active] {
  359.                     if {!$skip} {
  360.                         _deactivate $tag
  361.                     }
  362.                     set skip 0
  363.                 }
  364.                 bind $this.list <B1-Motion> { }
  365.             } else {
  366.                 bind $this.list <B1-Motion> \
  367.                     "$this _clickSweep \[%W index @%x,%y\]"
  368.             }
  369.         }
  370.     }
  371.     public action {}
  372.  
  373.     #
  374.     #  PROTECTED DATA
  375.     #    active ......... array of tags for selected entries
  376.     #    snapshot ....... snapshot of "active" list used during click-drag
  377.     #    sweep .......... select/unselect type of click-drag sweep
  378.     #
  379.     #    selectbg ....... background color for selected entries
  380.     #    selectfg ....... foreground color for selected entries
  381.     #    focusbg ........ background color when pointer is over entry
  382.     #    focusfg ........ foreground color when pointer is over entry
  383.     #
  384.     protected active
  385.     protected snapshot {}
  386.     protected sweep {}
  387.  
  388.     protected selectbg {}
  389.     protected selectfg {}
  390.     protected focusbg {}
  391.     protected focusfg {}
  392. }
  393.