source: trunk/builder/scripts/hierlist.tcl @ 4503

Last change on this file since 4503 was 3177, checked in by mmc, 8 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

File size: 19.8 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: hierlist - hierarchical list of elements
3#
4#  This widget is similar to the BLT hierbox or treeview, but it
5#  allows for embedded windows at each node.
6# ======================================================================
7#  AUTHOR:  Michael McLennan, Purdue University
8#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
9#
10#  See the file "license.terms" for information on usage and
11#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12# ======================================================================
13package require Itk
14package require BLT
15
16option add *Hierlist.width 2i widgetDefault
17option add *Hierlist.height 3i widgetDefault
18option add *Hierlist.indent 20 widgetDefault
19option add *Hierlist.icon {treepl treemn} widgetDefault
20option add *Hierlist.selectBackground cyan widgetDefault
21option add *Hierlist.dropLineColor blue widgetDefault
22option add *Hierlist.font {helvetica -12} widgetDefault
23
24itcl::class Rappture::Hierlist {
25    inherit itk::Widget Rappture::Dragdrop
26
27    itk_option define -indent indent Indent 10
28    itk_option define -padding padding Padding 4
29    itk_option define -icon icon Icon ""
30    itk_option define -font font Font ""
31    itk_option define -title title Title "%type: %id"
32    itk_option define -selectbackground selectBackground Foreground ""
33    itk_option define -droplinecolor dropLineColor Foreground ""
34
35    constructor {args} { # defined below }
36    destructor { # defined below }
37
38    public method tree {option args}
39    public method select {what {how "-notify"}}
40    public method curselection {args}
41    public method toggle {what}
42
43    public method xview {args} { eval $itk_component(area) xview $args }
44    public method yview {args} { eval $itk_component(area) yview $args }
45
46    protected method _redraw {args}
47    protected method _redrawChildren {node indent ypos}
48    protected method _edit {option node field args}
49
50    # define these for drag-n-drop support of items
51    protected method dd_get_source {widget x y}
52    protected method dd_scan_target {x y data}
53    protected method dd_finalize {option args}
54
55    private variable _dispatcher ""  ;# dispatcher for !events
56    private variable _tree ""        ;# BLT tree object for node data
57    private variable _current ""     ;# current selected node
58    private variable _droppos ""     ;# node index for dragdrop target pos
59    private variable _imh            ;# open/close images
60}
61
62itk::usual Hierlist {
63    keep -cursor -font -foreground -background
64}
65
66# ----------------------------------------------------------------------
67# CONSTRUCTOR
68# ----------------------------------------------------------------------
69itcl::body Rappture::Hierlist::constructor {args} {
70    itk_option add hull.width hull.height
71    pack propagate $itk_component(hull) off
72
73    # create a dispatcher for events
74    Rappture::dispatcher _dispatcher
75    $_dispatcher register !redraw
76    $_dispatcher dispatch $this !redraw [itcl::code $this _redraw]
77
78    # create a root node
79    set _tree [blt::tree create]
80    $_tree set 0 terminal yes  ;# so you can't drop at the top level
81
82    itk_component add area {
83        canvas $itk_interior.area -highlightthickness 0
84    } {
85        usual
86        ignore -borderwidth -relief
87        ignore -highlightthickness -highlightbackground -highlightcolor
88        keep -xscrollcommand -yscrollcommand
89    }
90    pack $itk_component(area) -expand yes -fill both
91
92    # this widget exports nodes via drag-n-drop
93    dragdrop source $itk_component(area)
94
95    set _imh(open) [image create photo]
96    set _imh(close) [image create photo]
97
98    eval itk_initialize $args
99}
100
101# ----------------------------------------------------------------------
102# DESTRUCTOR
103# ----------------------------------------------------------------------
104itcl::body Rappture::Hierlist::destructor {} {
105    foreach name [array names _imh] {
106        image delete $_imh($name)
107    }
108    blt::tree destroy $_tree
109}
110
111# ----------------------------------------------------------------------
112# USAGE: tree insert <node> <pos> ?<field1> <val1> <field2> <val2> ...?
113# USAGE: tree delete ?<node> <node> ...?
114# USAGE: tree get <node> <field>
115# USAGE: tree set <node> <field> <value>
116# USAGE: tree path <node> ?<pattern>?
117# USAGE: tree children <node>
118#
119# Clients use this to manipulate items in the tree being displayed
120# within the widget.  Each <node> is an integer node number in the
121# underlying BLT tree object.  The root node is node 0.  Each node
122# has a series of <field>'s with values.  The fields are used for the
123# -title of each node, and the "terminal" field controls whether or
124# not a node can have children added.
125# ----------------------------------------------------------------------
126itcl::body Rappture::Hierlist::tree {option args} {
127    switch -- $option {
128        insert {
129            set node [lindex $args 0]
130            set pos [lindex $args 1]
131            if {$pos == "end"} {set pos [llength [$_tree children $node]]}
132            set args [lrange $args 2 end]
133            set newnode [$_tree insert $node -at $pos -data [eval list open yes terminal yes dragdrop yes $args]]
134
135            # make sure we fix up the layout at some point
136            $_dispatcher event -idle !redraw
137
138            return $newnode
139        }
140        delete {
141            if {$args == "all"} {
142                $_tree delete 0
143            } else {
144                foreach node $args {
145                    $_tree delete $node
146                }
147            }
148
149            # make sure we fix up the layout at some point
150            $_dispatcher event -idle !redraw
151        }
152        get {
153            return [eval $_tree get $args]
154        }
155        set {
156            # changed an option -- may be %type or %id -- update display
157            $_dispatcher event -idle !redraw
158
159            return [eval $_tree set $args]
160        }
161        path {
162            if {[llength $args] < 1 || [llength $args] > 2} {
163                error "wrong # args: should be \"tree path node ?pattern?\""
164            }
165            set node [lindex $args 0]
166            set pattern [lindex $args 1]
167            if {$pattern == ""} { set pattern %id }
168
169            set path ""
170            while {$node > 0} {
171                catch {unset info}
172                foreach {name val} [$_tree get $node] {
173                    set info(%$name) $val
174                    set info(%lc:$name) [string tolower $val]
175                    set info(%uc:$name) [string toupper $val]
176                }
177                set name [string map [array get info] $pattern]
178                set path "$name.$path"
179                set node [$_tree parent $node]
180            }
181            return [string trimright $path .]
182        }
183        children {
184            set node [lindex $args 0]
185            return [$_tree children $node]
186        }
187        default {
188            error "bad option \"$option\": should be insert, delete, get, set, path, children"
189        }
190    }
191}
192
193# ----------------------------------------------------------------------
194# USAGE: select <what> ?-notify|-silent?
195#
196# Called when you click on an item to select it.  Highlights the item
197# and returns information about it for the curselection.  This normally
198# triggers a <<Selection>> event on the widget, but that is suppressed
199# if the -silent option is given.
200# ----------------------------------------------------------------------
201itcl::body Rappture::Hierlist::select {what {how "-notify"}} {
202    set c $itk_component(area)
203    if {$what == "none"} {
204        set what ""
205    }
206    set same [string equal $what $_current]
207
208    if {"" != $_current} {
209        # clear any current selection
210        $c itemconfigure item:$_current-bg -fill ""
211        set _current ""
212    }
213
214    if {"" != $what} {
215        $c itemconfigure item:$what-bg -fill $itk_option(-selectbackground)
216        set _current $what
217    }
218
219    if {!$same && ![string equal $how "-silent"]} {
220        # selection changed? then tell clients
221        event generate $itk_component(hull) <<Selection>>
222    }
223}
224
225# ----------------------------------------------------------------------
226# USAGE: curselection
227# USAGE: curselection -path <string>
228# USAGE: curselection -field <name>
229#
230# Returns information about the current selection.  Returns "" if
231# there is no selection.  If "-field <name>" is specified, then it
232# returns the value of that field for the current selection.  If
233# the "-path <string>" is specified, then it returns the path to
234# the current node, using <string> as a pattern for each node name
235# and filling in any %field items for each node.  With no extra args,
236# it returns the node number from the underlying BLT tree.
237# ----------------------------------------------------------------------
238itcl::body Rappture::Hierlist::curselection {args} {
239    if {"" == $_current} {
240        return ""
241    }
242
243    if {[llength $args] == 0} {
244        return $_current
245
246    } elseif {[llength $args] == 2} {
247        switch -- [lindex $args 0] {
248            -path {
249                set pattern [lindex $args 1]
250                return [tree path $_current $pattern]
251            }
252            -field {
253                return [$_tree get $_current [lindex $args 1]]
254            }
255            default {
256                error "bad option \"[lindex $args 0]\": should be -field, -path"
257            }
258        }
259    } else {
260        error "wrong # args: should be \"curselection ?-path str? ?-field name?\""
261    }
262}
263
264# ----------------------------------------------------------------------
265# USAGE: toggle <what>
266#
267# Called when you click on an item to select it.  Highlights the item
268# and returns information about it for the curselection.
269# ----------------------------------------------------------------------
270itcl::body Rappture::Hierlist::toggle {what} {
271    set flipped [expr {![$_tree get $what open]}]
272    $_tree set $what open $flipped
273    $_dispatcher event -idle !redraw
274}
275
276# ----------------------------------------------------------------------
277# USAGE: _redraw ?<eventArgs>...?
278#
279# Used internally to redraw all items in the hierarchy after the
280# tree has changed somehow.
281# ----------------------------------------------------------------------
282itcl::body Rappture::Hierlist::_redraw {args} {
283    set c $itk_component(area)
284    $c delete all
285
286    set lineht [font metrics $itk_option(-font) -linespace]
287    set ypos [expr {0.5*$lineht + $itk_option(-padding)}]
288    _redrawChildren 0 0 ypos
289
290    foreach {x0 y0 x1 y1} [$c bbox text] break
291    $c configure -scrollregion [list 0 0 [expr {$x1+10}] [expr {$y1+10}]]
292
293    # did a selected node get folded up when the parent closed?
294    if {"" == [$c find withtag selected]} {
295        select none
296    }
297}
298
299# ----------------------------------------------------------------------
300# USAGE: _redrawChildren <node> <indent> <yposVar>
301#
302# Used internally to redraw all items in the hierarchy after the
303# tree has changed somehow.
304# ----------------------------------------------------------------------
305itcl::body Rappture::Hierlist::_redrawChildren {node indent yposVar} {
306    set c $itk_component(area)
307    upvar $yposVar ypos
308
309    set xmid [expr {$indent + $itk_option(-indent)/2}]
310    set xtxt [expr {$indent + $itk_option(-indent)}]
311    set lineht [font metrics $itk_option(-font) -linespace]
312
313    foreach n [$_tree children $node] {
314        # background rectangle for selection highlight
315        set tlist [list item:$n item:$n-bg]
316        if {[string equal $n $_current]} {
317            set bg $itk_option(-selectbackground)
318            lappend tlist selected
319        } else {
320            set bg ""
321        }
322        $c create rect 0 [expr {$ypos-0.5*$lineht-1}] 1000 [expr {$ypos+0.5*$lineht+1}] -outline "" -fill $bg -tags $tlist
323
324        $c bind item:$n <ButtonRelease> [itcl::code $this select $n]
325
326        # +/- button for expanding the hierarchy
327        if {![$_tree get $n terminal]} {
328            if {[$_tree get $n open]} {
329                set imh $_imh(open)
330            } else {
331                set imh $_imh(close)
332            }
333            $c create image $xmid $ypos -anchor c -image $imh -tags plus:$n
334            $c bind plus:$n <ButtonPress> [itcl::code $this toggle $n]
335        }
336
337        # label for this node
338        catch {unset data}
339        array set data [$_tree get $n]
340        set xpos $xtxt
341
342        set subs(%type) ""
343        set subs(%id) ""
344        foreach {name val} [$_tree get $n] {
345            set subs(%$name) $val
346            set subs(%lc:$name) [string tolower $val]
347            set subs(%uc:$name) [string toupper $val]
348        }
349
350        set str [string map [array get subs] $itk_option(-title)]
351        $c create text $xpos $ypos -anchor w -text $str -font $itk_option(-font) -tags [list text item:$n item:$n-text]
352
353        set ypos [expr {$ypos+$lineht+$itk_option(-padding)}]
354
355        # indent and draw all children
356        if {![$_tree get $n terminal] && [$_tree get $n open]} {
357            # if this node has children, draw them here
358            _redrawChildren $n $xtxt ypos
359        }
360    }
361}
362
363# ----------------------------------------------------------------------
364# USAGE: dd_get_source <widget> <x> <y>
365#
366# Looks at the given <widget> and <x>,<y> coordinate to figure out
367# what data value the source is exporting.  Returns a string that
368# identifies the type of the data.  This string is passed along to
369# targets via the dd_scan_target method.  If the target may check
370# the source type and reject the data.
371# ----------------------------------------------------------------------
372itcl::body Rappture::Hierlist::dd_get_source {widget x y} {
373    # convert from screen coords to canvas coords (for scrollbars)
374    set x [$widget canvasx $x]
375    set y [$widget canvasy $y]
376
377    set data ""
378    foreach id [$widget find overlapping $x $y $x $y] {
379        foreach tag [$widget gettags $id] {
380            # search for a tag like item:NNN and make sure it's selected
381            if {[regexp {^item:([0-9]+)$} $tag match node]
382                  && $node == $_current} {
383
384                # some nodes have drag-n-drop turned off
385                if {[$_tree get $node dragdrop]} {
386                    set data [list node:$node [$_tree get $node]]
387                }
388                break
389            }
390        }
391    }
392    # return drag-n-drop data, if we found it
393    return $data
394}
395
396# ----------------------------------------------------------------------
397# USAGE: dd_scan_target <x> <y> <data>
398#
399# Looks at the given <x>,<y> coordinate and checks to see if the
400# dragdrop <data> can be accepted at that point.  Returns 1 if so,
401# and 0 if the data is rejected.
402# ----------------------------------------------------------------------
403itcl::body Rappture::Hierlist::dd_scan_target {x y data} {
404    set c $itk_component(area)
405    set _droppos ""  ;# assume no place to drop
406
407    switch -glob -- $data {
408        node:* {
409            # convert from screen coords to canvas coords (for scrollbars)
410            set x [$c canvasx $x]
411            set y [$c canvasy $y]
412
413            # search a little above the hot-spot
414            set y [expr {$y-5}]
415
416            foreach id [$c find overlapping $x $y $x $y] {
417                foreach tag [$c gettags $id] {
418                    if {[regexp {^item:([0-9]+)$} $tag match node]} {
419                        # draw the dropline beneath the item found
420                        if {"" == [$c find withtag dropline]} {
421                            $c create line 0 0 0 0 \
422                                -fill $itk_option(-droplinecolor) -tags dropline
423                        }
424
425                        foreach {x0 y0 x1 y1} [$c bbox item:$node-bg] break
426                        if {![$_tree get $node terminal]} {
427                            # drop on a node with children
428                            if {$y > $y0 + 0.6*($y1-$y0)} {
429                                # drop near the bottom -- insert as first child
430                                set _droppos "$node -at 0"
431                                set d [$_tree depth $node]
432                                set x0 [expr {($d+1)*$itk_option(-indent)}]
433                                $c coords dropline $x0 $y1 $x1 $y1
434                            } else {
435                                # drop on top -- insert as last child
436                                set x0 [expr {$x0+1}]
437                                set x1 [expr {[winfo width $c]-1}]
438                                $c coords dropline $x0 $y0 $x1 $y0 $x1 $y1 $x0 $y1 $x0 $y0
439                                set last [llength [$_tree children $node]]
440                                set _droppos "$node -at $last"
441                            }
442                        } else {
443                            set pnode [$_tree parent $node]
444                            if {![$_tree get $pnode terminal]} {
445                                set pos [expr {[$_tree position $node]+1}]
446                                set _droppos "$pnode -at $pos"
447                                set d [$_tree depth $node]
448                                set x0 [expr {$d*$itk_option(-indent)}]
449                                $c coords dropline $x0 $y1 $x1 $y1
450                            }
451                        }
452
453                        break
454                    }
455                }
456            }
457            if {"" != $_droppos} {
458                return 1
459            }
460            $c coords dropline -1 -1 -1 -1
461            return 0
462        }
463    }
464    return 0
465}
466
467# ----------------------------------------------------------------------
468# USAGE: dd_finalize drop -op start|end -from <w> -to <w> \
469#                           -x <x> -y <y> -data <data>
470# USAGE: dd_finalize cancel
471#
472# Handles the end of a drag and drop operation.  The operation can be
473# completed with a successful drop of data, or cancelled.
474# ----------------------------------------------------------------------
475itcl::body Rappture::Hierlist::dd_finalize {option args} {
476    $itk_component(area) delete dropline
477
478    if {$option == "drop" && "" != $_droppos} {
479        array set params $args
480        switch -glob -- $params(-data) {
481            node:* {
482                if {$params(-op) == "end"
483                      && [string equal $params(-from) $params(-to)]} {
484
485                    regexp {node:([0-9]+)} $params(-data) match node
486                    eval $_tree move $node $_droppos
487                    event generate $itk_component(hull) <<SelectionPath>>
488                } else {
489                    set dlist [list open yes terminal yes dragdrop yes]
490                    eval lappend dlist [lrange $params(-data) 1 end]
491                    eval $_tree insert $_droppos -data [list $dlist]
492                }
493                # make sure the parent is open so we can see this node
494                set parent [lindex $_droppos 0]
495                if {![$_tree get $parent open]} {
496                    $_tree set $parent open 1
497                }
498
499                $_dispatcher event -idle !redraw
500                return 1
501            }
502        }
503        return 0
504    }
505}
506
507# ----------------------------------------------------------------------
508# CONFIGURATION OPTION: -icon
509# ----------------------------------------------------------------------
510itcl::configbody Rappture::Hierlist::icon {
511    set imh0 [lindex $itk_option(-icon) 0]
512    set imh1 [lindex $itk_option(-icon) 1]
513    if {$imh1 == ""} { set imh1 $imh0 }
514
515    set imh0 [Rappture::icon $imh0]
516    if {$imh0 == ""} {
517        $_imh(open) configure -width 1 -height 1
518        $_imh(open) blank
519    } else {
520        $_imh(open) configure -width [image width $imh0] -height [image height $imh0]
521        $_imh(open) copy $imh0
522    }
523
524    set imh1 [Rappture::icon $imh1]
525    if {$imh1 == ""} {
526        $_imh(close) configure -width 1 -height 1
527        $_imh(close) blank
528    } else {
529        $_imh(close) configure -width [image width $imh1] -height [image height $imh1]
530        $_imh(close) copy $imh1
531    }
532}
533
534# ----------------------------------------------------------------------
535# CONFIGURATION OPTION: -selectbackground
536# ----------------------------------------------------------------------
537itcl::configbody Rappture::Hierlist::selectbackground {
538    $itk_component(area) itemconfigure select \
539        -background $itk_option(-selectbackground)
540}
Note: See TracBrowser for help on using the repository browser.