1 proc legend {command name} {
2 switch -exact $command {
3 read {set f [open $name]
4 set string [read -nonewline $f]
6 return [legend parse $string]
8 parse { set legname [fgisMakeObjectName legend "info exists"]
9 upvar \#0 $legname data
10 foreach line [split $name "\n"] {
11 if ![string length $line] continue
12 if ![regexp {^ *(-?[0-9]+) [^ ]* (.*)$} $line junk a b] {
13 error "Error in legend format"
15 if {$a==-1} {set a subtitle} elseif {$a==-2} {set a title
16 } elseif {$a<0||$a>65535} {error "Invalid class code $a"}
17 if [ info exists data($a)] {
18 append data($a) " " $b
19 } else { set data($a) $b }
23 set legname [fgisMakeObjectName legend "info exists"]
24 upvar \#0 $legname data
27 default { error "Invalid option. Should be one of set read parse"}
29 proc $legname {option args} "eval fgisLegend_\$option $legname \$args"
32 ;proc fgisLegend_list {name args} {
34 eval array get $name $args
36 ;proc fgisLegend_get {name class} {
39 if ![info exists data($class)] {
40 return $fgis(undefined_legend)
45 ;proc fgisLegend_classes {name} {
47 return [lsort -integer [array names $name {[0-9]*}]]
49 proc fgisLegend_title {name args} {
52 set data(title) [lindex $args 0]
53 } elseif [info exists data(title)] {
57 proc fgisLegend_subtitle {name args} {
60 set data(subtitle) [lindex $args 0]
61 } elseif [info exists data(subtitle)] {
62 return $data(subtitle)
65 proc fgisLegend_print {name args} {
67 if [info exists data(title)] {
68 set text "-2 $data(title)\n"
70 if [info exists data(subtitle)] {
71 append text "-1 $data(subtitle)\n"
73 foreach i [fgisLegend_classes $name] {
74 append text "$i $data($i)\n"
76 if {"$args"=="-nonewline"} {
77 return [string trim $text "\n"]
82 proc fgisLegend_set {name class value} {
84 set $name\($class) $value
86 proc fgisLegend_drawable {name args} {
89 return [expr ![info exists $name\(nodraw)]]
92 catch {unset $name\(nodraw)}
100 proc fgisLegend_delete {name} {
101 uplevel #0 unset $name
105 proc show_legend {y canvas legend boxcmd} {
107 set wraplength [expr [$canvas cget -width]-[$canvas canvasx 1c]]
108 set boxwidth [expr [$canvas canvasy 4m]-[$canvas canvasy 0m]]
110 if [info exists $legend\(title)] {
111 set item [$canvas create text [expr [$canvas cget -width]/2] $y -anchor n\
112 -justify center -width [$canvas cget -width] \
113 -text [set $legend\(title)] -tags title -font $fgis_font(3)]
114 set y [expr [lindex [$canvas bbox $item] 3]+2]
117 if [info exists $legend\(subtitle)] {
118 set item [$canvas create text 0 $y -anchor nw -justify left\
119 -width [$canvas cget -width] -text [set $legend\(subtitle)]\
120 -tags subtitle -font $fgis_font(2)]
121 set y [expr [lindex [$canvas bbox $item] 3]+2]
124 foreach i [$legend classes] {
125 eval $boxcmd $canvas 0 $y 7m [expr $y+$boxwidth] $i
126 $canvas create text 1c $y -anchor nw -justify left -width $wraplength\
127 -text [set $legend\($i)] -tags class$i -font $fgis_font(1)
128 set y [expr [lindex [$canvas bbox class$i] 3]+2]
130 $canvas config -scrollregion [list 0 0 [$canvas cget -width] $y]
133 proc color_box {palette canvas x1 y1 x2 y2 class} {
134 $canvas create rectangle $x1 $y1 $x2 $y2 -fill \
135 [palette get $palette $class] -tags class$class