Project

General

Profile

Statistics
| Branch: | Revision:

root / src / tkenv / tree.tcl @ e1750c09

History | View | Annotate | Download (11.7 KB)

1 01873262 Georg Kunz
#=================================================================
2
#  TREE.TCL - part of
3
#
4
#                     OMNeT++/OMNEST
5
#            Discrete System Simulation in C++
6
#
7
#   Losely based on:
8
#      tree.tcl, Copyright (C) 1997,1998 D. Richard Hipp
9
#      Author contact information:
10
#        drh@acm.org
11
#        http://www.hwaci.com/drh/
12
#      tree.tcl falls under the GNU Library General Public License
13
#
14
#=================================================================
15
16
#----------------------------------------------------------------#
17
#  Copyright (C) 1992-2008 Andras Varga
18
#
19
#  This file is distributed WITHOUT ANY WARRANTY. See the file
20
#  `license' for details on this and other legal matters.
21
#----------------------------------------------------------------#
22
23
#
24
# Changes by Andras Varga:
25
# - Tree:init to take content provider procedure
26
# - texts may contain "\b" to turn *bold* on/off
27
# - multi-line text accepted (beware when mixing with bold:
28
#   on each "\b", text jumps back to the top!)
29
# - multi-line texts can be opened/closed (if there're child nodes
30
#   as well, they open/close together with the text)
31
# - added keyboard navigation and proc Tree:view
32
# - can act as checkboxtree (checkbox can be turned on/off per tree node)
33
#
34
35
#
36
# Bitmaps used to show which parts of the tree can be opened.
37
#
38
set maskdata "#define solid_width 9\n#define solid_height 9"
39
append maskdata {
40
  static unsigned char solid_bits[] = {
41
   0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
42
   0xff, 0x01, 0xff, 0x01, 0xff, 0x01
43
  };
44
}
45
set data "#define open_width 9\n#define open_height 9"
46
append data {
47
  static unsigned char open_bits[] = {
48
   0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
49
   0x01, 0x01, 0x01, 0x01, 0xff, 0x01
50
  };
51
}
52
image create bitmap Tree:openbm -data $data -maskdata $maskdata \
53
  -foreground black -background white
54
set data "#define closed_width 9\n#define closed_height 9"
55
append data {
56
  static unsigned char closed_bits[] = {
57
   0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
58
   0x11, 0x01, 0x01, 0x01, 0xff, 0x01
59
  };
60
}
61
image create bitmap Tree:closedbm -data $data -maskdata $maskdata \
62
  -foreground black -background white
63
64
65
#
66
# Initialize a new tree widget. $w must be a previously created Tk canvas, and
67
# f a content provider procedure (like getNodeInfo).
68
#
69
proc Tree:init {w f} {
70
  global Tree
71
  set Tree($w:function) $f
72
  set v [$Tree($w:function) $w root]
73
  set Tree($w:$v:open) 0
74
  set Tree($w:selection) {}
75
  set Tree($w:selidx) {}
76
  set Tree($w:lastid) 0
77
78
  # forget tree checked state to force re-read
79
  foreach i [array names Tree "$w:*:checked"] {
80
      unset Tree($i)
81
  }
82
83
  Tree:buildwhenidle $w
84
  $w config -takefocus 1 -highlightcolor gray -highlightthickness 1
85
  Tree:addbindings $w
86
}
87
88
#
89
# Change the selection to the indicated item
90
#
91
proc Tree:setselection {w v} {
92
  global Tree
93
  set Tree($w:selection) $v
94
  Tree:drawselection $w
95
  Tree:view $w $v
96
}
97
98
#
99
# Retrieve the current selection
100
#
101
proc Tree:getselection w {
102
  global Tree
103
  return $Tree($w:selection)
104
}
105
106
#
107
# Scroll the canvas so that the given node becomes visible,
108
# provided it's currently displayed at all.
109
#
110
proc Tree:view {w v} {
111
  set bbox [$w bbox "node-$v"]
112
  if {$bbox!=""} {
113
    set done 0
114
    while {!$done} {
115
      set again 1
116
      set y1 [lindex $bbox 1]
117
      set y2 [lindex $bbox 3]
118
      set cy1 [$w canvasy 0]
119
      set cy2 [expr $cy1 + [winfo height $w]]
120
      if {$y1 < $cy1} {
121
          # scroll up
122
          $w yview scroll -1 units
123
          update idletasks
124
      } elseif {$y2 > $cy2 && ($y2-$y1 < $cy2-$cy1)} {
125
          # scroll down
126
          $w yview scroll 1 units
127
          update idletasks
128
      } else {
129
          set done 1
130
      }
131
    }
132
  }
133
}
134
135
#
136
# Open a branch of a tree
137
#
138
proc Tree:open {w v} {
139
  global Tree
140
  set isopen 0
141
  catch {set isopen $Tree($w:$v:open)}
142
  if {!$isopen && [$Tree($w:function) $w haschildren $v]} {
143
    set Tree($w:$v:open) 1
144
    Tree:build $w
145
  }
146
}
147
148
#
149
# Close a branch of a tree
150
#
151
proc Tree:close {w v} {
152
  global Tree
153
  set isopen 0
154
  catch {set isopen $Tree($w:$v:open)}
155
  if {$isopen} {
156
    set Tree($w:$v:open) 0
157
    Tree:build $w
158
  }
159
}
160
161
#
162
# Toggle a branch of a tree
163
#
164
proc Tree:toggle {w v} {
165
  global Tree
166
  if {[info exists Tree($w:$v:open)] && $Tree($w:$v:open)==1} {
167
    set Tree($w:$v:open) 0
168
  } else {
169
    set Tree($w:$v:open) 1
170
  }
171
  Tree:build $w
172
}
173
174
#
175
# Return the full pathname of the label for widget $w that is located
176
# at real coordinates $x, $y
177
#
178
proc Tree:nodeat {w x y} {
179
  set x [$w canvasx $x]
180
  set y [$w canvasy $y]
181
  return [Tree:nodeatcc $w $x $y]
182
}
183
184
#
185
# Return the full pathname of the label for widget $w that is located
186
# at canvas coordinates $x, $y
187
#
188
proc Tree:nodeatcc {w x y} {
189
  foreach m [$w find overlapping $x $y $x $y] {
190
    foreach tag [$w gettags $m] {
191
      if [string match "node-*" $tag] {
192
        regexp -- {node-(.*)} $tag match v
193
        return $v
194
      }
195
    }
196
  }
197
  return ""
198
}
199
200
#
201
# Returns the tooltip for the given node
202
#
203
proc Tree:gettooltip {w v} {
204
  global Tree
205
  if {$v==""} {return ""}
206
  return [$Tree($w:function) $w tooltip $v]
207
}
208
209
#
210
# Returns the name of the variable that's bound to the checkbox state
211
# for the given node. May not exist. Needs to be declared "global" to be accessed.
212
#
213
proc Tree:getcheckvar {w v} {
214
  return "Tree($w:$v:checked)"
215
}
216
217
#
218
# Returns the list of nodes for which checkbox state is kept.
219
#
220
proc Tree:getcheckvars {w} {
221
  global Tree
222
  set result {}
223
  foreach i [array names Tree "$w:*:checked"] {
224
    regsub -- "$w:(.*):checked" $i "\\1" v
225
    lappend result $v
226
  }
227
  return $result
228
}
229
230
#
231
# Draw the tree on the canvas
232
#
233
proc Tree:build {w} {
234
  global Tree
235
  $w delete all
236
  catch {unset Tree($w:buildpending)}
237
  set Tree($w:y) 30
238
  Tree:buildlayer $w [$Tree($w:function) $w root] 10
239
  Tree:drawselection $w
240
  $w config -scrollregion [$w bbox all]
241
242
  ## attempt to prevent scrolling when nodes don't fill the canvas. doesn't work.
243
  #set bbox [$w bbox all]
244
  #set h [winfo height $w]
245
  #if {[lindex $bbox 3]<$h} {lset bbox 3 $h}
246
  #$w config -scrollregion $bbox
247
}
248
249
#
250
# Internal use only.
251
# Build a single layer of the tree on the canvas.  Indent by $in pixels
252
#
253
proc Tree:buildlayer {w v in} {
254
  global Tree fonts
255
  if {$v==[$Tree($w:function) $w root]} {
256
    set vx {}
257
  } else {
258
    set vx $v
259
  }
260
  set start [expr $Tree($w:y)-10]
261
  set y $Tree($w:y)
262
  foreach c [$Tree($w:function) $w children $v] {
263
    set y $Tree($w:y)
264
    $w create line $in $y [expr $in+10] $y -fill gray50
265
266
    # get data
267
    set needcheckbox [$Tree($w:function) $w needcheckbox $c]
268
    set text [$Tree($w:function) $w text $c]
269
    set options [$Tree($w:function) $w options $c]
270
    set icon [$Tree($w:function) $w icon $c]
271
272
    # draw checkbox, icon and text
273
    set x [expr $in+12]
274
    if {$needcheckbox} {
275
        set tag "_$Tree($w:lastid)"
276
        incr Tree($w:lastid)
277
        set cb $w.$tag
278
        checkbutton $cb -padx 0 -pady 0 -bg [$w cget -bg] -takefocus 0 -activebackground [$w cget -bg] -variable Tree($w:$c:checked) -command [list Tree:checkstatechanged $w $c]
279
        $w create window $x $y -window $cb -anchor w
280
        incr x [winfo reqwidth $cb]
281
    }
282
    if {[string length $icon]>0} {
283
      set tags [list "node-$c" "tooltip"]
284
      set k [$w create image $x $y -image $icon -anchor w -tags $tags]
285
      incr x 20
286
    }
287
    set tags [list "node-$c" "text-$c" "tooltip"]
288
    set ismultiline [expr [string first "\n" $text]!=-1]
289
    set isopen 0
290
    if {$ismultiline && [info exists Tree($w:$c:open)]} {set isopen $Tree($w:$c:open)}
291
    set j [Tree:createtext $w $x $y $text $isopen $tags]
292
    eval $w itemconfig $j $options
293
294
    # draw helper line for keyboard navigation
295
    set bbox [$w bbox $j]
296
    set top [lindex [$w bbox $j] 1]
297
    set bottom [lindex [$w bbox $j] 3]
298
    $w create line 0 $top 0 $bottom -tags [list "node-$c" "helper"] -fill ""
299
    set Tree($w:y) [expr $bottom + 8]
300
301
    # draw [+] or [-] symbols
302
    if {$ismultiline || [$Tree($w:function) $w haschildren $c]} {
303
      if {[info exists Tree($w:$c:open)] && $Tree($w:$c:open)} {
304
         set j [$w create image $in $y -image Tree:openbm]
305
         $w bind $j <1> "set Tree($w:$c:open) 0; Tree:build $w"
306
         Tree:buildlayer $w $c [expr $in+18]
307
      } else {
308
         set j [$w create image $in $y -image Tree:closedbm]
309
         $w bind $j <1> "set Tree($w:$c:open) 1; Tree:build $w"
310
      }
311
    }
312
  }
313
  set j [$w create line $in $start $in [expr $y+1] -fill gray50 ]
314
  $w lower $j
315
}
316
317
#
318
# Internal use only.
319
# Displays the given text. "\b" charachers switch *bold* on/off. Returns tag.
320
#
321
proc Tree:createtext {w x y txt isopen tags} {
322
    global fonts Tree
323
324
    if {!$isopen} {regsub -all "\n" $txt " \\ " txt}
325
326
    set tag "_$Tree($w:lastid)"
327
    incr Tree($w:lastid)
328
    lappend tags $tag
329
330
    # position center of 1st line on y given coord (we use "nw" achor)
331
    incr y -6
332
333
    set bold 0
334
    foreach txtfrag [split $txt "\b"] {
335
        set font [expr $bold ? {$fonts(bold)} : {$fonts(normal)}]
336
        set color [expr $bold ? {"blue4"} : {"black"}]
337
        set id [$w create text $x $y -text $txtfrag -anchor nw -font $font -fill $color -tags $tags]
338
        set x [lindex [$w bbox $id] 2]
339
        set bold [expr !$bold]
340
    }
341
342
343
    return $tag
344
}
345
346
#
347
# Internal use only.
348
# Draw the selection highlight
349
#
350
proc Tree:drawselection w {
351
  global Tree
352
  if {[string length $Tree($w:selidx)]} {
353
    $w delete $Tree($w:selidx)
354
  }
355
  set v $Tree($w:selection)
356
  set bbox [$w bbox "text-$v"]
357
  if {[llength $bbox]==4} {
358
    set i [eval $w create rectangle $bbox -fill skyblue -outline {{}}]
359
    set Tree($w:selidx) $i
360
    $w lower $i
361
  } else {
362
    set Tree($w:selidx) {}
363
  }
364
}
365
366
#
367
# Internal use only
368
# Call Tree:build the next time we're idle
369
#
370
proc Tree:buildwhenidle w {
371
  global Tree
372
  if {![info exists Tree($w:buildpending)]} {
373
    set Tree($w:buildpending) 1
374
    after idle "Tree:build $w"
375
  }
376
}
377
378
#
379
# Internal use only.
380
# Add keyboard bindings to the tree widget
381
#
382
proc Tree:addbindings w {
383
  bind $w <Button-1> {
384
      focus %W
385
      set key [Tree:nodeat %W %x %y]
386
      if {$key!=""} {
387
          Tree:setselection %W $key
388
      }
389
  }
390
  bind $w <Up> {Tree:up %W}
391
  bind $w <Down> {Tree:down %W}
392
  bind $w <Return> {Tree:togglestate %W}
393
  bind $w <space> {Tree:toggleorcheck %W}
394
  bind $w <Left> {Tree:togglestate %W}
395
  bind $w <Right> {Tree:togglestate %W}
396
}
397
398
#
399
# Internal use only.
400
# Move selection to the element above the selected one
401
#
402
proc Tree:up w {
403
  set sel [Tree:getselection $w]
404
  if {$sel!=""} {
405
    set bbox [$w bbox "node-$sel"]
406
    set y [expr [lindex $bbox 1]-5]
407
    set nodeabove [Tree:nodeatcc $w 0 $y]
408
    if {$nodeabove!=""} {
409
        Tree:setselection $w $nodeabove
410
    }
411
  }
412
}
413
414
#
415
# Internal use only.
416
# Move selection to the element below the selected one
417
#
418
proc Tree:down w {
419
  set sel [Tree:getselection $w]
420
  if {$sel!=""} {
421
    set bbox [$w bbox "node-$sel"]
422
    set y [expr [lindex $bbox 3]+5]
423
    set nodebelow [Tree:nodeatcc $w 0 $y]
424
    if {$nodebelow!=""} {
425
        Tree:setselection $w $nodebelow
426
    }
427
  }
428
}
429
430
#
431
# Internal use only.
432
# If the node has a checkbox, check/uncheck it; otherwise toggle open/closed state
433
#
434
proc Tree:toggleorcheck w {
435
  global Tree
436
  set v [Tree:getselection $w]
437
  if {[info exist Tree($w:$v:checked)]} {
438
    set Tree($w:$v:checked) [expr !$Tree($w:$v:checked)]
439
    Tree:checkstatechanged $w $v
440
  } else {
441
    Tree:toggle $w $v
442
  }
443
}
444
445
#
446
# Internal use only.
447
# Opens the selected node if it's closed, and closes it if it's open
448
#
449
proc Tree:togglestate w {
450
  global Tree
451
  set v [Tree:getselection $w]
452
  if {$v!=""} {
453
    Tree:toggle $w $v
454
  }
455
}
456
457
#
458
# Internal use only.
459
# Called when a checkbox state changed.
460
#
461
proc Tree:checkstatechanged {w v} {
462
  global Tree
463
  set state $Tree($w:$v:checked)
464
  Tree:checksubtree $w $v $state
465
}
466
467
# Internal use only: helper for checkstatechanged
468
proc Tree:checksubtree {w v state} {
469
  global Tree
470
  set Tree($w:$v:checked) $state
471
  foreach c [$Tree($w:function) $w children $v] {
472
      Tree:checksubtree $w $c $state
473
  }
474
}