summaryrefslogtreecommitdiff
path: root/ruby_1_8_6/ext/tk/sample/tktree.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'ruby_1_8_6/ext/tk/sample/tktree.tcl')
-rw-r--r--ruby_1_8_6/ext/tk/sample/tktree.tcl305
1 files changed, 305 insertions, 0 deletions
diff --git a/ruby_1_8_6/ext/tk/sample/tktree.tcl b/ruby_1_8_6/ext/tk/sample/tktree.tcl
new file mode 100644
index 0000000000..a5e47eb776
--- /dev/null
+++ b/ruby_1_8_6/ext/tk/sample/tktree.tcl
@@ -0,0 +1,305 @@
+#
+# This Tcl/Tk script is quoted from <http://wiki.tcl.tk/10615>.
+#
+ package require Tk
+ namespace eval ::tktree {
+
+ # Images used for open and close state of subgroups
+ set ::tktree::imgcollapse [image create photo .tktreeopenbm -data {
+ R0lGODdhCQAJAIAAAAEBAf///ywAAAAACQAJAAACEISPoRvG614D80x5ZXyogwIAOw==}]
+ set ::tktree::imgexpand [image create photo .tktreeclosebm -data {
+ R0lGODdhCQAJAIAAAAEBAf///ywAAAAACQAJAAACEYSPoRu28KCSDSJLc44s3lMAADs=}]
+ ###Default images for groups and children
+ set ::tktree::imgsubgroups [image create photo .tktreeimgfolder -data {
+ R0lGODlhEAANAKIAANnZ2Xh4eLi4uPj4APj4+AAAAP///////yH5BAEAAAAA
+ LAAAAAAQAA0AAANkCIChiqDLITgyEgi6GoIjIyMYugCBpMsaWBA0giMjIzgy
+ UYBBMjIoIyODEgVBODIygiMjE1gQJIMyMjIoI1GAQSMjODIyghMFQSgjI4My
+ MhJYEDSCIyMjODJRgKHLXAiApcsMmAA7}]
+ set ::tktree::imgchildren [image create photo .tktreeimgfile -data {
+ R0lGODlhDQAQAKIAANnZ2Xh4ePj4+Li4uAAAAP///////////yH5BAEAAAAA
+ LAAAAAANABAAAANSGLoLgACBoqsRCBAoujqCASGDojtESCEihCREIjgUKLo8
+ hCGCpCsySIGiy0MYIki6IoMUKLo8hCGCpCsySIGiy0MYKLo8hIGiy0MYOLo8
+ SLrMCQA7}]
+
+ #### Swtich all subgroups of a layer to open or close
+ proc ::tktree::switchlayer {win opn {layer /}} {
+ variable cfg
+ foreach child $cfg($win,$layer:subgroups) {
+ set cfg($win,$child:open) $opn
+ switchlayer $win $opn $child
+ }
+ buildwhenidle $win
+ }
+
+ #### will open or close the item given
+ proc ::tktree::switchstate {win item} {
+ set ::tktree::cfg($win,$item:open) [expr ! $::tktree::cfg($win,$item:open)]
+ buildwhenidle $win
+ }
+
+ #### Select the next item up or down
+ proc ::tktree::updown {win down} {
+ variable cfg
+ set index [lsearch -exact $cfg($win,sortlist) $cfg($win,selection)]
+ if {$down} {incr index} {incr index -1}
+ if {$index < 0} {set index end} elseif {$index >= [llength $cfg($win,sortlist)]} {set index 0}
+ setselection $win [lindex $cfg($win,sortlist) $index]
+ }
+
+ #### left-right button binding commands
+ proc ::tktree::leftright {win right} {
+ variable cfg
+ set item $cfg($win,selection)
+ set index [lsearch -exact $cfg($win,sortlist) $item]
+ set parentindex [lsearch -exact $cfg($win,sortlist) [file dirname $item]]
+ if {$parentindex == -1} {set parentindex [expr $index - 1]}
+ if {$cfg($win,$item:group)} {
+ if {$right} {
+ if {$cfg($win,$item:open)} {incr index} {set cfg($win,$item:open) 1}
+ } else {
+ if {$cfg($win,$item:open)} {set cfg($win,$item:open) 0} {set index $parentindex}
+ }
+ } else {
+ if {$right} {incr index} {set index $parentindex}
+ }
+ if {$index < 0} {set index end} elseif {$index >= [llength $cfg($win,sortlist)]} {set index 0}
+ setselection $win [lindex $cfg($win,sortlist) $index]
+ buildwhenidle $win
+ }
+
+ #### will return the pathname of the item at x and y cooridinates
+ proc ::tktree::labelat {win x y} {
+ set x [$win canvasx $x]; set y [$win canvasy $y]
+ foreach m [$win find overlapping $x $y $x $y] {
+ if {[info exists ::tktree::cfg($win,tag:$m)]} {return $::tktree::cfg($win,tag:$m)}
+ }
+ return ""
+ }
+
+ #### will return the path of the current selection in the given tree widget
+ proc ::tktree::getselection {win} {
+ return $::tktree::cfg($win,selection)
+ }
+
+ #### adjust the scrollview to show the selected item as needed
+ proc ::tktree::scrolladjust {win tag} {
+ update
+ set item [$win bbox $tag]
+ set region [$win cget -scrollregion]
+ foreach {axis idx1 idx2} {yview 1 3 xview 0 2} {
+ set range [expr abs([lindex $region $idx2]) - abs([lindex $region $idx1])]
+ set itemtop [lindex $item $idx1]; set itembot [lindex $item $idx2]
+ set viewtop [expr $range * [lindex [$win $axis] 0]]
+ set viewbot [expr $range * [lindex [$win $axis] 1]]
+ if {$itembot > $viewbot} {$win $axis moveto [expr ($itembot. - $viewbot + $viewtop) / $range]}
+ if {$itemtop < $viewtop} {$win $axis moveto [expr $itemtop. / $range]}
+ }
+ }
+
+ #### will set the current selection to the given item on the given tree
+ proc ::tktree::setselection {win item} {
+ variable cfg
+ if {![llength $cfg($win,sortlist)]} {return}
+ if {$item eq ""} {set item [lindex $cfg($win,sortlist) 0]}
+ if {![info exists cfg($win,$item:tag)]} {set item [lindex $cfg($win,sortlist) 0]}
+ if {[$win gettags $cfg($win,$item:tag)] ne ""} {
+ $win select from $cfg($win,$item:tag) 0
+ $win select to $cfg($win,$item:tag) end
+ set cfg($win,selection) $item
+ scrolladjust $win $cfg($win,$item:tag)
+ } {
+ setselection $win "/[lindex $cfg($win,/:sortlist) 0]"
+ }
+ }
+
+ #### will delete the item given from the tree given
+ proc ::tktree::delitem {win item} {
+ variable cfg
+ if {$item eq "/"} {
+ array unset cfg $win,* ; catch {destroy $win}
+ } {
+ set group [file dirname $item]
+ if {$cfg($win,$item:group)} {set type subgroups} {set type children}
+ set index [lsearch -exact $cfg($win,$group:$type) $item]
+ set cfg($win,$group:$type) [lreplace $cfg($win,$group:$type) $index $index]
+ array unset cfg $win,$item*
+ buildwhenidle $win
+ }
+ }
+
+ #### create a new item in the tree and rebuild the widget
+ proc ::tktree::newitem {win item args} {
+ variable cfg
+ if {[string index $item 0] ne "/"} {set item /$item}
+ if {[string index $item end] eq "/"} {
+ set subgroup 1
+ set type subgroups
+ set item [string range $item 0 end-1]
+ set cfg($win,$item:command) [list ::tktree::switchstate $win $item]
+ } {
+ set subgroup 0
+ set type children
+ set cfg($win,$item:command) {}
+ }
+ #Build parent group if needed
+ set group [file dirname $item]
+ if {![info exists cfg($win,$group:open)]} {newitem $win "$group\/"}
+ lappend cfg($win,$group:$type) $item
+ #Configure the new item
+ set cfg($win,$item:group) $subgroup
+ set cfg($win,$item:subgroups) {}
+ set cfg($win,$item:children) {}
+ set cfg($win,$item:sortlist) {}
+ set cfg($win,$item:tags) {}
+ set cfg($win,$item:open) 0
+ set cfg($win,$item:image) {}
+ set cfg($win,$item:textcolor) $cfg($win,textcolor)
+ set cfg($win,$item:font) $cfg($win,font)
+ if {$cfg($win,images)} {set cfg($win,$item:image) [eval list \$::tktree::img$type]}
+ foreach {confitem confval} $args {
+ switch -exact -- $confitem {
+ -textcolor {set cfg($win,$item:textcolor) $confval}
+ -command {set cfg($win,$item:command) $confval}
+ -image {set cfg($win,$item:image) $confval}
+ -font {set cfg($win,$item:font) $confval}
+ }
+ }
+ buildwhenidle $win
+ }
+
+ #### Draw the given layer of the tree on the canvas starting at xposition
+ proc ::tktree::buildlayer {win layer xpos} {
+ variable cfg
+ #Record y positions for vertical line later on
+ set ystart $cfg($win,y); set yend $cfg($win,y)
+ if {$layer eq "/"} {set cfg($win,sortlist) ""}
+ foreach child $cfg($win,$layer:sortlist) {
+ lappend cfg($win,sortlist) $child
+ #Check spacing required for images
+ set imgwidth 0; set imgheight 0
+ if {[string length $cfg($win,$child:image)]} {
+ set imgwidth [expr ([image width $cfg($win,$child:image)] + 2) / 2]
+ set imgheight [expr ([image height $cfg($win,$child:image)] + 2) / 2]
+ }
+ #find X-axis points for image, horiz line, and text
+ if {$imgwidth} {
+ set centerX [expr $imgwidth + $xpos + 7]
+ set rightX [expr $xpos + 7]
+ set textX [expr ($imgwidth * 2) + $xpos + 10]
+ } {
+ set centerX [expr $xpos + 10]
+ set rightX [expr $centerX + 4]
+ set textX [expr $rightX + 1]
+ }
+ #Find the proper amount to increment the y axis
+ set fontheight [lindex [font metrics $cfg($win,$child:font)] 5]
+ set yincr [expr ($fontheight + 1) / 2]
+ if {$imgheight > $yincr} {set yincr $imgheight}
+ incr cfg($win,y) $yincr
+ #Draw the horizonal line
+ $win create line $xpos $cfg($win,y) $rightX $cfg($win,y) -fill $cfg($win,linecolor)
+ set yend $cfg($win,y)
+ #Draw the image, if it exists
+ if {$imgwidth} {
+ set it [$win create image $centerX $cfg($win,y) -image $cfg($win,$child:image)]
+ $win bind $it <1> [list ::tktree::setselection $win $child]
+ }
+ #Draw text and store tags for reference
+ set cfg($win,$child:tag) [$win create text $textX $cfg($win,y) \
+ -text [file tail $child] -font $cfg($win,$child:font) -anchor w -tags x -fill $cfg($win,$child:textcolor)]
+ set cfg($win,tag:$cfg($win,$child:tag)) $child
+ #Command binding
+ $win bind $cfg($win,$child:tag) <1> [list ::tktree::setselection $win $child]
+ $win bind $cfg($win,$child:tag) <Double-1> $cfg($win,$child:command)
+ #next step up on the y axis
+ incr cfg($win,y) $yincr
+ #If its a group, add open-close functionality
+ if {$cfg($win,$child:group)} {
+ if {$cfg($win,$child:open)} {set img collapse} {set img expand}
+ set ocimg [$win create image $xpos [expr $cfg($win,y) - $yincr] -image [eval list \$::tktree::img$img]]
+ $win bind $ocimg <1> [list ::tktree::switchstate $win $child]
+ if {$cfg($win,$child:open)} {buildlayer $win $child $centerX}
+ }
+ }
+ #Vertical line
+ $win lower [$win create line $xpos [expr $ystart - 7] $xpos $yend -fill $cfg($win,linecolor)]
+ }
+
+ #### sort the layer by subgroups then children
+ proc ::tktree::sortlayer {win {layer /}} {
+ variable cfg
+ set cfg($win,$layer:subgroups) [lsort -dictionary $cfg($win,$layer:subgroups)]
+ set cfg($win,$layer:children) [lsort -dictionary $cfg($win,$layer:children)]
+ set cfg($win,$layer:sortlist) [join [list $cfg($win,$layer:subgroups) $cfg($win,$layer:children)]]
+ foreach group $cfg($win,$layer:subgroups) {sortlayer $win $group}
+ }
+
+ #### build the tree at the given path
+ proc ::tktree::buildtree {win} {
+ variable cfg
+ $win delete all
+ sortlayer $win
+ set xpos 5
+ set cfg($win,y) 5
+ #Draw global expand/contract button, if needed
+ if {[string length $cfg($win,/:subgroups)] && $cfg($win,expandall)} {
+ set exp 0
+ foreach subgroup $cfg($win,/:subgroups) {incr exp $cfg($win,$subgroup:open)}
+ if {$exp} {set type collapse} {set type expand}
+ set ocimg [$win create image 1 1 -image [eval list \$::tktree::img$type] -anchor w]
+ $win bind $ocimg <1> [list ::tktree::switchlayer $win [expr ! $exp]]
+ }
+ #Build the layers and set initial selection
+ buildlayer $win / $xpos
+ $win config -scrollregion [$win bbox all]
+ setselection $win $cfg($win,selection)
+ }
+
+ #### internal use - set up a handle to build the tree when everything is idle
+ proc ::tktree::buildwhenidle {win} {
+ catch {after cancel $::tktree::cfg($win,buildHandle)}
+ set ::tktree::cfg($win,buildHandle) [after idle [list ::tktree::buildtree $win]]
+ }
+
+ #### will create a new tree widget at the given path
+ proc ::tktree::treecreate {win args} {
+ variable cfg
+ #Default configuration for new tree
+ set cfg($win,selection) {}
+ set cfg($win,selidx) {}
+ set cfg($win,/:subgroups) {}
+ set cfg($win,/:children) {}
+ set cfg($win,/:open) 1
+ set cfg($win,images) 1
+ set cfg($win,expandall) 1
+ set cfg($win,linecolor) black
+ set cfg($win,textcolor) black
+ set cfg($win,font) {-family Helvetica -size 10}
+ #Parse and setup custom configuration options
+ set canvascfg ""
+ foreach {item val} $args {
+ switch -- $item {
+ -linecolor {set cfg($win,linecolor) $val}
+ -textcolor {set cfg($win,textcolor) $val}
+ -font {set cfg($win,font) $val}
+ -images {set cfg($win,images) $val}
+ -expandall {set cfg($win,expandall) $val}
+ default {lappend canvascfg $item $val}
+ }
+ }
+ #Build the canvas
+ eval {canvas $win -takefocus 1} $canvascfg
+ bind $win <Destroy> [list ::tktree::delitem $win /]
+ bind $win <1> [list focus $win]
+ bind $win <Return> {eval $::tktree::cfg(%W,[::tktree::getselection %W]:command)}
+ bind $win <space> {eval $::tktree::cfg(%W,[::tktree::getselection %W]:command)}
+ bind $win <Up> [list ::tktree::updown $win 0]
+ bind $win <Down> [list ::tktree::updown $win 1]
+ bind $win <Left> [list ::tktree::leftright $win 0]
+ bind $win <Right> [list ::tktree::leftright $win 1]
+
+ #Build the tree when idle
+ buildwhenidle $win
+ }
+ }
+