tcl/planchet.tcl

   1 #
   2 # planchet.tcl
   3 # definition of planchet widget.
   4 #
   5 # This file is part of fGIS tcl library
   6 # Copyright (c) by SoftWeyr, 1997
   7 #
   8
   9 #
  10 # Class options
  11 #
  12 #
  13 array set Planchet {
  14 legbox {}
  15 zoombutton {}
  16 unzoombuttons {}
  17 shiftbuttons {{} {} {} {}}
  18 statusline {}
  19 scalevar {}
  20 rulerpos {1c -1c}
  21 projection {}
  22 lookwidth 200
  23 resizable 1
  24 }
  25 #this options are got from application defaults
  26 array set Planchet [list\
  27 coordformat $fgis(coordformat)\
  28 orient $fgis(orient)\
  29 shiftfactor $fgis(shift_factor)\
  30 ]
  31
  32 # This options added here to make getopt eat up them, if they specified, and
  33 # so they would never passed to canvas command, so planchet would effectively
  34 # ignore them
  35 array set Planchet {
  36 borderwidth 0
  37 bd 0
  38 highlightthickness 0
  39 }
  40 #
  41 # bindings
  42 #
  43
  44 bind Planchet <Configure> "fgisPlanchet:resize %W"
  45 bind Planchet <Destroy>  "fgisPlanchet:destroy %W"
  46 bind Planchet <Button-3> "fgisPlanchet:look %W %x %y"
  47 bind Planchet <Any-Leave> "fgisPlanchet_setstatus %W {} {}"
  48 bind Planchet <Any-Enter> "fgisPlanchet:setstatus %W %x %y"
  49 bind Planchet <Any-Motion> "fgisPlanchet:setstatus %W %x %y"
  50 bind LookToplevel <ButtonRelease-3> "fgisPlanchet:hidelook %W"
  51 bind LookToplevel <Button-1> "fgisPlanchet:hidelook %W"
  52 bind Zoom <Any-Motion> break
  53 bind Zoom <Button-1> "fgisPlanchet_zoom %W %x %y;break"
  54 bind Zoom <Button-3> "fgisPlanchet_zoom %W cancel;break"
  55 bind Zoom <Key-Escape> "fgisPlanchet_zoom %W cancel;break"
  56 bind Zoom <Any-Leave> "break"
  57 bind Zoom <Any-Enter> "break"
  58 #
  59 # create planchet widget
  60 #
  61 #
  62 proc planchet {w args} {
  63 upvar \#0 $w data
  64 global Planchet
  65 #parse options
  66 array set data [array get Planchet]
  67 set data(default) {}
  68 if [catch {getopt data $args} err] {
  69   unset data
  70   return -code error $err
  71 }
  72 set restargs $data(default)
  73 unset data(default)
  74 #check helper widgets, if available
  75 foreach t {legbox statusline shiftbuttons unzoombuttons zoombutton} {
  76    if [catch {fgisSetHelper $w $t $data($t)} err] {
  77         unset data
  78         return -code error $err
  79     }
  80 }
  81 #correct value of "resizable" options
  82 if [checkbooleanopt data(resizable) err] {
  83    return -code error $err
  84 }
  85 #create canvas
  86 if [catch {eval canvas [list $w] $restargs -bd 0\
  87          -highlightthickness 0} err] {
  88    unset data
  89    return -code error $err
  90 }
  91 bindtags $w [list $w Planchet [winfo parent $w] all]
  92 #create widget command
  93 set data(cmd) .$w
  94 rename $w $data(cmd)
  95 ;proc $w args "eval fgisPlanchet:eval [list $w] \$args"
  96 # create look widnow
  97
  98 set data(lookToplevel) [toplevel $w.look -class LookToplevel\
  99          -relief raised -bd 3]
 100 set data(lookLabel) [label $w.look.label -wraplength $data(lookwidth)\
 101     -justify left]
 102 pack $data(lookLabel)
 103 wm overrideredirect $data(lookToplevel) y
 104 wm transient $data(lookToplevel) $w
 105 wm positionfrom $data(lookToplevel) program
 106 wm withdraw $data(lookToplevel)
 107 # fill placeholders for layer information
 108 array set data {
 109 lookable {}
 110 overlays {}
 111 base {}
 112 limits {}
 113 zoom {}
 114 }
 115 return $w
 116 }
 117
 118 #
 119 # fgisPlanchet:eval
 120 # -evaluates planchet widget command
 121 #
 122 ;proc fgisPlanchet:eval {w option args} {
 123  upvar \#0 $w data
 124   if [string match {} [set arg [info command fgisPlanchet_$option]]] {
 125       set arg [info command fgiPlanchet_$option*]
 126   }
 127   switch -exact [llength $arg] {
 128       0 { if [catch {uplevel [list $data(cmd) $option] $args} err] {
 129             return -code error $err
 130           } else {
 131             return $err
 132           }
 133       }
 134       1 {return [uplevel $arg [list $w] $args] }
 135       default {
 136            return -code error "ambiquous option \"$option\""
 137       }
 138   }
 139 }
 140
 141 #
 142 # fgisPlanchet:destroy
 143 # destroys planchet
 144 #
 145
 146 ;proc fgisPlanchet:destroy w {
 147   upvar \#0 $w data
 148   foreach layer [linsert $data(overlays) end $data(base)] {
 149     if [string length $layer] {$layer  hide $w}
 150   }
 151   catch {rename $w {}}
 152   #catch {rename $data(cmd) $w}
 153   catch {unset data}
 154   return
 155 }
 156 #
 157 # releases grab and hides look window
 158 #
 159 ;proc fgisPlanchet:hidelook {w} {
 160   catch {grab release $w}
 161   wm withdraw $w
 162 }
 163 #
 164 # Given point in canvas coordinates, displays window with content
 165 # of current layers
 166 #
 167 ;proc fgisPlanchet:look {w x y} {
 168     upvar \#0 $w data
 169     set text [join [fgisPlanchet_look $w \
 170             [fgisPlanchet_mapx $w $x] [fgisPlanchet_mapy $w $y] -titled] "\n"]
 171     if ![string length $text] {
 172         set text "No info for this point"
 173     }
 174     $data(lookLabel) configure -text $text
 175     set rootx [expr [winfo rootx $w]+$x+5]
 176     if {$rootx>[winfo screenwidth $w]} {
 177         set rootx [expr $rootx-10-[winfo reqwidth $data(lookToplevel)]]
 178     }
 179     set rooty [expr [winfo rooty $w]+$y+5]
 180     if {$rooty>[winfo screenwidth $w]} {
 181         set rooty [expr $rooty-10-[winfo reqheight $data(lookToplevel)]]
 182     }
 183     wm geometry $data(lookToplevel)  +$rootx+$rooty
 184     wm deiconify $data(lookToplevel)
 185     raise $data(lookToplevel)
 186     grab $data(lookToplevel)
 187 }
 188 #
 189 # User visible implementation of look. Can be invoked as look planchet
 190 # subcommand. Gets two map-coordinates and returns list of active layers
 191 # Forms
 192 # $planchet look x y ?-titled|-list?
 193 # $planchet look add $layer
 194 # $planchet look remove pattern
 195 # $planchet look remove all
 196 # $planchet look list ?pattern?
 197 # legend text as layer value x y -titled returns
 198 #
 199 # Layers that return an empty string are ignored
 200 #
 201 ;proc fgisPlanchet_look {w x {y {}} {flag -list}} {
 202    upvar \#0 $w data
 203    switch -exact -- $x {
 204       add {
 205           if ![string length $y] {
 206               return -code error "Wrong # args. Should be $w look add layer"
 207           }
 208           if ![layer exists $y] {
 209               return -code error "Layer \"$y\" doesn't exist"
 210           }
 211           if ![$y info lookable] {
 212               return -code error "Layer \"$y\" is not lookable"
 213           }
 214           if [lsearch -exact $data(lookable) $y]!=-1 {
 215               return -code error "Layer \"$y\" is already in look list of $w"
 216           }
 217           lappend data(lookable) $y
 218       }
 219       remove {
 220          if ![string length $y] {
 221             return -code error\
 222                   "Wrong # args. Should be $w look remove pattern"
 223          }
 224          if {"$y"=="all"} {
 225              set data(lookable) {}
 226          } else {
 227            if [lsearch -glob $data(lookable) $y]==-1 {
 228                return -code error "No layers match pattern \"$y\""
 229            }
 230            while {[set index [lsearch -glob $data(lookable) $y]]!=-1} {
 231               set data(lookable) [lreplace $data(lookable) $index $index]
 232            }
 233          }
 234       }
 235       list {
 236          set result {}
 237          if [string match {} $y] {set y *}
 238          foreach l $data(lookable) {
 239             if [string match $y $l] {
 240                lappend result $l
 241             }
 242          }
 243          return $result
 244       }
 245       default {
 246           set result {}
 247           foreach layer $data(lookable) {
 248              lappend result [$layer value $x $y $flag]
 249           }
 250           return $result
 251       }
 252    }
 253 }
 254 #
 255 # Displays mouse coordinates in window.
 256 # Recalculates pixels to meters and calls $w setstatus
 257 # If no coordinate defined, displays "No coords"
 258 #
 259
 260 ;proc fgisPlanchet:setstatus {w x y}  {
 261 upvar \#0 $w data
 262 if ![llength $data(limits)] {
 263    fgisPlanchet_setstatus $w "No coordinates defined"
 264 } else {
 265   fgisPlanchet_setstatus $w [fgisPlanchet_mapx $w $x] [fgisPlanchet_mapy $w $y]
 266 }
 267 }
 268
 269 #
 270 # Changes content of status window, if available
 271 # possible variants setstatus {} - clears status line
 272 # setstatus msg - displays $msg
 273 # setstatus x y - displays coordinates. Map coordinates, not screen!
 274 ;proc fgisPlanchet_setstatus {w x {y {}}} {
 275 upvar \#0 $w data
 276 if ![string length $data(statusline)] {
 277    return
 278 }
 279 if ![string length $y] {
 280   $data(statusline) configure -text $x
 281 } elseif ![string length $data(projection)] {
 282   $data(statusline) configure -text [format $data(coordformat) $x $y]
 283 } else {
 284   $data(statusline) configure -text [$data(projection) format $x $y]
 285 }
 286 }
 287
 288 #
 289 # intercepts widget configure command
 290 #
 291 #
 292 ;proc fgisPlanchet_configure {w args} {
 293 upvar \#0 $w data
 294 if ![llength opt] {
 295    return [eval $data(cmd) configure]
 296 }
 297 array set opt [list\
 298     legbox [list fgisSetHelper $w legbox]\
 299     zoombutton [list fgisSetHelper $w zoombutton ]\
 300     unzoombuttons [list fgisSetHelper $w unzoombuttons ]\
 301     shiftbuttons [list fgisSetHelper $w shiftbuttons]\
 302     statusline [list fgisSetHelper $w statusline]\
 303     scalevar {set data(scalevar)}\
 304     rulerpos [list fgisPlanchet:ruler $w]\
 305     projection {set data(projection)}\
 306     lookwidth [list $data(lookLabel) configure -wraplength]\
 307     coordformat "set data(coordformat)"\
 308     orient "set data(orient)"\
 309     shiftfactor "set data(shiftfactor)"\
 310     borderwidth {#}\
 311     bd 0\
 312     highlightthickness {#}\
 313     default "lappend restargs"\
 314 ]
 315 set restargs {}
 316 if [catch {handleopt opt $args} res] {
 317     return -code error $res
 318 }
 319 if [llength $restargs] {
 320     if [catch {eval $data(cmd) configure $restargs}] {
 321       return -code error $res
 322     }
 323 }
 324 }
 325 #
 326 # Installs link to helper widget.
 327 # Strictly internal use
 328 #
 329 ;proc fgisSetHelper {w type widgets} {
 330 array set CLASS {
 331 legbox Canvas
 332 shiftbuttons Button
 333 zoombutton Button
 334 unzoombuttons Button
 335 statusline Label
 336 }
 337 upvar \#0 $w data
 338 foreach i $widgets {
 339     if ![string match {} $i] {
 340         if {![winfo exist $i]} {
 341           return -code error "Window $i doesn't exist"
 342         } elseif {"[winfo class $i]"!="$CLASS($type)"} {
 343           return -code error \
 344           "Wrong window $i. Should be [string tolower $CLASS($type)] widget."
 345         }
 346     }
 347 }
 348 # additional checks
 349 switch -exact $type {
 350     zoombutton {
 351        if [llength $widgets]>1 {
 352           return -code error "-zoombutton allows only one widget"
 353        }
 354        if {[llength $widgets]&&![llength $data(limits)]} {
 355            $widgets configure -state disabled
 356        }
 357     }
 358     shiftbuttons {
 359        if [llength $widgets]!=4 {
 360           return -code error "-shiftbuttons requires list of four buttons"
 361        }
 362        if [string length [join $widgets ""]] {
 363            set dir {left down up right}
 364            set j 0
 365            foreach i $widgets {
 366               if [string compare {} $i] {
 367                   $i configure -command [list $w shift [lindex $dir $j]]
 368               } else {
 369                   return -code error\
 370                          "-shiftbuttons should all exist or all be empty"
 371               }
 372               incr j
 373            }
 374            set data(shiftbuttons) $widgets
 375            fgisCheckShifts $w
 376        }
 377     }
 378     unzoombuttons {}
 379     default {
 380        if [llength $widgets]>1 {
 381           return -code error "Only one widget allowed for -$type option"
 382        }
 383     }
 384 }
 385 uplevel #0 set $w\($type) [list $widgets]
 386 }
 387 #
 388 # intercert widget cget command
 389 #
 390 #
 391 ;proc fgisPlanchet_cget {w args} {
 392     upvar \#0 $w data
 393     if [llength $args]!=1 {
 394      return -code error "Wrong # args. Should be $w cget option"
 395     }
 396     set arg [array names data [string trimleft $args -]]
 397     set num [llength $arg]
 398     if $num==1 {
 399       return $data($arg)
 400     } elseif $num {
 401       return -code error  "Amgiquous option \"$args\""
 402     } elseif [catch {$data(cmd) cget $args} result] {
 403       return -code error $result
 404     } else {
 405       return $result
 406     }
 407 }
 408 #
 409 #Set up new coordinates of ruler
 410 #or simply redraws ruler, if shown
 411 #
 412 ;proc fgisPlanchet:ruler {w {coord {}}} {
 413     upvar \#0 $w data
 414     if [llength [$data(cmd) find withtag ruler]] {
 415        fgisPlanchet_ruler off
 416        if [string length $coord] {
 417            set tmp $data(rulerpos)
 418            set data(rulerpos) $coord
 419            if [catch {fgisPlanchet_ruler on} err] {
 420               set data(rulerpos) $tmp
 421               fgisPlanchet_ruler on
 422               return -code error $err
 423            }
 424        } else {
 425          fgisPlanchet_ruler on
 426        }
 427     }
 428 }
 429 #
 430 # actually implements ruler command
 431 #
 432 #
 433 ;proc fgisPlanchet_ruler {w {flag {}}} {
 434 upvar \#0 $w data
 435 switch -exact $flag {
 436    {}  {
 437         if [llength [$data(cmd) find withtag ruler]] {
 438           return on
 439         } else {
 440           return off
 441         }
 442    }
 443    off {
 444          $data(cmd) delete ruler
 445        }
 446    on  { #here we actually draw it
 447          # parse coordinates
 448          global fgis_font
 449          foreach {x y} $data(rulerpos) break
 450          if [catch {fgisConvertCoords $data(cmd) x $x [winfo width $w]} x] {
 451              return -code error $x
 452          }
 453          if [catch {fgisConvertCoords $data(cmd) y $y [winfo height $w]} y] {
 454              return -code error $y
 455          }
 456          if [llength $data(limits)]!=4 {
 457              return -code error "Coordinate system not defined for $w"
 458          }
 459          set origin_x [fgisPlanchet_mapx $w $x]
 460          set origin_y [fgisPlanchet_mapy $w $y]
 461          set meters [expr [fgisPlanchet_mapx $w 2c]-[fgisPlanchet_mapx $w 0c]]
 462          for {set size 10;set step 2} {abs($size)<$meters } {
 463                 set size [expr $size*$step]} {
 464             set step [expr $step==2?5:2]
 465          }
 466         $data(cmd) create line $x $y [$w scrx [expr $origin_x+$size]] \
 467               $y -width 3  -tags ruler
 468         $data(cmd) create text $x [expr $y-5] -anchor s -text 0 -tags ruler \
 469                -font $fgis_font(1)
 470         if {$size>1000} {
 471             set msg "[expr $size/1000]km"
 472         } else {
 473             set msg "${size}m"
 474         }
 475         $data(cmd) create text [$w scrx [expr $origin_x+$size]]\
 476                 [expr $y-5] -anchor s -text $msg -tags ruler \
 477                 -font $fgis_font(1)
 478         for {set xx $origin_x} {$xx<=$size+$origin_x} {
 479                       set xx [expr $xx+$size/$step]} {
 480            $data(cmd) create line [$w scrx $xx] $y [$w scrx $xx] [expr $y-4] \
 481                   -tags ruler
 482         }
 483   }
 484 }
 485 }
 486 #
 487 # Converts values given in any cordinate form into pixels
 488 # if value is negative, corresponding window size is added
 489 #
 490
 491 ;proc fgisConvertCoords {w cmd value limit} {
 492    if [regexp -- {-(.*)} $value junk abs] {
 493      set negate 1
 494      set value $abs
 495    } else { set negate 0 }
 496    if [catch { expr [$w canvas$cmd $value]-[$w canvas$cmd 0]} value] {
 497      return -code error $value
 498    }
 499    if $negate {
 500      return [expr $limit-$value]
 501    } else {
 502      return $value
 503    }
 504 }
 505 #
 506 # Sets limits of planchet coordinate system
 507 # If limits were defined, pushes them into zoom stack and
 508 # converts axis directions if neccessary
 509 #
 510 ;proc fgisPlanchet_limits {w args} {
 511     upvar \#0 $w data
 512     if [llength $args]==1 {
 513       eval set args $args
 514     } elseif ![llength $args] {
 515        return $data(limits)
 516     }
 517     if [string match $args* default] {
 518         if {![llength $data(zoom)]} {
 519            return -code error "No views stacked"
 520         }
 521         set data(limits) {}
 522         set args [lindex $data(zoom) 0]
 523         set data(zoom) {}
 524     }
 525     if [llength $args]!=4 {
 526        return -code error "List of four floating point numbers expected"
 527     }
 528     foreach {x1 y1 x2 y2} $args break
 529     set width [expr $x2-$x1]
 530     set height [expr $y2-$y1]
 531     if [llength $data(limits)] {
 532         foreach b $data(unzoombuttons) {
 533           $b config -state normal
 534         }
 535         if {$width*([lindex $data(limits) 2]-[lindex $data(limits) 0])<0} {
 536            set tmp $x2; set x2 $x1; set x1 $tmp
 537            set width [expr -$width]
 538         }
 539         if {$height*([lindex $data(limits) 3]-[lindex $data(limits) 1])<0} {
 540             set tmp $y2;set y2 $y1;set y1 $tmp
 541             set height [expr -$height]
 542         }
 543     } else {
 544       foreach b $data(unzoombuttons) {
 545          $b config -state disabled
 546       }
 547       if [string length $data(zoombutton)] {
 548          $data(zoombutton) config -state normal
 549       }
 550     }
 551     if {![llength $data(limits)]&&$data(resizable)} {
 552     # Trying to adjust canvas size, preserving area
 553       set area [expr [winfo reqheight $w]*[winfo reqwidth $w]]
 554       set ratio [expr abs($width/$height)]
 555       set hei [expr sqrt($area/$ratio)]
 556       set wid [expr $hei*$ratio]
 557       $data(cmd) config -width $wid -height $hei
 558     } else {
 559     # Trying to expand coordinate limits
 560         if (abs($height/[winfo reqheight $w])<abs($width/[winfo reqwidth $w])) {
 561          set newh [expr abs($width)*[winfo reqheight $w]/[winfo reqwidth $w]]
 562          if ($height<0) {
 563              set y2 [expr $y1-$newh]
 564           } else {
 565              set y2 [expr  $y1+$newh]
 566           }
 567         } else {
 568           set neww [expr abs($height)*[winfo reqwidth $w]/[winfo reqheight $w]]
 569           if ($width<0)  {
 570              set x2 [expr $x1-$neww]
 571           } else {
 572              set x2 [expr $x1+$neww]
 573           }
 574         }
 575
 576       if ![info exists data(this_is_not_zoom)] {
 577           lappend  data(zoom) $data(limits)
 578       }
 579    }
 580    set data(limits) [list $x1 $y1 $x2 $y2]
 581    fgisManageZoomList $w
 582    fgisCheckShifts $w
 583    fgisPlanchet:Redraw $w
 584 }
 585 #
 586 # checks all shift directions and enables/disables buttons, if exists
 587 # strictly internal use, no error checking
 588 #
 589 ;proc fgisCheckShifts w {
 590     upvar \#0 $w data
 591     if [string length [join $data(shiftbuttons) ""]] {
 592         foreach b $data(shiftbuttons) {
 593             $b configure -state disabled
 594         }
 595         if [llength $data(zoom)] {
 596           foreach {X1 Y1 X2 Y2} [lindex $data(zoom) 0] break
 597           foreach {x1 y1 x2 y2} $data(limits) break
 598           foreach {left down up right} $data(shiftbuttons) break
 599           fgisEnableShift $left $x1 $X1 $X2
 600           fgisEnableShift $down $y1 $Y1 $Y2
 601           fgisEnableShift $up   $y2 $Y2 $Y1
 602           fgisEnableShift $right $x2 $X2 $X1
 603         }
 604   }
 605 }
 606 #
 607 # fgisEnableShift - checks if shift in given direction is possible,
 608 # and, if so, enables given button
 609 #
 610
 611 ;proc fgisEnableShift {button view lim1 lim2} {
 612     if {($view-$lim2)/($lim1-$lim2)<1} {
 613        $button config -state normal
 614     }
 615 }
 616 #
 617 # implements scale widget command
 618 # without arguments returns current scale,
 619 # with exactly one numeric argument sets scale to specified
 620 # keeping center of window at same coordinates, otherwise calls canvas scale
 621 #
 622
 623 ;proc fgisPlanchet_scale {w args} {
 624    upvar \#0 $w data
 625    if {[llength $args]<=1&&[llength $data(limits)]!=4} {
 626       return -code error "Coorinate system for $w is not set"
 627    }
 628    if ![llength $args] {
 629       return [format "%0.0f" [expr [$w mapx 1000m]-[$w mapx 0m]]]
 630    }
 631    if [llength $args]==1 {
 632        # compute coordinates of central point
 633        set x [$w mapx [set halfwidth [expr [winfo reqwidth $w]/2]]]
 634        set y [$w mapy [set halfheight [expr [winfo reqheight $w]/2]]]
 635        # compute width and height in meters
 636        set wm [expr $halfwidth/[$data(cmd) canvasx 1000m]-[$data(cmd) canvasx 0m]]
 637        if [catch {expr $args*$wm} dx] {
 638           return -code error $dx
 639        }
 640        set hm [expr {$halfheight/[$data(cmd) canvasy 1000m]-
 641                     [$data(cmd) canvasy 0m]}]
 642        set dy [expr $args*$hm]
 643        foreach {x1 y1 x2 y2} $data(limits) break
 644        if {$x1>$x2} {set dx [expr -$dx]}
 645        set x1 [expr $x - $dx]
 646        set x2 [expr $x + $dx]
 647        if {$y1>$y2} {set dy [expr -$dy]}
 648        set y1 [expr $y - $dy]
 649        set y2 [expr $y + $dy]
 650        fgisPlanchet_limits $w $x1 $y1 $x2 $y2
 651    } elseif [catch {eval $data(cmd) scale $args} err] {
 652        return -code error $err
 653    }
 654 }
 655
 656 #
 657 # handles <Configure> events by expanding coordinate system appropriately
 658 # and redrawing all layers
 659 #
 660 ;proc fgisPlanchet:resize {w} {
 661 upvar \#0 $w data
 662 set oldw [winfo reqwidth $w]
 663 set oldh [winfo reqheight $w]
 664 set nw [winfo width $w]
 665 set nh [winfo height $w]
 666 if {$oldw==$nw&&$oldh==$nh} return
 667 $data(cmd) configure -width $nw -height $nh
 668 if [llength $data(limits)]==4 {
 669   foreach {x1 y1 x2 y2} $data(limits) break
 670   set y2 [expr ($y2-$y1)/$oldh*$nh+$y1]
 671   set x2 [expr ($x2-$x1)/$oldw*$nw+$x1]
 672   set data(limits) [list $x1 $y1 $x2 $y2]
 673   fgisCheckShifts $w
 674   fgisPlanchet:Redraw $w
 675 }
 676 }
 677
 678 #
 679 # implements shift command - shifts viewport shiftfactor share in given
 680 # direction
 681 #
 682
 683 ;proc fgisPlanchet_shift {w args} {
 684     if [llength $args]!=1 {
 685        return -code error "Wrong # args. should be $w shift direction"
 686     }
 687     upvar \#0 $w data
 688     if [llength $data(limits)]!=4 {
 689       return -code error "Coordinate system for $w not set"
 690     }
 691     array set dir {
 692     left {-1 0}
 693     west {-1 0}
 694     right {1 0}
 695     east {1 0}
 696     up {0 1}
 697     north {0 1}
 698     down {0 -1}
 699     south {0 -1}
 700     }
 701     set d [array names dir [string tolower $args]*]
 702     if [llength $d]>1 {
 703       return -code error "Ambiquous direction \"$dir\"."
 704     } elseif ![llength $d] {
 705       return -code error \
 706              "Invalid direction \"$dir\". Should be one of [array names dir]"
 707     }
 708     set  d $dir($d)
 709
 710     foreach {x1 y1 x2 y2} $data(limits) break;
 711     set dx [expr ($x2-$x1)*$data(shiftfactor)*[lindex $d 0]]
 712     set dy [expr ($y2-$y1)*$data(shiftfactor)*[lindex $d 1]]
 713     set data(limits) [list  [expr $x1+$dx] [expr $y1+$dy] [expr $x2+$dx]\
 714              [expr $y2+$dy]]
 715     fgisCheckShifts $w
 716     fgisPlanchet:Redraw $w
 717 }
 718
 719 #
 720 # Pops up last zoom from stack
 721 # does call _limits to ensure that possible window size changes are haldled
 722 #
 723
 724 ;proc fgisPlanchet_unzoom w {
 725     upvar \#0 $w data
 726     if ![set len [llength $data(zoom)]] {
 727       return -code error "No views stacked"
 728     }
 729     set data(this_is_not_zoom) {}
 730     set newlim [lindex $data(zoom) [incr len -1]]
 731     set data(zoom) [lreplace $data(zoom) $len end]
 732     fgisPlanchet_limits $w $newlim
 733     unset data(this_is_not_zoom)
 734 }
 735
 736 #
 737 # Checks it zoom stack contain some views with larger scale than current
 738 # and discards them, becouse unzoom should never enlarge scale.
 739 # (it was too annoying in Serge Mikhailov's eppedit
 740 #
 741 # Here can also be shifting of old views to make them contain new one,
 742 # but I'm not sure that here is a good way to do so
 743 #
 744
 745 ;proc fgisManageZoomList w {
 746     upvar \#0 $w data
 747     set zoom {}
 748     set width [expr abs([lindex $data(limits) 2]-[lindex $data(limits) 0])]
 749     foreach view $data(zoom) {
 750         if {abs([lindex $view 2]-[lindex $view 0])>$width} {
 751             lappend zoom $view
 752         }
 753     }
 754     if [llength $zoom] {
 755        set data(zoom) $zoom
 756     } elseif [llength $data(zoom)] {
 757        # always preserve default limits
 758        set data(zoom) [list [lindex $data(zoom) 0]]
 759     }
 760     # update scale variable, if exist
 761     if [string length $data(scalevar)] {
 762         uplevel \#0 set $data(scalevar) "1:[fgisPlanchet_scale $w]"
 763     }
 764     # redraw ruler, if it is already visible
 765
 766 }
 767
 768 #
 769 # Implements zoom widget command.
 770 # with no options start interactive zooming process
 771 # with two coords starts interactive zooming with specified point (in
 772 # canvas coord) as one of corner. With four coords - just does it.
 773 # with cancel flag - cancels zoom in progress
 774 #
 775 ;proc fgisPlanchet_zoom {w args} {
 776    upvar \#0 $w data
 777    switch -exact [llength $args] {
 778    0 {
 779        fgisPlanchet_setstatus $w \
 780                 "Pick first corner. ESC or right button cancels"
 781         bind Zoom <Button-1> "fgisPlanchet_zoom %W %x %y;break"
 782         bind Zoom <Any-Motion> "break"
 783         bindtags $w [linsert [bindtags $w] 0 Zoom]
 784    }
 785    1 { if ![string match $args* cancel] {
 786          return -code error "Wrong # args. Should be $w zoom ?x y ?x y?? or\
 787             $w zoom cancel"
 788        }
 789        if {![string match "Zoom*" [lindex [bindtags $w] 0]]} {
 790            return -code error "No zoom in progress"
 791        }
 792        bindtags $w [lrange [bindtags $w] 1 end]
 793        $data(cmd) delete zoomer
 794        fgisPlanchet_setstatus {}
 795    }
 796    2 { if {[lindex [bindtags $w] 0]!="Zoom"} {
 797            bindtags $w [linsert [bindtags $w] 0 Zoom]]
 798        }
 799        fgisPlanchet_setstatus $w\
 800                "Pick second corner. ESC or right button cancels"
 801        set x [lindex $args 0]
 802        set y [lindex $args 1]
 803        $data(cmd) create rectangle $x $y $x $y -tag zoomer
 804        bind Zoom <Button-1> "fgisPlanchet_zoom %W $x $y %x %y;break"
 805        bind Zoom <Any-Motion> "%W coord zoomer $x $y %x %y; break"
 806    }
 807    4 { foreach {x1 y1 x2 y2} $args break
 808        if {[lindex [bindtags $w] 0]=="Zoom"} {
 809           bindtags $w [lrange [bindtags $w] 1 end]
 810        }
 811        fgisPlanchet_limits $w [$w mapx $x1] [$w mapy $y1] [$w mapx $x2]\
 812             [$w mapy $y2]
 813        $data(cmd) delete zoomer
 814      }
 815    default {
 816      return -code error  "Wrong # args. Should be $w zoom ?x y ?x y?? or\
 817             $w zoom cancel"
 818    }
 819 }
 820 }
 821
 822 #
 823 # clear - deletes all layers and resets coordinate system.
 824 # leaves projection untouched
 825 #
 826
 827 ;proc fgisPlanchet_clear w {
 828    upvar \#0 $w data
 829    set data(lookable) {}
 830    foreach layer [concat $data(overlays) $data(base)] {
 831       $layer hide $w
 832    }
 833    $data(cmd) delete all
 834    set data(limits) {}
 835    set data(zoom) {}
 836    set data(overlays) {}
 837    set data(base) {}
 838    if {[string length $data(legbox)]} {$data(legbox) delete all}
 839    foreach b [concat $data(unzoombuttons) [list $data(zoombutton)] \
 840           $data(shiftbuttons)] {
 841      if {[string length $b]&&[winfo exists $b]} {
 842          $b configure -state disabled
 843      }
 844    }
 845 }
 846
 847 #
 848 # layers - returns list of all layers
 849 #
 850 #
 851
 852 ;proc fgisPlanchet_layers {w args} {
 853     upvar \#0 $w data
 854     if [llength $args]>1 {
 855         return -code error "Wrong # of args. Should be $w layers ?pattern?"
 856     }
 857     if ![llength $args] { set args "*"}
 858     set result {}
 859     upvar #0 $w data
 860     foreach l [concat $data(base) $data(overlays)] {
 861       if {[string match $args $l]&&[lsearch -exact $result $l]==-1} {
 862          lappend result $l
 863       }
 864     }
 865     return $result
 866 }
 867
 868 #
 869 # hide $layer - clears given layer
 870 #
 871 #
 872 ;proc fgisPlanchet_hide {w args} {
 873    upvar \#0 $w data
 874    foreach l $args {
 875       set list [fgisPlanchet_layers $w $l]
 876       if ![llength $list] {
 877          return -code error "No such layer \"$l\" in $w"
 878       }
 879       foreach ll $list {
 880          $ll hide $w
 881          $data(cmd) delete $ll
 882          if {"$ll"=="$data(base)"} {
 883            if {[string length $data(legbox)]} {
 884                $data(legbox) delete all
 885            }
 886            set data(base) {}
 887          }
 888          if {[set index [lsearch -exact $data(overlays) $ll]]!=-1} {
 889             set data(overlays) [lreplace $data(overlays) $index $index]
 890          }
 891       }
 892    }
 893
 894 }
 895
 896 #
 897 # show $layer ?-base|-overlay?
 898 # displays layer
 899 #
 900 ;proc fgisPlanchet_show {w args} {
 901    upvar \#0 $w data
 902    if ![llength $args]&&[llength $args]>2 {
 903       return -code error "Wrong # args. Should be $w show layer ?mode?"
 904    }
 905    set layer [lindex $args 0]
 906    if [llength $args]==1 {
 907       if {![llength $data(limits)]&&[$layer info opaque]} {
 908         set mode -base
 909       } else {
 910         set mode -overlay
 911       }
 912    } else {
 913      set mode [lindex $args 1]
 914      if [string match $mode* -base] {
 915         set mode -base
 916         if ![$layer info opaque] {
 917            return -code error "Opaque mode is not supporded by $layer"
 918         }
 919      } elseif [string match $mode* -overlay] {
 920         set mode -overlay
 921         if [lsearch -exact $data(overlays) $layer]!=-1 {
 922            return -code error "Layer \"$layer\" already visible in $w"
 923         }
 924      } else {
 925         return -code error \
 926             "Invalid option \"$mode\". Should be -base or -overlay"
 927      }
 928    }
 929    if ![llength $data(limits)] {
 930      if [$layer info limits] {
 931        # am I wrong?
 932        eval fgisPlanchet_limits $w [$layer limits]
 933      } else {
 934        return -code error\
 935             "Cannot show $layer without defined coordinate system"
 936      }
 937    } else {
 938      foreach {x1 y1 x2 y2} [$layer limits] break
 939      foreach {X1 Y1 X2 Y2} $data(limits) break
 940      if {($x2-$x1)*($X2-$X1)<0||($Y2-$Y1)*($y2-$y1)<0} {
 941         return -code error "Layer $layer is not compatible with $w"
 942      }
 943    }
 944    $layer show $w $mode
 945    if {$mode=="-base"} {
 946       if [llength $data(base)] {
 947          $data(base)  hide $w
 948          $data(cmd) delete $data(base)
 949       }
 950       set data(base) $layer
 951       $data(cmd) lower $layer
 952       if {[string length $data(legbox)]&&[winfo exists $data(legbox)]} {
 953         drawlegend 0 0 $data(legbox) $layer -base -columns 1 \
 954               -width [$data legbox cget -width]
 955       }
 956    } else {
 957      lappend data(overlays) $layer
 958    }
 959    fgisPlanchet_setstatus $w "REDRAW: Wait please..."
 960    update
 961    $layer redraw $w
 962    fgisPlanchet_setstatus $w {}
 963 }
 964
 965 #
 966 #
 967 # fgisPlanchet:Redraw - redraws all layers. Very expensive thing.
 968 # Should be called only if view coords are changed
 969 #
 970 ;proc fgisPlanchet:Redraw {w} {
 971     upvar \#0 $w data
 972     fgisPlanchet_setstatus $w "REDRAW: Wait please..."
 973     update
 974     foreach layer [concat $data(base) $data(overlays)] {
 975         $layer redraw $w
 976     }
 977     fgisPlanchet_setstatus $w {}
 978     if {[fgisPlanchet_ruler $w]=="on"} {
 979          fgisPlanchet_ruler $w off
 980          fgisPlanchet_ruler $w on
 981     }
 982     update
 983 }
 984 ;proc fgisPlanchet_print {w args} {
 985 upvar \#0 $w data
 986 global fgis
 987 array set opt [list\
 988 file "|"\
 989 printer $fgis(printer)\
 990 colormode $fgis(print_colormode)\
 991 fontmap fgis_fontmap]
 992
 993 getopt opt $args
 994 if [uplevel array exist $opt(fontmap)] {
 995     upvar $opt(fontmap) fontmap
 996 } elseif [uplevel #0 array exist $opt(fontmap)] {
 997     upvar $opt(fontmap) fontmap
 998 } else {
 999    return -code error "Array \"$opt(fontmap)\" doesn't exist"
1000 }
1001 if {$data(orient)=="landscape"} {set rotate y} else {set rotate n}
1002 if [catch {if {$opt(file)=="|"} {
1003    exec $fgis(printcmd) -P$opt(printer) << [ $data(cmd) postscript\
1004       -rotate $rotate -colormode $opt(colormode) -fontmap fontmap
1005 } else {
1006   $data(cmd) postscript -rotate $rotate -colormode $opt(colormode)\
1007       -fontmap fontmap -file $opt(file)
1008 } } err ] {
1009   return -code error $err
1010 }
1011 }