* Relifted from Perl

1 files changed, 165 insertions, 129 deletions

diff --git a/demos/pathTags.tcl b/demos/pathTags.tcl
index 40a2066..54888b6 100644
--- a/demos/pathTags.tcl
+++ b/demos/pathTags.tcl
@@ -1,6 +1,9 @@
-#
-# these simple samples have been developped by C. Mertz mertz@cena.fr in perl
-# tcl version by Jean-Paul Imbert imbert@cena.fr
+#!/usr/bin/perl -w
+# $Id$
+# this pathtatg demo have been developped by C. Mertz mertz@cena.fr
+# with the help of Daniel Etienne etienne@cena.fr.
+# tcl version by Patrick Lecoanet lecoanet@cena.fr
+
 
 if {![info exists zincDemo]} {
     error "This script should be run from the zinc-widget demo."
@@ -12,7 +15,7 @@ toplevel $w
 wm title $w "Zinc Path tags Demonstration"
 wm iconname $w "Path tags"
 
-set defaultfont [font create -family Helvetica -size 10 -weight bold]
+set defaultFont [font create -family Helvetica -size 10 -weight bold]
 
 frame $w.buttons
 pack $w.buttons -side bottom -fill x -pady 2m
@@ -46,17 +49,18 @@ pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
 #the same objects are cloned and put in an other hierarchy where
 #grTop is replaced by grOtherTop
 
-set defaultForeColor sienna
+set defaultForeColor grey80
+set selectedColor yellow
 
 ###########################################
 # Text zone
 ###########################################
 
-text $w.text -relief sunken -borderwidth 2 -height 5
+text $w.text -relief sunken -borderwidth 2 -height 5 -font $defaultFont
 pack $w.text -expand yes -fill both
 
 $w.text insert end {This represents a group hierarchy:
-    - groups are represented by a rectangle and a Title.
+    - groups are represented by a rectangle and an underlined title.
     - non-group items are represented by a text.
     Select a pathTag or a tag with one of the radio-button
     or experiment your own tags in the input field}
@@ -64,7 +68,9 @@ $w.text insert end {This represents a group hierarchy:
 ###########################################
 # Zinc creation
 ###########################################
-zinc $w.zinc -width 850 -height 360 -font 10x20 -borderwidth 0 -backcolor white
+
+zinc $w.zinc -width 850 -height 360 -font $defaultFont -borderwidth 0 \
+    -backcolor black -forecolor $defaultForeColor
 pack $w.zinc
 
 ###########################################
@@ -74,68 +80,77 @@ pack $w.zinc
 pack [frame $w.tagsfm]
 
 set pathtag {}
-pack [frame $w.left] -side left -expand 1 -padx .5c -pady .2c
-pack [frame $w.middle] -side left -expand 1 -padx .5c -pady .2c
-pack [frame $w.right] -side left -expand 1 -padx .5c -pady .2c
-pack [frame $w.rtop] -side left -expand 1 -padx .5c -pady .2c
-pack [frame $w.rbottom ] -side left -expand 1 -padx .5c -pady .2c
-pack [frame $w.rbot_left] -side left -expand 1 -padx .5c -pady .2c
-pack [frame $w.rbot_right] -side left -expand 1 -padx .5c -pady .2c
-
-set i 0
-foreach p {top .top .top. .top* .top*cca .5.} {
-    radiobutton $w.left.r$i -text $p -command displayPathtag \
-	-variable pathtag -relief flat -value $p 
-    pack $w.left.r$i -side top -pady 2 -anchor w
-    incr i
-}
-set i 0
-foreach p {.top*aa .top*aa. .top*aa* .top*aaa .top*aaa. .5*} {
-    radiobutton $w.middle.r$i -text $p -command displayPathtag \
-	-variable pathtag -relief flat -value $p
-    pack $w.middle.r$i -side top -pady 2 -anchor w
-    incr i
+set explanation {...}
+
+pack [frame $w.toggles] -expand 1 -padx .5c -pady .2c
+
+set tagsExpl {
+    top {a simple tag matching the top group}
+    .top {all items with tag 'top' in the root group }
+    .top. {direct children of a group with tag 'top' in the root group}
+    .top* {descendents of a group with tag 'top' in the root group }
+    .top*cca {items with a tag 'cca' in a direct group of root group with tag 'top'}
+    .5. {direct content of the group with id 5}
+    .top*aa {items with a tag 'aa' in a direct group of root group with tag 'top'}
+    .top*aa. {direct children of a group with a tag 'aa', descending from a direct group of root group with tag 'top'}
+    .top*aa* {descendance of a group with a tag 'aa', descending from a direct group of root group with tag 'top'}
+    .top.a {items with a tag 'a' in a direct group of root group with tag 'top'}
+    .top.a. {direct children of a group with tag 'a' in a direct group of root group with tag 'top'}
+    .5* {descendents of the group of id 5}
+    .top*aa*aaa {all items with tag 'aaa' descending from a group with tag 'aa' descending from a group with tag 'top', child of the root group}
+    .top*aa*aaa. {children of a group with a tag 'aaa' descending from ONE group with a tag 'aa' descending from a group with a tag 'top' child of the root group}
+    .top*aa*aaa* {descendance of ONE group with a tag 'aaa' descending from ONE group with a tag 'aa' descending from ONE group with a tag 'top' child of the root group}
+    .other_top*aa* {descendance of ONE group with a tag 'aa' descending from ONE group with a tag 'other_top' child of the root group}
+    .5*ca* {descendance of ONE group with a tag 'ca' descending from THE group with id 5}
+    *aa*aaaa {all items with a tag 'aaaa' descending from a group with a tag 'aa'}
+    *aaa {all items with a tag 'aaa'}
+    aa||ca {items with tag 'aa' or tag 'ca'}
+    none {no items, as none has the tag 'none'}
+    all {all items}
 }
 
-
-label $w.rtop.label -relief flat -text {your own tag:}
-pack $w.rtop.label -side left
-entry $w.rtop.entry -width 15
-pack $w.rtop.entry -side left
-bind $w.rtop.entry <Key-Return> " "
-#sub {$pathtag $_"0"->get &displayPathtag} 
-
-set i 0
-foreach p {.top*aa*aaa .top*aa*aaa. .top*aa*aaa* .otherTop*aa* .5*ca*} {
-    radiobutton $w.rbot_left.r$i -text $p -command displayPathtag \
-	-variable pathtag -relief flat -value $p
-    pack $w.rbot_left.r$i -side top -pady 2 -anchor w
-    incr i
+set row 1
+set col 2
+foreach {key val} $tagsExpl {
+    grid [radiobutton $w.toggles.r$row+$col -text $key -font $defaultFont \
+	  -command displayPathtag -variable pathtag -relief flat \
+	  -value $key] -column $col -row $row -sticky w -pady 0 -ipady 0
+    incr row
+    if {$row > 6} {
+	set row 1
+	incr col
+    }
 }
 
-set i 0
-foreach p "{*aa*aaaa *aaa} {aa || ca} none all" {
-    radiobutton $w.rbot_right.r$i -text $p -command displayPathtag \
-	-variable pathtag -relief flat -value p 
-    pack $w.rbot_right.r$i -side top -pady 2 -anchor w
-    incr i
-}
+grid [label $w.toggles.lyt -font $defaultFont -relief flat \
+	  -text {your own tag:}] -column 2 -row 7 -sticky e -ipady 5
+grid [entry $w.toggles.eyt -font $defaultFont -width 15 \
+	  -textvariable pathtag] -column 3 -row 7 -sticky w
+bind $w.toggles.eyt <Return> displayPathtag
+grid [label $w.toggles.elabel -font $defaultFont -text "explanation:"] \
+    -row 8 -column 2 -sticky e
+grid [label $w.toggles.explan -font $defaultFont -width 70 -height 3 \
+	  -justify left -anchor w -wraplength 16c -textvariable explanation] \
+    -row 8 -column 3 -columnspan 4 -sticky w
+grid columnconfigure $w.toggles 5 -weight 10
+
 
 ### Here we create the genuine hierarchy of groups and items
 ### Later we will create graphical objects to display groups
 proc createSubHierarchy {gr} {
     global w
-    $w.zinc add group $gr -tags a 
+
+    $w.zinc add group $gr -tags a
     $w.zinc add text $gr -tags {b text} -text b -position {270 150}
-    $w.zinc add group $gr -tags c 
+    $w.zinc add group $gr -tags c
     
-    $w.zinc add group a -tags aa 
+    $w.zinc add group a -tags aa
     $w.zinc add text a -tags {ab text} -text ab -position {60 220}
-    $w.zinc add group a -tags ac 
+    $w.zinc add group a -tags ac
     
-    $w.zinc add group aa -tags aaa 
+    $w.zinc add group aa -tags aaa
     $w.zinc add text aa -tags {aab text} -text aab -position {90 190}
-    $w.zinc add group aaa -tags aaaa 
+    $w.zinc add group aaa -tags aaaa
     $w.zinc add text aaaa -tags {aaaaa text} -text aaaaa -position {150 110}
     $w.zinc add text aaaa -tags {aaaab text} -text aaaab -position {150 130}
     $w.zinc add text aaa -tags {aaab text} -text aaab -position {120 160}
@@ -143,9 +158,9 @@ proc createSubHierarchy {gr} {
     $w.zinc add text ac -tags aca -text aca -position {90 260}
     $w.zinc add text ac -tags {acb text} -text acb -position {90 290}
     
-    $w.zinc add group c -tags ca 
+    $w.zinc add group c -tags ca
     $w.zinc add text c -tags {cb text} -text cb -position {330 160}
-    $w.zinc add group c -tags cc 
+    $w.zinc add group c -tags cc
     
     $w.zinc add text ca -tags {caa text} -text caa -position {360 110}
     $w.zinc add text ca -tags {cab text} -text cab -position {360 130}
@@ -154,126 +169,147 @@ proc createSubHierarchy {gr} {
     $w.zinc add text cc -tags {ccb text} -text ccb -position {360 220}
 }
 
+# creating the item hierarchy
+$w.zinc add group 1 -tags top
+createSubHierarchy top
+
+# creating a parallel hierarchy
+$w.zinc add group 1 -tags other_top
+createSubHierarchy other_top
+
+
+## modifying the priority so that all rectangles and text will be visible
+foreach item [$w.zinc find withtype text ".top*"] {
+    $w.zinc itemconfigure $item -priority 20
+}
+foreach item [$w.zinc find withtype text ".other_top*"] {
+    $w.zinc itemconfigure $item -priority 20
+}
+foreach item [$w.zinc find withtype group ".top*"] {
+    $w.zinc itemconfigure $item -priority 20
+}
+foreach item [$w.zinc find withtype group ".other_top*"] {
+    $w.zinc itemconfigure $item -priority 20
+}
 
-# converts a list of items ids in a list of sorted tags the first tag of each item 
+# converts a list of items ids in a list of sorted tags (the first tag of each item)
 proc items2tags {items} {
     global w
 
+    set selectedTags {}
     foreach item $items {
-	set tags [$w.zinc itemcget $item -tags ]
-	if {[lindex $tags 0]=="frame" || [lindex $tags 0]=="title"} {
+	set tags [$w.zinc itemcget $item -tags]
+	if {[regexp {frame|title} [lindex $tags 0]]} {
+	    # to remove group titles frame
 	    continue
 	}
-	lappend selected_tags [lindex $tags 0]
+	lappend selectedTags [lindex tags 0]
     }
-    return [lsort selected_tags]
+    return [lsort $selectedTags]
 }
 
 ### drawing :
-#### a rectangle item for showing the bounding box of each group 
-### a text item for the group name i.e. its first tag 
+####   a rectangle item for showing the bounding box of each group 
+###    a text item for the group name (i.e. its first tag)
 
 ## backgrounds used to fill rectangles representing groups
-set backgrounds {grey90 grey82 grey75 grey68 grey60 grey52 grey45}
+set backgrounds {grey25 grey35 grey43 grey50 grey55}
 
 proc drawHierarchy {group level} {
     global w backgrounds
 
     set tags [$w.zinc gettags $group]
-
-    foreach g [$w.zinc find withtype group ".$group."] {
-	drawHierarchy $g [expr $level+1]
+#    print "level=$level (" $tags[0],")\n";
+    foreach g [$w.zinc find withtype group .$group.] {
+	drawHierarchy $g [expr $level + 1]
     }
-    set coords [$w.zinc bbox $group]
-    foreach {x y x2 y2} $coords break
+    foreach {x y x2 y2} [$w.zinc bbox $group] break
     $w.zinc add text $group -position [list [expr $x-5] [expr $y-4]] \
-	-text [lindex $tags 0] -anchor w -alignment left \
-	-underlined 1 -priority 20 -tags [list "title_.[lindex $tags 0]" group_title] 
-
-    if {$x} {
-	set background [lindex $backgrounds $level] 
-	$w.zinc add rectangle $group [list [expr $x+0] [expr $y+5] [expr $x2+5] [expr $y2+2]]\
-	    -filled 1 -fillcolor $background -priority $level \
-	    -tags [list frame_.[lindex $tags 0]group_frame]
-	
+	-text [lindex $tags 0] -anchor w -alignment left -underlined 1 \
+	-priority 20 -tags [list title_[lindex $tags 0] group_title]
+    foreach {x y x2 y2} [$w.zinc bbox $group] break
+    if {$x ne "" } {
+	$w.zinc add rectangle $group [list [expr $x+0] [expr $y+5] \
+					  [expr $x2+5] [expr $y2+2]] \
+	    -filled 1 -fillcolor [lindex $backgrounds $level] -priority $level \
+	    -tags [list frame_[lindex $tags 0] group_frame]
     } else {
-	puts "undefined bbox for $group : $tags\n"
+	puts "undefined bbox for $group : $tags"
     }
 }
 
 ### this sub extracts out of groups both text and frame representing
 ### each group. This is necessary to avoid unexpected selection of
 ### rectangles and titles inside groups
-proc extractTextAndFrames {} {
+proc extractTextAndFrames { } {
     global w
-    foreach group_title [$w.zinc find withtag {group_title || group_frame}] {
+
+    foreach group_title [$w.zinc find withtag group_title||group_frame] {
 	set ancestors [$w.zinc find ancestor $group_title]
-	# puts "$group_title @ancestors\n"
+#	puts "$group_title $ancestors"
 	set grandFather [lindex $ancestors 1]
-	$w.zinc chggroup $group_title $grandFather 1 
+	$w.zinc chggroup $group_title $grandFather 1
     }
 }
 
+proc TLGet {list tag {default ""}} {
+  foreach {key val} $list {
+    if { [string compare $key $tag] == 0 } {
+      return $val
+    }
+  }
+  return $default
+}
+
 ## this sub modifies the color/line color of texts and rectangles
 ## representing selected items. 
-proc displayPathtag {} {
-    global w pathtag defaultForeColor
+proc displayPathtag { } {
+    global w explanation pathtag defaultForeColor selectedColor tagsExpl
 
+    if {[catch {set explanation [TLGet $tagsExpl $pathtag]}]} {
+	set explanation {sorry, I am not smart enough to explain your pathTag ;-\)}
+    }
     set selected [$w.zinc find withtag $pathtag]
     set tags [items2tags $selected]
-    puts "selected: $tags\n"
-    # puts "selected= "
-    # foreach sel $selected {
-    #     puts "$sel [$w.zinc type $sel] [join [$w.zinc gettags $sel] ,] /\n"
-    # }
-    #
+#    puts "selected: $tags"
+	
     ## unselecting all items 
     foreach item [$w.zinc find withtype text] {
-	$w.zinc itemconfigure $item -color $defaultForeColor 
+	$w.zinc itemconfigure $item -color $defaultForeColor
     }
     foreach item [$w.zinc find withtype rectangle] {
-	$w.zinc itemconfigure $item -linecolor $defaultForeColor 
+	$w.zinc itemconfigure $item -linecolor $defaultForeColor
     }
 
     ## highlighting selected items
     foreach item $selected {
-	set type [$w.zinc type $item ]
-	#	print $item " " $w.zinc type $item " " join " " $w.zinc gettags $item "\n"
-	switch -- $type {
-	    text {
-		$w.zinc itemconfigure $item -color black 
-	    }
-	    rectangle {
-		$w.zinc itemconfigure $item -linecolor black 
-	    }
-	    group {
-		set tag [lindex [$w.zinc gettags $item] 0]
-		set grandFather [$w.zinc find ancestors $item top]
-		if {$grandFather == 1} {
-		    ## as there is 2 // hierachy we must refine the tag used
-		    ## to restrict to the proper hierarchy
-		    $w.zinc itemconfigure "*$grandFather*frame_$tag" -linecolor black
-		    $w.zinc itemconfigure "*$grandFather*title_$tag" -color black
-		} else {
-		    ## when a group as no grandfather it can only be top or otherTop
-		    ## as their tags are non-ambiguous no need to refine!
-		    $w.zinc itemconfigure "frame_$tag" -linecolor black
-		    $w.zinc itemconfigure "title_$tag" -color black
-		}
+	set type [$w.zinc type $item]
+	#puts "$item $type [$w.zinc gettags $item]"
+	if {$type eq "text"} {
+	    $w.zinc itemconfigure $item -color $selectedColor
+	} elseif {$type eq "rectangle"} {
+	    $w.zinc itemconfigure $item -linecolor $selectedColor
+	} elseif {$type eq "group"} {
+	    set tag [lindex [$w.zinc gettags $item] 0]
+	    ## as there is 2 // hierachy we must refine the tag used
+	    ## to restrict to the proper hierarchy
+	    ## NB: this is due to differences between the group hierarchy
+	    ##     and the graphical object hierarchy used for this demo
+	    if {[llength [$w.zinc find ancestors $item top]]} {
+		$w.zinc itemconfigure ".top*frame_$tag" -linecolor $selectedColor
+		$w.zinc itemconfigure ".top*title_$tag" -color $selectedColor
+	    } elseif {[llength [$w.zinc find ancestors $item other_top]]} {
+		$w.zinc itemconfigure ".other_top*frame_$tag" -linecolor $selectedColor
+		$w.zinc itemconfigure ".other_top*title_$tag" -color $selectedColor
+	    } else {
+		$w.zinc itemconfigure "frame_$tag" -linecolor $selectedColor
+		$w.zinc itemconfigure "title_$tag" -color $selectedColor
 	    }
 	}
     }
 }
 
-# creating the item hierarchy
-$w.zinc add group 1 -tags top
-createSubHierarchy top
-
-# creating a parallel hierarchy
-$w.zinc add group 1 -tags otherTop
-createSubHierarchy otherTop
-
-drawHierarchy top 0 
-drawHierarchy otherTop 0 
-$w.zinc translate otherTop 400 0
+drawHierarchy top 0
+drawHierarchy other_top 0
+$w.zinc translate other_top 400 0
 extractTextAndFrames