]> www.wagner.pp.ru Git - oss/fgis.git/blob - tcl/layer.tcl
The second attempt to automate building :-) A lot of work here should be
[oss/fgis.git] / 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 }