source: trunk/BWidget-1.2.1/tree.tcl

Last change on this file was 931, checked in by toby, 11 years ago

include rest of files

File size: 46.6 KB
Line 
1# ------------------------------------------------------------------------------
2#  tree.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: tree.tcl,v 1.12 1999/07/09 08:10:38 eric Exp $
5# ------------------------------------------------------------------------------
6#  Index of commands:
7#     - Tree::create
8#     - Tree::configure
9#     - Tree::cget
10#     - Tree::insert
11#     - Tree::itemconfigure
12#     - Tree::itemcget
13#     - Tree::bindText
14#     - Tree::bindImage
15#     - Tree::delete
16#     - Tree::move
17#     - Tree::reorder
18#     - Tree::selection
19#     - Tree::exists
20#     - Tree::parent
21#     - Tree::index
22#     - Tree::nodes
23#     - Tree::see
24#     - Tree::opentree
25#     - Tree::closetree
26#     - Tree::edit
27#     - Tree::xview
28#     - Tree::yview
29#     - Tree::_update_edit_size
30#     - Tree::_destroy
31#     - Tree::_see
32#     - Tree::_recexpand
33#     - Tree::_subdelete
34#     - Tree::_update_scrollregion
35#     - Tree::_cross_event
36#     - Tree::_draw_node
37#     - Tree::_draw_subnodes
38#     - Tree::_update_nodes
39#     - Tree::_draw_tree
40#     - Tree::_redraw_tree
41#     - Tree::_redraw_selection
42#     - Tree::_redraw_idle
43#     - Tree::_drag_cmd
44#     - Tree::_drop_cmd
45#     - Tree::_over_cmd
46#     - Tree::_auto_scroll
47#     - Tree::_scroll
48# ------------------------------------------------------------------------------
49
50namespace eval Tree {
51    namespace eval Node {
52        Widget::declare Tree::Node {
53            {-text       String     ""      0}
54            {-font       TkResource ""      0 listbox}
55            {-image      TkResource ""      0 label}
56            {-window     String     ""      0}
57            {-fill       TkResource black   0 {listbox -foreground}}
58            {-data       String     ""      0}
59            {-open       Boolean    0       0}
60            {-drawcross  Enum       auto    0 {auto allways never}}
61        }
62    }
63
64    Widget::tkinclude Tree canvas :cmd \
65        remove     {-insertwidth -insertbackground -insertborderwidth -insertofftime \
66                        -insertontime -selectborderwidth -closeenough -confine -scrollregion \
67                        -xscrollincrement -yscrollincrement -width -height} \
68        initialize {-relief sunken -borderwidth 2 -takefocus 1 \
69                        -highlightthickness 1 -width 200}
70
71    Widget::declare Tree {
72        {-deltax           Int 10 0 {=0 ""}}
73        {-deltay           Int 15 0 {=0 ""}}
74        {-padx             Int 20 0 {=0 ""}}
75        {-background       TkResource "" 0 listbox}
76        {-selectbackground TkResource "" 0 listbox}
77        {-selectforeground TkResource "" 0 listbox}
78        {-width            TkResource "" 0 listbox}
79        {-height           TkResource "" 0 listbox}
80        {-showlines        Boolean 1  0}
81        {-linesfill        TkResource black  0 {frame -background}}
82        {-linestipple      TkResource ""     0 {label -bitmap}}
83        {-redraw           Boolean 1  0}
84        {-opencmd          String  "" 0}
85        {-closecmd         String  "" 0}
86        {-dropovermode     Flag    "wpn" 0 "wpn"}
87        {-bg               Synonym -background}
88    }
89    DragSite::include Tree "TREE_NODE" 1
90    DropSite::include Tree {
91        TREE_NODE {copy {} move {}}
92    }
93
94    Widget::addmap Tree "" :cmd {-deltay -yscrollincrement}
95
96    proc ::Tree { path args } { return [eval Tree::create $path $args] }
97    proc use {} {}
98
99    variable _edit
100}
101
102
103# ------------------------------------------------------------------------------
104#  Command Tree::create
105# ------------------------------------------------------------------------------
106proc Tree::create { path args } {
107    variable $path
108    upvar 0  $path data
109
110    Widget::init Tree $path $args
111
112    set data(root)         {{}}
113    set data(selnodes)     {}
114    set data(upd,level)    0
115    set data(upd,nodes)    {}
116    set data(upd,afterid)  ""
117    set data(dnd,scroll)   ""
118    set data(dnd,afterid)  ""
119    set data(dnd,selnodes) {}
120    set data(dnd,node)     ""
121
122    set path [eval canvas $path [Widget::subcget $path :cmd] \
123                  -width  [expr {[Widget::getoption $path -width]*8}] \
124                  -height [expr {[Widget::getoption $path -height]*[Widget::getoption $path -deltay]}] \
125                  -xscrollincrement 8]
126
127    $path bind cross <ButtonPress-1> {Tree::_cross_event %W}
128    bind $path <Configure> "Tree::_update_scrollregion $path"
129    bind $path <Destroy>   "Tree::_destroy $path"
130
131    DragSite::setdrag $path $path Tree::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
132    DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd 1
133
134    rename $path ::$path:cmd
135    proc ::$path { cmd args } "return \[eval Tree::\$cmd $path \$args\]"
136
137    return $path
138}
139
140
141# ------------------------------------------------------------------------------
142#  Command Tree::configure
143# ------------------------------------------------------------------------------
144proc Tree::configure { path args } {
145    variable $path
146    upvar 0  $path data
147
148    set res [Widget::configure $path $args]
149
150    set ch1 [expr {[Widget::hasChanged $path -deltax val] |
151                   [Widget::hasChanged $path -deltay dy]  |
152                   [Widget::hasChanged $path -padx val]   |
153                   [Widget::hasChanged $path -showlines val]}]
154
155    set ch2 [expr {[Widget::hasChanged $path -selectbackground val] |
156                   [Widget::hasChanged $path -selectforeground val]}]
157
158    if { [Widget::hasChanged $path -linesfill   fill] |
159         [Widget::hasChanged $path -linestipple stipple] } {
160        $path:cmd itemconfigure line  -fill $fill -stipple $stipple
161        $path:cmd itemconfigure cross -foreground $fill
162    }
163
164    if { $ch1 } {
165        _redraw_idle $path 3
166    } elseif { $ch2 } {
167        _redraw_idle $path 1
168    }
169
170    if { [Widget::hasChanged $path -height h] } {
171        $path:cmd configure -height [expr {$h*$dy}]
172    }
173    if { [Widget::hasChanged $path -width w] } {
174        $path:cmd configure -width [expr {$w*8}]
175    }
176
177    if { [Widget::hasChanged $path -redraw bool] && $bool } {
178        set upd $data(upd,level)
179        set data(upd,level) 0
180        _redraw_idle $path $upd
181    }
182
183    set force [Widget::hasChanged $path -dragendcmd dragend]
184    DragSite::setdrag $path $path Tree::_init_drag_cmd $dragend $force
185    DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd
186
187    return $res
188}
189
190
191# ------------------------------------------------------------------------------
192#  Command Tree::cget
193# ------------------------------------------------------------------------------
194proc Tree::cget { path option } {
195    return [Widget::cget $path $option]
196}
197
198
199# ------------------------------------------------------------------------------
200#  Command Tree::insert
201# ------------------------------------------------------------------------------
202proc Tree::insert { path index parent node args } {
203    variable $path
204    upvar 0  $path data
205
206    if { [info exists data($node)] } {
207        return -code error "node \"$node\" already exists"
208    }
209    if { ![info exists data($parent)] } {
210        return -code error "node \"$parent\" does not exist"
211    }
212
213    Widget::init Tree::Node $path.$node $args
214    if { ![string compare $index "end"] } {
215        lappend data($parent) $node
216    } else {
217        incr index
218        set data($parent) [linsert $data($parent) $index $node]
219    }
220    set data($node) [list $parent]
221
222    if { ![string compare $parent "root"] } {
223        _redraw_idle $path 3
224    } elseif { [visible $path $parent] } {
225        # parent is visible...
226        if { [Widget::getoption $path.$parent -open] } {
227            # ...and opened -> redraw whole
228            _redraw_idle $path 3
229        } else {
230            # ...and closed -> redraw cross
231            lappend data(upd,nodes) $parent 8
232            _redraw_idle $path 2
233        }
234    }
235    return $node
236}
237
238
239# ------------------------------------------------------------------------------
240#  Command Tree::itemconfigure
241# ------------------------------------------------------------------------------
242proc Tree::itemconfigure { path node args } {
243    variable $path
244    upvar 0  $path data
245
246    if { ![string compare $node "root"] || ![info exists data($node)] } {
247        return -code error "node \"$node\" does not exist"
248    }
249
250    set result [Widget::configure $path.$node $args]
251    if { [visible $path $node] } {
252        set lopt   {}
253        set flag   0
254        foreach opt {-window -image -drawcross -font -text -fill} {
255            set flag [expr {$flag << 1}]
256            if { [Widget::hasChanged $path.$node $opt val] } {
257                set flag [expr {$flag | 1}]
258            }
259        }
260
261        if { [Widget::hasChanged $path.$node -open val] } {
262            _redraw_idle $path 3
263        } elseif { $data(upd,level) < 3 && $flag } {
264            if { [set idx [lsearch $data(upd,nodes) $node]] == -1 } {
265                lappend data(upd,nodes) $node $flag
266            } else {
267                incr idx
268                set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
269                set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
270            }
271            _redraw_idle $path 2
272        }
273    }
274    return $result
275}
276
277
278# ------------------------------------------------------------------------------
279#  Command Tree::itemcget
280# ------------------------------------------------------------------------------
281proc Tree::itemcget { path node option } {
282    variable $path
283    upvar 0  $path data
284
285    if { ![string compare $node "root"] || ![info exists data($node)] } {
286        return -code error "node \"$node\" does not exist"
287    }
288
289    return [Widget::cget $path.$node $option]
290}
291
292
293# ------------------------------------------------------------------------------
294#  Command Tree::bindText
295# ------------------------------------------------------------------------------
296proc Tree::bindText { path event script } {
297    if { $script != "" } {
298        $path:cmd bind "node" $event \
299            "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
300    } else {
301        $path:cmd bind "node" $event {}
302    }
303}
304
305
306# ------------------------------------------------------------------------------
307#  Command Tree::bindImage
308# ------------------------------------------------------------------------------
309proc Tree::bindImage { path event script } {
310    if { $script != "" } {
311        $path:cmd bind "img" $event \
312            "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
313    } else {
314        $path:cmd bind "img" $event {}
315    }
316}
317
318
319# ------------------------------------------------------------------------------
320#  Command Tree::delete
321# ------------------------------------------------------------------------------
322proc Tree::delete { path args } {
323    variable $path
324    upvar 0  $path data
325
326    foreach lnodes $args {
327        foreach node $lnodes {
328            if { [string compare $node "root"] && [info exists data($node)] } {
329                set parent [lindex $data($node) 0]
330                set idx    [lsearch $data($parent) $node]
331                set data($parent) [lreplace $data($parent) $idx $idx]
332                _subdelete $path [list $node]
333            }
334        }
335    }
336
337    set sel $data(selnodes)
338    set data(selnodes) {}
339    eval selection $path set $sel
340    _redraw_idle $path 3
341}
342
343
344# ------------------------------------------------------------------------------
345#  Command Tree::move
346# ------------------------------------------------------------------------------
347proc Tree::move { path parent node index } {
348    variable $path
349    upvar 0  $path data
350
351    if { ![string compare $node "root"] || ![info exists data($node)] } {
352        return -code error "node \"$node\" does not exist"
353    }
354    if { ![info exists data($parent)] } {
355        return -code error "node \"$parent\" does not exist"
356    }
357    set p $parent
358    while { [string compare $p "root"] } {
359        if { ![string compare $p $node] } {
360            return -code error "node \"$parent\" is a descendant of \"$node\""
361        }
362        set p [parent $path $p]
363    }
364
365    set oldp        [lindex $data($node) 0]
366    set idx         [lsearch $data($oldp) $node]
367    set data($oldp) [lreplace $data($oldp) $idx $idx]
368    set data($node) [concat [list $parent] [lrange $data($node) 1 end]]
369    if { ![string compare $index "end"] } {
370        lappend data($parent) $node
371    } else {
372        incr index
373        set data($parent) [linsert $data($parent) $index $node]
374    }
375    if { (![string compare $oldp "root"] ||
376          ([visible $path $oldp] && [Widget::getoption $path.$oldp   -open])) ||
377         (![string compare $parent "root"] ||
378          ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } {
379        _redraw_idle $path 3
380    }
381}
382
383
384# ------------------------------------------------------------------------------
385#  Command Tree::reorder
386# ------------------------------------------------------------------------------
387proc Tree::reorder { path node neworder } {
388    variable $path
389    upvar 0  $path data
390
391    if { ![info exists data($node)] } {
392        return -code error "node \"$node\" does not exist"
393    }
394    set children [lrange $data($node) 1 end]
395    if { [llength $children] } {
396        set children [BWidget::lreorder $children $neworder]
397        set data($node) [linsert $children 0 [lindex $data($node) 0]]
398        if { [visible $path $node] && [Widget::getoption $path.$node -open] } {
399            _redraw_idle $path 3
400        }
401    }
402}
403
404
405# ------------------------------------------------------------------------------
406#  Command Tree::selection
407# ------------------------------------------------------------------------------
408proc Tree::selection { path cmd args } {
409    variable $path
410    upvar 0  $path data
411
412    switch -- $cmd {
413        set {
414            set data(selnodes) {}
415            foreach node $args {
416                if { [info exists data($node)] } {
417                    if { [lsearch $data(selnodes) $node] == -1 } {
418                        lappend data(selnodes) $node
419                    }
420                }
421            }
422        }
423        add {
424            foreach node $args {
425                if { [info exists data($node)] } {
426                    if { [lsearch $data(selnodes) $node] == -1 } {
427                        lappend data(selnodes) $node
428                    }
429                }
430            }
431        }
432        remove {
433            foreach node $args {
434                if { [set idx [lsearch $data(selnodes) $node]] != -1 } {
435                    set data(selnodes) [lreplace $data(selnodes) $idx $idx]
436                }
437            }
438        }
439        clear {
440            set data(selnodes) {}
441        }
442        get {
443            return $data(selnodes)
444        }
445        default {
446            return
447        }
448    }
449    _redraw_idle $path 1
450}
451
452
453# ------------------------------------------------------------------------------
454#  Command Tree::exists
455# ------------------------------------------------------------------------------
456proc Tree::exists { path node } {
457    variable $path
458    upvar 0  $path data
459
460    return [info exists data($node)]
461}
462
463
464# ------------------------------------------------------------------------------
465#  Command Tree::visible
466# ------------------------------------------------------------------------------
467proc Tree::visible { path node } {
468    set idn [$path:cmd find withtag n:$node]
469    return [llength $idn]
470}
471
472
473# ------------------------------------------------------------------------------
474#  Command Tree::parent
475# ------------------------------------------------------------------------------
476proc Tree::parent { path node } {
477    variable $path
478    upvar 0  $path data
479
480    if { ![info exists data($node)] } {
481        return -code error "node \"$node\" does not exist"
482    }
483    return [lindex $data($node) 0]
484}
485
486
487# ------------------------------------------------------------------------------
488#  Command Tree::index
489# ------------------------------------------------------------------------------
490proc Tree::index { path node } {
491    variable $path
492    upvar 0  $path data
493
494    if { ![string compare $node "root"] || ![info exists data($node)] } {
495        return -code error "node \"$node\" does not exist"
496    }
497    set parent [lindex $data($node) 0]
498    return [expr {[lsearch $data($parent) $node] - 1}]
499}
500
501
502# ------------------------------------------------------------------------------
503#  Command Tree::nodes
504# ------------------------------------------------------------------------------
505proc Tree::nodes { path node {first ""} {last ""} } {
506    variable $path
507    upvar 0  $path data
508
509    if { ![info exists data($node)] } {
510        return -code error "node \"$node\" does not exist"
511    }
512
513    if { ![string length $first] } {
514        return [lrange $data($node) 1 end]
515    }
516
517    if { ![string length $last] } {
518        return [lindex [lrange $data($node) 1 end] $first]
519    } else {
520        return [lrange [lrange $data($node) 1 end] $first $last]
521    }
522}
523
524
525# ------------------------------------------------------------------------------
526#  Command Tree::see
527# ------------------------------------------------------------------------------
528proc Tree::see { path node } {
529    variable $path
530    upvar 0  $path data
531
532    if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
533        after cancel $data(upd,afterid)
534        _redraw_tree $path
535    }
536    set idn [$path:cmd find withtag n:$node]
537    if { $idn != "" } {
538        Tree::_see $path $idn right
539        Tree::_see $path $idn left
540    }
541}
542
543
544# ------------------------------------------------------------------------------
545#  Command Tree::opentree
546# ------------------------------------------------------------------------------
547proc Tree::opentree { path node } {
548    variable $path
549    upvar 0  $path data
550
551    if { ![string compare $node "root"] || ![info exists data($node)] } {
552        return -code error "node \"$node\" does not exist"
553    }
554
555    _recexpand $path $node 1 [Widget::getoption $path -opencmd]
556    _redraw_idle $path 3
557}
558
559
560# ------------------------------------------------------------------------------
561#  Command Tree::closetree
562# ------------------------------------------------------------------------------
563proc Tree::closetree { path node } {
564    variable $path
565    upvar 0  $path data
566
567    if { ![string compare $node "root"] || ![info exists data($node)] } {
568        return -code error "node \"$node\" does not exist"
569    }
570
571    _recexpand $path $node 0 [Widget::getoption $path -closecmd]
572    _redraw_idle $path 3
573}
574
575
576# ------------------------------------------------------------------------------
577#  Command Tree::edit
578# ------------------------------------------------------------------------------
579proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} {
580    variable _edit
581    variable $path
582    upvar 0  $path data
583
584    if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
585        after cancel $data(upd,afterid)
586        _redraw_tree $path
587    }
588    set idn [$path:cmd find withtag n:$node]
589    if { $idn != "" } {
590        Tree::_see $path $idn right
591        Tree::_see $path $idn left
592
593        set oldfg  [$path:cmd itemcget $idn -fill]
594        set sbg    [Widget::getoption $path -selectbackground]
595        set coords [$path:cmd coords $idn]
596        set x      [lindex $coords 0]
597        set y      [lindex $coords 1]
598        set bd     [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
599        set w      [expr {[winfo width $path] - 2*$bd}]
600        set wmax   [expr {[$path:cmd canvasx $w]-$x}]
601
602        set _edit(text) $text
603        set _edit(wait) 0
604
605        $path:cmd itemconfigure $idn    -fill [Widget::getoption $path -background]
606        $path:cmd itemconfigure s:$node -fill {} -outline {}
607
608        set frame  [frame $path.edit \
609                        -relief flat -borderwidth 0 -highlightthickness 0 \
610                        -background [Widget::getoption $path -background]]
611        set ent    [entry $frame.edit \
612                        -width              0     \
613                        -relief             solid \
614                        -borderwidth        1     \
615                        -highlightthickness 0     \
616                        -foreground         [Widget::getoption $path.$node -fill] \
617                        -background         [Widget::getoption $path -background] \
618                        -selectforeground   [Widget::getoption $path -selectforeground] \
619                        -selectbackground   $sbg  \
620                        -font               [Widget::getoption $path.$node -font] \
621                        -textvariable       Tree::_edit(text)]
622        pack $ent -ipadx 8 -anchor w
623
624        set idw [$path:cmd create window $x $y -window $frame -anchor w]
625        trace variable Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax"
626        tkwait visibility $ent
627        grab  $frame
628        BWidget::focus set $ent
629
630        _update_edit_size $path $ent $idw $wmax
631        update
632        if { $select } {
633            $ent selection range 0 end
634            $ent icursor end
635            $ent xview end
636        }
637
638        bind $ent <Escape> {set Tree::_edit(wait) 0}
639        bind $ent <Return> {set Tree::_edit(wait) 1}
640        if { $clickres == 0 || $clickres == 1 } {
641            bind $frame <Button>  "set Tree::_edit(wait) $clickres"
642        }
643
644        set ok 0
645        while { !$ok } {
646            tkwait variable Tree::_edit(wait)
647            if { !$_edit(wait) || $verifycmd == "" ||
648                 [uplevel \#0 $verifycmd [list $_edit(text)]] } {
649                set ok 1
650            }
651        }
652
653        trace vdelete Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax"
654        grab release $frame
655        BWidget::focus release $ent
656        destroy $frame
657        $path:cmd delete $idw
658        $path:cmd itemconfigure $idn    -fill $oldfg
659        $path:cmd itemconfigure s:$node -fill $sbg -outline $sbg
660
661        if { $_edit(wait) } {
662            return $_edit(text)
663        }
664    }
665    return ""
666}
667
668
669# ------------------------------------------------------------------------------
670#  Command Tree::xview
671# ------------------------------------------------------------------------------
672proc Tree::xview { path args } {
673    return [eval $path:cmd xview $args]
674}
675
676
677# ------------------------------------------------------------------------------
678#  Command Tree::yview
679# ------------------------------------------------------------------------------
680proc Tree::yview { path args } {
681    return [eval $path:cmd yview $args]
682}
683
684
685# ------------------------------------------------------------------------------
686#  Command Tree::_update_edit_size
687# ------------------------------------------------------------------------------
688proc Tree::_update_edit_size { path entry idw wmax args } {
689    set entw [winfo reqwidth $entry]
690    if { $entw+8 >= $wmax } {
691        $path:cmd itemconfigure $idw -width $wmax
692    } else {
693        $path:cmd itemconfigure $idw -width 0
694    }
695}
696
697
698# ------------------------------------------------------------------------------
699#  Command Tree::_destroy
700# ------------------------------------------------------------------------------
701proc Tree::_destroy { path } {
702    variable $path
703    upvar 0  $path data
704
705    if { $data(upd,afterid) != "" } {
706        after cancel $data(upd,afterid)
707    }
708    if { $data(dnd,afterid) != "" } {
709        after cancel $data(dnd,afterid)
710    }
711    _subdelete $path [lrange $data(root) 1 end]
712    Widget::destroy $path
713    unset data
714    rename $path {}
715}
716
717
718# ------------------------------------------------------------------------------
719#  Command Tree::_see
720# ------------------------------------------------------------------------------
721proc Tree::_see { path idn side } {
722    set bbox [$path:cmd bbox $idn]
723    set scrl [$path:cmd cget -scrollregion]
724
725    set ymax [lindex $scrl 3]
726    set dy   [$path:cmd cget -yscrollincrement]
727    set yv   [$path yview]
728    set yv0  [expr {round([lindex $yv 0]*$ymax/$dy)}]
729    set yv1  [expr {round([lindex $yv 1]*$ymax/$dy)}]
730    set y    [expr {int([lindex [$path:cmd coords $idn] 1]/$dy)}]
731    if { $y < $yv0 } {
732        $path:cmd yview scroll [expr {$y-$yv0}] units
733    } elseif { $y >= $yv1 } {
734        $path:cmd yview scroll [expr {$y-$yv1+1}] units
735    }
736
737    set xmax [lindex $scrl 2]
738    set dx   [$path:cmd cget -xscrollincrement]
739    set xv   [$path xview]
740    if { ![string compare $side "right"] } {
741        set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}]
742        set x1  [expr {int([lindex $bbox 2]/$dx)}]
743        if { $x1 >= $xv1 } {
744            $path:cmd xview scroll [expr {$x1-$xv1+1}] units
745        }
746    } else {
747        set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}]
748        set x0  [expr {int([lindex $bbox 0]/$dx)}]
749        if { $x0 < $xv0 } {
750            $path:cmd xview scroll [expr {$x0-$xv0}] units
751        }
752    }
753}
754
755
756# ------------------------------------------------------------------------------
757#  Command Tree::_recexpand
758# ------------------------------------------------------------------------------
759proc Tree::_recexpand { path node expand cmd } {
760    variable $path
761    upvar 0  $path data
762
763    if { [Widget::getoption $path.$node -open] != $expand } {
764        Widget::setoption $path.$node -open $expand
765        if { $cmd != "" } {
766            uplevel \#0 $cmd $node
767        }
768    }
769
770    foreach subnode [lrange $data($node) 1 end] {
771        _recexpand $path $subnode $expand $cmd
772    }
773}
774
775
776# ------------------------------------------------------------------------------
777#  Command Tree::_subdelete
778# ------------------------------------------------------------------------------
779proc Tree::_subdelete { path lnodes } {
780    variable $path
781    upvar 0  $path data
782
783    while { [llength $lnodes] } {
784        set lsubnodes [list]
785        foreach node $lnodes {
786            foreach subnode [lrange $data($node) 1 end] {
787                lappend lsubnodes $subnode
788            }
789            unset data($node)
790            if { [set win [Widget::getoption $path.$node -window]] != "" } {
791                destroy $win
792            }
793            Widget::destroy $path.$node
794        }
795        set lnodes $lsubnodes
796    }
797}
798
799
800# ------------------------------------------------------------------------------
801#  Command Tree::_update_scrollregion
802# ------------------------------------------------------------------------------
803proc Tree::_update_scrollregion { path } {
804    set bd   [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
805    set w    [expr {[winfo width  $path] - $bd}]
806    set h    [expr {[winfo height $path] - $bd}]
807    set xinc [$path:cmd cget -xscrollincrement]
808    set yinc [$path:cmd cget -yscrollincrement]
809    set bbox [$path:cmd bbox all]
810    if { [llength $bbox] } {
811        set xs [lindex $bbox 2]
812        set ys [lindex $bbox 3]
813
814        if { $w < $xs } {
815            set w [expr {int($xs)}]
816            if { [set r [expr {$w % $xinc}]] } {
817                set w [expr {$w+$xinc-$r}]
818            }
819        }
820        if { $h < $ys } {
821            set h [expr {int($ys)}]
822            if { [set r [expr {$h % $yinc}]] } {
823                set h [expr {$h+$yinc-$r}]
824            }
825        }
826    }
827
828    $path:cmd configure -scrollregion [list 0 0 $w $h]
829}
830
831
832# ------------------------------------------------------------------------------
833#  Command Tree::_cross_event
834# ------------------------------------------------------------------------------
835proc Tree::_cross_event { path } {
836    variable $path
837    upvar 0  $path data
838
839    set node [string range [lindex [$path:cmd gettags current] 1] 2 end]
840    if { [Widget::getoption $path.$node -open] } {
841        if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
842            uplevel \#0 $cmd $node
843        }
844        Widget::setoption $path.$node -open 0
845    } else {
846        if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
847            uplevel \#0 $cmd $node
848        }
849        Widget::setoption $path.$node -open 1
850    }
851    _redraw_idle $path 3
852}
853
854
855# ------------------------------------------------------------------------------
856#  Command Tree::_draw_node
857# ------------------------------------------------------------------------------
858proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
859    global   env
860    variable $path
861    upvar 0  $path data
862
863    set x1 [expr {$x0+$deltax+5}]
864    set y1 $y0
865    if { $showlines } {
866        $path:cmd create line $x0 $y0 $x1 $y0 \
867            -fill    [Widget::getoption $path -linesfill]   \
868            -stipple [Widget::getoption $path -linestipple] \
869            -tags    line
870    }
871    $path:cmd create text [expr {$x1+$padx}] $y0 \
872        -text   [Widget::getoption $path.$node -text] \
873        -fill   [Widget::getoption $path.$node -fill] \
874        -font   [Widget::getoption $path.$node -font] \
875        -anchor w \
876        -tags   "node n:$node"
877    set len [expr {[llength $data($node)] > 1}]
878    set dc  [Widget::getoption $path.$node -drawcross]
879    set exp [Widget::getoption $path.$node -open]
880
881    if { $len && $exp } {
882        set y1 [_draw_subnodes $path [lrange $data($node) 1 end] \
883                    [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines]
884    }
885
886    if { [string compare $dc "never"] && ($len || ![string compare $dc "allways"]) } {
887        if { $exp } {
888            set bmp [file join $env(BWIDGET_LIBRARY) "images" "minus.xbm"]
889        } else {
890            set bmp [file join $env(BWIDGET_LIBRARY) "images" "plus.xbm"]
891        }
892        $path:cmd create bitmap $x0 $y0 \
893            -bitmap     @$bmp \
894            -background [$path:cmd cget -background] \
895            -foreground [Widget::getoption $path -linesfill] \
896            -tags       "cross c:$node" -anchor c
897    }
898
899    if { [set win [Widget::getoption $path.$node -window]] != "" } {
900        $path:cmd create window $x1 $y0 -window $win -anchor w -tags "win i:$node"
901    } elseif { [set img [Widget::getoption $path.$node -image]] != "" } {
902        $path:cmd create image $x1 $y0 -image $img -anchor w -tags "img i:$node"
903    }
904    return $y1
905}
906
907
908# ------------------------------------------------------------------------------
909#  Command Tree::_draw_subnodes
910# ------------------------------------------------------------------------------
911proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } {
912    set y1 $y0
913    foreach node $nodes {
914        set yp $y1
915        set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines]
916    }
917    if { $showlines && [llength $nodes] } {
918        set id [$path:cmd create line $x0 $y0 $x0 [expr {$yp+$deltay}] \
919                    -fill    [Widget::getoption $path -linesfill]   \
920                    -stipple [Widget::getoption $path -linestipple] \
921                    -tags    line]
922
923        $path:cmd lower $id
924    }
925    return $y1
926}
927
928
929# ------------------------------------------------------------------------------
930#  Command Tree::_update_nodes
931# ------------------------------------------------------------------------------
932proc Tree::_update_nodes { path } {
933    global   env
934    variable $path
935    upvar 0  $path data
936
937    set deltax [Widget::getoption $path -deltax]
938    set padx   [Widget::getoption $path -padx]
939    foreach {node flag} $data(upd,nodes) {
940        set idn [$path:cmd find withtag "n:$node"]
941        if { $idn == "" } {
942            continue
943        }
944        set c  [$path:cmd coords $idn]
945        set x0 [expr {[lindex $c 0]-$padx}]
946        set y0 [lindex $c 1]
947        if { $flag & 48 } {
948            # -window or -image modified
949            set win  [Widget::getoption $path.$node -window]
950            set img  [Widget::getoption $path.$node -image]
951            set idi  [$path:cmd find withtag i:$node]
952            set type [lindex [$path:cmd gettags $idi] 0]
953            if { [string length $win] } {
954                if { ![string compare $type "win"] } {
955                    $path:cmd itemconfigure $idi -window $win
956                } else {
957                    $path:cmd delete $idi
958                    $path:cmd create window $x0 $y0 -window $win -anchor w -tags "win i:$node"
959                }
960            } elseif { [string length $img] } {
961                if { ![string compare $type "img"] } {
962                    $path:cmd itemconfigure $idi -image $img
963                } else {
964                    $path:cmd delete $idi
965                    $path:cmd create image $x0 $y0 -image $img -anchor w -tags "img i:$node"
966                }
967            } else {
968                $path:cmd delete $idi
969            }
970        }
971
972        if { $flag & 8 } {
973            # -drawcross modified
974            set len [expr {[llength $data($node)] > 1}]
975            set dc  [Widget::getoption $path.$node -drawcross]
976            set exp [Widget::getoption $path.$node -open]
977            set idc [$path:cmd find withtag c:$node]
978
979            if { [string compare $dc "never"] && ($len || ![string compare $dc "allways"]) } {
980                if { $exp } {
981                    set bmp [file join $env(BWIDGET_LIBRARY) "images" "minus.xbm"]
982                } else {
983                    set bmp [file join $env(BWIDGET_LIBRARY) "images" "plus.xbm"]
984                }
985                if { $idc == "" } {
986                    $path:cmd create bitmap [expr {$x0-$deltax-5}] $y0 \
987                        -bitmap     @$bmp \
988                        -background [$path:cmd cget -background] \
989                        -foreground [Widget::getoption $path -linesfill] \
990                        -tags       "cross c:$node" -anchor c
991                } else {
992                    $path:cmd itemconfigure $idc -bitmap @$bmp
993                }
994            } else {
995                $path:cmd delete $idc
996            }
997        }
998
999        if { $flag & 7 } {
1000            # -font, -text or -fill modified
1001            $path:cmd itemconfigure $idn \
1002                -text [Widget::getoption $path.$node -text] \
1003                -fill [Widget::getoption $path.$node -fill] \
1004                -font [Widget::getoption $path.$node -font]
1005        }
1006    }
1007}
1008
1009
1010# ------------------------------------------------------------------------------
1011#  Command Tree::_draw_tree
1012# ------------------------------------------------------------------------------
1013proc Tree::_draw_tree { path } {
1014    variable $path
1015    upvar 0  $path data
1016
1017    $path:cmd delete all
1018    $path:cmd configure -cursor watch
1019    _draw_subnodes $path [lrange $data(root) 1 end] 8 \
1020        [expr {-[Widget::getoption $path -deltay]/2}] \
1021        [Widget::getoption $path -deltax] \
1022        [Widget::getoption $path -deltay] \
1023        [Widget::getoption $path -padx]   \
1024        [Widget::getoption $path -showlines]
1025    $path:cmd configure -cursor [Widget::getoption $path -cursor]
1026}
1027
1028
1029# ------------------------------------------------------------------------------
1030#  Command Tree::_redraw_tree
1031# ------------------------------------------------------------------------------
1032proc Tree::_redraw_tree { path } {
1033    variable $path
1034    upvar 0  $path data
1035
1036    if { [Widget::getoption $path -redraw] } {
1037        if { $data(upd,level) == 2 } {
1038            _update_nodes $path
1039        } elseif { $data(upd,level) == 3 } {
1040            _draw_tree $path
1041        }
1042        _redraw_selection $path
1043        _update_scrollregion $path
1044        set data(upd,nodes)   {}
1045        set data(upd,level)   0
1046        set data(upd,afterid) ""
1047    }
1048}
1049
1050
1051# ------------------------------------------------------------------------------
1052#  Command Tree::_redraw_selection
1053# ------------------------------------------------------------------------------
1054proc Tree::_redraw_selection { path } {
1055    variable $path
1056    upvar 0  $path data
1057
1058    set selbg [Widget::getoption $path -selectbackground]
1059    set selfg [Widget::getoption $path -selectforeground]
1060    foreach id [$path:cmd find withtag sel] {
1061        set node [string range [lindex [$path:cmd gettags $id] 1] 2 end]
1062        $path:cmd itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
1063    }
1064    $path:cmd delete sel
1065    foreach node $data(selnodes) {
1066        set bbox [$path:cmd bbox "n:$node"]
1067        if { [llength $bbox] } {
1068            set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$node"]]
1069            $path:cmd itemconfigure "n:$node" -fill $selfg
1070            $path:cmd lower $id
1071        }
1072    }
1073}
1074
1075
1076# ------------------------------------------------------------------------------
1077#  Command Tree::_redraw_idle
1078# ------------------------------------------------------------------------------
1079proc Tree::_redraw_idle { path level } {
1080    variable $path
1081    upvar 0  $path data
1082
1083    if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
1084        set data(upd,afterid) [after idle Tree::_redraw_tree $path]
1085    }
1086    if { $level > $data(upd,level) } {
1087        set data(upd,level) $level
1088    }
1089    return ""
1090}
1091
1092
1093# --------------------------------------------------------------------------------------------
1094# Commandes pour le Drag and Drop
1095
1096
1097# ------------------------------------------------------------------------------
1098#  Command Tree::_init_drag_cmd
1099# ------------------------------------------------------------------------------
1100proc Tree::_init_drag_cmd { path X Y top } {
1101    set ltags [$path:cmd gettags current]
1102    set item  [lindex $ltags 0]
1103    if { ![string compare $item "node"] ||
1104         ![string compare $item "img"]  ||
1105         ![string compare $item "win"] } {
1106        set node [string range [lindex $ltags 1] 2 end]
1107        if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
1108            return [uplevel \#0 $cmd [list $path $node $top]]
1109        }
1110        if { [set type [Widget::getoption $path -dragtype]] == "" } {
1111            set type "TREE_NODE"
1112        }
1113        if { [set img [Widget::getoption $path.$node -image]] != "" } {
1114            pack [label $top.l -image $img -padx 0 -pady 0]
1115        }
1116        return [list $type {copy move link} $node]
1117    }
1118    return {}
1119}
1120
1121
1122# ------------------------------------------------------------------------------
1123#  Command Tree::_drop_cmd
1124# ------------------------------------------------------------------------------
1125proc Tree::_drop_cmd { path source X Y op type dnddata } {
1126    variable $path
1127    upvar 0  $path data
1128
1129    $path:cmd delete drop
1130    if { [string length $data(dnd,afterid)] } {
1131        after cancel $data(dnd,afterid)
1132        set data(dnd,afterid) ""
1133    }
1134    set data(dnd,scroll) ""
1135    if { [llength $data(dnd,node)] } {
1136        if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
1137            return [uplevel \#0 $cmd [list $path $source $data(dnd,node) $op $type $dnddata]]
1138        }
1139    }
1140    return 0
1141}
1142
1143
1144# ------------------------------------------------------------------------------
1145#  Command Tree::_over_cmd
1146# ------------------------------------------------------------------------------
1147proc Tree::_over_cmd { path source event X Y op type dnddata } {
1148    variable $path
1149    upvar 0  $path data
1150
1151    if { ![string compare $event "leave"] } {
1152        # we leave the window tree
1153        $path:cmd delete drop
1154        if { [string length $data(dnd,afterid)] } {
1155            after cancel $data(dnd,afterid)
1156            set data(dnd,afterid) ""
1157        }
1158        set data(dnd,scroll) ""
1159        return 0
1160    }
1161
1162    if { ![string compare $event "enter"] } {
1163        # we enter the window tree - dnd data initialization
1164        set mode [Widget::getoption $path -dropovermode]
1165        set data(dnd,mode) 0
1166        foreach c {w p n} {
1167            set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
1168        }
1169        set bbox [$path:cmd bbox all]
1170        if { [llength $bbox] } {
1171            set data(dnd,xs) [lindex $bbox 2]
1172        } else {
1173            set data(dnd,xs) 0
1174        }
1175        set data(dnd,node) {}
1176    }
1177
1178    set x [expr {$X-[winfo rootx $path]}]
1179    set y [expr {$Y-[winfo rooty $path]}]
1180    $path:cmd delete drop
1181    set data(dnd,node) {}
1182
1183    # test for auto-scroll unless mode is widget only
1184    if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
1185        return 2
1186    }
1187
1188    if { $data(dnd,mode) & 4 } {
1189        # dropovermode includes widget
1190        set target [list widget]
1191        set vmode  4
1192    } else {
1193        set target [list ""]
1194        set vmode  0
1195    }
1196
1197    set xc [$path:cmd canvasx $x]
1198    set xs $data(dnd,xs)
1199    if { $xc <= $xs } {
1200        set yc   [$path:cmd canvasy $y]
1201        set dy   [$path:cmd cget -yscrollincrement]
1202        set line [expr {int($yc/$dy)}]
1203        set xi   0
1204        set yi   [expr {$line*$dy}]
1205        set ys   [expr {$yi+$dy}]
1206        foreach id [$path:cmd find overlapping $xi $yi $xs $ys] {
1207            set ltags [$path:cmd gettags $id]
1208            set item  [lindex $ltags 0]
1209            if { ![string compare $item "node"] ||
1210                 ![string compare $item "img"]  ||
1211                 ![string compare $item "win"] } {
1212                # item is the label or image/window of the node
1213                set node [string range [lindex $ltags 1] 2 end]
1214                set xi   [expr {[lindex [$path:cmd coords n:$node] 0]-[Widget::getoption $path -padx]}]
1215
1216                if { $data(dnd,mode) & 1 } {
1217                    # dropovermode includes node
1218                    lappend target $node
1219                    set vmode [expr {$vmode | 1}]
1220                } else {
1221                    lappend target ""
1222                }
1223
1224                if { $data(dnd,mode) & 2 } {
1225                    # dropovermode includes position
1226                    if { $yc >= $yi+$dy/2 } {
1227                        # position is after $node
1228                        if { [Widget::getoption $path.$node -open] &&
1229                             [llength $data($node)] > 1 } {
1230                            # $node is open and have subnodes
1231                            # drop position is 0 in children of $node
1232                            set parent $node
1233                            set index  0
1234                            set xli    [expr {$xi-5}]
1235                        } else {
1236                            # $node is not open and doesn't have subnodes
1237                            # drop position is after $node in children of parent of $node
1238                            set parent [lindex $data($node) 0]
1239                            set index  [lsearch $data($parent) $node]
1240                            set xli    [expr {$xi-[Widget::getoption $path -deltax]-5}]
1241                        }
1242                        set yl $ys
1243                    } else {
1244                        # position is before $node
1245                        # drop position is before $node in children of parent of $node
1246                        set parent [lindex $data($node) 0]
1247                        set index  [expr {[lsearch $data($parent) $node] - 1}]
1248                        set xli    [expr {$xi-[Widget::getoption $path -deltax]-5}]
1249                        set yl     $yi
1250                    }
1251                    lappend target [list $parent $index]
1252                    set vmode  [expr {$vmode | 2}]
1253                } else {
1254                    lappend target {}
1255                }
1256
1257                if { ($vmode & 3) == 3 } {
1258                    # result have both node and position
1259                    # we compute what is the preferred method
1260                    if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
1261                        lappend target "position"
1262                    } else {
1263                        lappend target "node"
1264                    }
1265                }
1266                break
1267            }
1268        }
1269    }
1270
1271    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
1272        # user-defined dropover command
1273        set res     [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
1274        set code    [lindex $res 0]
1275        set newmode 0
1276        if { $code & 1 } {
1277            # update vmode
1278            set mode [lindex $res 1]
1279            if { ($vmode & 1) && ![string compare $mode "node"] } {
1280                set newmode 1
1281            } elseif { ($vmode & 2) && ![string compare $mode "position"] } {
1282                set newmode 2
1283            } elseif { ($vmode & 4) && ![string compare $mode "widget"] } {
1284                set newmode 4
1285            }
1286        }
1287        set vmode $newmode
1288    } else {
1289        if { ($vmode & 3) == 3 } {
1290            # result have both item and position
1291            # we choose the preferred method
1292            if { ![string compare [lindex $target 3] "position"] } {
1293                set vmode [expr {$vmode & ~1}]
1294            } else {
1295                set vmode [expr {$vmode & ~2}]
1296            }
1297        }
1298
1299        if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
1300            # dropovermode is widget or empty - recall is not necessary
1301            set code 1
1302        } else {
1303            set code 3
1304        }
1305    }
1306
1307    # draw dnd visual following vmode
1308    if { $vmode & 1 } {
1309        set data(dnd,node) [list "node" [lindex $target 1]]
1310        $path:cmd create rectangle $xi $yi $xs $ys -tags drop
1311    } elseif { $vmode & 2 } {
1312        set data(dnd,node) [concat "position" [lindex $target 2]]
1313        $path:cmd create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
1314    } elseif { $vmode & 4 } {
1315        set data(dnd,node) [list "widget"]
1316    } else {
1317        set code [expr {$code & 2}]
1318    }
1319
1320    if { $code & 1 } {
1321        DropSite::setcursor based_arrow_down
1322    } else {
1323        DropSite::setcursor dot
1324    }
1325    return $code
1326}
1327
1328
1329# ------------------------------------------------------------------------------
1330#  Command Tree::_auto_scroll
1331# ------------------------------------------------------------------------------
1332proc Tree::_auto_scroll { path x y } {
1333    variable $path
1334    upvar 0  $path data
1335
1336    set xmax   [winfo width  $path]
1337    set ymax   [winfo height $path]
1338    set scroll {}
1339    if { $y <= 6 } {
1340        if { [lindex [$path:cmd yview] 0] > 0 } {
1341            set scroll [list yview -1]
1342            DropSite::setcursor sb_up_arrow
1343        }
1344    } elseif { $y >= $ymax-6 } {
1345        if { [lindex [$path:cmd yview] 1] < 1 } {
1346            set scroll [list yview 1]
1347            DropSite::setcursor sb_down_arrow
1348        }
1349    } elseif { $x <= 6 } {
1350        if { [lindex [$path:cmd xview] 0] > 0 } {
1351            set scroll [list xview -1]
1352            DropSite::setcursor sb_left_arrow
1353        }
1354    } elseif { $x >= $xmax-6 } {
1355        if { [lindex [$path:cmd xview] 1] < 1 } {
1356            set scroll [list xview 1]
1357            DropSite::setcursor sb_right_arrow
1358        }
1359    }
1360
1361    if { [string length $data(dnd,afterid)] && [string compare $data(dnd,scroll) $scroll] } {
1362        after cancel $data(dnd,afterid)
1363        set data(dnd,afterid) ""
1364    }
1365
1366    set data(dnd,scroll) $scroll
1367    if { [string length $scroll] && ![string length $data(dnd,afterid)] } {
1368        set data(dnd,afterid) [after 200 Tree::_scroll $path $scroll]
1369    }
1370    return $data(dnd,afterid)
1371}
1372
1373
1374# ------------------------------------------------------------------------------
1375#  Command Tree::_scroll
1376# ------------------------------------------------------------------------------
1377proc Tree::_scroll { path cmd dir } {
1378    variable $path
1379    upvar 0  $path data
1380
1381    if { ($dir == -1 && [lindex [$path:cmd $cmd] 0] > 0) ||
1382         ($dir == 1  && [lindex [$path:cmd $cmd] 1] < 1) } {
1383        $path:cmd $cmd scroll $dir units
1384        set data(dnd,afterid) [after 100 Tree::_scroll $path $cmd $dir]
1385    } else {
1386        set data(dnd,afterid) ""
1387        DropSite::setcursor dot
1388    }
1389}
Note: See TracBrowser for help on using the repository browser.