3 # Implements high level layer object
4 # This file is part of fGIS
7 # Global variable fgisLayerTypes - keeps names of constructor procedures
8 # for all defined layer types
10 array set fgisLayerTypes {
11 raster fgisCreateRaster
16 # proc layer - create layer or query information about all layers
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
23 proc layer {option args} {
24 global fgisLayerTypes fgisLayerList
25 switch -exact -- $option {
28 return -code error "usage: layer create ?name? ?options?"
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"
43 if [catch [concat $fgisLayerTypes($type) $args] name] {
44 return -code error $name
46 set fgisLayerList($name) $type
50 0 { # No matching type found
51 return -code error "Invalid layer type. Should be one of\
52 [join [array names fgisLayerTypes] ", "]"
54 default { # Too many matching types found
55 return -code error "Ambiquous layer type \"$tname\": $type"
59 types { # Return list of available types
60 return [array names fgisLayerTypes]
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 *
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?\
76 } elseif {![string match [lindex $args 0]* -type]} {
77 return -code error "wrong option. should be -type"
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\""
87 # then scan list of layers
89 foreach {name type} [array get fgisLayerList $pattern] {
90 if [info exists tmp($type)] {
97 type { # return type of given layer
98 if ![info exists fgisLayerList($args)] {
99 return -code error "Layer $args doesn't exists"
101 return $fgisLayerList($args)
106 if [llength $args]!=1 {
107 return -code error "wrong # args. should be: layer exist name"
109 return [info exists fgisLayerList([lindex $args 0])]
111 default { # unrecognized command
112 return -code error "Invalid option. should be one of create, exists,\
119 # Calls method of layer object. Searches in the global array
120 # fgisLayerMethods for index "type,method", and, if found, executes it.
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
129 foreach i [array names fgisLayerMethods $type,*] {
130 lappend msg [lindex [split $i ","] 1]
132 return -code error "Unknown option. should be one of [join $msg ", "]"
135 eval $fgisLayerMethods($methods) $object $args
138 return -code error "Ambiquous option \"$method\""
143 # creates instance command for layer
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
158 # copies name of old object methods to new one
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
166 # copy field template
167 global fgis${father}Fields fgis${son}Fields
168 array set fgis${son}Fields [array get fgis${father}Fields]
171 # Common methods for all layers
175 # return various info for layer
177 ;proc fgisLayerInfo {name args} {
179 if [llength $args]!=1 {
180 return -code error "wrong # of args. should be $name info option"
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 ", "]"
186 set key [lindex $goodopt $idx]
189 return [expr {[info exist data(legend)]&&[$data(legend) drawable]}]
197 # Two procedures, which return title and subtitle
199 ;proc fgisLayerTitle {name args} {
201 return -code error "wrong # args. should be $name title"
204 if [info exists data(title)] {
210 ;proc fgisLayerSubtitle {name args} {
212 return -code error "wrong # args. should be $name title"
215 if [info exists data(subtitle)] {
216 return $data(subtitle)
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
243 # table of fields (more precisely - template of default values
244 array set fgisRasterFields {
251 palette defaultpalette
260 # Other fields exist only in runtime
261 # legend - holds name of legend object
262 # raster - holds name of raster object
264 # constructor of raster layer.
267 # -raster - recieves handle of raster object
268 # -file - recieves epp file
270 # -reclass statements -recieves reclass in EPPL-like syntax
271 # -table list - recieves reclass as Tcl list
273 # -legend - recieves legend object handle
274 # -legfile - recieves legend file
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
285 ;proc fgisCreateRaster {name args} {
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"
293 fgisLayerDefine raster $name
297 # Three small procedures to create object from file.
298 # They are needed becouse handleopt doesn't allow ] after option value
300 ;proc fgisOpenEppFile {filename} {
301 set raster [raster $filename]
302 uplevel fgisSetObj data(raster) nodefault $raster
304 ;proc fgisOpenLegFile {filename} {
305 uplevel fgisSetObj data(legend) none [legend read $filename]
307 ;proc fgisOpenClrFile {filename} {
308 uplevel fgisSetObj data(palette) defaultpalette [palette read $filename]
311 # All done via handleopt. Only validity of border flags are checked
314 ;proc fgisRasterConfigure {name args} {
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)}
338 handleopt handlers $args
339 set data(numeric) [expr ![info exists data(legend)]]
341 foreach planchet [array names data .*] {
342 fgisRasterRedraw $name $planchet
348 # Return values of certain instance variables,
349 # or state information, corresponding to given configuration options
352 ;proc fgisRasterCget {name args} {
353 if [llength $args]!=1 {
354 return -code error "wrong # args. should be $name cget option"
356 if [checklistopt args {-raster -reclass -table -palette -patterns -symbols
357 -legend -border -ovrborder -ovrcolor -title -subtitle -file} msg] {
358 return -code error $msg
361 switch -exact -- $args {
362 -file { return [$data(raster) filename] }
363 -table { return [$data(raster) reclass]}
364 -reclass {return [$data(raster) reclass -statements]}
367 if {$data(plotmode)=="$args"} {
368 return $data(patterns)
374 regexp -- {-(.*)} $args junk index
375 if [info exists data($index)] {
384 # Returns Tcl script, which creates same layer
386 ;proc fgisRasterDump {name args} {
388 return -code error "wrong # args. should be $name dump"
392 append result "#fGIS Layer file. Layer type: raster\n"
393 if [string length $data(title)] {
394 append result "# Layer: $data(title)\n"
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]"
403 if [info exists data(legend)] {
404 append result "set _legend_ \[legend parse [list [$data(legend) print]]]\n"
405 append opts "-legend \$_legend_"
408 if {$data(palette)!="defaultpalette"} {
409 append result "set _palette_ \[palette set [list [$data(palette) list]]]\n"
410 append opts " -palette \$_palette_"
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_"
418 if {[info exists $data(subtitle)]&&[string length $data(subtitle)]} {
419 append opts " -title [list $data(subtitle)]"
421 # finally, creating layer command
422 append result "layer create raster -raster \$_raster_\\
423 -border $data(border) -ovrborder $data(ovrborder) -ovrcolor\
425 -title [list $data(title)]\\
431 # Destroys raster, destroys legend, if exists
432 # destroys palette, if it is not defaultpalette,
433 # destroys patterns if they are not empty
435 ;proc fgisRasterDelete {name args} {
437 return -code error "wrong # args. should be $name delete"
440 foreach planchet [array names data ".*"] {
444 if [info exists data(legend)] {
447 if {$data(palette)!="defaultpalette"} {
448 $data(palette) delete
450 if [string length $data(patterns)] {
451 $data(patterns) delete
455 uplevel #0 unset fgisLayerList($name)
458 # Redraws layer accodring to information, created by show
460 ;proc fgisRasterRedraw {name args} {
461 if [llength $args]!=1 {
462 return -code error "Wrong # args. should be $name redraw planchet"
465 if {![winfo exists $args]||[winfo class $args]!="Canvas"} {
466 return -code error "Invalid planchet $args"
468 if ![info exists data($args)] {
469 return -code error "Layer $name is not shown on planchet $args"
474 # Forget, that we was visible in planchet
476 ;proc fgisRasterHide {name args} {
478 if ![info exists data($args)] {
479 return -code error "Layer $name is not shown on planchet $args"
484 # Prepares to show itself in planchet
486 ;proc fgisRasterShow {name args} {
487 if [llength $args]!=2 {
488 return -code error "Wrong # args. should be $name planchet mode"
490 set planchet [lindex $args 0]
491 set mode [lindex $args 1]
493 if {![winfo exists $planchet]||[winfo class $planchet]!="Canvas"} {
494 return -code error "Invalid planchet $args"
496 switch -exact -- $mode {
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
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)"
514 return -code error "Invalid option. should be either -base or -overlay"
519 # Returns value of layer (with legend etc)
521 ;proc fgisRasterValue {name args} {
522 set n [llength $args]
524 return -code error "wrong # args. should be $name value x y ?option?"
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]
531 return -code error "invalid option. should be one of [join goodopt ","]"
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]
542 switch -exact -- $flag {
544 -list {return [list $name $value]}
545 -titled {return "[fgisLayerTitle $name]: $value"}
549 # Returns limits of raster (planchets are very interested in this)
551 ;proc fgisRasterLimits {name args} {
553 return -code error "wrong # args. should be $name limits"
556 return [$data(raster) limits]
562 fgisLayerInherit raster chart
563 array set fgisLayerMethods {
564 chart,dump fgisChartDump
565 chart,value fgisChartValue
566 chart,configure fgisChartConfigure