OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [tags/] [start/] [insight/] [libgui/] [library/] [multibox.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# multibox.tcl - Multi-column listbox.
2 
# Copyright (C) 1997 Cygnus Solutions.
3 
# Written by Tom Tromey <tromey@cygnus.com>.
4 
 
5 
# FIXME:
6 
# * Should support sashes so user can repartition widget sizes.
7 
# * Should support itemcget, itemconfigure.
8 
 
9 
itcl_class Multibox {
10 
  # The selection mode.
11 
  public selectmode browse {
12 
    _apply_all configure [list -selectmode $selectmode]
13 
  }
14 
 
15 
  # The height.
16 
  public height 10 {
17 
    _apply_all configure [list -height $height]
18 
  }
19 
 
20 
  # This is a list of all the listbox widgets we've created.  Private
21 
  # variable.
22 
  protected _listboxen {}
23 
 
24 
  # Tricky: take the class bindings for the Listbox widget and turn
25 
  # them into Multibox bindings that directly run our bindings.  That
26 
  # way any binding on any of our children will automatically work the
27 
  # right way.
28 
  # FIXME: this loses if any Listbox bindings are added later.
29 
  # To really fix we need Uhler's change to support megawidgets.
30 
  foreach seq [bind Listbox] {
31 
    regsub -all -- %W [bind Listbox $seq] {[winfo parent %W]} sub
32 
    bind Multibox $seq $sub
33 
  }
34 
 
35 
  constructor {config} {
36 
    # The standard widget-making trick.
37 
    set class [$this info class]
38 
    set hull [namespace tail $this]
39 
    set old_name $this
40 
    ::rename $this $this-tmp-
41 
    ::frame $hull -class $class -relief flat -borderwidth 0
42 
    ::rename $hull $old_name-win-
43 
    ::rename $this $old_name
44 
 
45 
    scrollbar [namespace tail $this].vs -orient vertical
46 
    bind [namespace tail $this].vs <Destroy> [list $this delete]
47 
 
48 
    grid rowconfigure  [namespace tail $this] 0 -weight 0
49 
    grid rowconfigure  [namespace tail $this] 1 -weight 1
50 
  }
51 
 
52 
  destructor {
53 
    destroy $this
54 
  }
55 
 
56 
  #
57 
  # Our interface.
58 
  #
59 
 
60 
  # Add a new column.
61 
  method add {args} {
62 
    # The first array set sets up the default values, and the second
63 
    # overwrites with what the user wants.
64 
    array set opts {-width 20 -fix 0 -title Zardoz}
65 
    array set opts $args
66 
 
67 
    set num [llength $_listboxen]
68 
    listbox [namespace tail $this].box$num -exportselection 0 -height $height \
69 
      -selectmode $selectmode -width $opts(-width)
70 
    if {$num == 0} then {
71 
      [namespace tail $this].box$num configure -yscrollcommand [list [namespace tail $this].vs set]
72 
      [namespace tail $this].vs configure -command [list $this yview]
73 
    }
74 
    label [namespace tail $this].label$num -text $opts(-title) -anchor w
75 
 
76 
    # No more class bindings.
77 
    set tag_list [bindtags [namespace tail $this].box$num]
78 
    set index [lsearch -exact $tag_list Listbox]
79 
    bindtags [namespace tail $this].box$num [lreplace $tag_list $index $index Multibox]
80 
 
81 
    grid [namespace tail $this].label$num -row 0 -column $num -sticky new
82 
    grid [namespace tail $this].box$num -row 1 -column $num -sticky news
83 
    if {$opts(-fix)} then {
84 
      grid columnconfigure  [namespace tail $this] $num -weight 0 \
85 
        -minsize [winfo reqwidth [namespace tail $this].box$num]
86 
    } else {
87 
      grid columnconfigure  [namespace tail $this] $num -weight 1
88 
    }
89 
 
90 
    lappend _listboxen [namespace tail $this].box$num
91 
 
92 
    # Move the scrollbar over.
93 
    incr num
94 
    grid [namespace tail $this].vs -row 1 -column $num -sticky nsw
95 
    grid columnconfigure  [namespace tail $this] $num -weight 0
96 
  }
97 
 
98 
  method configure {config} {}
99 
 
100 
  # FIXME: should handle automatically.
101 
  method cget {option} {
102 
    switch -- $option {
103 
      -selectmode {
104 
        return $selectmode
105 
      }
106 
      -height {
107 
        return $height
108 
      }
109 
 
110 
      default {
111 
        error "option $option not supported"
112 
      }
113 
    }
114 
  }
115 
 
116 
  # FIXME: this isn't ideal.  But we want to support adding bindings
117 
  # at least.  A "bind" method might be better.
118 
  method get_boxes {} {
119 
    return $_listboxen
120 
  }
121 
 
122 
 
123 
  #
124 
  # Methods that duplicate Listbox interface.
125 
  #
126 
 
127 
  method activate index {
128 
    _apply_all activate [list $index]
129 
  }
130 
 
131 
  method bbox index {
132 
    error "bbox method not supported"
133 
  }
134 
 
135 
  method curselection {} {
136 
    return [_apply_first curselection {}]
137 
  }
138 
 
139 
  # FIXME: In itcl 1.5, can't have a method name "delete".  Sigh.
140 
  method delete_hack {args} {
141 
    _apply_all delete $args
142 
  }
143 
 
144 
  # Return some contents.  We return each item as a list of the
145 
  # columns.
146 
  method get {first {last {}}} {
147 
    if {$last == ""} then {
148 
      set r {}
149 
      foreach l $_listboxen {
150 
        lappend r [$l get $first]
151 
      }
152 
      return $r
153 
    } else {
154 
      # We do things this way so that we don't have to specially
155 
      # handle the index "end".
156 
      foreach box $_listboxen {
157 
        set seen(var-$box) [$box get $first $last]
158 
      }
159 
 
160 
      # Tricky: we use the array indices as variable names and the
161 
      # array values as values.  This lets us "easily" construct the
162 
      # result lists.
163 
      set r {}
164 
      eval foreach [array get seen] {{
165 
        set elt {}
166 
        foreach box $_listboxen {
167 
          lappend elt [set var-$box]
168 
        }
169 
        lappend r $elt
170 
      }}
171 
      return $r
172 
    }
173 
  }
174 
 
175 
  method index index {
176 
    return [_apply_first index [list $index]]
177 
  }
178 
 
179 
  # Insert some items.  Each new item is a list of items for all
180 
  # columns.
181 
  method insert {index args} {
182 
    if {[llength $args]} then {
183 
      set seen(_) {}
184 
      unset seen(_)
185 
 
186 
      foreach value $args {
187 
        foreach columnvalue $value lname $_listboxen {
188 
          lappend seen($lname) $columnvalue
189 
        }
190 
      }
191 
 
192 
      foreach box $_listboxen {
193 
        eval $box insert $index $seen($box)
194 
      }
195 
    }
196 
  }
197 
 
198 
  method nearest y {
199 
    return [_apply_first nearest [list $y]]
200 
  }
201 
 
202 
  method scan {option args} {
203 
    _apply_all scan $option $args
204 
  }
205 
 
206 
  method see index {
207 
    _apply_all see [list $index]
208 
  }
209 
 
210 
  method selection {option args} {
211 
    if {$option == "includes"} then {
212 
      return [_apply_first selection [concat $option $args]]
213 
    } else {
214 
      return [_apply_all selection [concat $option $args]]
215 
    }
216 
  }
217 
 
218 
  method size {} {
219 
    return [_apply_first size {}]
220 
  }
221 
 
222 
  method xview args {
223 
    error "xview method not supported"
224 
  }
225 
 
226 
  method yview args {
227 
    if {! [llength $args]} then {
228 
      return [_apply_first yview {}]
229 
    } else {
230 
      return [_apply_all yview $args]
231 
    }
232 
  }
233 
 
234 
 
235 
  #
236 
  # Private methods.
237 
  #
238 
 
239 
  # This applies METHOD to every listbox.
240 
  method _apply_all {method argList} {
241 
    foreach l $_listboxen {
242 
      eval $l $method $argList
243 
    }
244 
  }
245 
 
246 
  # This applies METHOD to the first listbox, and returns the result.
247 
  method _apply_first {method argList} {
248 
    set l [lindex $_listboxen 0]
249 
    return [eval $l $method $argList]
250 
  }
251 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.