tcl/layer.tcl

   1 #
   2 # layers.tcl
   3 # Implements high level layer object
   4 # This file is part of fGIS
   5 #
   6
   7 # Global variable fgisLayerTypes - keeps names of constructor procedures
   8 # for all defined layer types
   9
  10 array set fgisLayerTypes {
  11 raster fgisCreateRaster
  12 chart  fgisCreateChart
  13 tag    fgisCreateTag
  14 }
  15
  16 # proc layer - create layer or query information about all layers
  17 # usage:
  18 # layer create type ?name? ?-option value...? - returns name of layer.
  19 # layer names ?pattern? ?-type type? - returns names of all matching layers
  20 # layer types  - list available layer types
  21 # layer type name - return type of given layer
  22
  23 proc layer {option args} {
  24 global fgisLayerTypes fgisLayerList
  25 switch -exact -- $option {
  26    create {
  27       if ![llength $args] {
  28           return -code error "usage: layer create ?name? ?options?"
  29       }
  30       set tname [lindex $args 0]
  31       set type [array names fgisLayerTypes $tname*]
  32       switch [llength $type] {
  33          1 { # type good - call constructor
  34              # drop layer type from args
  35              set args [lreplace $args 0 0]
  36              # if layer name not supplied, generate one
  37              if {![llength $args]||[string match -* [lindex $args 0]]} {
  38                  set args [linsert $args 0 [fgisMakeObjectName layer]]
  39              } elseif {![fgisCheckName [lindex $args 0]]} {
  40                  return -code error "Name \"[lindex $args 0]\" already used"
  41              }
  42
  43              if [catch [concat $fgisLayerTypes($type) $args] name] {
  44                 return -code error $name
  45              } else {
  46                 set fgisLayerList($name) $type
  47                 return $name
  48              }
  49          }
  50          0 { # No matching type found
  51              return -code error "Invalid layer type. Should be one of\
  52                 [join [array names fgisLayerTypes] ", "]"
  53          }
  54          default { # Too many matching types found
  55              return -code error "Ambiquous layer type \"$tname\": $type"
  56          }
  57       }
  58    }
  59   types { # Return list of available types
  60      return [array names fgisLayerTypes]
  61   }
  62   names { # Return list of names
  63       if {[llength $args]&&![string match -* [lindex $args 0]]} {
  64           # extract glob pattern from arguments
  65           set pattern [lindex $args 0]
  66           set args [lreplace $args 0 0]
  67       } else { # no pattern supplied, use *
  68           set pattern *
  69       }
  70       if ![llength $args] { # if no other args, return all matching names
  71          return [array names fgisLayerList $pattern]
  72       } elseif {[llength $args]!=2} {
  73          #check if args are -type list
  74          return -code error "wrong # args. should be \"layer names ?pattern?\
  75                  ?-type type?\""
  76       } elseif {![string match [lindex $args 0]* -type]} {
  77          return -code error "wrong option. should be -type"
  78       } else {
  79          # first, check if all types in list are good
  80          # and create array to lookup matching types
  81          foreach type [lindex $args 1] {
  82            if ![info exists fgisLayerTypes($type)] {
  83               return -code error "Invalid layer type \"$type\""
  84            }
  85            set tmp($type) 1
  86          }
  87          # then scan list of layers
  88         set result {}
  89         foreach {name type} [array get fgisLayerList $pattern] {
  90            if [info exists tmp($type)] {
  91               lappend result $name
  92            }
  93         }
  94         return $result
  95      }
  96   }
  97   type { # return type of given layer
  98          if ![info exists fgisLayerList($args)] {
  99              return -code error "Layer $args doesn't exists"
 100          } else {
 101              return $fgisLayerList($args)
 102          }
 103   }
 104   exist -
 105   exists {
 106      if [llength $args]!=1 {
 107         return -code error "wrong # args. should be: layer exist name"
 108      }
 109      return [info exists fgisLayerList([lindex $args 0])]
 110   }
 111   default { # unrecognized command
 112       return -code error "Invalid option. should be one of create, exists,\
 113             names, type, types"
 114   }
 115 }
 116 }
 117
 118 #
 119 # Calls method of layer object. Searches in the global array
 120 # fgisLayerMethods for index "type,method", and, if found, executes it.
 121 #
 122 ;proc fgisLayerEval {type method object args} {
 123    global fgisLayerMethods
 124    # get list of methods of type, which match given method name
 125    set methods [array names fgisLayerMethods $type,$method*]
 126    switch -exact [llength $methods] {
 127    0 { # no applicable methods
 128        set msg {}
 129        foreach i [array names fgisLayerMethods $type,*] {
 130           lappend msg [lindex [split $i ","] 1]
 131        }
 132        return -code error "Unknown option. should be one of [join $msg ", "]"
 133    }
 134    1 {
 135        eval $fgisLayerMethods($methods) $object $args
 136    }
 137    default {
 138       return -code error "Ambiquous option \"$method\""
 139    }
 140 }
 141 }
 142 #
 143 # creates instance command for layer
 144 #
 145 #
 146 #
 147 ;proc fgisLayerDefine {type object} {
 148     global fgisLayerMethods
 149     ;proc $object {option args} "
 150  if \[catch {eval fgisLayerEval $type \$option $object \$args} res] {
 151     return -code error \$res
 152  } else {
 153     return \$res
 154  }
 155 "
 156 }
 157 #
 158 # copies name of old object methods to new one
 159 #
 160 ;proc fgisLayerInherit {father son} {
 161    global fgisLayerMethods
 162    # copy virtual method table
 163    foreach {name value} [array get fgisLayerMethods $father,*] {
 164         set fgisLayerMethods($son,[lindex [split $name ","] 1]) $value
 165    }
 166    # copy field template
 167    global fgis${father}Fields fgis${son}Fields
 168    array set fgis${son}Fields [array get fgis${father}Fields]
 169 }
 170 #
 171 # Common methods for all layers
 172 #
 173
 174 #
 175 # return various info for layer
 176 #
 177 ;proc fgisLayerInfo {name args} {
 178   upvar #0 $name data
 179   if [llength $args]!=1 {
 180      return -code error "wrong # of args. should be $name info option"
 181   }
 182   set goodopt {opaque lookable legend limits numeric dimension reclass}
 183   if [set idx [lsearch -glob $goodopt $args*]]==-1 {
 184      return -code error "invalid option. should be one of [join $goodopt ", "]"
 185   }
 186   set key [lindex $goodopt $idx]
 187   switch -exact $key {
 188       legend {
 189          return [expr {[info exist data(legend)]&&[$data(legend) drawable]}]
 190       }
 191       default {
 192          return $data($key)
 193       }
 194   }
 195 }
 196 #
 197 # Two procedures, which return title and subtitle
 198 #
 199 ;proc fgisLayerTitle {name args} {
 200 if [llength $args] {
 201   return -code error "wrong # args. should be $name title"
 202 }
 203 upvar #0 $name data
 204 if [info exists data(title)] {
 205   return $data(title)
 206 } else {
 207   return $name
 208 }
 209 }
 210 ;proc fgisLayerSubtitle {name args} {
 211 if [llength $args] {
 212   return -code error "wrong # args. should be $name title"
 213 }
 214 upvar #0 $name data
 215 if [info exists data(subtitle)] {
 216   return $data(subtitle)
 217 } else {
 218   return
 219 }
 220 }
 221 #
 222 # raster layers
 223 #
 224 # table of methods
 225 array set fgisLayerMethods {
 226 raster,info fgisLayerInfo
 227 raster,dump fgisRasterDump
 228 raster,value fgisRasterValue
 229 raster,show fgisRasterShow
 230 raster,hide fgisRasterHide
 231 raster,configure fgisRasterConfigure
 232 raster,cget fgisRasterCget
 233 raster,legclasses fgisRasterLegClasses
 234 raster,sample fgisRasterSample
 235 raster,legtext fgisRasterLegtext
 236 raster,title fgisLayerTitle
 237 raster,subtitle fgisLayerSubtitle
 238 raster,delete fgisRasterDelete
 239 raster,expand fgisRasterExpand
 240 raster,limits fgisRasterLimits
 241 raster,redraw fgisRasterRedraw
 242 }
 243 # table of fields (more precisely - template of default values
 244 array set fgisRasterFields {
 245 opaque 1
 246 lookable 1
 247 limits 1
 248 numeric 0
 249 dimension 2
 250 reclass 1
 251 palette defaultpalette
 252 plotmode -patterns
 253 border none
 254 ovrborder yes
 255 ovrcolor black
 256 patterns {}
 257 title {}
 258 subtitle {}
 259 }
 260 # Other fields exist only in runtime
 261 # legend - holds name of legend object
 262 # raster - holds name of raster object
 263
 264 # constructor of raster layer.
 265 # Options available
 266 # to specify raster
 267 # -raster - recieves handle of raster object
 268 # -file - recieves epp file
 269 # to specify reclass
 270 # -reclass statements -recieves reclass in EPPL-like syntax
 271 # -table list - recieves reclass as Tcl list
 272 # to specify legend
 273 # -legend - recieves legend object handle
 274 # -legfile - recieves legend file
 275 # Appearance
 276 # -palette - recieves palette object
 277 # -palfile - recieves palette file
 278 # -patterns - recieves pattern object
 279 # -symbols - recieves pattern object and switches mode do symbols
 280 # -borders - recieves none yes or base. Controls opaque mode
 281 # -ovrborders - same for transparent mode
 282 # -ovrcolor - color for transparent drawing
 283 #
 284 #
 285 ;proc fgisCreateRaster {name args} {
 286    upvar #0 $name data
 287    global fgisRasterFields
 288    array set data [array get fgisRasterFields]
 289    eval fgisRasterConfigure $name $args
 290    if ![info exists data(raster)] {
 291       error "No raster specified"
 292    }
 293    fgisLayerDefine raster $name
 294    return $name
 295 }
 296 #
 297 # Three small procedures to create object from file.
 298 # They are needed becouse handleopt doesn't allow ] after option value
 299 #
 300 ;proc fgisOpenEppFile {filename} {
 301   set raster [raster $filename]
 302   uplevel fgisSetObj data(raster) nodefault $raster
 303 }
 304 ;proc fgisOpenLegFile {filename} {
 305   uplevel fgisSetObj data(legend) none [legend read $filename]
 306 }
 307 ;proc fgisOpenClrFile {filename} {
 308   uplevel fgisSetObj data(palette) defaultpalette [palette read $filename]
 309 }
 310 #
 311 # All done via handleopt. Only validity of border flags are checked
 312 # afterward
 313 #
 314 ;proc fgisRasterConfigure {name args} {
 315    upvar #0 $name data
 316    array set handlers {
 317       raster {set redraw 1; set data(raster) }
 318       file {set redraw 1; fgisOpenEppFile}
 319       reclass {set redraw 1; $data(raster) reclass}
 320       table {set redraw 1; $data(raster) reclass -table}
 321       legend {fgisSetObj data(legend) none}
 322       legfile {fgisOpenLegFile}
 323       palette {set redraw 1; fgisSetObj data(palette) defaultpalette}
 324       palfile {set redraw 1; fgisOpenClrFile}
 325       patterns {set redraw 1
 326                 set data(plotmode) -patterns
 327                 fgisSetObj  data(patterns) {} }
 328       symbols {set redraw 1
 329               set data(plotmode) -symbols
 330               fgisSetObj data(patterns) {}}
 331       border {set redraw 1;fgisSetList data(border) {none yes base}}
 332       ovrborder {set redraw 1;fgisSetList data(ovrborder) {none yes base}}
 333       ovrcolor {set redraw 1;set data(ovrcolor)}
 334       title {set data(title)}
 335       subtitle {set data(subtitle)}
 336    }
 337    set redraw 0
 338    handleopt handlers $args
 339    set data(numeric) [expr ![info exists data(legend)]]
 340    if $redraw {
 341       foreach planchet [array names data .*] {
 342         fgisRasterRedraw $name $planchet
 343       }
 344    }
 345    return
 346 }
 347 #
 348 # Return values of certain instance variables,
 349 # or state information, corresponding to given configuration options
 350 # See list below.
 351 #
 352 ;proc fgisRasterCget {name args} {
 353 if [llength $args]!=1 {
 354   return -code error "wrong # args. should be $name cget option"
 355 }
 356 if [checklistopt args {-raster -reclass -table -palette -patterns -symbols
 357    -legend -border -ovrborder -ovrcolor -title -subtitle -file} msg] {
 358    return -code error $msg
 359 }
 360 upvar #0 $name data
 361 switch -exact -- $args {
 362     -file { return [$data(raster) filename] }
 363     -table { return [$data(raster) reclass]}
 364     -reclass {return [$data(raster) reclass -statements]}
 365     -symbols -
 366     -patterns {
 367         if {$data(plotmode)=="$args"} {
 368           return $data(patterns)
 369         } else {
 370           return
 371         }
 372     }
 373     default {
 374        regexp -- {-(.*)} $args junk index
 375        if [info exists data($index)] {
 376           return $data($index)
 377        } else {
 378          return
 379        }
 380     }
 381 }
 382 }
 383 #
 384 # Returns Tcl script, which creates same layer
 385 #
 386 ;proc fgisRasterDump {name args} {
 387   if [llength $args] {
 388      return -code error "wrong # args. should be $name dump"
 389   }
 390   upvar #0 $name data
 391   set opts ""
 392   append result "#fGIS Layer file. Layer type: raster\n"
 393   if [string length $data(title)] {
 394      append result "# Layer: $data(title)\n"
 395   }
 396   # dumping raster
 397   append result "set _raster_ \[raster [$data(raster) filename]"
 398   if [string length [set reclass [$data(raster) reclass -statements]]] {
 399     append result " -reclass [list $reclass]"
 400   }
 401   append result "\]\n"
 402   # dumping legend
 403   if [info exists data(legend)] {
 404     append result "set _legend_ \[legend parse [list [$data(legend) print]]]\n"
 405     append opts "-legend \$_legend_"
 406   }
 407   # dumping palette
 408   if {$data(palette)!="defaultpalette"} {
 409     append result "set _palette_ \[palette set [list [$data(palette) list]]]\n"
 410     append opts " -palette \$_palette_"
 411   }
 412   # dumping patterns
 413   if {[string length $data(patterns)]} {
 414     append result "set _patterns_ \[patterns set [list \
 415              [$data(patterns) list]]]\n"
 416     append opts " $data(plotmode) \$_patterns_"
 417   }
 418   if {[info exists $data(subtitle)]&&[string length $data(subtitle)]} {
 419     append opts " -title [list $data(subtitle)]"
 420   }
 421   # finally, creating layer command
 422   append result "layer create raster -raster \$_raster_\\
 423     -border $data(border) -ovrborder $data(ovrborder) -ovrcolor\
 424     $data(ovrcolor)\\
 425     -title [list $data(title)]\\
 426     $opts\n"
 427   return $result
 428 }
 429
 430
 431 # Destroys raster, destroys legend, if exists
 432 # destroys palette, if it is not defaultpalette,
 433 # destroys patterns if they are not empty
 434 #
 435 ;proc fgisRasterDelete {name args} {
 436   if [llength $args] {
 437     return -code error "wrong # args. should be $name delete"
 438   }
 439   upvar #0 $name data
 440   foreach planchet [array names data ".*"] {
 441      $planchet hide $name
 442   }
 443   $data(raster) delete
 444   if [info exists data(legend)] {
 445      $data(legend) delete
 446   }
 447   if {$data(palette)!="defaultpalette"} {
 448      $data(palette) delete
 449   }
 450   if [string length $data(patterns)] {
 451       $data(patterns) delete
 452   }
 453   unset data
 454   rename $name {}
 455   uplevel #0 unset fgisLayerList($name)
 456 }
 457 #
 458 # Redraws layer accodring to information, created by show
 459 #
 460 ;proc fgisRasterRedraw {name args} {
 461     if [llength $args]!=1 {
 462       return -code error "Wrong # args. should be $name redraw planchet"
 463     }
 464     upvar #0 $name data
 465     if {![winfo exists $args]||[winfo class $args]!="Canvas"} {
 466       return -code error "Invalid planchet $args"
 467     }
 468     if ![info exists data($args)] {
 469       return -code error "Layer $name is not shown on planchet $args"
 470     }
 471     eval $data($args)
 472 }
 473 #
 474 # Forget, that we was visible in planchet
 475 #
 476 ;proc fgisRasterHide {name args} {
 477     upvar \#0 $name data
 478     if ![info exists data($args)] {
 479       return -code error "Layer $name is not shown on planchet $args"
 480     }
 481     unset data($args)
 482 }
 483 #
 484 # Prepares to show itself in planchet
 485 #
 486 ;proc fgisRasterShow {name args} {
 487     if [llength $args]!=2 {
 488       return -code error "Wrong # args. should be $name planchet mode"
 489     }
 490     set planchet [lindex $args 0]
 491     set mode [lindex $args 1]
 492     upvar #0 $name data
 493     if {![winfo exists $planchet]||[winfo class $planchet]!="Canvas"} {
 494       return -code error "Invalid planchet $args"
 495     }
 496     switch -exact -- $mode {
 497     -base {
 498         set item [$planchet create image 0 0 -anchor nw \
 499                -image [image create photo -width [winfo reqwidth $planchet]\
 500                           -height [winfo reqheight $planchet]] -tags $name]
 501         set data($planchet) "fgisRasterColorImage $data(raster) $planchet\
 502                $item -border \$data(border) -palette \$data(palette)"
 503         $planchet lower $item
 504     }
 505     -overlay {
 506         set item [$planchet create image 0 0 -anchor nw \
 507                -image [image create bitmap -width [winfo reqwidth $planchet]\
 508                           -height [winfo reqheight $planchet]] -tags $name]
 509         set data($planchet) "fgisRasterBWImage $data(raster) $planchet\
 510                $item -border \$data(ovrborder) \$data(plotmode)\
 511                \$data(pattern) -color $data(ovrcolor)"
 512     }
 513     default {
 514        return -code error "Invalid option. should be either -base or -overlay"
 515     }
 516     }
 517 }
 518 #
 519 # Returns value of layer (with legend etc)
 520 #
 521 ;proc fgisRasterValue {name args} {
 522    set n [llength $args]
 523    if {$n<2||$n>3} {
 524       return -code error "wrong # args. should be $name value x y ?option?"
 525    } elseif {$n==3} {
 526       set flag [lindex $args 2]
 527       set goodopt {-raw -list -titled}
 528       if [set ind [lsearch -glob $goodopt $flag*]]!=-1 {
 529          set flag [lindex $goodopt $ind]
 530       } else {
 531          return -code error "invalid option. should be one of [join goodopt ","]"
 532       }
 533    } else {
 534       set flag -raw
 535    }
 536    upvar #0 $name data
 537    set value [$data(raster) get [lindex $args 0] [lindex $args 1]]
 538    if {$value==[$data(raster) offsite]} return
 539    if [info exist data(legend)] {
 540       set value [$data(legend) get $value]
 541    }
 542    switch -exact -- $flag {
 543    -raw {return $value}
 544    -list {return [list $name $value]}
 545    -titled {return "[fgisLayerTitle $name]: $value"}
 546    }
 547 }
 548 #
 549 # Returns limits of raster (planchets are very interested in this)
 550 #
 551 ;proc fgisRasterLimits {name args} {
 552   if [llength $args] {
 553     return -code error "wrong # args. should be $name limits"
 554   }
 555   upvar #0 $name data
 556   return [$data(raster) limits]
 557 }
 558
 559 #
 560 # chart layers
 561 #
 562 fgisLayerInherit raster chart
 563 array set fgisLayerMethods {
 564 chart,dump fgisChartDump
 565 chart,value fgisChartValue
 566 chart,configure fgisChartConfigure
 567 }