tcl/legend.tcl

   1 proc legend {command name} {
   2 switch -exact $command {
   3 read {set f [open $name]
   4       set string [read -nonewline $f]
   5       close $f
   6       return [legend parse $string]
   7      }
   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"
  14             }
  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 }
  20         }
  21       }
  22 set {
  23       set legname [fgisMakeObjectName legend "info exists"]
  24       upvar \#0 $legname data
  25       array set data $name
  26    }
  27 default { error "Invalid option. Should be one of set read parse"}
  28 }
  29 proc $legname {option args} "eval fgisLegend_\$option $legname \$args"
  30 return $legname
  31 }
  32 ;proc fgisLegend_list {name args} {
  33    global $name
  34    eval array get $name $args
  35 }
  36 ;proc fgisLegend_get {name class} {
  37       global  fgis
  38       upvar \#0 $name data
  39       if ![info exists data($class)] {
  40          return $fgis(undefined_legend)
  41       } else {
  42         return  $data($class)
  43       }
  44 }
  45 ;proc fgisLegend_classes {name} {
  46       global $name
  47       return [lsort -integer [array names $name {[0-9]*}]]
  48         }
  49 proc fgisLegend_title {name args} {
  50   upvar #0 $name data
  51   if [llength $args] {
  52        set data(title) [lindex $args 0]
  53   } elseif [info exists data(title)] {
  54       return  $data(title)
  55   } else { return }
  56 }
  57 proc fgisLegend_subtitle {name args} {
  58   upvar #0 $name data
  59   if [llength $args] {
  60        set data(subtitle) [lindex $args 0]
  61   } elseif [info exists data(subtitle)] {
  62      return  $data(subtitle)
  63   } else return
  64 }
  65 proc fgisLegend_print {name args} {
  66 upvar \#0 $name data
  67     if [info exists data(title)] {
  68        set text "-2  $data(title)\n"
  69     }
  70     if [info exists data(subtitle)] {
  71             append text "-1  $data(subtitle)\n"
  72     }
  73     foreach i [fgisLegend_classes $name] {
  74        append text "$i  $data($i)\n"
  75     }
  76     if {"$args"=="-nonewline"} {
  77        return [string trim $text "\n"]
  78     } else {
  79         return $text
  80     }
  81 }
  82 proc fgisLegend_set {name class value} {
  83       global $name
  84       set $name\($class) $value
  85 }
  86 proc fgisLegend_drawable {name args} {
  87    global $name
  88    if ![llength $args] {
  89       return [expr ![info exists $name\(nodraw)]]
  90    } else  {
  91      if [lindex $args 0] {
  92        catch {unset $name\(nodraw)}
  93      } else {
  94        set $name\(nodraw) 1
  95      }
  96     return
  97   }
  98 }
  99
 100 proc fgisLegend_delete {name} {
 101 uplevel #0 unset $name
 102 rename $name {}
 103 }
 104
 105 proc show_legend {y canvas legend boxcmd} {
 106 global fgis_font
 107 set wraplength [expr [$canvas cget -width]-[$canvas canvasx 1c]]
 108 set boxwidth [expr [$canvas canvasy 4m]-[$canvas canvasy 0m]]
 109 global $legend
 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]
 115 }
 116
 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]
 122 }
 123
 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]
 129 }
 130 $canvas config -scrollregion [list 0 0 [$canvas cget -width] $y]
 131 }
 132
 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
 136 }