1# 2# This file is part of: 3# 4# gpsman --- GPS Manager: a manager for GPS receiver data 5# 6# Copyright (c) 1998-2013 Miguel Filgueiras migfilg@t-online.de 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either version 3 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program. 20# 21# File: map.tcl 22# Last change: 6 October 2013 23# 24# Includes contributions by 25# - Brian Baulch (baulchb _AT_ onthenet.com.au) marked "BSB contribution" 26# - Stefan Heinen (stefan.heinen _AT_ djh-freeweb.de) marked "SH contribution" 27# - David Gardner (djgardner _AT_ users.sourceforge.net) marked "DJG contribution" 28# - Rudolf Martin (rudolf.martin _AT_ gmx.de) marked "RM contribution" 29 30## tags used: 31# waypoints: WP WP=$name forWP=$ix lab=$name sq2 32# possibly: inRT=$RTix inRT=:$number 33# labels of WP: WP WPn forWP=$ix lab=$name txt 34# possibly: inRT=$RTix inRT=:$number 35# symbols of WP: WP WPsy lab=$name syforWP=$ix 36# lines of RSs (RT stages): 37# RT forRT=$ix from=$itWP to=$itWP stno=$number (>=0) line 38# labels of RSs: RT forRT=$ix lab txt 39# trackpoints: TR forTR=$ix inTR=$ix lab=$ix-$number sq2 40# on first point: TRfirst TR=$ix 41# labels of TP: TR forTR=$ix inTR=$ix lab=$ix-$number txt 42# lines in TRs: TR forTR=$ix line 43# first point in LNs: LN forLN=$ix LNfirst LN=$ix sq2 44# lines in LNs: LN forLN=$ix line 45# lines for measuring distance: measure mseg=$number (>0) 46# for animation: 47# - points: sq2 an=$no 48# possibly: lastfor=$no 49# - lines: line an=$no 50# - blinking image: lab an=$no anblink=$no 51# when saving map: temp 52# for RT under definition: mkRT 53# - line from WP to cursor: mkRTfrom mkRTfrline mkRTtrans 54# - point under cursor: mkRTfrom mkRTcursor mkRTtrans 55# - line from cursor to WP (when editing RS): mkRTtoline mkRTtrans 56# - stage: mkRTedge from=$itWP to=$itWP stno=$number line 57# background images in grid: mapimage forIm=$dx,$dy 58# background images not in grid: mapimage forIm=$number 59# when loading background image ($n in {1, 2}): 60# - WP name to place when geo-referencing map: mapfix mapfixname 61# - name of 3rd WP when adjusting map: mapfix mapfixthird 62# - temporary lines when fixing map: mapfix mapfixline=$n 63# - lines when adjusting map: mapadjust mapfixline=$n 64# - temporary points when adjusting map: mapfix mappoint=$n 65# when simplifying/converting TR to RT/TR, with $w a window path, 66# $n a natural number: 67# - lines in converted RT/TR: exp=$w expconv=$w line 68# - turnpoints in converted RT/TR: exp=$w expconv=$w sq2 lab=$n.$n 69# - TR elements: exp=$w expTR=$w (in addition to normal tags) 70## 71 72### map bindings 73# 74# - by event 75# 76# <Key-Up> & scroll up (move map down) slowly 77# <Shift-Up> & scroll NE (move map SW) slowly 78# <Key-Down> & scroll down (move map up) slowly 79# <Shift-Down> & scroll SW (move map NE) slowly 80# <Key-Left> & scroll left (move map right) slowly 81# <Shift-Right> & scroll SE (move map NW) slowly 82# <Shift-Left> & scroll NW (move map SE) slowly 83# <Key-Right> & scroll right (move map left) slowly 84# <Key-Delete> & scroll up (move map down) fast 85# <Key-space> & scroll down (move map up) fast 86# <Return> & create waypoint 87# 88# <Control-Motion> & panning slowly % <---- SH 89# 90# <Button-1> & create waypoint, or 91# & add waypoint to route being edited on map (if any) 92# <Double-1> & open item (if over item) 93# <Control-1> & open waypoint menu (if over waypoint); otherwise 94# & Unix: open route menu if editing it on the map 95# & non-Unix: finish edition of route on map 96# <Shift-1> & delete waypoint from route being edited on map (if any) 97# 98# <B2-Motion> & panning fast 99# <Shift-2> & cancel edition of route on map 100# 101# <Button-3> & stop motion of waypoint (if one moving) 102# & Unix: finish edition of route on map 103# & non-Unix: open waypoint menu (if over waypoint); otherwise 104# & non-Unix: open route menu if editing it on the map 105# <Control-3> & edit previous stage of route being edited on map (if any) 106# <Shift-3> & mark position to measure distance and compute azimuth 107# (not when loading image or editing a route on map) 108# <Control-Shift-3> 109# & edit next stage of route being edited on map (if any) 110# 111# <Button-4> & scroll up (move map down) 112# <Shift-4> & scroll up (move map down) fast 113# <Control-4> & scroll left (move map right) fast 114# <Alt-4> & scroll left (move map right) 115# <Button-5> & scroll down (move map up) 116# <Shift-5> & scroll down (move map up) fast 117# <Control-5> & scroll right (move map left) fast 118# <Alt-5> & scroll right (move map left) 119# 120# - by action 121# 122# scroll up (move map down) slowly & <Key-Up> 123# scroll up (move map down) & <Button-4> 124# scroll up (move map down) fast & <Key-Delete>, <Shift-4> 125# 126# scroll down (move map up) slowly & <Key-Down> 127# scroll down (move map up) & <Button-5> 128# scroll down (move map up) fast & <Key-space>, <Shift-5> 129# 130# scroll left (move map right) slowly & <Key-Left> 131# scroll left (move map right) & <Alt-4> 132# scroll left (move map right) fast & <Control-4> 133# 134# scroll right (move map left) slowly & <Key-Right> 135# scroll right (move map left) & <Alt-5> 136# scroll right (move map left) fast & <Control-5> 137# 138# scroll NE (move map SW) slowly & <Shift-Up> 139# scroll SE (move map NW) slowly & <Shift-Right> 140# scroll SW (move map NE) slowly & <Shift-Down> 141# scroll NW (move map SE) slowly & <Shift-Left> 142# 143# panning slowly & <Control-Motion> 144# panning fast & <B2-Motion> 145# 146# create waypoint & <Button-1>, <Return> 147# 148# stop motion of waypoint (if one moving) & <Button-3> 149# 150# open item (if over item) & <Double-1> 151# 152# measure distance/azimuth & <Shift-3> 153# 154# open waypoint menu (if over waypoint) & Unix: <Control-1> 155# & non-Unix: <Button-3> 156# 157# add waypoint to route being edited on map (if any) & <Button-1> 158# delete waypoint from route being edited on map (if any) & <Shift-1> 159# edit previous stage of route being edited on map (if any) 160# & <Control-3> 161# edit next stage of route being edited on map (if any) 162# & <Control-Shift-3> 163# open route menu if editing it on the map & Unix: <Control-1> 164# & non-Unix: <Button-3> 165# 166# finish edition of route on map & Unix: <Button-3> 167# & non-Unix: <Control-1> 168# cancel edition of route on map & <Shift-2> 169# 170### 171# general bindings are set in proc SetMapBindings 172# other bindings are set in procs: 173# MapCreateWP, PutMapRTWPRS, PutMapTREls 174# changes in scrolling/panning bindings should be reflected in 175# proc MapBackNGPlaceWP 176 177proc SetMapBindings {} { 178 # set cursor and initial bindings for map items and perform other 179 # initializations 180 # a logo or "dummy" text is created for this purpose and then destroyed 181 global Map Logo MAPTYPES MAPW2 MAPH2 UNIX LNSREACT 182 183 $Map configure -cursor crosshair 184 185 if { $UNIX } { 186 bind $Map <Enter> "focus $Map ; MapCursor" 187 bind $Map <Leave> { focus . ; UnMapCursor } 188 } else { 189 # SH contribution: focus when creating but no focus changes when 190 # entering/leaving 191 focus $Map 192 bind $Map <Enter> MapCursor 193 bind $Map <Leave> { UnMapCursor } 194 } 195 196 # changes in scrolling/panning bindings should be reflected in 197 # proc MapBackNGPlaceWP 198 # scrolling in N-S, E-W 199 bind $Map <Key-Up> { ScrollMap y scroll -1 units ; MapCursorUpdate } 200 bind $Map <Key-Delete> { ScrollMap y scroll -1 pages ; MapCursorUpdate } 201 bind $Map <Key-space> { ScrollMap y scroll 1 pages ; MapCursorUpdate } 202 bind $Map <Key-Down> { ScrollMap y scroll 1 units ; MapCursorUpdate } 203 bind $Map <Key-Left> { ScrollMap x scroll -1 units ; MapCursorUpdate } 204 bind $Map <Key-Right> { ScrollMap x scroll 1 units ; MapCursorUpdate } 205 # scrolling in NE-SW, NW-SE 206 bind $Map <Shift-Up> { ScrollMap y scroll -1 units 207 ScrollMap x scroll 1 units ; MapCursorUpdate } 208 bind $Map <Shift-Down> { ScrollMap y scroll 1 units 209 ScrollMap x scroll -1 units ; MapCursorUpdate } 210 bind $Map <Shift-Left> { ScrollMap y scroll -1 units 211 ScrollMap x scroll -1 units ; MapCursorUpdate } 212 bind $Map <Shift-Right> { ScrollMap y scroll 1 units 213 ScrollMap x scroll 1 units ; MapCursorUpdate } 214 # panning 215 # SH contribution: marking during motion and panning with 216 # Control-Motion at a lower speed 217 bind $Map <Motion> {$Map scan mark %x %y; MapCursorMotion %x %y} 218 bind $Map <Control-Motion> "$Map scan dragto %x %y 1; \ 219 SetVisibleOrigin x ; SetVisibleOrigin y ; MapCursorUpdate" 220 221 bind $Map <B2-Motion> "$Map scan dragto %x %y ; SetVisibleOrigin x ; \ 222 SetVisibleOrigin y ; MapCursorUpdate" 223 # BSB contribution: wheelmouse scrolling 224 bind $Map <Button-5> { ScrollMap y scroll 25 units ; MapCursorUpdate } 225 bind $Map <Button-4> { ScrollMap y scroll -25 units ; MapCursorUpdate } 226 bind $Map <Shift-Button-5> { ScrollMap y scroll 1 pages 227 MapCursorUpdate } 228 bind $Map <Shift-Button-4> { ScrollMap y scroll -1 pages 229 MapCursorUpdate } 230 bind $Map <Control-Button-5> { ScrollMap x scroll 1 pages 231 MapCursorUpdate } 232 bind $Map <Control-Button-4> { ScrollMap x scroll -1 pages 233 MapCursorUpdate } 234 bind $Map <Alt-Button-5> { ScrollMap x scroll 25 units 235 MapCursorUpdate } 236 bind $Map <Alt-Button-4> { ScrollMap x scroll -25 units 237 MapCursorUpdate } 238 239 set ts [linsert $MAPTYPES 0 dummy] 240 if { $Logo != "" } { 241 $Map create image $MAPW2 $MAPH2 -image $Logo -anchor center -tags $ts 242 } else { $Map create text 0 0 -tags $ts } 243 foreach m $MAPTYPES { 244 $Map bind $m <Enter> { HighLight } 245 $Map bind $m <Leave> { LowLight } 246 } 247 if { $LNSREACT } { 248 $Map bind LN <Enter> { HighLight } 249 $Map bind LN <Leave> { LowLight } 250 } 251 after 5000 "$Map delete dummy" 252 bind $Map <Button-1> { SafeSingleClick 1 MarkMapPoint %x %y } 253 bind $Map <Double-1> { SafeCompoundClick 1 Ignore ; break } 254 # bindings of mkRTtrans tag that did not work under some window managers 255 # are now set in this way 256 foreach e "Control-1 Shift-1 Shift-2 Button-3 Control-3 Control-Shift-3" { 257 bind $Map <$e> "MapBinding $e %x %y ; break" 258 } 259 bind $Map <Shift-3> { MapMeasure %x %y } 260 # BSB contribution 261 bind $Map <Return> { MarkMapPoint %x %y } 262 return 263} 264 265proc MapBinding {event x y} { 266 # answer to a map event 267 global UNIX MapMakingRT 268 269 switch $event { 270 Control-1 { 271 if { $MapMakingRT } { 272 # SH contribution: roles of B-3 and Control-1 in non-Unix 273 if { $UNIX} { 274 MapRTMenu -1 $x $y 275 } else { MapFinishRT $x $y } 276 } 277 } 278 Shift-1 { 279 if { $MapMakingRT } { MapDelFromRT sel } 280 } 281 Button-3 { 282 if { $MapMakingRT } { 283 # SH contribution: roles of B-3 and Control-1 in non-Unix 284 if { $UNIX} { 285 MapFinishRT $x $y 286 } else { MapRTMenu -1 $x $y } 287 } else { 288 StopMapWPMoving 289 } 290 } 291 Control-3 { 292 if { $MapMakingRT} { MapChangeRTLastRS } 293 } 294 Control-Shift-3 { 295 if { $MapMakingRT} { MapChangeRTNextRS } 296 } 297 Shift-2 { 298 if { $MapMakingRT} { MapCancelRT ask close } 299 } 300 } 301 return 302} 303 304### cursor: marking, moving 305 306proc MarkMapPoint {x y} { 307 # mark point on map if map is not void 308 global Map MapEmpty MapWPMoving MapMakingRT MapScale MapLoading \ 309 MapLoadWPs MapLoadWPNs MapLoadPos MapPFormat MapPFDatum OVx OVy \ 310 CRHAIRx CRHAIRy EdWindow Datum CREATIONDATE 311 312 set xx [expr $OVx+$x-$CRHAIRx] ; set yy [expr $OVy+$y-$CRHAIRy] 313 switch -glob $MapLoading { 314 0 { 315 if { ! $MapEmpty } { 316 if { $MapWPMoving != -1 } { 317 eval MapMoveWP [MapToPosn $xx $yy] 318 return 319 } elseif { $MapMakingRT } { 320 # this was a binding of mkRTtrans tag that 321 # did not work under some window managers 322 MapAddToRT $x $y 323 return 324 } else { 325 # create new WP 326 if { [winfo exists $EdWindow(WP)] } { 327 Raise $EdWindow(WP) ; bell ; return 328 } 329 foreach "latd longd" [MapToPosn $xx $yy] { break } 330 foreach "p pfmt datum" \ 331 [FormatPosition $latd $longd $Datum \ 332 $MapPFormat $MapPFDatum DDD] { break } 333 set opts [list create revert cancel] 334 if { $CREATIONDATE } { 335 GMWPoint -1 $opts \ 336 [FormData WP "PFrmt Posn Datum Date" \ 337 [list $pfmt $p $datum [Now]]] 338 } else { 339 GMWPoint -1 $opts \ 340 [FormData WP "Commt PFrmt Posn Datum" \ 341 [list [DateCommt [Now]] $pfmt $p $datum]] 342 } 343 } 344 } 345 } 346 NoRot=3 { 347 # display first waypoint 348 set MapLoadPos(origin,x) $xx ; set MapLoadPos(origin,y) $yy 349 MapCreateWP $xx $yy [lindex $MapLoadWPs 0] [lindex $MapLoadWPNs 0] 350 # change tags of line segments 351 foreach a "1 2" { 352 set it [$Map find withtag mapfixline=$a] 353 $Map dtag $it mapfix ; $Map addtag mapadjust withtag $it 354 } 355 set dmx $MapLoadPos(dmx,1) ; set dmy $MapLoadPos(dmy,1) 356 if { [set dir $MapLoadPos(dir)] == "x" } { 357 # compute coefficients of line (y=a x+b) 358 set MapLoadPos(a) [expr -1.0*$dmy/$dmx] 359 set MapLoadPos(b) [expr $yy-$MapLoadPos(a)*$xx] 360 } else { 361 # compute coefficients of line (x=a y+b) 362 set MapLoadPos(a) [expr -1.0*$dmx/$dmy] 363 set MapLoadPos(b) [expr $xx-$MapLoadPos(a)*$yy] 364 } 365 set MapLoadPos(bound) $MapLoadPos(origin,$dir) 366 set c dm$dir 367 # Does 2nd point lie to the right (East), or above (North) the 1st 368 # in the terrain? 369 set MapLoadPos(rtab) [expr $MapLoadPos($c,1) > 0] 370 set MapLoading NoRot=end ; set MapScale 1e6 371 MapCursor 372 } 373 NoRot=end { 374 if { $MapLoadPos(scale) > 1e5 } { 375 bell 376 } else { 377 foreach a "1 2" { 378 set ix [lindex $MapLoadWPs $a] 379 $Map delete forWP=$ix syforWP=$ix 380 eval MapCreateWP $MapLoadPos(adj,$a) $ix \ 381 {[lindex $MapLoadWPNs $a]} 382 } 383 set MapScale $MapLoadPos(scale) 384 .wmapload.fr.bns.ok configure -state normal 385 } 386 } 387 Affine*=[1-3] - LeastSquares=* { 388 # type of transformation and number of points to be placed 389 regexp (.*)=(.*) $MapLoading z how n 390 incr n -1 391 set MapLoadPos($n,x) $xx ; set MapLoadPos($n,y) $yy 392 if { [set ix [lindex $MapLoadWPs $n]] == -1 && \ 393 [set ix [DefineCtrlPoint .wmapload $n \ 394 .wmapload.fr.frbx.bx 0]] == -1 } { 395 MapLoadBkCancel 396 return 397 } 398 MapCreateWP $xx $yy [lindex $MapLoadWPs $n] \ 399 [lindex $MapLoadWPNs $n] 400 set MapLoading ${how}=$n 401 $Map delete mapfixname 402 MapCursor 403 if { $n == 0 } { 404 .wmapload.fr.bns.ok configure -state normal 405 } 406 # continuation to either MapLoadBkDialDone or MapLoadBkCancel 407 } 408 } 409 return 410} 411 412proc MapCursor {} { 413 # start following pointer on map if map is not void 414 global Map MapEmpty MapMakingRT MapRTCurrent MapLoading MapLoadWPNs \ 415 MapLoadPos MAPCOLOUR MapEditingRS MapRTNext DEFTRTWIDTH 416 417 switch -glob $MapLoading { 418 Affine*=[1-3] - LeastSquares=* { 419 $Map delete mapfix 420 regsub .*= $MapLoading "" n 421 incr n -1 422 $Map create text 100 100 -fill $MAPCOLOUR(mapsel) -anchor sw \ 423 -text [lindex $MapLoadWPNs $n] -justify left \ 424 -tags [list map mapfix mapfixname] 425 } 426 NoRot=3 { 427 $Map delete mapfix 428 foreach a "1 2" { 429 set ts [list map mapfix mapfixline=$a] 430 eval $Map create line $MapLoadPos(pos,$a) \ 431 -fill $MAPCOLOUR(mapsel) -width 2 -tags {$ts} 432 } 433 $Map create text 100 100 -fill $MAPCOLOUR(mapsel) -anchor sw \ 434 -text [lindex $MapLoadWPNs 0] -justify left \ 435 -tags [list map mapfix mapfixname] 436 } 437 NoRot=end { 438 $Map delete mapfix 439 # create two circles for 2nd and 3rd WPs 440 foreach a "1 2" { 441 $Map create oval 100 100 105 105 -fill $MAPCOLOUR(mapsel) \ 442 -tags [list mapfix mappoint=$a] 443 } 444 $Map create text 100 100 -fill $MAPCOLOUR(mapsel) -anchor sw \ 445 -text [lindex $MapLoadWPNs 2] -justify center \ 446 -tags [list map mapfix mapfixthird] 447 $Map create text 100 100 -fill $MAPCOLOUR(mapsel) -anchor sw \ 448 -text [lindex $MapLoadWPNs 1] -justify left \ 449 -tags [list map mapfix mapfixname] 450 } 451 0 { 452 if { ! $MapEmpty && $MapMakingRT } { 453 if { $MapEditingRS } { 454 set x [lindex $MapRTNext 0] 455 set y [lindex $MapRTNext 1] 456 $Map create line $x $y $x $y -fill $MAPCOLOUR(mkRT) \ 457 -arrow first -smooth 0 -width $DEFTRTWIDTH \ 458 -tags [list mkRT mkRTtoline mkRTtrans] 459 } 460 set x [lindex $MapRTCurrent 0] ; set y [lindex $MapRTCurrent 1] 461 $Map create line $x $y $x $y -fill $MAPCOLOUR(mkRT) \ 462 -arrow first -smooth 0 -width $DEFTRTWIDTH \ 463 -tags [list mkRT mkRTfrom mkRTfrline mkRTtrans] 464 $Map create oval [expr $x-3] [expr $y-3] \ 465 [expr $x+3] [expr $y+3] -fill $MAPCOLOUR(mkRT) \ 466 -tags [list mkRT mkRTfrom mkRTcursor mkRTtrans] 467 } 468 } 469 } 470 return 471} 472 473proc UnMapCursor {} { 474 # stop following pointer on map if map is not void 475 global Map MapEmpty MapMakingRT MapLoading XCoord YCoord CursorPos \ 476 UNIX RealTimeLogAnim 477 478 switch -glob $MapLoading { 479 Affine*=* - NoRot=* - LeastSquares=* { 480 $Map delete mapfix 481 # SH contribution: do not raise .wmapload under non-Unix 482 if { $UNIX && [winfo exists .wmapload] } { Raise .wmapload } 483 } 484 0 { 485 if { ! $MapEmpty } { 486 catch { unset CursorPos } 487 set XCoord "" ; set YCoord "" 488 if { $MapMakingRT } { 489 $Map delete mkRTtrans 490 # SH contribution: do not raise .gmRT under non-Unix 491 if { $UNIX && [winfo exists .gmRT] } { Raise .gmRT } 492 } elseif { $UNIX && $RealTimeLogAnim && \ 493 [winfo exists .simdrive] } { 494 # raise driving simulator window 495 Raise .simdrive 496 } 497 } 498 } 499 } 500 return 501} 502 503proc MapCursorMotion {x y} { 504 # compute coordinates of pointer on map if map is not void 505 global Map MapEmpty MapScale OVx OVy CursorPos MapMakingRT MapRTCurrent \ 506 MapLoading MapLoadPos MapWPMoving CRHAIRx CRHAIRy \ 507 MapEditingRS MapRTNext 508 509 set CursorPos [list $x $y] 510 set xx [expr $OVx+$x-$CRHAIRx] ; set yy [expr $OVy+$y-$CRHAIRy] 511 switch -glob $MapLoading { 512 Affine*=[1-3] - LeastSquares=* { 513 # move name of WP to be placed 514 $Map coords mapfixname $xx $yy 515 } 516 NoRot=3 { 517 # move name of 1st WP and lines to the other two WPs 518 $Map coords mapfixname $xx $yy 519 foreach a "1 2" { 520 $Map coords mapfixline=$a $xx $yy \ 521 [expr $xx+$MapLoadPos(dx,$a)] [expr $yy+$MapLoadPos(dy,$a)] 522 } 523 } 524 NoRot=end { 525 # move names and positions of 2nd and 3rd WPs 526 # move 2nd on its line; then place 3rd according to scale 527 set bound $MapLoadPos(bound) ; set rtab $MapLoadPos(rtab) 528 if { $MapLoadPos(dir) == "x" } { 529 # $rtab!=0 means that segment is to the right of 1st point 530 # assuming vector (0,1) in terrain coordinates to point North 531 if { $rtab } { 532 if { $xx < $bound } { set xx $bound } 533 } elseif { $xx > $bound } { 534 set xx $bound 535 } 536 set yy [expr $MapLoadPos(a)*$xx+$MapLoadPos(b)] 537 } else { 538 # $rtab!=0 means that segment is above the 1st point 539 # assuming vector (0,1) in terrain coordinates to point North 540 # y-coordinates in the canvas grow South! 541 if { $rtab } { 542 if { $yy > $bound } { set yy $bound } 543 } elseif { $yy < $bound } { 544 set yy $bound 545 } 546 set xx [expr $MapLoadPos(a)*$yy+$MapLoadPos(b)] 547 } 548 # move 2nd point 549 $Map coords mappoint=1 [expr $xx-3] [expr $yy-3] \ 550 [expr $xx+3] [expr $yy+3] 551 $Map coords mapfixname $xx [expr $yy-8] 552 # compute scale (m/pixel) 553 set dx0 [expr $xx-$MapLoadPos(origin,x)] 554 set dy0 [expr $yy-$MapLoadPos(origin,y)] 555 if { [set d0 [expr sqrt($dx0*$dx0+$dy0*$dy0)]] < 1e-15 } { 556 set sc 1e6 557 } else { 558 set sc [expr 1.0*$MapLoadPos(dist)/$d0] 559 } 560 # compute coords of 3rd point and move it 561 set x3 [expr $MapLoadPos(origin,x)+1.0*$MapLoadPos(dmx,2)/$sc] 562 set y3 [expr $MapLoadPos(origin,y)-1.0*$MapLoadPos(dmy,2)/$sc] 563 $Map coords mappoint=2 [expr $x3-3] [expr $y3-3] \ 564 [expr $x3+3] [expr $y3+3] 565 $Map coords mapfixthird $x3 [expr $y3-8] 566 MapScaleChange $sc 567 set MapLoadPos(adj,1) [list $xx $yy] 568 set MapLoadPos(adj,2) [list $x3 $y3] 569 set MapLoadPos(scale) $sc 570 } 571 0 { 572 if { ! $MapEmpty } { 573 SetMapCoords $xx $yy 574 if { $MapMakingRT } { 575 set cx [lindex $MapRTCurrent 0] 576 set cy [lindex $MapRTCurrent 1] 577 $Map coords mkRTfrline $xx $yy $cx $cy 578 $Map coords mkRTcursor [expr $xx-2] [expr $yy-2] \ 579 [expr $xx+2] [expr $yy+2] 580 if { $MapEditingRS } { 581 set cx [lindex $MapRTNext 0] 582 set cy [lindex $MapRTNext 1] 583 $Map coords mkRTtoline $cx $cy $xx $yy 584 } 585 } 586 if { $MapWPMoving != -1 } { 587 BalloonMotion $x $y 588 } 589 } 590 } 591 } 592 return 593} 594 595proc MapCursorUpdate {} { 596 # update cursor coordinates after scrolling 597 global CursorPos 598 599 if { ! [catch {set CursorPos}] } { 600 eval MapCursorMotion $CursorPos 601 } 602 return 603} 604 605### measuring 606 607proc MapMeasure {x y} { 608 # measuring a distance along a line on the map 609 # this proc is used both for starting the operation and for adding each 610 # new point 611 # $x,$y are the map coordinates of point 612 global MapEmpty MapLoading MapMakingRT MapMeasure FixedFont \ 613 OVx OVy CRHAIRx CRHAIRy DPOSX DPOSY TXT COLOUR Map 614 615 if { $MapEmpty || $MapMakingRT || $MapLoading != 0 } { return } 616 set xx [expr $OVx+$x-$CRHAIRx] ; set yy [expr $OVy+$y-$CRHAIRy] 617 set pn [MapToPosn $xx $yy] 618 if { $MapMeasure == "" } { 619 # list with total distance, number of segments, followed by 620 # positions and coordinates for each point 621 set MapMeasure [list 0 0 $pn $xx $yy] 622 return 623 } 624 625 # used elsewhere 626 set w .mapmeasure 627 628 if { ! [winfo exists $w] } { 629 GMToplevel $w distazim +[expr $DPOSX+100]+[expr $DPOSY+100] {} \ 630 {WM_DELETE_WINDOW MapMeasureEnd} {} 631 632 frame $w.fr -relief flat -borderwidth 5 -bg $COLOUR(dialbg) 633 label $w.fr.fromto -text $TXT(distazim) 634 frame $w.fr.fr1 -relief flat -borderwidth 0 635 label $w.fr.fr1.dist -width 15 -font $FixedFont -anchor w 636 label $w.fr.fr1.bear -width 15 -font $FixedFont -anchor w 637 frame $w.fr.frsel -relief flat -borderwidth 0 638 button $w.fr.frsel.loop -text $TXT(loop) -command MapMeasureLoop 639 button $w.fr.frsel.back -text $TXT(undo) -command MapMeasureUndo 640 button $w.fr.frsel.cr -text $TXT(crtLN) -command MapMeasureCreateLN 641 button $w.fr.frsel.cnc -text $TXT(cancel) -command MapMeasureEnd 642 643 pack $w.fr -side top 644 pack $w.fr.fr1.dist $w.fr.fr1.bear -side left -padx 5 645 pack $w.fr.frsel.loop $w.fr.frsel.back $w.fr.frsel.cr \ 646 $w.fr.frsel.cnc -side left -padx 5 647 pack $w.fr.fromto $w.fr.fr1 $w.fr.frsel -side top -pady 5 648 } 649 MapMeasureAdd $pn $xx $yy 650 return 651} 652 653proc MapMeasureAdd {posn xx yy} { 654 # add new point to measure line updating the map and the dialog window 655 # unless distance to last point is less than 1 metre 656 global MapMeasure Map Datum DSCALE DTUNIT TXT 657 658 set pp [lindex $MapMeasure end-2] 659 set xxp [lindex $MapMeasure end-1] 660 set yyp [lindex $MapMeasure end] 661 foreach "dist nsegs p1" $MapMeasure { break } 662 if { [set dist [expr $dist+[ComputeDist $pp $posn $Datum]]] < 1e-3 } { 663 bell ; return 664 } 665 lappend MapMeasure $posn $xx $yy 666 set MapMeasure [lreplace $MapMeasure 0 1 $dist [incr nsegs]] 667 set dist [format "%8.3f" [expr $dist*$DSCALE]] 668 set bear [format "%5d" [ComputeBear $p1 $posn $Datum]] 669 $Map create line $xxp $yyp $xx $yy -width 4 -arrow last -fill green \ 670 -tags [list measure mseg=$nsegs] 671 set w .mapmeasure 672 $w.fr.fr1.dist configure -text "$dist $DTUNIT" 673 $w.fr.fr1.bear configure -text "$bear $TXT(degrees)" 674 return 675} 676 677proc MapMeasureCreateLN {} { 678 # create LN from measurement line 679 # there must be at least two points 680 global MapMeasure EdWindow Datum MapPFormat MapPFDatum 681 682 if { [llength $MapMeasure] < 8 } { bell ; return } 683 if { [winfo exists $EdWindow(LN)] } { 684 bell ; Raise $EdWindow(LN) 685 return 686 } 687 set lps "" 688 foreach "p xx yy" [lrange $MapMeasure 2 end] { 689 foreach "latd longd" $p { break } 690 set p [lindex \ 691 [FormatPosition $latd $longd $Datum $MapPFormat $MapPFDatum] 0] 692 lappend lps [FormData LP posn [list $p]] 693 } 694 GMLine -1 {create revert cancel} [FormData LN "Datum PFrmt LPoints" \ 695 [list $MapPFDatum $MapPFormat $lps]] 696 return 697} 698 699proc MapMeasureLoop {} { 700 # add segment from current to first point 701 # there must be at least two points 702 global MapMeasure 703 704 if { [llength $MapMeasure] < 8 } { bell ; return } 705 eval MapMeasureAdd [lrange $MapMeasure 2 4] 706 return 707} 708 709proc MapMeasureUndo {} { 710 # delete last segment of measurement line or finish if there is 711 # only one 712 global Map MapMeasure Datum DSCALE DTUNIT TXT 713 714 foreach "dist nsegs p1" $MapMeasure { break } 715 if { $nsegs < 2 } { 716 MapMeasureEnd 717 return 718 } 719 $Map delete mseg=$nsegs 720 set lp [lindex $MapMeasure end-2] 721 set MapMeasure [lrange $MapMeasure 0 end-3] 722 set pp [lindex $MapMeasure end-2] 723 set dist [expr $dist-[ComputeDist $pp $lp $Datum]] 724 set MapMeasure [lreplace $MapMeasure 0 1 $dist [incr nsegs -1]] 725 set dist [format "%8.3f" [expr $dist*$DSCALE]] 726 set bear [format "%5d" [ComputeBear $p1 $pp $Datum]] 727 set w .mapmeasure 728 $w.fr.fr1.dist configure -text "$dist $DTUNIT" 729 $w.fr.fr1.bear configure -text "$bear $TXT(degrees)" 730 return 731} 732 733proc MapMeasureEnd {} { 734 # finish measuring distances 735 global Map MapMeasure 736 737 set MapMeasure "" 738 $Map delete measure 739 destroy .mapmeasure 740 return 741} 742 743### scrolling and resizing 744 745proc ScrollMapTo {x0 y0 x y} { 746 # scroll map so that point at ($x0,$y0) is shown at ($x,$y), 747 # pixel coordinates relative to canvas origin 748 global Map MapRange 749 750 ScrollMap x moveto [expr [lindex [$Map xview] 0]+($x0-$x)/$MapRange(x)] 751 ScrollMap y moveto [expr [lindex [$Map yview] 0]+($y0-$y)/$MapRange(y)] 752 return 753} 754 755proc ScrollMap {dim args} { 756 # scroll map and set corresponding coordinate of origin of visible region 757 # $dim in {x, y}, $args suitable to {x,y}view command 758 global Map 759 760 eval $Map ${dim}view $args 761 SetVisibleOrigin $dim 762 return 763} 764 765proc SetVisibleOrigin {dim} { 766 # set coordinate of origin of visible region 767 # $dim in {x, y} 768 global Map OV$dim MapRange 769 770 set sc [lindex [$Map ${dim}view] 0] 771 set OV$dim [expr $sc*$MapRange($dim)+$MapRange(${dim}0)] 772 return 773} 774 775proc MapResize {} { 776 global Map MAPW2 MAPH2 MapWidth MapHeight 777 global OVx OVy 778 779 set cx [expr $MAPW2+$OVx] ; set cy [expr $MAPH2+$OVy] 780 set MapWidth [winfo width $Map] ; set MapHeight [winfo height $Map] 781 set MAPW2 [expr $MapWidth/2] ; set MAPH2 [expr $MapHeight/2] 782 SetMapBounds 783 ScrollMapTo $cx $cy [expr $MAPW2+$OVx] [expr $MAPH2+$OVy] 784 return 785} 786 787### highlighting items 788 789proc HighLightWP {ix syit} { 790 # highlight WP representation 791 global Map MAPCOLOUR 792 793 $Map itemconfigure forWP=$ix -fill $MAPCOLOUR(mapsel) 794 return 795} 796 797proc HighLight {} { 798 # highlight mapped item where the pointer is currently on 799 global Map MAPCOLOUR 800 801 set ts [$Map itemcget [set it [$Map find withtag current]] -tags] 802 if { [set i [lsearch -glob $ts {forRT=*}]] != -1 } { 803 set t [lindex $ts $i] 804 $Map itemconfigure $t -fill $MAPCOLOUR(mapsel) 805 regsub forRT= $t "" ix 806 $Map itemconfigure inRT=$ix -fill $MAPCOLOUR(mapsel) 807 return 808 } 809 if { [set i [lsearch -glob $ts {forWP=*}]] != -1 } { 810 regsub forWP= [lindex $ts $i] "" ix 811 set syit [$Map find withtag syforWP=$ix] 812 HighLightWP $ix $syit 813 return 814 } 815 if { [set i [lsearch -glob $ts {syforWP=*}]] != -1 } { 816 regsub syforWP= [lindex $ts $i] "" ix 817 HighLightWP $ix $it 818 return 819 } 820 if { [set i [lsearch -glob $ts {for??=*}]] != -1 } { 821 $Map itemconfigure [lindex $ts $i] -fill $MAPCOLOUR(mapsel) 822 } 823 return 824} 825 826proc LowLight {} { 827 # finish highlighting a mapped item 828 global MAPCOLOUR Map RTColour TRColour LNColour 829 830 set ts [$Map itemcget [$Map find withtag current] -tags] 831 if { [set i [lsearch -glob $ts {forRT=*}]] != -1 } { 832 set t [lindex $ts $i] 833 regsub forRT= $t "" ix 834 if { $ix != -1 } { 835 set c $RTColour($ix) 836 } else { set c $MAPCOLOUR(RT) } 837 $Map itemconfigure $t -fill $c 838 $Map itemconfigure inRT=$ix -fill $MAPCOLOUR(WP) 839 return 840 } 841 if { [set i [lsearch -glob $ts {forWP=*}]] != -1 } { 842 $Map itemconfigure [lindex $ts $i] -fill $MAPCOLOUR(WP) 843 # $Map delete syframe 844 ## this avoids an infinite loop; don't ask me why... 845 # update idletasks 846 return 847 } 848 if { [set i [lsearch -glob $ts {syforWP=*}]] != -1 } { 849 regsub syforWP= [lindex $ts $i] "" ix 850 $Map itemconfigure forWP=$i -fill $MAPCOLOUR(WP) 851 # cannot "$Map delete syframe": infinite loop... 852 return 853 } 854 if { [set i [lsearch -glob $ts {forTR=*}]] != -1 } { 855 set t [lindex $ts $i] 856 regsub forTR= $t "" ix 857 if { $ix != -1 } { 858 set c $TRColour($ix) 859 } else { set c $MAPCOLOUR(TR) } 860 $Map itemconfigure $t -fill $c 861 $Map itemconfigure inTR=$ix -fill $MAPCOLOUR(TP) 862 return 863 } 864 if { [set i [lsearch -glob $ts {forLN=*}]] != -1 } { 865 set t [lindex $ts $i] 866 regsub forLN= $t "" ix 867 if { $ix != -1 } { 868 set c $LNColour($ix) 869 } else { set c $MAPCOLOUR(LN) } 870 $Map itemconfigure $t -fill $c 871 } 872 return 873} 874 875### map bounds 876 877proc SetMapBounds {} { 878 # set map bounds according to mapped items and configure map buttons 879 global Map MapBounds MapEmpty MapRange MapWPMoving MapMakingRT WConf \ 880 MAPW2 MAPH2 MapWidth MapHeight MapTransfTitle PrevCentre 881 882 set MapBounds [$Map bbox all] 883 if { [$Map find all] != "" } { 884 # enlarge bounds so that corners can be scrolled to window centre 885 set mbs "" 886 foreach i "0 1 2 3" d [list $MAPW2 $MAPH2 $MAPW2 $MAPH2] \ 887 s "-1 -1 1 1" { 888 lappend mbs [expr $s*$d+[lindex $MapBounds $i]] 889 } 890 set MapBounds $mbs 891 foreach d "x y" i "0 1" ii "2 3" l [list $MapWidth $MapHeight] { 892 set MapRange($d) \ 893 [expr [lindex $MapBounds $ii]-[lindex $MapBounds $i]] 894 set MapRange(${d}0) [lindex $MapBounds $i] 895 } 896 set st normal 897 $Map configure -scrollregion $MapBounds 898 SetVisibleOrigin x ; SetVisibleOrigin y 899 set PrevCentre [list [lindex [$Map xview] 0] [lindex [$Map yview] 0]] 900 } else { 901 set st disabled 902 set MapEmpty 1 ; set MapTransfTitle "" 903 MapMeasureEnd 904 foreach b $WConf(mapdatum) { $b configure -state normal } 905 set MapRange(x) $MapWidth ; set MapRange(y) $MapHeight 906 set MapRange(x0) 0 ; set MapRange(y0) 0 907 $Map configure -scrollregion [list 0 0 $MapWidth $MapHeight] 908 set MapMakingRT 0 909 StopMapWPMoving 910 } 911 ChangeOnState mapstate $st 912 return 913} 914 915### scale 916 917proc MapScaleToShow {scale} { 918 # compute distance and unit to show for map scale in metre/pixel 919 global DSCALE MAPSCLENGTH DTUNIT SUBDTUNIT SUBDSCALE 920 921 if { [set v [expr $DSCALE*$MAPSCLENGTH*$scale/1000.0]] < 0.999 } { 922 set u $SUBDTUNIT ; set v [expr 1.0*$v/$SUBDSCALE] 923 } else { set u $DTUNIT } 924 return "[format %.2f $v] $u" 925} 926 927proc MapScaleFromDist {d} { 928 # compute scale in metre/pixel from distance shown on map window 929 global DSCALE MAPSCLENGTH 930 931 return [expr $d*1000.0/$DSCALE/$MAPSCLENGTH] 932} 933 934proc MapScaleChange {value} { 935 # show change in map scale 936 # $value is either a scale in metre/pixel when geo-referencing image, 937 # or distance to show on map window 938 global MpW MapLoading DTUNIT SUBDTUNIT SUBDSCALE 939 940 if { $MapLoading != 0 } { 941 if { $value > 1e5 } { 942 $MpW.frm.frmap3.fr3.cv.val configure -text ? 943 update idletasks 944 return 945 } 946 set txt [MapScaleToShow $value] 947 } else { 948 if { $value < 1 } { 949 set u $SUBDTUNIT ; set value [expr 1.0*$value/$SUBDSCALE] 950 if { [expr int($value)] != $value } { 951 set value [format %.2f $value] 952 } 953 } else { set u $DTUNIT } 954 set txt "$value $u" 955 } 956 $MpW.frm.frmap3.fr3.cv.val configure -text $txt 957 update idletasks 958 return 959} 960 961proc FixMapScale {proj} { 962 # compute map scale after a foreign geo-referencing file was used 963 # by evaluating the distance between the inverse projections of 964 # the map center and a point to its right at $MAPSCLENGTH pixels 965 # assume that the MPData array has the map projection parameters and 966 # that the map transformation has been set up 967 # cannot call proc MapToPosn because proc MapProjectionIs has not 968 # been called yet 969 global MapTransf MapScale MAPSCLENGTH MAPW2 MAPH2 MPData MAPPARTPROJ 970 971 foreach n "1 2" xm "$MAPW2 [expr $MAPW2+$MAPSCLENGTH]" { 972 set pt [MapInvert${MapTransf}Transf $xm $MAPH2] 973 if { ! [catch {set mp $MAPPARTPROJ($proj)}] } { 974 set proj $mp 975 } 976 set p$n [eval Proj${proj}Invert MPData $pt] 977 } 978 set MapScale \ 979 [expr 1000.0*[ComputeDist $p1 $p2 $MPData(datum)]/$MAPSCLENGTH] 980 return 981} 982 983proc MapScaleSet {d} { 984 # apply map scale change 985 # $d is number of distance units represented by $MAPSCLENGTH pixels 986 global Map MapScale MAPW2 MAPH2 MapMakingRT MapRTCurrent MapLoading \ 987 MapRange OVx OVy MapTransf MapEmpty MESS MapEditingRS MapRTNext 988 989 if { $MapLoading != 0 } { return } 990 set s [MapScaleFromDist $d] 991 if { $s == $MapScale } { return } 992 if { ! $MapEmpty && ! [MapNewScale${MapTransf}Transf $s] } { 993 GMMessage $MESS(transfcantscale) 994 return 995 } 996 SetCursor . watch 997 MapScaleChange $d 998 set r [expr $MapScale*1.0/$s] 999 set MapScale $s 1000 # pixel coordinates of centre, relative to canvas origin after scaling 1001 set xms [expr $r*($OVx+$MAPW2)] ; set yms [expr $r*($OVy+$MAPH2)] 1002 # scale map items 1003 foreach item [$Map find withtag sq2] { 1004 set cs [$Map coords $item] 1005 # coordinates of the centre of the square 1006 set x0 [expr [lindex $cs 0]+1] ; set y0 [expr [lindex $cs 1]+1] 1007 set dx [expr ($r-1)*$x0] ; set dy [expr ($r-1)*$y0] 1008 set ts [$Map gettags $item] 1009 if { [set i [lsearch -glob $ts {lab=*}]] != -1 } { 1010 set t [lindex $ts $i] 1011 } else { set t $item } 1012 $Map move $t $dx $dy 1013 } 1014 foreach item [$Map find withtag {line||lab}] { 1015 set cs "" 1016 foreach c [$Map coords $item] { 1017 lappend cs [expr $r*$c] 1018 } 1019 eval $Map coords $item $cs 1020 } 1021 if { $MapMakingRT } { 1022 set x [expr $r*[lindex $MapRTCurrent 0]] 1023 set y [expr $r*[lindex $MapRTCurrent 1]] 1024 set MapRTCurrent [list $x $y [lindex $MapRTCurrent 2]] 1025 if { $MapEditingRS } { 1026 set x [expr $r*[lindex $MapRTNext 0]] 1027 set y [expr $r*[lindex $MapRTNext 1]] 1028 set MapRTNext [list $x $y [lindex $MapRTNext 2]] 1029 } 1030 } 1031 # compute new bounds and origin of visible part 1032 SetMapBounds 1033 # scroll old centre (xms,yms) to new centre 1034 ScrollMapTo $xms $yms [expr $OVx+$MAPW2] [expr $OVy+$MAPH2] 1035 ResetCursor . 1036 return 1037} 1038 1039### abstract mapping procedures 1040## conversions between geodetic positions and map coordinates 1041 1042proc MapFromPosn {latd longd datum} { 1043 # compute map coordinates from position 1044 global MapEmpty MapLoading MapScale MapProjPointProc MapProjInitProc \ 1045 MapProjection MapTransf MAPW2 MAPH2 WConf MPData MTData Datum \ 1046 RealTimeLogOn RealTimeLogAnim ASKPROJPARAMS 1047 1048 if { $MapEmpty && ! $MapLoading } { 1049 set MapEmpty 0 1050 catch { unset MPData } ; catch { unset MTData } 1051 foreach b $WConf(mapdatum) { $b configure -state disabled } 1052 # do not ask for parameters confirmation if getting real-time log and 1053 # animating it 1054 set oask $ASKPROJPARAMS 1055 if { $RealTimeLogOn && $RealTimeLogAnim } { 1056 set ASKPROJPARAMS 0 1057 } 1058 set pt [$MapProjInitProc $MapProjection MPData $Datum \ 1059 [list [list $latd $longd $datum]]] 1060 set ASKPROJPARAMS $oask 1061 # default transformation: no rotation 1062 # default initial location on map: $MAPW2 $MAPH2 1063 eval MapInitNoRotTransf $MapScale $pt $MAPW2 $MAPH2 1064 } else { 1065 set pt [$MapProjPointProc MPData $latd $longd $datum] 1066 } 1067 return [eval MapApply${MapTransf}Transf $pt] 1068} 1069 1070proc MapToPosn {xm ym} { 1071 # compute latitude and longitude in projection datum from map coordinates 1072 global MapProjInvertProc MapTransf 1073 1074 set pt [MapInvert${MapTransf}Transf $xm $ym] 1075 return [eval $MapProjInvertProc MPData $pt] 1076} 1077 1078proc SetMapCoords {xm ym} { 1079 # set map cursor coordinates in selected format 1080 global MapProjInvertProc MapTransf MapPFormat MapPFDatum XCoord YCoord \ 1081 MapZone Datum ZGRID POSTYPE 1082 1083 set pt [MapInvert${MapTransf}Transf $xm $ym] 1084 foreach "latd longd" [eval $MapProjInvertProc MPData $pt] { break } 1085 set p [lindex \ 1086 [FormatPosition $latd $longd $Datum $MapPFormat $MapPFDatum] 0] 1087 switch $POSTYPE($MapPFormat) { 1088 latlong - nzgrid - mh { 1089 set MapZone "" 1090 foreach "XCoord YCoord" [lrange $p 2 end] { break } 1091 } 1092 utm { 1093 set XCoord [expr round([lindex $p 4])] 1094 set YCoord [expr round([lindex $p 5])] 1095 set MapZone "[lindex $p 2][lindex $p 3]" 1096 } 1097 grid { 1098 foreach "MapZone XCoord YCoord" [lrange $p 2 end] { break } 1099 } 1100 } 1101 return 1102} 1103 1104### displaying items 1105 1106proc MapCreateWP {x y wpix name} { 1107 # create WP representation on map 1108 # return rectangle item 1109 global Map WPCommt WPSymbol WPDispOpt MAPCOLOUR ICONHEIGHT MapFont UNIX 1110 1111 set its [set it [$Map create rectangle [expr $x-1] [expr $y-1] \ 1112 [expr $x+1] [expr $y+1] -fill $MAPCOLOUR(WP) \ 1113 -outline $MAPCOLOUR(WP) \ 1114 -tags [list WP WP=$name forWP=$wpix lab=$name sq2]]] 1115 switch [set o $WPDispOpt($wpix)] { 1116 name - 1117 s_name { 1118 lappend its [$Map create text $x [expr $y-6-$ICONHEIGHT/2.0] \ 1119 -text $name -fill $MAPCOLOUR(WP) -font $MapFont \ 1120 -justify center \ 1121 -tags [list WP WPn forWP=$wpix lab=$name txt]] 1122 } 1123 comment - 1124 s_comment { 1125 set t $WPCommt($wpix) 1126 lappend its [$Map create text $x [expr $y-6-$ICONHEIGHT/2.0] \ 1127 -text $t -fill $MAPCOLOUR(WP) -font $MapFont \ 1128 -justify center \ 1129 -tags [list WP WPn forWP=$wpix lab=$name txt]] 1130 } 1131 } 1132 if { [string first s $o] == 0 } { 1133 set syim [lindex [SymbolImageName $WPSymbol($wpix)] 0] 1134 lappend its [$Map create image $x $y -anchor center \ 1135 -image $syim -tags [list WP WPsy syforWP=$wpix lab=$name]] 1136 } 1137 # SH contribution: use B-3 in non-Unix systems instead of Control-1 1138 if { $UNIX } { 1139 set event "<Control-1>" 1140 set com "SafeCompoundClick 1 MapWPMenu $wpix" 1141 } else { 1142 set event "<Button-3>" 1143 set com "MapWPMenu $wpix" 1144 } 1145 foreach m $its { 1146 $Map bind $m <Double-1> "SafeCompoundClick 1 OpenItem WP $wpix" 1147 $Map bind $m $event $com 1148 } 1149 return $it 1150} 1151 1152proc PutMapWP {ix} { 1153 # map WP with given index 1154 # return map item for the rectangle 1155 global Datum WPName WPPosn WPDatum WPMBack MapEmpty 1156 1157 if { $MapEmpty && [set mbak $WPMBack($ix)] != "" } { LoadMapBack $mbak } 1158 set p [MapFromPosn [lindex $WPPosn($ix) 0] [lindex $WPPosn($ix) 1] \ 1159 $WPDatum($ix)] 1160 return [MapCreateWP [lindex $p 0] [lindex $p 1] $ix $WPName($ix)] 1161} 1162 1163proc PutMapRT {ix} { 1164 # map RT with given index 1165 # return -1 if RT contains a WP either unknown or being edited, or 1166 # the operation was aborted, otherwise 1 1167 global RTWPoints RTStages RTMBack MapEmpty 1168 1169 if { $MapEmpty && [set mbak $RTMBack($ix)] != "" } { LoadMapBack $mbak } 1170 return [PutMapRTWPRS $ix $RTWPoints($ix) $RTStages($ix) \ 1171 [list RT forRT=$ix] inRT=$ix] 1172} 1173 1174proc PutMapRTWPRS {ix wps rss rttags wptag} { 1175 # map RT having the WPs in $wps, RSs in $rss, adding $rttags to RT 1176 # elements and $wptag (unless void) to WPs 1177 # $ix may be -1, in which case there will be no bindings to open 1178 # the RT 1179 # the colour is taken to be indexed by the head of $rttags 1180 # return -1 if RT contains a WP either unknown or being edited, 1181 # or if operation was aborted, and 1 otherwise 1182 # slow operation dialog only used if $xi!=-1, "mkRT" not in $rttags and 1183 # there are more than 100 WPs 1184 global WPDispl EdWindow GMEd Map MAPCOLOUR MESS TXT DataIndex MapFont \ 1185 RTWidth RTColour DEFTRTWIDTH 1186 1187 if { $ix != -1 && [lindex $wps 100] != "" && \ 1188 [lsearch -exact $rttags mkRT] == -1 } { 1189 set slow 1 1190 set sid [SlowOpWindow $TXT(displ)] 1191 } else { 1192 set slow 0 1193 SetCursor . watch 1194 } 1195 set its "" 1196 foreach wp $wps { 1197 if { $slow && [SlowOpAborted] } { 1198 UnMapRT $ix 1199 SlowOpFinish $sid "" 1200 return -1 1201 } 1202 set wpix [IndexNamed WP $wp] 1203 if { [set it [$Map find withtag WP=$wp]] == "" } { 1204 if { $wpix == -1 } { 1205 set m "$MESS(cantmapRTunkn) $wp" 1206 } elseif { [winfo exists $EdWindow(WP)] && \ 1207 $GMEd(WP,Index) == $wpix } { 1208 set m "$MESS(cantmapRTed): $wp" 1209 } else { set m "" } 1210 if { $m != "" } { 1211 if { $slow } { 1212 SlowOpFinish $sid $m 1213 } else { 1214 GMMessage $m 1215 ResetCursor . 1216 } 1217 return -1 1218 } 1219 set it [PutMapWP $wpix] 1220 set WPDispl($wpix) 1 1221 SetDisplShowWindow WP $wpix select 1222 } 1223 lappend its $it 1224 if { $wptag != "" } { 1225 $Map addtag $wptag withtag forWP=$wpix 1226 } 1227 } 1228 if { $ix != -1 } { 1229 set wdth $RTWidth($ix) ; set colour $RTColour($ix) 1230 } else { 1231 set wdth $DEFTRTWIDTH ; set colour $MAPCOLOUR(RT) 1232 } 1233 if { [lindex $rttags 0] == "mkRT" } { set colour $MAPCOLOUR(mkRT) } 1234 set cs [$Map coords [set it0 [lindex $its 0]]] 1235 # coordinates of the centre of the square 1236 set x0 [expr [lindex $cs 0]+1] ; set y0 [expr [lindex $cs 1]+1] 1237 set ixlab $DataIndex(RSlabel) 1238 set k 0 1239 foreach it [lrange $its 1 end] st $rss { 1240 if { $slow && [SlowOpAborted] } { 1241 UnMapRT $ix 1242 SlowOpFinish $sid "" 1243 return -1 1244 } 1245 if { $it != "" } { 1246 set cs [$Map coords $it] 1247 set x [expr [lindex $cs 0]+1] ; set y [expr [lindex $cs 1]+1] 1248 set ts [concat $rttags [list from=$it0 to=$it stno=$k line]] 1249 set zs [$Map create line $x0 $y0 $x $y -arrow last -smooth 0 \ 1250 -fill $colour -width $wdth -tags $ts] 1251 if { [set sl [lindex $st $ixlab]] != "" } { 1252 set xl [expr ($x0+$x)/2] ; set yl [expr ($y0+$y)/2] 1253 set ts [linsert $rttags end lab txt] 1254 lappend zs [$Map create text $xl $yl \ 1255 -text $sl -fill $colour -font $MapFont \ 1256 -justify center -tags $ts] 1257 } 1258 if { $ix != -1 } { 1259 foreach l $zs { 1260 $Map bind $l <Double-1> \ 1261 "SafeCompoundClick 1 OpenItem RT $ix" 1262 $Map lower $l $it0 1263 } 1264 } else { 1265 foreach l $zs { $Map lower $l $it0 } 1266 } 1267 set x0 $x ; set y0 $y ; set it0 $it 1268 incr k 1269 } 1270 } 1271 if { $slow } { 1272 SlowOpFinish $sid "" 1273 } else { ResetCursor . } 1274 return 1 1275} 1276 1277proc PutMapTREls {ix tps segsts datum tags} { 1278 # map TR elements 1279 # $ix is index of TR or -1; used for tagging 1280 # $tps is list of TR points with given $datum 1281 # $segsts is list of indices (!=0) of TR points starting segments 1282 # $tags is tags to add to all created canvas items (may be void) 1283 # slow operation dialog only used if there are more then 100 TPs 1284 # return -1 if operation was aborted, 1 otherwise 1285 global MAPCOLOUR Map TRName TRWidth TRColour DEFTTRWIDTH TRNUMBERINTVL \ 1286 MapFont TXT TRINFO 1287 1288 if { [lindex $tps 101] != "" } { 1289 set slow 1 1290 set sid [SlowOpWindow $TXT(displ)] 1291 } else { 1292 set slow 0 1293 SetCursor . watch 1294 } 1295 set res 1 1296 set tags1 [linsert $tags 0 TR forTR=$ix inTR=$ix] 1297 set tags2 [linsert $tags 0 TR forTR=$ix line] 1298 set its "" ; set i 1 1299 if { $ix != -1 } { 1300 set name $TRName($ix) ; set wdth $TRWidth($ix) 1301 set colour $TRColour($ix) 1302 } else { 1303 set name "(???)" ; set wdth $DEFTTRWIDTH 1304 set colour $MAPCOLOUR(TR) 1305 } 1306 foreach tp $tps { 1307 if { $slow && [SlowOpAborted] } { 1308 set res -1 ; break 1309 } 1310 set p [MapFromPosn [lindex $tp 0] [lindex $tp 1] $datum] 1311 set x [lindex $p 0] ; set y [lindex $p 1] 1312 set it [$Map create rectangle [expr $x-1] [expr $y-1] \ 1313 [expr $x+1] [expr $y+1] -fill $colour \ 1314 -outline $colour \ 1315 -tags [linsert $tags1 0 lab=$ix-$i sq2]] 1316 if { $i == 1 } { 1317 $Map addtag TRfirst withtag $it 1318 $Map addtag TR=$ix withtag $it 1319 } 1320 $Map bind $it <Double-1> "SafeCompoundClick 1 OpenItem TR $ix" 1321 lappend its $it 1322 if { $TRNUMBERINTVL && $i%$TRNUMBERINTVL == 0 } { 1323 set t [$Map create text $x [expr $y-8] -text $i \ 1324 -fill $colour -font $MapFont -justify center \ 1325 -tags [linsert $tags1 0 lab=$ix-$i txt]] 1326 $Map bind $t <Double-1> "SafeCompoundClick 1 OpenItem TR $ix" 1327 } 1328 switch $TRINFO { 1329 number { 1330 set bbi [list ={$name}:$i] 1331 } 1332 date { 1333 set bbi [list ={$name}:[lindex $tp 4]] 1334 } 1335 } 1336 BalloonBindings "$Map lab=$ix-$i" $bbi 1337 incr i 1338 } 1339 if { $res == 1 && [set rts [lreplace $its 0 0]] != "" } { 1340 set cs [$Map coords [set it0 [lindex $its 0]]] 1341 # coordinates of centre of the square 1342 set x0 [expr [lindex $cs 0]+1] ; set y0 [expr [lindex $cs 1]+1] 1343 set tpn 1 ; set nsst [lindex $segsts 0] 1344 foreach it $rts { 1345 if { $slow && [SlowOpAborted] } { 1346 set res -1 ; break 1347 } 1348 set cs [$Map coords $it] 1349 set x [expr [lindex $cs 0]+1] ; set y [expr [lindex $cs 1]+1] 1350 if { $nsst == $tpn } { 1351 set segsts [lreplace $segsts 0 0] 1352 set nsst [lindex $segsts 0] 1353 } else { 1354 set l [$Map create line $x0 $y0 $x $y -smooth 0 \ 1355 -fill $colour -width $wdth -tags $tags2] 1356 $Map bind $l <Double-1> "SafeCompoundClick 1 OpenItem TR $ix" 1357 $Map lower $l $it0 1358 } 1359 set x0 $x ; set y0 $y 1360 incr tpn 1361 } 1362 } 1363 if { $slow } { 1364 if { $res == -1 } { $Map delete forTR=$ix } 1365 SlowOpFinish $sid "" 1366 } else { ResetCursor . } 1367 return $res 1368} 1369 1370proc PutMapTR {ix} { 1371 # map TR with given index 1372 # return -1 if operation was aborted, 1 otherwise 1373 global TRTPoints TRSegStarts TRDatum TRMBack MapEmpty 1374 1375 if { $MapEmpty && [set mbak $TRMBack($ix)] != "" } { LoadMapBack $mbak } 1376 return [PutMapTREls $ix $TRTPoints($ix) $TRSegStarts($ix) $TRDatum($ix) ""] 1377} 1378 1379proc PutMapLNEls {ix lps segsts datum tags} { 1380 # map LN elements 1381 # $ix is index of LN or -1; used for tagging 1382 # $lps is list of LN points with given $datum 1383 # $segsts is list of indices (!=0) of LN points starting segments 1384 # $tags is tags to add to all created canvas items (may be void) 1385 # slow operation dialog only used if there are more then 100 LPs 1386 # return -1 if operation was aborted, 1 otherwise 1387 global MAPCOLOUR Map LNWidth LNColour DEFTLNWIDTH Datum TXT LNSREACT 1388 1389 if { [lindex $lps 101] != "" } { 1390 set slow 1 1391 set sid [SlowOpWindow $TXT(displ)] 1392 } else { 1393 set slow 0 1394 SetCursor . watch 1395 } 1396 set res 1 1397 if { $ix == -1 } { 1398 set colour $MAPCOLOUR(LN) ; set width $DEFTLNWIDTH 1399 } else { 1400 set colour $LNColour($ix) ; set width $LNWidth($ix) 1401 } 1402 set tgs [linsert $tags 0 LN forLN=$ix LNfirst LN=$ix sq2] 1403 set lp [lindex $lps 0] 1404 foreach "latd longd" [lindex $lp 0] { break } 1405 foreach "x0 y0" [MapFromPosn $latd $longd $datum] {} 1406 set its [$Map create rectangle [expr $x0-1] [expr $y0-1] \ 1407 [expr $x0+1] [expr $y0+1] -fill $colour \ 1408 -outline $colour -tags $tgs] 1409 set tgs [linsert $tags 0 LN forLN=$ix line] 1410 set lpn 1 ; set nsst [lindex $segsts 0] 1411 foreach lp [lreplace $lps 0 0] { 1412 if { $slow && [SlowOpAborted] } { 1413 $Map delete forLN=$ix 1414 set res -1 1415 break 1416 } 1417 foreach "latd longd" [lindex $lp 0] { break } 1418 foreach "x y" [MapFromPosn $latd $longd $datum] {} 1419 if { $nsst == $lpn } { 1420 set segsts [lreplace $segsts 0 0] 1421 set nsst [lindex $segsts 0] 1422 } else { 1423 $Map create line $x0 $y0 $x $y -smooth 0 -fill $colour \ 1424 -width $width -tags $tgs 1425 } 1426 set x0 $x ; set y0 $y 1427 incr lpn 1428 } 1429 if { $res != -1 && $LNSREACT } { 1430 $Map bind forLN=$ix <Double-1> "SafeCompoundClick 1 OpenItem LN $ix" 1431 } 1432 if { $slow } { 1433 SlowOpFinish $sid "" 1434 } else { ResetCursor . } 1435 return $res 1436} 1437 1438proc PutMapLN {ix} { 1439 # map LN with given index 1440 # return -1 if operation was aborted, 1 otherwise 1441 global LNLPoints LNSegStarts LNDatum LNMBack MapEmpty 1442 1443 if { $MapEmpty && [set mbak $LNMBack($ix)] != "" } { LoadMapBack $mbak } 1444 return [PutMapLNEls $ix $LNLPoints($ix) $LNSegStarts($ix) $LNDatum($ix) ""] 1445} 1446 1447proc PutMapGREl {wh ix} { 1448 # map GR element of given kind and index 1449 # return -1 if the element cannot be unmapped/mapped, otherwise 1 1450 global ${wh}Displ 1451 1452 if { [set ${wh}Displ($ix)] } { 1453 if { ! [UnMap $wh $ix] } { return -1 } 1454 } 1455 return [PutMap $wh $ix] 1456} 1457 1458proc PutMapGR {ix} { 1459 # map GR with given index 1460 # use slow operation window explicitly only for WPs if there are more 1461 # than 100 1462 # return -1 if an element cannot be unmapped/mapped, otherwise 1 1463 global GRConts TXT 1464 1465 set res 1 1466 foreach p $GRConts($ix) { 1467 foreach "wh es" $p {} 1468 if { $wh == "LAP" } { continue } 1469 if { $wh == "WP" && [lindex $es 100] != "" } { 1470 set slow 1 1471 set sid [SlowOpWindow $TXT(displ)] 1472 } else { set slow 0 } 1473 foreach e $es { 1474 if { $slow && [SlowOpAborted] } { 1475 SlowOpFinish $sid "" 1476 return -1 1477 } elseif { [set ex [IndexNamed $wh $e]] == -1 || \ 1478 [PutMapGREl $wh $ex] == -1 } { 1479 set res -1 1480 } 1481 } 1482 if { $slow } { SlowOpFinish $sid "" } 1483 } 1484 return $res 1485} 1486 1487proc PutMap {wh ix} { 1488 # put item with index $ix and of type $wh (in $TYPES) on map 1489 # if possible 1490 # set map bounds and change display button in show windows 1491 global Map ${wh}Displ 1492 1493 set r [PutMap$wh $ix] 1494 SetMapBounds 1495 if { $r == -1 } { 1496 set [set wh]Displ($ix) 0 1497 return 0 1498 } 1499 set [set wh]Displ($ix) 1 1500 SetDisplShowWindow $wh $ix select 1501 return 1 1502} 1503 1504proc PutMapAnimPoint {mpos no centre} { 1505 # display point for animation $no at map position given by 1506 # first two elements of $mpos; scroll to centre if $centre 1507 # draw line from previous point if there is one 1508 global Map MAPCOLOUR OVx OVy MAPW2 MAPH2 FRAMEIMAGE DEFTTRWIDTH 1509 1510 set x [lindex $mpos 0] ; set y [lindex $mpos 1] 1511 if { [set itl [$Map find withtag lastfor=$no]] != "" } { 1512 set cs [$Map coords $itl] 1513 set x1 [expr [lindex $cs 0]+1] ; set y1 [expr [lindex $cs 1]+1] 1514 $Map create line $x $y $x1 $y1 -smooth 0 -fill $MAPCOLOUR(anim) \ 1515 -width $DEFTTRWIDTH -tags [list an=$no line] 1516 $Map dtag $itl lastfor=$no 1517 set blit [$Map find withtag anblink=$no] 1518 $Map coords $blit $x $y 1519 } else { 1520 $Map create image $x $y -anchor center \ 1521 -image $FRAMEIMAGE -tags [list lab an=$no anblink=$no] 1522 after 500 "MapBlink anblink=$no 1" 1523 } 1524 set it [$Map create rectangle [expr $x-1] [expr $y-1] [expr $x+1] \ 1525 [expr $y+1] -fill $MAPCOLOUR(anim) -outline $MAPCOLOUR(anim) \ 1526 -tags [list an=$no lastfor=$no sq2]] 1527 SetMapBounds 1528 if { $centre } { 1529 # scroll new point to centre 1530 ScrollMapTo $x $y [expr $OVx+$MAPW2] [expr $OVy+$MAPH2] 1531 } 1532 return 1533} 1534 1535proc MapBlink {tag state} { 1536 # make items with $tag blink on map 1537 # $state toggles between 1 and 0 1538 global Map 1539 1540 set on 0 1541 foreach it [$Map find withtag $tag] { 1542 set on 1 1543 if { $state } { $Map lower $it } else { $Map raise $it } 1544 } 1545 if { $on } { after 500 "MapBlink $tag [expr 1-$state]" } 1546 return 1547} 1548 1549proc UnMapWP {ix} { 1550 # delete WP with index $ix from map 1551 # fails if WP belongs to a mapped RT 1552 global Map WPName MapWPMoving 1553 1554 set it [$Map find withtag WP=$WPName($ix)] ; set ts [$Map gettags $it] 1555 if { [lsearch -glob $ts {inRT=*}] == -1 } { 1556 $Map delete forWP=$ix syforWP=$ix 1557 if { $MapWPMoving == $ix } { StopMapWPMoving } 1558 return 1 1559 } 1560 return 0 1561} 1562 1563proc UnMapRT {ix} { 1564 # delete RT with index $ix from map 1565 global Map 1566 1567 $Map delete forRT=$ix 1568 foreach it [$Map find withtag inRT=$ix] { 1569 $Map dtag $it inRT=$ix 1570 } 1571 return 1 1572} 1573 1574proc UnMapTR {ix} { 1575 # delete TR with index $ix from map 1576 global Map 1577 1578 $Map delete forTR=$ix 1579 return 1 1580} 1581 1582proc UnMapLN {ix} { 1583 # delete LN with index $ix from map 1584 global Map 1585 1586 $Map delete forLN=$ix 1587 return 1 1588} 1589 1590proc UnMapGR {ix} { 1591 # delete from map all items in GR with index $ix or in its subgroups 1592 # unmapping of some items may fail, but others will be unmapped 1593 global GRConts 1594 1595 set r 1 1596 set wps "" 1597 foreach p $GRConts($ix) { 1598 set wh [lindex $p 0] 1599 if { $wh != "WP" } { 1600 if { $wh == "LAP" } { continue } 1601 foreach e [lindex $p 1] { 1602 if { [set eix [IndexNamed $wh $e]]==-1 || ![UnMap $wh $eix] } { 1603 set r 0 1604 } 1605 } 1606 } else { set wps [concat $wps [lindex $p 1]] } 1607 } 1608 foreach wp $wps { 1609 if { [set eix [IndexNamed WP $wp]]==-1 || ![UnMap WP $eix] } { 1610 set r 0 1611 } 1612 } 1613 return $r 1614} 1615 1616proc UnMap {wh ix args} { 1617 # delete item with index $ix and of type $wh (in $TYPES) from map 1618 # $args not used, but needed because of callback in menus 1619 # if possible 1620 global Map ${wh}Displ 1621 1622 if { [set r [UnMap$wh $ix]] } { 1623 set [set wh]Displ($ix) 0 1624 SetDisplShowWindow $wh $ix deselect 1625 } 1626 SetMapBounds 1627 return $r 1628} 1629 1630### moving a WP 1631 1632proc StartMapWPMoving {ix} { 1633 # WP with index $ix is to be placed elsewhere on map 1634 global MapWPMoving MESS WPName 1635 1636 after 5 "BalloonCreate 0 [list =[format $MESS(movingWP) $WPName($ix)]]" 1637 set MapWPMoving $ix 1638 return 1639} 1640 1641proc MapMoveWP {latd longd} { 1642 # place WP at a new position for $Datum 1643 global EdWindow GMEd MapWPMoving MapPFormat WPPosn WPPFrmt WPName WPDatum \ 1644 Datum MapPFDatum 1645 1646 set ix $MapWPMoving 1647 StopMapWPMoving 1648 if { [winfo exists $EdWindow(WP)] && $GMEd(WP,Index) == $ix } { 1649 bell ; Raise $EdWindow(WP) 1650 return 1651 } 1652 set name $WPName($ix) 1653 foreach "posn frmt datum" \ 1654 [FormatPosition $latd $longd $Datum $MapPFormat $MapPFDatum DDD] { 1655 break 1656 } 1657 set WPPosn($ix) $posn ; set WPPFrmt($ix) $frmt 1658 set WPDatum($ix) $datum 1659 MoveOnMap WP $ix $name 0 $name 1660 ChangeWPInRTWindows $name $name 1 1661 UpdateItemWindows WP $ix 1662 return 1663} 1664 1665proc StopMapWPMoving {} { 1666 global MapWPMoving 1667 1668 if { $MapWPMoving != -1 } { destroy .balloon } 1669 set MapWPMoving -1 1670 return 1671} 1672 1673### updating item coordinates 1674 1675proc MoveOnMap {wh ix oldname diffname newname} { 1676 # change mapped item with index $ix 1677 # $wh in $TYPES 1678 # if $diffname is set $oldname is different from $newname 1679 global WPDispOpt Map WPName MapMakingRT MapRTCurrent MapEditingRS MapRTNext 1680 1681 if { $wh != "WP" } { 1682 UnMap $wh $ix ; PutMap $wh $ix 1683 } else { 1684 # change WP 1685 set it [$Map find withtag WP=$oldname] 1686 set ts [$Map gettags $it] 1687 if { [set iz [lsearch -glob $ts {inRT=*}]] == -1 } { 1688 UnMap WP $ix ; PutMap $wh $ix 1689 return 1690 } 1691 $Map delete forWP=$ix syforWP=$ix 1692 PutMap WP $ix 1693 # add inRT=* tags 1694 while { 1 } { 1695 set t [lindex $ts $iz] 1696 regsub inRT= $t "" rx 1697 $Map addtag inRT=$rx withtag forWP=$ix 1698 set ts [lrange $ts [expr $iz+1] end] 1699 if { [set iz [lsearch -glob $ts {inRT=*}]] == -1 } { break } 1700 } 1701 set ni [$Map find withtag WP=$WPName($ix)] 1702 set x [$Map coords $ni] 1703 set y [lindex $x 1] ; set x [lindex $x 0] 1704 if { $MapMakingRT } { 1705 if { [lindex $MapRTCurrent 2]==$it } { 1706 set MapRTCurrent [list $x $y $ni] 1707 } 1708 if { $MapEditingRS && [lindex $MapRTNext 2]==$it } { 1709 set MapRTNext [list $x $y $ni] 1710 } 1711 } 1712 foreach lf [$Map find withtag from=$it] { 1713 $Map dtag $lf from=$it ; $Map addtag from=$ni withtag $lf 1714 set cs [lreplace [$Map coords $lf] 0 1 $x $y] 1715 eval $Map coords $lf $cs 1716 } 1717 foreach lt [$Map find withtag to=$it] { 1718 $Map dtag $lt to=$it ; $Map addtag to=$ni withtag $lt 1719 set cs [lreplace [$Map coords $lt] 2 3 $x $y] 1720 eval $Map coords $lt $cs 1721 } 1722 } 1723 return 1724} 1725 1726### updating WP symbol 1727 1728proc ChangeMapWPSymbol {ix symbol} { 1729 # change symbol of mapped WP if there is one 1730 global Map 1731 1732 if { [set it [$Map find withtag syforWP=$ix]] != -1 } { 1733 foreach "x y" [$Map coords $it] { break } 1734 set ts [$Map gettags $it] 1735 $Map delete $it 1736 set syim [lindex [SymbolImageName $symbol] 0] 1737 $Map create image $x $y -anchor center -image $syim -tags $ts 1738 } 1739 return 1740} 1741 1742### saving and clearing mao 1743 1744proc SaveMap {fmt} { 1745 # save map in graphics file format 1746 # $fmt is either PS, or in $ImgOutFormats (if the Img library is loaded) 1747 global Map OVx OVy MapWidth MapHeight 1748 1749 SaveCanvas $Map [list $OVx $OVy \ 1750 [expr $OVx+$MapWidth] [expr $OVy+$MapHeight]] $fmt file 1751 return 1752} 1753 1754proc PrintMap {} { 1755 # print map to postscript printer 1756 global Map OVx OVy MapWidth MapHeight 1757 1758 SaveCanvas $Map [list $OVx $OVy \ 1759 [expr $OVx+$MapWidth] [expr $OVy+$MapHeight]] PS printer 1760 return 1761} 1762 1763proc ClearMap {} { 1764 # clear map after confirmation 1765 global MESS 1766 1767 if { [GMConfirm $MESS(okclrmap)] } { 1768 DoClearMap 1769 } 1770 return 1771} 1772 1773proc DoClearMap {} { 1774 # delete all map items even if being edited 1775 global MpW Map MapLoading MapScale MapScInitVal MapImageItems \ 1776 MapImageFile WConf XCoord YCoord MapZone \ 1777 EdWindow GMEd TYPES MapMakingRT 1778 1779 if { $MapMakingRT } { MapCancelRT dontask close } 1780 # RTs (if they exist) must be dealt with first 1781 if { [set i [lsearch -exact $TYPES RT]] != -1 } { 1782 set types [linsert [lreplace $TYPES $i $i] 0 RT] 1783 } else { 1784 set types $TYPES 1785 } 1786 foreach wh $types { 1787 if { [winfo exists $EdWindow($wh)] } { 1788 set GMEd($wh,Displ) 0 1789 set GMEd($wh,Data) [lreplace [set GMEd($wh,Data)] end end 0] 1790 $EdWindow($wh).fr.frdw.displayed deselect 1791 } 1792 global ${wh}Displ 1793 foreach n [array names ${wh}Displ] { 1794 set ${wh}Displ($n) 0 1795 } 1796 } 1797 eval $Map delete [$Map find all] 1798 set MapImageItems "" ; catch { unset MapImageFile } 1799 SetMapBounds 1800 set MapLoading 0 1801 StopMapWPMoving 1802 set XCoord "" ; set YCoord "" ; set MapZone "" 1803 $MpW.frm.frmap3.fr3.mn configure -state normal 1804 foreach b $WConf(mapdatum) { $b configure -state normal } 1805 MapScaleChange $MapScInitVal 1806 set MapScale [MapScaleFromDist $MapScInitVal] 1807 ChangeOnState mapstateback disabled 1808 return 1809} 1810 1811### menu for item on map 1812 1813proc MapCreateMenu {wh title} { 1814 # create menu on map for item of type $wh with a dummy entry 1815 # labelled $TXT($title) 1816 # return path of menu 1817 # SH contribution: no need for menubutton as in previous versions 1818 global Map TXT 1819 1820 set mb $Map.m$wh 1821 destroy $mb 1822 menu $mb -tearoff 0 1823 $mb add command -label $TXT($title) -state disabled 1824 $mb add separator 1825 return $mb 1826} 1827 1828proc MapWPMenu {ix} { 1829 # create menubutton and menus to put, on map, items in relation to 1830 # mapped WP with given index, or for starting making a RT from it, or 1831 # for creating a new WP at given distance and bearing 1832 global Map TXT WPName LsW MAXMENUITEMS MapBounds DSCALE EdWindow \ 1833 GMEd UNIX 1834 1835 set wp $WPName($ix) 1836 set mapitem [$Map find withtag WP=$wp] 1837 set cs [$Map coords $mapitem] 1838 set sx [expr [lindex $cs 0]+1] ; set sy [expr [lindex $cs 1]+1] 1839 # SH contribution: no need for menubutton as in previous versions 1840 set menu [MapCreateMenu WP withWP] 1841 1842 if { [winfo exists $EdWindow(WP)] && $GMEd(WP,Index) == $ix } { 1843 set st disabled 1844 } else { set st normal } 1845 $menu add command -label $TXT(move) -state $st \ 1846 -command "StartMapWPMoving $ix" 1847 if { [winfo exists $EdWindow(RT)] } { 1848 set st disabled 1849 } else { set st normal } 1850 $menu add command -label $TXT(startRT) -state $st \ 1851 -command "MapMakeRT $ix $sx $sy" 1852 1853 foreach f "displ clear" tg "d c" { 1854 set mn $menu.$tg 1855 $menu add cascade -label "$TXT($f) ..." -menu $mn 1856 menu $mn -tearoff 0 1857 $mn add cascade -label "$TXT(within) ..." -menu $mn.within 1858 menu $mn.within -tearoff 0 1859 foreach d "1 5 10 20 50 100 200 300 500" { 1860 $mn.within add command -label $d \ 1861 -command "MapWPsWithin $f [expr $d/$DSCALE] $ix" 1862 } 1863 $mn add cascade -label "$TXT(inrect) ..." -menu $mn.rect 1864 set mw $mn.rect 1865 menu $mw -tearoff 0 1866 set n 0 ; set m 0 1867 foreach it [$LsW.frlWP.frl.box get 0 end] { 1868 if { $wp != $it } { 1869 if { $n > $MAXMENUITEMS } { 1870 $mw add cascade -label "$TXT(more) ..." -menu $mw.m$m 1871 set mw $mw.m$m ; menu $mw -tearoff 0 1872 set n 0 ; incr m 1873 } 1874 $mw add command -label $it -command "MapWPsInRect $f $ix $it" 1875 incr n 1876 } 1877 } 1878 $mn add cascade -label "$TXT(nameRT) ..." -menu $mn.rts 1879 menu $mn.rts -tearoff 0 1880 $mn.rts add command -label $TXT(forthisWP) \ 1881 -command "MapRTsFor $ix $f" 1882 $mn.rts add command -label $TXT(formappedWPs) \ 1883 -command "MapRTsForMappedWPs $f" 1884 } 1885 $menu add command -label $TXT(newWPatdb) -command "CreateWPAtDistBear $ix" 1886 # SH contribution: no need for "close menu" entry in non-Unix systems 1887 if { $UNIX } { 1888 $menu add command -label $TXT(closemenu) -command "destroy $menu" 1889 } 1890 eval $menu post [winfo pointerxy .] 1891 return 1892} 1893 1894proc MapRTMenu {ix x y} { 1895 # create menubutton for RT on map or being built on map ($ix==-1) 1896 global TXT OVx OVy MapEditingRS MapEditedRS MapRTLast Map CRHAIRx CRHAIRy \ 1897 UNIX 1898 1899 set xx [expr $OVx+$x-$CRHAIRx] ; set yy [expr $OVy+$y-$CRHAIRy] 1900 foreach it [$Map find overlapping $xx $yy [expr $xx+10] [expr $yy+10]] { 1901 set ts [$Map gettags $it] 1902 if { [set i [lsearch -glob $ts forWP=*]] != -1 } { 1903 regsub forWP= [lindex $ts $i] "" wpix 1904 MapWPMenu $wpix 1905 return 1906 } 1907 } 1908 # SH contribution: no need for menubutton as in previous versions 1909 set menu [MapCreateMenu RT route] 1910 1911 if { $MapEditingRS } { 1912 $menu add command -label $TXT(stop) -command MapFinishRTLastWP 1913 } else { 1914 $menu add cascade -label $TXT(stop) -menu $menu.mnf 1915 menu $menu.mnf -tearoff 0 1916 # SH contribution: exchange roles of B-3 and Control-1 in 1917 # non-Unix systems 1918 if { $UNIX } { 1919 $menu.mnf add command -label $TXT(here) -accelerator "<Button-3>" \ 1920 -command "MapFinishRT $x $y" 1921 } else { 1922 $menu.mnf add command -label $TXT(here) -accelerator "<Ctrl-B1>" \ 1923 -command "MapFinishRT $x $y" 1924 } 1925 $menu.mnf add command -label $TXT(atprevwp) -command MapFinishRTLastWP 1926 } 1927 $menu add command -label $TXT(cancel) -accelerator "<Shift-B2>" \ 1928 -command "MapCancelRT ask close" 1929 if { $MapRTLast != 0 } { 1930 $menu add cascade -label $TXT(del) -menu $menu.mnd 1931 menu $menu.mnd -tearoff 0 1932 $menu.mnd add command -label $TXT(prevwp) -accelerator "<Shift-B1>" \ 1933 -command "MapDelFromRT sel" 1934 if { $MapEditingRS && $MapEditedRS == 0 } { 1935 set st disabled 1936 } else { set st normal } 1937 $menu.mnd add command -label $TXT(firstwp) -state $st \ 1938 -command "MapDelFromRT 0" 1939 } 1940 if { $MapEditingRS } { 1941 if { $MapEditedRS != 0 } { 1942 $menu add command -label $TXT(chglstrs) \ 1943 -accelerator "<Control-B3>" -command MapChangeRTLastRS 1944 } 1945 if { $MapEditedRS != $MapRTLast-1 } { 1946 $menu add command -label $TXT(chgnxtrs) \ 1947 -accelerator "<Ctrl-Shift-B3>" -command MapChangeRTNextRS 1948 } 1949 $menu add command -label $TXT(contnend) -command MapContRTEnd 1950 } elseif { $MapRTLast != 0 } { 1951 $menu add command -label $TXT(chglstrs) -accelerator "<Control-B3>" \ 1952 -command MapChangeRTLastRS 1953 } 1954 # SH contribution: no need for "close menu" entry in non-Unix systems 1955 if { $UNIX } { 1956 $menu add command -label $TXT(closemenu) -command "destroy $menu" 1957 } 1958 eval $menu post [winfo pointerxy .] 1959 return 1960} 1961 1962### editing a RT 1963 1964proc MapEditRT {} { 1965 # start editing on map RT currently in the RT edit window 1966 # this is assumed to be launched from the RT edit window 1967 global Map GMEd RTDispl RTWPoints MapMakingRT MapRTLast MAPCOLOUR MESS 1968 1969 if { $MapMakingRT } { bell ; return } 1970 if { [.gmRT.fr.fr3.fr31.frbx.bxn size] == 0 } { 1971 GMMessage $MESS(needs1wp) 1972 return 1973 } 1974 if { [set rtix $GMEd(RT,Index)] != -1 } { 1975 if { $RTDispl($rtix) } { UnMapRT $rtix } 1976 set wps $RTWPoints($rtix) 1977 } else { 1978 set wps [.gmRT.fr.fr3.fr31.frbx.box get 0 end] 1979 } 1980 if { [PutMapRTWPRS -1 $wps {} {mkRT mkRTedge} {}] == -1 } { return } 1981 set i -1 1982 foreach nwp $wps { 1983 set wpix [IndexNamed WP $nwp] 1984 $Map addtag inRT=:$i withtag forWP=$wpix 1985 incr i 1986 } 1987 set MapMakingRT 1 ; set MapRTLast $i 1988 GMRouteMapEdit 1989 set it [$Map find withtag WP=$nwp] 1990 set cs [$Map coords $it] 1991 MapStartRTEdit $rtix [expr [lindex $cs 0]+1] [expr [lindex $cs 1]+1] $it 1992 return 1993} 1994 1995proc MapMakeRT {wpix x y} { 1996 # start making and mapping a RT for a mapped WP 1997 global Map MapMakingRT MapRTLast EdWindow WPName 1998 1999 if { $MapMakingRT } { bell ; return } 2000 if { [winfo exists $EdWindow(RT)] } { Raise $EdWindow(RT) ; bell ; return } 2001 set MapMakingRT 1 ; set MapRTLast 0 2002 set n $WPName($wpix) 2003 set it [$Map find withtag WP=$n] 2004 $Map addtag inRT=:-1 withtag forWP=$wpix 2005 GMRoute -1 {create cancel} [FormData RT "WPoints Displ" [list [list $n] 1]] 2006 MapStartRTEdit -1 $x $y $it 2007 return 2008} 2009 2010proc MapStartRTEdit {rtix x y wpit} { 2011 # prepare RT to be edited on map 2012 global Map MapRTCurrent MapRTLast MapRTNewWPs MapEditingRS MapEditedRS \ 2013 MAPCOLOUR DEFTRTWIDTH 2014 2015 set MapEditingRS 0 ; set MapEditedRS -1 2016 set MapRTCurrent [list $x $y $wpit] 2017 set MapRTNewWPs "" 2018 GMRouteSelect end 2019 foreach it [$Map find withtag mkRT] { 2020 foreach t [$Map gettags $it] { 2021 if { [regexp {^mkRT} $t] } { $Map dtag $it $t } 2022 } 2023 } 2024 $Map create line $x $y $x $y -fill $MAPCOLOUR(mkRT) -arrow first \ 2025 -smooth 0 -width $DEFTRTWIDTH \ 2026 -tags [list mkRT mkRTfrom mkRTfrline mkRTtrans] 2027 $Map create oval [expr $x-3] [expr $y-3] [expr $x+3] [expr $y+3] \ 2028 -fill $MAPCOLOUR(mkRT) \ 2029 -tags [list mkRT mkRTfrom mkRTcursor mkRTtrans] 2030 # all bindings of mkRTtrans tag are now set on the canvas 2031 return 2032} 2033 2034proc MapFinishRTLastWP {} { 2035 # stop editing RT in the map 2036 global MapMakingRT TXT UNIX 2037 2038 if { $MapMakingRT } { 2039 MapDestroyRT 2040 GMRouteMapEditEnd 2041 } 2042 if { ! $UNIX } { 2043 # SH contribution 2044 focus .gmRT 2045 } 2046 return 2047} 2048 2049proc MapFinishRT {x y} { 2050 global MapMakingRT TXT UNIX 2051 2052 if { $MapMakingRT } { 2053 MapAddToRT $x $y 2054 MapFinishRTLastWP 2055 } 2056 if { ! $UNIX } { 2057 # SH contribution 2058 focus .gmRT 2059 } 2060 return 2061} 2062 2063proc MapAddToRT {x y} { 2064 global Map MapMakingRT MapRTCurrent MapRTLast MapRTNewWPs OVx OVy WPName \ 2065 CRHAIRx CRHAIRy MAPCOLOUR MapPFormat MapPFDatum CREATIONDATE \ 2066 Datum MapEditingRS MapRTNext MapEditedRS MapWPMoving GMEd \ 2067 DEFTRTWIDTH 2068 2069 if { ! $MapMakingRT || $MapWPMoving != -1 } { return } 2070 set xx [expr $OVx+$x-$CRHAIRx] ; set yy [expr $OVy+$y-$CRHAIRx] 2071 set its [$Map find overlapping [expr $xx-3] [expr $yy-3] \ 2072 [expr $xx+3] [expr $yy+3]] 2073 set ix -1 2074 foreach it $its { 2075 set ts [$Map gettags $it] 2076 if { [set i [lsearch -glob $ts {*forWP=*}]] != -1 } { 2077 set t [lindex $ts $i] 2078 regsub .*forWP= $t "" ix 2079 set name $WPName($ix) 2080 # cannot repeat last WP 2081 if { $name == [.gmRT.fr.fr3.fr31.frbx.box get end] } { 2082 bell ; return 2083 } 2084 break 2085 } 2086 } 2087 if { $ix == -1 } { 2088 # create new WP at $xx,$yy 2089 foreach "latd longd" [MapToPosn $xx $yy] { break } 2090 foreach "p pfmt datum" \ 2091 [FormatPosition $latd $longd $Datum $MapPFormat $MapPFDatum DDD] { 2092 break 2093 } 2094 set name [NewName WP] 2095 if { $CREATIONDATE } { 2096 set data [FormData WP "Name PFrmt Posn Datum Date" \ 2097 [list $name $pfmt $p $datum [Now]]] 2098 } else { 2099 set data [FormData WP "Name Commt PFrmt Posn Datum" \ 2100 [list $name [DateCommt [Now]] $pfmt $p $datum]] 2101 } 2102 set ix [CreateItem WP $data] 2103 PutMap WP $ix 2104 lappend MapRTNewWPs $name 2105 } 2106 set maprttag (mkRTedge||forRT=$GMEd(RT,Index)) 2107 if { $MapEditingRS } { 2108 # start and end points of the new stage 2109 set fromit [$Map find withtag WP=$name] 2110 set toit [lindex $MapRTNext 2] 2111 # change previous stage to end at $xx,$yy 2112 set oldst stno=$MapEditedRS 2113 set oldit [$Map find withtag $oldst&&$maprttag] 2114 set cs [$Map coords $oldit] 2115 $Map coords $oldit [lreplace $cs 2 3 $xx $yy] 2116 $Map itemconfigure $oldit -fill $MAPCOLOUR(mkRT) 2117 $Map dtag $oldit to=$toit ; $Map addtag to=$fromit withtag $oldit 2118 set stno [lindex $MapEditedRS 0] 2119 # renumber RT items after this RS 2120 set nxt [expr $MapEditedRS+1] 2121 for { set n $MapRTLast } { $n > $nxt } { set n $i } { 2122 set i [expr $n-1] 2123 foreach it [$Map find withtag (stno=$i)&&$maprttag] { 2124 $Map dtag $it stno=$i ; $Map addtag stno=$n withtag $it 2125 } 2126 foreach it [$Map find withtag inRT=:$i] { 2127 $Map dtag $it inRT=:$i ; $Map addtag inRT=:$n withtag $it 2128 } 2129 } 2130 # old end point of stage 2131 foreach it [$Map find withtag inRT=:$MapEditedRS] { 2132 $Map dtag $it inRT=:$MapEditedRS 2133 $Map addtag inRT=:$nxt withtag $it 2134 } 2135 $Map addtag inRT=:$MapEditedRS withtag forWP=$ix 2136 # create a new stage from the new point to the old end point 2137 set cs [$Map coords $fromit] 2138 set xx [expr [lindex $cs 0]+1] ; set yy [expr [lindex $cs 1]+1] 2139 set is [$Map create line $xx $yy \ 2140 [lindex $MapRTNext 0] [lindex $MapRTNext 1] \ 2141 -fill $MAPCOLOUR(mapsel) -arrow last -smooth 0 \ 2142 -width $DEFTRTWIDTH -tags [list \ 2143 mkRT mkRTedge from=$fromit to=$toit stno=$nxt line]] 2144 set MapEditedRS $nxt 2145 set sel $nxt 2146 set MapRTCurrent [list $xx $yy $fromit] 2147 $Map coords mkRTfrom $xx $yy $xx $yy 2148 } else { 2149 $Map addtag inRT=:$MapRTLast withtag forWP=$ix 2150 set toit [$Map find withtag WP=$name] 2151 set cs [$Map coords $toit] 2152 set xx [expr [lindex $cs 0]+1] ; set yy [expr [lindex $cs 1]+1] 2153 $Map coords mkRTfrom $xx $yy $xx $yy 2154 set oldit [lindex $MapRTCurrent 2] 2155 set is [$Map create line [lindex $MapRTCurrent 0] \ 2156 [lindex $MapRTCurrent 1] $xx $yy \ 2157 -fill $MAPCOLOUR(mkRT) -arrow last -smooth 0 \ 2158 -width $DEFTRTWIDTH -tags [list \ 2159 mkRT mkRTedge to=$toit from=$oldit stno=$MapRTLast line]] 2160 set MapRTCurrent [list $xx $yy $toit] 2161 set sel end 2162 } 2163 GMRTChange insa $name 2164 GMRouteSelect $sel 2165 incr MapRTLast 2166 .gmRT.fr.fr3.frbt.del configure -state normal 2167 return 2168} 2169 2170proc MapDelFromRT {which} { 2171 # delete WP from RT being built on map but fail if there is 2172 # only one 2173 # $which is either 0 (for 1st WP) or "sel" (for previous one) 2174 # GMRTChange will call MapDelRT1st or MapDelRTPrevious on success 2175 global MapMakingRT MapRTLast 2176 2177 if { $MapMakingRT } { 2178 if { $MapRTLast == 0 } { bell ; return } 2179 GMRTChange del $which 2180 } 2181 return 2182} 2183 2184proc MapDelRT1st {delwp} { 2185 # update map by deleting first WP on RT under construction on map 2186 global Map MapRTLast MapRTNewWPs MapEditedRS MapEditingRS GMEd 2187 2188 if { $MapEditingRS } { 2189 if { $MapEditedRS == 0 } { 2190 if { $MapRTLast == 1 } { 2191 MapContRTEnd 2192 } else { 2193 MapChangeRTNextRS 2194 } 2195 } else { 2196 incr MapEditedRS -1 2197 } 2198 } 2199 set maprttag (mkRTedge||forRT=$GMEd(RT,index)) 2200 # zero or one items will have this tag 2201 foreach it [$Map find withtag (stno=0)&&$maprttag] { 2202 $Map delete $it 2203 } 2204 foreach it [$Map find withtag inRT=:-1] { 2205 $Map dtag $it inRT=:-1 2206 } 2207 if { [set i [lsearch -exact $MapRTNewWPs $delwp]] != -1 && \ 2208 [lsearch -exact [.gmRT.fr.fr3.fr31.frbx.box get 0 end] $delwp] == \ 2209 -1 } { 2210 set MapRTNewWPs [lreplace $MapRTNewWPs $i $i] 2211 Forget WP [IndexNamed WP $delwp] 2212 } 2213 incr MapRTLast -1 2214 # renumber items 2215 set i -1 2216 while { $i < $MapRTLast } { 2217 set nxt [expr $i+1] 2218 foreach it [$Map find withtag (stno=$nxt)&&$maprttag] { 2219 $Map dtag $it stno=$nxt ; $Map addtag stno=$i withtag $it 2220 } 2221 foreach it [$Map find withtag inRT=:$nxt] { 2222 $Map dtag $it inRT=:$nxt ; $Map addtag inRT=:$i withtag $it 2223 } 2224 set i $nxt 2225 } 2226 return 2227} 2228 2229proc MapDelRTPrevious {prevwp delwp} { 2230 # update map by deleting previous WP on RT under construction on map 2231 # $delwp is name of deleted WP 2232 # $prevwp is name of WP preceding $delwp 2233 global Map MapRTLast MapRTCurrent MapRTNewWPs MapEditingRS MapEditedRS \ 2234 MapRTNext GMEd MAPCOLOUR DEFTRTWIDTH 2235 2236 set maprttag (mkRTedge||forRT=$GMEd(RT,index)) 2237 if { $MapEditingRS } { 2238 if { $MapEditedRS == 0 } { 2239 MapDelRT1st $delwp 2240 return 2241 } 2242 # zero or one items will have this tag 2243 foreach it [$Map find withtag (stno=$MapEditedRS)&&$maprttag] { 2244 $Map delete $it 2245 } 2246 incr MapEditedRS -1 2247 set sel [set stno $MapEditedRS] 2248 } else { 2249 set stno [expr $MapRTLast-1] 2250 set sel end 2251 } 2252 incr MapRTLast -1 2253 set cit [$Map find withtag WP=$prevwp] 2254 set cs [$Map coords $cit] 2255 set xx [expr [lindex $cs 0]+1] ; set yy [expr [lindex $cs 1]+1] 2256 $Map coords mkRTfrom $xx $yy $xx $yy 2257 set MapRTCurrent [list $xx $yy $cit] 2258 # zero or one items will have this tag 2259 foreach it [$Map find withtag (stno=$stno)&&$maprttag] { 2260 $Map delete $it 2261 } 2262 foreach it [$Map find withtag inRT=:$stno] { 2263 $Map dtag $it inRT=:$stno 2264 } 2265 if { [set i [lsearch -exact $MapRTNewWPs $delwp]] != -1 && \ 2266 [lsearch -exact [.gmRT.fr.fr3.fr31.frbx.box get 0 end] $delwp] == \ 2267 -1 } { 2268 set MapRTNewWPs [lreplace $MapRTNewWPs $i $i] 2269 Forget WP [IndexNamed WP $delwp] 2270 } 2271 # renumber items 2272 set i $stno 2273 while { $i < $MapRTLast } { 2274 set nxt [expr $i+1] 2275 foreach it [$Map find withtag (stno=$nxt)&&$maprttag] { 2276 $Map dtag $it stno=$nxt ; $Map addtag stno=$i withtag $it 2277 } 2278 foreach it [$Map find withtag inRT=:$nxt] { 2279 $Map dtag $it inRT=:$nxt ; $Map addtag inRT=:$i withtag $it 2280 } 2281 set i $nxt 2282 } 2283 if { $MapEditingRS } { 2284 GMRouteSelect $MapEditedRS 2285 # create RS 2286 set toit [lindex $MapRTNext 2] 2287 set is [$Map create line $xx $yy \ 2288 [lindex $MapRTNext 0] [lindex $MapRTNext 1] \ 2289 -fill $MAPCOLOUR(mapsel) -arrow last -smooth 0 \ 2290 -width $DEFTRTWIDTH -tags [list mkRT mkRTedge to=$toit \ 2291 from=$cit stno=$MapEditedRS line]] 2292 } else { 2293 GMRouteSelect $MapRTLast 2294 } 2295 return 2296} 2297 2298proc MapCancelRT {ask close} { 2299 # cancel construction of RT on map 2300 # $ask is "ask" if cancellation must be confirmed when defining a new RT 2301 # $close is "close" if RT window must be closed 2302 global MapMakingRT MapRTNewWPs MESS TXT GMEd 2303 2304 if { $MapMakingRT && \ 2305 ( $GMEd(RT,Index) != -1 || $ask != "ask" || \ 2306 [GMConfirm [format $MESS(askforget) $TXT(nameRT)]] ) } { 2307 MapDestroyRT 2308 foreach wp $MapRTNewWPs { 2309 Forget WP [IndexNamed WP $wp] 2310 } 2311 if { $close == "close" } { GMButton RT cancel } 2312 } 2313 return 2314} 2315 2316proc MapDestroyRT {} { 2317 # destroy RT being made on map but display the original RT if it 2318 # was already there 2319 global Map MapMakingRT MapRTLast GMEd RTDispl 2320 2321 set MapMakingRT 0 2322 $Map delete mkRT 2323 while { $MapRTLast >= 0 } { 2324 incr MapRTLast -1 2325 foreach it [$Map find withtag inRT=:$MapRTLast] { 2326 $Map dtag $it inRT=:$MapRTLast 2327 } 2328 } 2329 if { [set ix $GMEd(RT,Index)] != -1 && $RTDispl($ix) } { PutMapRT $ix } 2330 return 2331} 2332 2333proc MapChangeRTLastRS {} { 2334 # open previous RS for editing when creating RT on map 2335 global MapMakingRT MapEditingRS MapEditedRS Map MapRTLast GMEd \ 2336 MAPCOLOUR 2337 2338 if { ! $MapMakingRT } { return } 2339 set maprttag (mkRTedge||forRT=$GMEd(RT,index)) 2340 if { $MapEditingRS } { 2341 if { $MapEditedRS == 0 } { bell ; return } 2342 # restore stage being edited 2343 $Map itemconfigure (stno=$MapEditedRS)&&$maprttag -fill $MAPCOLOUR(mkRT) 2344 # open stage before this one 2345 set n [expr $MapEditedRS-1] 2346 } else { set n [expr $MapRTLast-1] } 2347 # RM contribution: must have the "mkRT" tag otherwise finds stages of 2348 # all routes on map 2349 # changed by MF: may have "forRT=$ix" instead 2350 if { [set is [$Map find withtag (stno=$n)&&$maprttag]] == {} } { 2351 bell ; return 2352 } 2353 set ts [$Map gettags $is] 2354 set tx [lsearch -glob $ts to=*] 2355 set fx [lsearch -glob $ts from=*] 2356 if { $tx == -1 || $fx == -1 } { BUG "bad tags on stage" } 2357 regsub to= [lindex $ts $tx] "" toit 2358 regsub from= [lindex $ts $fx] "" fromit 2359 MapOpenStage -1 $n $is $fromit $toit 2360 return 2361} 2362 2363proc MapChangeRTNextRS {} { 2364 # open next RS for editing when creating RT on map 2365 global MapMakingRT MapEditingRS MapEditedRS Map MapRTLast GMEd \ 2366 MAPCOLOUR 2367 2368 if { ! $MapMakingRT || ! $MapEditingRS } { return } 2369 if { $MapEditedRS == $MapRTLast-1 } { 2370 MapContRTEnd 2371 return 2372 } 2373 # restore stage being edited 2374 $Map itemconfigure stno=$MapEditedRS -fill $MAPCOLOUR(mkRT) 2375 # open stage after this one 2376 set n [expr $MapEditedRS+1] 2377 # RM contribution: must have the "mkRT" tag otherwise finds stages of 2378 # all routes on map 2379 # changed by MF: may have "forRT=$ix" instead 2380 set maprttag (mkRTedge||forRT=$GMEd(RT,index)) 2381 if { [set is [$Map find withtag (stno=$n)&&$maprttag]] == {} } { 2382 bell ; return 2383 } 2384 set ts [$Map gettags $is] 2385 set tx [lsearch -glob $ts to=*] 2386 set fx [lsearch -glob $ts from=*] 2387 if { $tx == -1 || $fx == -1 } { BUG "bad tags on stage" } 2388 regsub to= [lindex $ts $tx] "" toit 2389 regsub from= [lindex $ts $fx] "" fromit 2390 MapOpenStage -1 $n $is $fromit $toit 2391 return 2392} 2393 2394proc MapContRTEnd {} { 2395 # finish editing RSs and continue at the end of RT being created on map 2396 global MapMakingRT MapEditingRS Map MapRTLast MapRTCurrent MapEditedRS \ 2397 GMEd MAPCOLOUR DEFTRTWIDTH 2398 2399 if { ! $MapMakingRT || ! $MapEditingRS } { return } 2400 set maprttag (mkRTedge||forRT=$GMEd(RT,index)) 2401 $Map itemconfigure (stno=$MapEditedRS)&&$maprttag -fill $MAPCOLOUR(mkRT) 2402 set n [expr $MapRTLast-1] 2403 if { [set wpit [$Map find withtag sq2&&inRT=:$n]] == "" } { 2404 BUG "no item for WP at end" 2405 } 2406 set cs [$Map coords $wpit] 2407 set x [expr [lindex $cs 0]+1] ; set y [expr [lindex $cs 1]+1] 2408 set MapRTCurrent [list $x $y $wpit] 2409 set MapEditingRS 0 2410 GMRouteSelect end 2411 $Map delete mkRTtrans 2412 $Map create line $x $y $x $y -fill $MAPCOLOUR(mkRT) -arrow first \ 2413 -smooth 0 -width $DEFTRTWIDTH \ 2414 -tags [list mkRT mkRTfrom mkRTfrline mkRTtrans] 2415 $Map create oval [expr $x-3] [expr $y-3] [expr $x+3] [expr $y+3] \ 2416 -fill $MAPCOLOUR(mkRT) \ 2417 -tags [list mkRT mkRTfrom mkRTcursor mkRTtrans] 2418 return 2419} 2420 2421## editing RT stage 2422 2423proc MapOpenStage {ix stno it fromit toit} { 2424 # open RT stage for editing on map 2425 # $ix is RT index, -1 if RT is being built on map 2426 # $stno is stage number (from 0) 2427 # $it is map item of line representing the stage 2428 # $fromit, $toit are the map items for the start and end WPs 2429 global MapMakingRT MapEditingRS Map MapRTCurrent MapRTNext MapEditedRS \ 2430 MAPCOLOUR DEFTRTWIDTH 2431 2432 if { $ix != -1 } { 2433 GMMessage "not yet" ; return 2434 } 2435 if { ! $MapMakingRT } { return } 2436 set MapEditedRS $stno 2437 GMRouteSelect $stno 2438 $Map itemconfigure $it -fill $MAPCOLOUR(mapsel) 2439 set cs [$Map coords $fromit] 2440 set xx [expr [lindex $cs 0]+1] ; set yy [expr [lindex $cs 1]+1] 2441 set MapRTCurrent [list $xx $yy $fromit] 2442 set cs [$Map coords $toit] 2443 set xx [expr [lindex $cs 0]+1] ; set yy [expr [lindex $cs 1]+1] 2444 set MapRTNext [list $xx $yy $toit] 2445 $Map create line $xx $yy $xx $yy -fill $MAPCOLOUR(mkRT) \ 2446 -arrow first -smooth 0 -width $DEFTRTWIDTH \ 2447 -tags [list mkRT mkRTtoline mkRTtrans] 2448 set MapEditingRS 1 2449 return 2450} 2451 2452### displaying or clearing sets of items 2453 2454proc MapWPsWithin {how d ix} { 2455 # map or clear all WPs with distance $d of WP with index $ix 2456 # $how in {displ, clear} 2457 # when clearing the given WP will not be cleared 2458 # slow operation dialog used if there are more than 100 WPs 2459 global WPName WPPosn WPDatum WPDispl EdWindow GMEd TXT 2460 2461 set wpixs [array names WPName] 2462 if { [lindex $wpixs 100] != "" } { 2463 set slow 1 2464 set sid [SlowOpWindow $TXT(displ)] 2465 } else { 2466 set slow 0 2467 SetCursor . watch 2468 } 2469 if { [winfo exists $EdWindow(WP)] } { 2470 set edix $GMEd(WP,Index) 2471 } else { set edix -1 } 2472 set displ [string compare $how clear] 2473 set p1 $WPPosn($ix) ; set d1 $WPDatum($ix) 2474 SetDatumData $d1 2475 foreach ix2 $wpixs { 2476 if { $slow && [SlowOpAborted] } { break } 2477 if { $ix2 != $ix && (($displ && ! $WPDispl($ix2)) || \ 2478 (! $displ && $WPDispl($ix2))) } { 2479 set p2 $WPPosn($ix2) ; set d2 $WPDatum($ix2) 2480 if { $d1 != $d2 } { 2481 set p2 [ToDatum [lindex $p2 0] [lindex $p2 1] $d2 $d1] 2482 } 2483 if { $d >= [lindex [ComputeDistFD $p1 $p2] 0] } { 2484 MapOrClear WP $displ $ix2 $edix 2485 } 2486 } 2487 } 2488 SetMapBounds 2489 if { $slow } { 2490 SlowOpFinish $sid "" 2491 } else { ResetCursor . } 2492 return 2493} 2494 2495proc MapWPsInRect {how ix1 wp2} { 2496 # map or clear all WPs in the rectangle defined by the WPs with index $ix1 2497 # and name $wp2 2498 # $how in {displ, clear} 2499 # when clearing the WP with index $ix1 will not be cleared 2500 # slow operation dialog used if there are more than 100 WPs 2501 global WPName WPPosn WPDatum WPDispl EdWindow GMEd 2502 2503 set wpixs [array names WPName] 2504 if { [lindex $wpixs 100] != "" } { 2505 set slow 1 2506 set sid [SlowOpWindow $TXT(displ)] 2507 } else { 2508 set slow 0 2509 SetCursor . watch 2510 } 2511 if { [winfo exists $EdWindow(WP)] } { 2512 set edix $GMEd(WP,Index) 2513 } else { set edix -1 } 2514 set displ [string compare $how clear] 2515 set p1 $WPPosn($ix1) ; set d1 $WPDatum($ix1) 2516 SetDatumData $d1 2517 set ix2 [IndexNamed WP $wp2] 2518 set p2 $WPPosn($ix2) ; set d2 $WPDatum($ix2) 2519 if { $d1 != $d2 } { 2520 set p2 [ToDatum [lindex $p2 0] [lindex $p2 1] $d2 $d1] 2521 } 2522 set la1 [lindex $p1 0] ; set lo1 [lindex $p1 1] 2523 set la2 [lindex $p2 0] ; set lo2 [lindex $p2 1] 2524 if { $la1 >= $la2 } { 2525 set lamx $la1 ; set lamn $la2 2526 } else { set lamx $la2 ; set lamn $la1 } 2527 if { $lo1 >= $lo2 } { 2528 set lomx $lo1 ; set lomn $lo2 2529 } else { set lomx $lo2 ; set lomn $lo1 } 2530 foreach ixn $wpixs { 2531 if { $slow && [SlowOpAborted] } { break } 2532 if { $ixn != $ix1 && (($displ && ! $WPDispl($ixn)) || \ 2533 (! $displ && $WPDispl($ixn))) } { 2534 set pn $WPPosn($ixn) ; set dn $WPDatum($ixn) 2535 if { $d1 != $dn } { 2536 set pn [ToDatum [lindex $pn 0] [lindex $pn 1] $dn $d1] 2537 } 2538 set lan [lindex $pn 0] 2539 if { $lamx>=$lan && $lan>=$lamn } { 2540 set lon [lindex $pn 1] 2541 if { $lomx>=$lon && $lon>=$lomn } { 2542 MapOrClear WP $displ $ixn $edix 2543 } 2544 } 2545 } 2546 } 2547 SetMapBounds 2548 if { $slow } { 2549 SlowOpFinish $sid "" 2550 } else { ResetCursor . } 2551 return 2552} 2553 2554proc MapRTsFor {ix how} { 2555 # map or clear all RTs that contain the WP with index $ix 2556 # $how in {displ, clear} 2557 global WPRoute RTDispl EdWindow GMEd 2558 2559 set displ [string compare $how clear] 2560 if { [winfo exists $EdWindow(RT)] } { 2561 set edix $GMEd(RT,Index) 2562 } else { set edix -1 } 2563 foreach rt $WPRoute($ix) { 2564 MapOrClear RT $displ [IndexNamed RT $rt] $edix 2565 } 2566 return 2567} 2568 2569proc MapRTsForMappedWPs {how} { 2570 # map or clear all RTs for all mapped WPs 2571 # $how in {displ, clear} 2572 global WPName WPDispl 2573 2574 foreach ix [array names WPName] { 2575 if { $WPDispl($ix) } { 2576 MapRTsFor $ix $how 2577 } 2578 } 2579 return 2580} 2581 2582proc MapOrClear {wh displ ix edix} { 2583 # map or clear an item of type $wh in {WP, RT} with index $ix 2584 # $displ is set if item is to be displayed 2585 # $edix is the index of item being edited 2586 global GMEd ${wh}Displ EdWindow 2587 2588 if { $ix == $edix } { 2589 if { $displ } { 2590 if { ! $GMEd($wh,Displ) } { 2591 PutMap$wh $ix 2592 set $GMEd($wh,Displ) 1 ; set ${wh}Displ($ix) 1 2593 $EdWindow($wh).fr.frdw.displayed select 2594 } 2595 } elseif { $GMEd($wh,Displ) && [UnMap$wh $ix] } { 2596 set GMEd($wh,Displ) 0 ; set ${wh}Displ($ix) 0 2597 $EdWindow($wh).fr.frdw.displayed deselect 2598 } 2599 } elseif { $displ } { 2600 PutMap$wh $ix 2601 set ${wh}Displ($ix) 1 2602 } elseif { [UnMap$wh $ix] } { set ${wh}Displ($ix) 0 } 2603 return 2604} 2605 2606##### background image 2607 2608### geo-referencing an image 2609 2610proc MapLoadWPSelect {n} { 2611 # select WPs (existing or to be defined) for geo-referencing 2612 # $n is either ">=INT" or number of WPs needed 2613 # global variables set: 2614 # $MapLoadWPDefs is the maximum number of WPs that may be defined 2615 # (will be 0 at the end) 2616 # $MapLoadWPs is list with indices of WPs (-1 for those to be defined) 2617 # $MapLoadWPNs is list of names of WPs ("(?)" for those to be defined) 2618 # return number of points selected on success, -1 if operation cancelled 2619 global Number MapLoadWPDefs MapLoadWPs MapLoadWPNs MapLoading WPName \ 2620 TXT MESS 2621 2622 set MapLoadWPs "" ; set MapLoadWPNs "" 2623 if { [regexp {^>=([1-9])$} $n x min] } { 2624 while 1 { 2625 if { $Number(WP) < $min } { 2626 set MapLoadWPDefs [expr $min-$Number(WP)] 2627 } else { set MapLoadWPDefs 0 } 2628 set wps [ChooseItems WP many_0 MapLoadWPDefs [list =$TXT(cwpsdef)]] 2629 if { $wps == -1 } { return -1 } 2630 if { ! [regexp {^ *(0|([1-9][0-9]*)) *$} $MapLoadWPDefs \ 2631 x MapLoadWPDefs] } { 2632 GMMessage [format $MESS(nan) $MapLoadWPDefs] 2633 continue 2634 } 2635 set n [expr $MapLoadWPDefs+[llength $wps]] 2636 if { $n >= $min } { break } 2637 GMMessage [format $MESS(needNpoints) 3] 2638 } 2639 if { ! [regexp {^([a-zA-Z0-9_]+)=} $MapLoading x how] } { 2640 BUG bad contents of MapLoading in proc MapLoadWPSelect 2641 return -1 2642 } 2643 set MapLoading ${how}=$n 2644 set MapLoadWPs $wps 2645 foreach ix $wps { 2646 lappend MapLoadWPNs $WPName($ix) 2647 } 2648 } else { 2649 if { $Number(WP) < $n } { 2650 set missing [expr $n-$Number(WP)] 2651 } else { set missing 0 } 2652 set no [expr $n-$missing] 2653 set MapLoadWPDefs $missing 2654 while { $no > 0 } { 2655 set ds $MapLoadWPDefs 2656 for { set i [expr $MapLoadWPDefs+1] } { $i <= $n } { incr i } { 2657 lappend ds $i 2658 } 2659 set wps [ChooseItems WP many_0 MapLoadWPDefs \ 2660 [list +$TXT(cwpsdef)/$ds]] 2661 if { $wps == -1 } { return -1 } 2662 foreach ix $wps { 2663 set nn $WPName($ix) ; set d 0 2664 foreach name $MapLoadWPNs { 2665 if { $name == $nn } { set d 1 ; break } 2666 } 2667 if { $d } { 2668 GMMessage [format $MESS(duplicate) $nn] 2669 } else { 2670 lappend MapLoadWPs $ix ; lappend MapLoadWPNs $nn 2671 incr no -1 ; incr n -1 2672 if { $no == 0 } { break } 2673 } 2674 } 2675 if { $MapLoadWPDefs >= $n } { 2676 set MapLoadWPDefs $n ; break 2677 } 2678 } 2679 } 2680 # number of WPs to be defined later 2681 while { $MapLoadWPDefs > 0 } { 2682 lappend MapLoadWPs -1 ; lappend MapLoadWPNs "(?)" 2683 incr MapLoadWPDefs -1 2684 } 2685 return $n 2686} 2687 2688proc LoadMapBack {args} { 2689 # load map background 2690 # if $args=="" load either an image to be geo-ref'd, or information on 2691 # an image and geo-referencing information 2692 # otherwise $args is list with name of a background definition and 2693 # menu (not used) 2694 global Map File MESS 2695 2696 if { [$Map find all] != "" && ! [GMConfirm $MESS(clrcurrmap)] } { 2697 return 2698 } 2699 if { $args == "" } { 2700 set r [LoadMapFixedBk ""] 2701 switch -- [lindex $r 0] { 2702 0 { 2703 LoadMapBackImage $File(MapBkInfo) 2704 } 2705 1 { 2706 eval LoadMapBackGeoRef [lreplace $r 0 0] 2707 } 2708 } 2709 } elseif { [set fn [GetDefFields backgrnd [lindex $args 0] file]] == "" } { BUG backgrnd definition with empty file 2710 } else { 2711 set r [LoadMapFixedBk $fn] 2712 if { [lindex $r 0] == 1 } { 2713 eval LoadMapBackGeoRef [lreplace $r 0 0] 2714 } 2715 } 2716 return 2717} 2718 2719proc BadImage {im filename} { 2720 # create image 2721 2722 SetCursor . watch 2723 catch { image delete $im } 2724 set r [catch {image create photo $im -file $filename}] 2725 ResetCursor . 2726 return $r 2727} 2728 2729proc MapCreateOriginImage {path} { 2730 # create map background image at origin 2731 # clear the map, disable scale and datum, and set image parameters 2732 global MpW Map MapImageFile MapImageHeight MapImageWidth MapImageItems \ 2733 MapImageGrid MAPW2 MAPH2 WConf 2734 2735 DoClearMap 2736 $MpW.frm.frmap3.fr3.mn configure -state disabled 2737 $MpW.frm.frmap3.fr3.cv.val configure -text ? 2738 foreach b $WConf(mapdatum) { $b configure -state disabled } 2739 set MapImageFile(0,0) $path 2740 set MapImageHeight [image height MapImage] 2741 set MapImageWidth [image width MapImage] 2742 set MapImageItems [$Map create image 0 0 -image MapImage \ 2743 -anchor nw -tags [list map mapimage forIm=0,0]] 2744 SetMapBounds 2745 # scroll image to centre it 2746 ScrollMapTo [expr $MapImageWidth/2.0] [expr $MapImageHeight/2.0] \ 2747 $MAPW2 $MAPH2 2748 set MapImageGrid(dxmin) -1 ; set MapImageGrid(dymin) -1 2749 set MapImageGrid(dxn) 3 ; set MapImageGrid(dyn) 3 2750 return 2751} 2752 2753proc LoadMapParams {datum pdata tdata pformt pfdatum scale} { 2754 # load map parameters 2755 # $pdata, $tdata describe projection and transformation and are pairs 2756 # with name and list of pairs with parameter name and value 2757 # assume map is empty 2758 global MpW Map MPData MTData MapScale MapProjection MapProjTitle \ 2759 MapTransf MAPPROJDATA MAPPARTPDATA MAPPARTPROJ MAPPROJAUX 2760 2761 set MapScale $scale 2762 catch {unset MPData} ; catch {unset MTData} 2763 MapProjectionIs [lindex $pdata 0] 2764 set MPData(datum) $datum 2765 if { [catch {set mp $MAPPARTPROJ($MapProjection)}] } { 2766 set mp $MapProjection 2767 foreach p [lindex $pdata 1] { 2768 set MPData([lindex $p 0]) [lindex $p 1] 2769 } 2770 if { $MapProjection == "UTM" } { 2771 regexp {^([0-9]+)[ ]*([A-Z])$} $MPData(UTMzone) x ze zn 2772 set MPData(UTMzone) [list $ze $zn] 2773 } 2774 } else { 2775 foreach e $MAPPROJDATA($mp) v $MAPPARTPDATA($MapProjection) { 2776 set MPData($e) $v 2777 } 2778 if { [lsearch -exact $MAPPROJAUX $mp] != -1 } { 2779 Proj${mp}ComputeAux MPData $datum 2780 } 2781 } 2782 ChangeMapDatum $datum 2783 # do not reorder this: 2784 ChangeMapPFormat $pformt ; ChangeMPFDatum $pfdatum 2785 MapTransfIs [lindex $tdata 0] 2786 foreach p [lindex $tdata 1] { 2787 set MTData([lindex $p 0]) [lindex $p 1] 2788 } 2789 regsub {\.00 } [MapScaleToShow $scale] " " txt 2790 $MpW.frm.frmap3.fr3.cv.val configure -text $txt 2791 return 2792} 2793 2794proc LoadMapBackGeoRef {path datum pdata tdata scale ixps csps} { 2795 # load geo-referenced map background image 2796 # $pdata, $tdata describe projection and transformation and are pairs 2797 # with name and list of pairs with parameter name and value 2798 # $ixps: list of image grid coordinates and path for subsidiary images in 2799 # grid 2800 # $csps: list of image canvas coordinates (NW) and path for subsidiary 2801 # images not in grid 2802 global Map MapImageFile MapImageItems MapImageHeight MapImageWidth \ 2803 MapImageGrid MapImageNGrid MapImageNGCs MapEmpty MapPFormat MESS \ 2804 MapImageNGW MapImageNGH MapPFDatum 2805 2806 foreach ixp $ixps { 2807 set p [lindex $ixp 2] 2808 if { [BadImage MapImage[lindex $ixp 0],[lindex $ixp 1] $p] } { 2809 GMMessage "$MESS(badimage): $p" 2810 return 2811 } 2812 } 2813 set MapImageNGrid 0 2814 foreach csp $csps { 2815 set p [lindex $csp 2] 2816 if { [BadImage MapImage$MapImageNGrid $p] } { 2817 GMMessage "$MESS(badimage): $p" 2818 return 2819 } 2820 incr MapImageNGrid 2821 } 2822 if { [BadImage MapImage $path] } { 2823 GMMessage "$MESS(badimage): $path" 2824 return 2825 } 2826 MapCreateOriginImage $path 2827 set dxmin 0 ; set dxmax 0 ; set dymin 0 ; set dymax 0 2828 foreach ixp $ixps { 2829 foreach "dx dy p" $ixp {} 2830 set MapImageFile($dx,$dy) $p 2831 set x [expr $MapImageWidth*$dx] ; set y [expr $MapImageHeight*$dy] 2832 set it [$Map create image $x $y \ 2833 -image "MapImage$dx,$dy" -anchor nw \ 2834 -tags [list map mapimage forIm=$dx,$dy]] 2835 $Map lower $it 2836 lappend MapImageItems $it 2837 if { $dx > $dxmax } { set dxmax $dx } 2838 if { $dy > $dymax } { set dymax $dy } 2839 if { $dx < $dxmin } { set dxmin $dx } 2840 if { $dy < $dymin } { set dymin $dy } 2841 } 2842 set MapImageGrid(dxmin) [expr $dxmin-1] 2843 set MapImageGrid(dymin) [expr $dymin-1] 2844 set MapImageGrid(dxn) [expr $dxmax+3-$dxmin] 2845 set MapImageGrid(dyn) [expr $dymax+3-$dymin] 2846 set ni 0 2847 foreach csp $csps { 2848 foreach "x y p" $csp {} 2849 set MapImageFile($ni) $p ; set MapImageNGCs($ni) $x,$y 2850 set MapImageNGW($ni) [image width MapImage$ni] 2851 set MapImageNGH($ni) [image height MapImage$ni] 2852 set it [$Map create image $x $y -image MapImage$ni -anchor nw \ 2853 -tags [list map mapimage forIm=$ni]] 2854 $Map lower $it 2855 lappend MapImageItems $it 2856 incr ni 2857 } 2858 SetMapBounds 2859 LoadMapParams $datum $pdata $tdata $MapPFormat $MapPFDatum $scale 2860 set MapEmpty 0 2861 ChangeOnState mapstateback normal 2862 return 2863} 2864 2865proc LoadMapBackImage {filename} { 2866 # load map background image to be geo-referenced, from file under $filename 2867 global MpW MapLoading MapScale MapLdOldScale MapScInitVal EdWindow \ 2868 MAPKNOWNTRANSFS MAPTRANSFNPTS CDPData MPData LSqsTransf MESS TXT TYPES 2869 2870 # select transformation 2871 set ts "" ; set rs "" ; set rlsq "" ; set rlsqf "" 2872 foreach t $MAPKNOWNTRANSFS { 2873 lappend ts $TXT(TRNSF$t) ; lappend rs $t 2874 lappend rlsq lsq=$t ; lappend rlsqf lsqf=$t 2875 } 2876 lappend ts "@[linsert $ts 0 $TXT(lstsqs)]" \ 2877 "@[linsert $ts 0 $TXT(lstsqsfile)]" $TXT(tfwfile) \ 2878 $TXT(ozimapfile) $TXT(cancel) 2879 lappend rs $rlsq $rlsqf TFW OziMap 0 2880 switch -glob -- [set how [GMSelect $MESS(georefhow) $ts $rs]] { 2881 0 { return } 2882 lsq=* { 2883 if { ! [regexp {lsq=(.+)$} $how x LSqsTransf] } { 2884 BUG LoadMapBackImage regexp lsq= failed 2885 } 2886 set how LeastSquares 2887 } 2888 lsqf=* { 2889 if { ! [regexp {lsqf=(.+)$} $how x LSqsTransf] } { 2890 BUG LoadMapBackImage regexp lsqf= failed 2891 } 2892 set how LeastSquaresFile 2893 } 2894 } 2895 2896 # load and check image 2897 if { [BadImage MapImage $filename] } { 2898 GMMessage $MESS(badimage) 2899 return 2900 } 2901 MapCreateOriginImage [file join [pwd] $filename] 2902 # save scale 2903 set s [$MpW.frm.frmap3.fr3.cv.val cget -text] 2904 if { [scan $s %d MapLdOldScale] != 1 } { 2905 set MapLdOldScale $MapScInitVal 2906 } 2907 switch $how { 2908 LeastSquaresFile - OziMap - TFW { 2909 ReadApplyTransfData $how $filename 2910 } 2911 default { 2912 # disable display of items being edited 2913 foreach wh $TYPES { 2914 if { [winfo exists $EdWindow($wh)] } { 2915 $EdWindow($wh).fr.frdw.displayed configure -state disabled 2916 } 2917 } 2918 # find number of control waypoints needed 2919 set n $MAPTRANSFNPTS($how) 2920 set MapLoading ${how}=$n 2921 # dialog to select/define waypoints and supervise their placement 2922 MapLoadBkDial $how $n 2923 } 2924 } 2925 return 2926} 2927 2928proc ReadApplyTransfData {fmt filename} { 2929 # load or import transformation data from file and set up projection and 2930 # transformation 2931 # $fmt in {LeastSquaresFile, OziMap, TFW} 2932 # reading procs must return 0 on error or a list whose head is a list of 2933 # latd,longd,datum to be projected (possibly empty); the whole list is 2934 # passed as a parameter to the transformation initialization proc 2935 # initializion procs return 0 on error, or may return a list of WP 2936 # names to be displayed (but see below!) 2937 global MPData MTData CDPData MESS MapScale MapLoading 2938 2939 set MapLoading importing 2940 if { $fmt == "LeastSquaresFile" } { 2941 set indata [LoadLeastSquaresInfo] 2942 set fmt LeastSquares 2943 } else { set indata [Import$fmt $filename] } 2944 if { $indata != 0 } { 2945 set ps [lindex $indata 0] 2946 if { [set proj [ChooseDatumProjection $ps]] == 0 } { 2947 set indata 0 2948 } 2949 } 2950 if { $indata == 0 } { 2951 MapLoadBkCancel 2952 return 2953 } 2954 catch {unset MPData} ; catch {unset MTData} 2955 array set MPData [array get CDPData] 2956 if { [set res [MapInit${fmt}Transf $indata $CDPData(main_proj)]] == 0 } { 2957 GMMessage $MESS(badTransfargs) 2958 MapLoadBkCancel 2959 return 2960 } 2961 MapProjectionIs $proj 2962 ChangeMapDatum $CDPData(datum) 2963 MapScaleChange $MapScale 2964 set MapLoading 0 2965 MapLoadBkDialDone 2966 # display WPs if needs be 2967 if { $fmt == "LeastSquares" } { 2968 foreach name $res { PutMap WP [IndexNamed WP $name] } 2969 } 2970 return 2971} 2972 2973proc MapLoadBkDial {how n} { 2974 # dialog used during map background loading 2975 # $how in $MAPKNOWNTRANSFS or LeastSquares 2976 # $n is either ">=INT", or number of WPs used for geo-referencing 2977 # this dialog is changed by proc DefineCtrlPoint 2978 global WPName MapLoadWPs MapLoadWPNs LISTWIDTH TXT MESS COLOUR EPOSX EPOSY 2979 2980 if { [set n [MapLoadWPSelect $n]] == -1 } { 2981 MapLoadBkCancel 2982 return 2983 } 2984 destroy .wmapload 2985 # used elsewhere 2986 set w .wmapload 2987 GMToplevel $w mapload +[expr $EPOSX+100]+$EPOSY {} \ 2988 {WM_DELETE_WINDOW MapLoadBkCancel} {} 2989 2990 frame $w.fr -borderwidth 5 -bg $COLOUR(messbg) 2991 label $w.fr.title -text $TXT(mapload) -relief sunken 2992 message $w.fr.text -aspect 800 -text $MESS(mapadjust) 2993 2994 frame $w.fr.frbx 2995 listbox $w.fr.frbx.bx -width $LISTWIDTH -relief flat \ 2996 -selectmode single -exportselection 1 2997 bind $w.fr.frbx.bx <Button-1> "$w.fr.frbx.bx selection clear 0 end" 2998 if { $n < 8 } { 2999 $w.fr.frbx.bx configure -height $n 3000 pack $w.fr.frbx.bx 3001 } else { 3002 $w.fr.frbx.bx configure -height 8 \ 3003 -yscrollcommand "$w.fr.frbx.bscr set" 3004 scrollbar $w.fr.frbx.bscr -command "$w.fr.frbx.bx yview" 3005 grid $w.fr.frbx.bx $w.fr.frbx.bscr -sticky ns 3006 } 3007 frame $w.fr.bns 3008 button $w.fr.bns.ok -text $TXT(ok) -command MapLoadBkDialDone \ 3009 -state disabled 3010 button $w.fr.bns.cnc -text $TXT(cancel) -command MapLoadBkCancel 3011 pack $w.fr -side top 3012 pack $w.fr.bns.ok $w.fr.bns.cnc -side left 3013 pack $w.fr.title $w.fr.text $w.fr.frbx $w.fr.bns -side top -pady 5 3014 if { $how == "NoRot" } { 3015 # show WPs in the order they were selected 3016 set ix end 3017 } else { 3018 # show in reverse order because in these cases WPs will be taken 3019 # from right to left of $MapLoadWPs by the cursor procedures 3020 set ix 0 3021 } 3022 foreach name $MapLoadWPNs { 3023 $w.fr.frbx.bx insert $ix $name 3024 } 3025 raise $w 3026 update idletasks 3027 3028 if { $how == "NoRot" } { 3029 MapComputePositions 3030 } 3031 # control will be assumed by MapCursor, MarkMapPoint and MapLoadBkDialDone 3032 3033 return 3034} 3035 3036proc MapLoadRestore {} { 3037 # restore interface state after success or failure of map loading 3038 global MapLoading MapLoadPos EdWindow TYPES 3039 3040 foreach wh $TYPES { 3041 if { [winfo exists $EdWindow($wh)] } { 3042 $EdWindow($wh).fr.frdw.displayed configure -state normal 3043 } 3044 } 3045 set MapLoading 0 3046 destroy .wmapload 3047 catch {unset MapLoadPos} 3048 return 3049} 3050 3051proc MapLoadBkDialDone {} { 3052 # successful end of map background loading dialog 3053 global Map MapLoading MapScale MapLoadWPs MapLoadPos MapEmpty EdWindow \ 3054 WPDispl GMEd MESS MPData MTData MapImageNGrid 3055 3056 if { $MapLoading != 0 } { 3057 catch {unset MTData} 3058 set remap 0 3059 switch -glob $MapLoading { 3060 Affine* { 3061 regexp {(Affine[a-zA-Z_]*)=} $MapLoading x tr 3062 if { ! [MapInit${tr}Transf] } { 3063 GMMessage $MESS(cantsolve) 3064 MapLoadBkCancel 3065 return 3066 } 3067 } 3068 LeastSquares=* { 3069 if { [MapInitLeastSquaresTransf] == 0 } { 3070 GMMessage $MESS(cantsolve) 3071 MapLoadBkCancel 3072 return 3073 } 3074 # must re-map all control points 3075 incr remap 3076 } 3077 NoRot=* { 3078 MapInitNoRotTransf $MapScale $MapLoadPos(xt0) \ 3079 $MapLoadPos(yt0) $MapLoadPos(origin,x) \ 3080 $MapLoadPos(origin,y) 3081 } 3082 } 3083 MapScaleChange $MapScale 3084 MapLoadRestore 3085 $Map delete mapadjust 3086 set MapEmpty 0 3087 foreach wpix $MapLoadWPs { 3088 if { $remap } { 3089 UnMapWP $wpix ; PutMapWP $wpix 3090 } 3091 set WPDispl($wpix) 1 3092 if { [winfo exists $EdWindow(WP)] && $GMEd(WP,Index) == $wpix } { 3093 set GMEd(WP,Displ) 1 3094 set GMEd(WP,Data) [lreplace $GMEd(WP,Data) end end 1] 3095 $EdWindow(WP).fr.frdw.displayed select 3096 } else { 3097 SetDisplShowWindow WP $wpix select 3098 } 3099 } 3100 } 3101 set MapEmpty 0 3102 set MapImageNGrid 0 3103 ChangeOnState mapstateback normal 3104 return 3105} 3106 3107proc MapLoadBkCancel {} { 3108 # cancel loading a map background image 3109 global MpW Map MapLoading MapLdOldScale MapImageItems MapEmpty Dfctrl 3110 3111 if { [winfo exists .wmapload.frd] } { 3112 set Dfctrl 0 3113 return 3114 } 3115 eval $Map delete [$Map find all] 3116 set MapEmpty 1 3117 set MapImageItems "" 3118 MapMeasureEnd 3119 SetMapBounds 3120 if { $MapLoading != 0 } { 3121 MapLoadRestore 3122 # now $MapLoading is 0 3123 $MpW.frm.frmap3.fr3.mn configure -state normal 3124 MapScaleChange $MapLdOldScale 3125 } 3126 return 3127} 3128 3129proc DefineCtrlPoint {w mpix lbox cancel} { 3130 # change map loading dialog to define a control waypoint 3131 # $w is parent of frame that will be created and destroyed for 3132 # entering the information 3133 # $mpix is index of control waypoint in $MapLoadWPs and $MapLoadWPNs 3134 # which will be updated with WP index and name on success 3135 # $lbox is either "", or listbox in which names of defined waypoints 3136 # must be replaced at index $mpix 3137 # $cancel is true if Cancel button must be created 3138 # binding: Return for create 3139 # return WP index, or -1 on failure 3140 global PositionFormat TXT MESS NAMEWIDTH Datum CPDatum CPChangedPosn \ 3141 CREATIONDATE Dfctrl COLOUR MapLoadWPs MapLoadWPNs DefCPWindow \ 3142 INVTXT 3143 3144 # used in ancillary procs 3145 set DefCPWindow $w 3146 destroy $w.frd 3147 set Dfctrl 0 3148 set CPChangedPosn 1 ; set CPDatum $Datum 3149 frame $w.frd -relief flat -borderwidth 2 -bg $COLOUR(dialbg) 3150 label $w.frd.ntitle -text "$TXT(name):" 3151 entry $w.frd.id -width $NAMEWIDTH -exportselection 1 3152 ShowTEdit $w.frd.id "" 1 3153 ShowPosnDatum $w.frd $PositionFormat [list ""] DefCPChangeDatum CPDatum \ 3154 CPDatum normal 1 CPChangedPosn 3155 frame $w.frd.frb -relief flat -borderwidth 0 3156 button $w.frd.frb.ct -text $TXT(create) \ 3157 -command "$w.frd.frb.ct configure -state normal ; set Dfctrl 1" 3158 button $w.frd.frb.cnc -text $TXT(cancel) \ 3159 -command "$w.frd.frb.cnc configure -state normal ; set Dfctrl 0" 3160 grid configure $w.frd.ntitle -column 0 -row 0 -sticky w 3161 grid configure $w.frd.id -column 1 -row 0 -sticky w 3162 grid configure $w.frd.frp -column 0 -row 1 -columnspan 2 -pady 3 3163 grid configure $w.frd.frd -column 0 -row 2 -columnspan 2 3164 grid configure $w.frd.frb.ct -column 0 -row 0 3165 if { $cancel } { 3166 grid configure $w.frd.frb.cnc -column 1 -row 0 3167 } 3168 grid configure $w.frd.frb -column 0 -row 3 -columnspan 2 -pady 5 3169 pack $w.frd -side top -pady 5 3170 3171 update idletasks 3172 set pw [grab current] 3173 grab $w 3174 bind $w <Return> { set Dfctrl 1 ; break } 3175 raise $w 3176 focus $w.frd.id 3177 while 1 { 3178 tkwait variable Dfctrl 3179 3180 if { $Dfctrl } { 3181 set p [PosnGetCheck $w.frd.frp.frp1 $CPDatum GMMessage \ 3182 CPChangedPosn] 3183 if { $p == "nil" } { bell ; continue } 3184 if { [string trim [$w.frd.id get]] == "" } { 3185 set name [NewName WP] 3186 } else { 3187 set name [CheckEntries GMMessage "" \ 3188 [list [list $w.frd.id CheckName]]] 3189 if { $name == "" } { continue } 3190 if { [CheckArrayElement WPName $name] } { 3191 GMMessage $MESS(idinuse) 3192 continue 3193 } 3194 } 3195 set pf $INVTXT([$w.frd.frp.pfmt cget -text]) 3196 if { $CREATIONDATE } { 3197 set data [FormData WP \ 3198 [list Name Posn PFrmt Datum Date Symbol] \ 3199 [list $name $p $pf $CPDatum [Now] mark_x]] 3200 } else { 3201 set data [FormData WP [list Name Posn PFrmt Datum Symbol] \ 3202 [list $name $p $pf $CPDatum mark_x]] 3203 } 3204 set ix [CreateItem WP $data] 3205 set MapLoadWPs [lreplace $MapLoadWPs $mpix $mpix $ix] 3206 set MapLoadWPNs [lreplace $MapLoadWPNs $mpix $mpix $name] 3207 if { $lbox != "" } { 3208 $lbox delete $mpix ; $lbox insert $mpix $name 3209 } 3210 break 3211 } else { set ix -1 ; break } 3212 } 3213 grab release $w 3214 foreach pg $pw { 3215 if { [winfo exists $pg] } { grab $pg } 3216 } 3217 pack forget $w.frd 3218 destroy $w.frd 3219 return $ix 3220} 3221 3222proc DefCPChangeDatum {datum args} { 3223 # change datum of control WP being defined 3224 # $args is not used but is needed as this is called-back from a menu 3225 global DefCPWindow 3226 3227 ChangeDatum $datum CPDatum CPDatum CPChangedPosn $DefCPWindow.frd.frp 3228 return 3229} 3230 3231proc MapGeoRefPoints {n} { 3232 # in command line mode just return the projected coordinates given 3233 # by proc CmdProjCoords 3234 # in graphical mode compute planar Cartesian coordinates of $n WPs 3235 # for geo-referencing and initialize projection procedure 3236 # $MapLoadWPs is list of indices of relevant WPs 3237 # assume that .wmapload is being used 3238 # return list of coordinates, or -1 on cancel 3239 global Datum MapLoadWPs WPPosn WPDatum MapProjInitProc MapProjPointProc \ 3240 MapProjection MPData Datum CMDLINE 3241 3242 if { $CMDLINE } { 3243 return [CmdProjCoords $n] 3244 } 3245 for { set i 0 ; set ps "" } { $i < $n } { incr i } { 3246 if { [set ix [lindex $MapLoadWPs $i]] == -1 && \ 3247 [set ix [DefineCtrlPoint .wmapload $i \ 3248 .wmapload.fr.frbx.bx 0]] == -1 } { 3249 MapLoadBkCancel 3250 return -1 3251 } 3252 set p $WPPosn($ix) 3253 set latd [lindex $p 0] ; set longd [lindex $p 1] 3254 if { [set datum $WPDatum($ix)] != $Datum } { 3255 set p [ToDatum $latd $longd $datum $Datum] 3256 set latd [lindex $p 0] ; set longd [lindex $p 1] 3257 } 3258 lappend ps [list $latd $longd $Datum] 3259 } 3260 catch {unset MPData} 3261 $MapProjInitProc $MapProjection MPData $Datum $ps 3262 set xys "" 3263 foreach p $ps { 3264 lappend xys [eval $MapProjPointProc MPData $p] 3265 } 3266 return $xys 3267} 3268 3269proc MapComputePositions {} { 3270 # compute lines from 1st to 2nd and 1st to 3rd selected WPs 3271 # when loading a map background image with no rotation 3272 # set MapLoadPos(xt0),MapLoadPos(yt0) to terrain coords of 1st WP 3273 global MapLoadPos MapWidth MapHeight 3274 3275 if { [set tcs [MapGeoRefPoints 3]] == -1 } { return } 3276 set p0 [lindex $tcs 0] 3277 set MapLoadPos(xt0) [set xt0 [lindex $p0 0]] 3278 set MapLoadPos(yt0) [set yt0 [lindex $p0 1]] 3279 set mx $MapWidth 3280 if { $MapHeight > $MapWidth } { set mx $MapHeight } 3281 incr mx 10000 3282 # start with 3rd WP, then 2nd 3283 foreach a "2 1" { 3284 set p [lindex $tcs $a] 3285 set xta [lindex $p 0] ; set yta [lindex $p 1] 3286 # difference in projected coordinates from first point 3287 set MapLoadPos(dmx,$a) [set dx [expr $xta-$xt0]] 3288 set MapLoadPos(dmy,$a) [set dy [expr $yta-$yt0]] 3289 # $dx/$l is cos of angle of line from 1st point to point and x-axis 3290 # $dy/$l is sin of same angle 3291 # distance from point to first point 3292 set l [expr sqrt(1.0*$dx*$dx+1.0*$dy*$dy)] 3293 # difference in canvas coordinates between point and a point on the 3294 # line from first point but at distance $mx (out of canvas) 3295 set MapLoadPos(dx,$a) [set dxc [expr $mx/$l*$dx]] 3296 set MapLoadPos(dy,$a) [set dyc [expr -$mx/$l*$dy]] 3297 # position of line from (100,100) to out of canvas, parallel to 3298 # line from 1st point to point 3299 set MapLoadPos(pos,$a) [list 100 100 [expr 100+$dxc] [expr 100+$dyc]] 3300 } 3301 # for 2nd WP, using $dx,$dy and $l computed above 3302 # axis along which difference in coordinates is larger 3303 if { abs($dx) >= abs($dy) } { 3304 set MapLoadPos(dir) x 3305 } else { 3306 set MapLoadPos(dir) y 3307 } 3308 set MapLoadPos(dist) $l 3309 return 3310} 3311 3312proc ClearMapBack {} { 3313 # clear map background images 3314 global MpW Map MapImageItems MapImageFile MESS 3315 3316 if { [GMConfirm $MESS(okclrbkmap)] } { 3317 $Map delete mapimage 3318 set MapImageItems "" ; catch {unset MapImageFile} 3319 $MpW.frm.frmap3.fr3.mn configure -state normal 3320 ChangeOnState mapstateback disabled 3321 return 1 3322 } 3323 return 0 3324} 3325 3326proc SaveMapBack {args} { 3327 # save map background image information 3328 # in graphical mode 3329 # $args is either "" or file 3330 # in command line mode 3331 # $args is list with path to image file and file to write on 3332 global Map MapImageFile MapScale MapProjection MPData MapTransf MTData \ 3333 MAPPARTPROJ MAPPROJDATA MAPTRANSFDATA MapImageNGCs CMDLINE 3334 3335 if { $CMDLINE } { 3336 set MapImageFile(0,0) [lindex $args 0] 3337 set args [lindex $args 1] 3338 } elseif { [$Map find withtag mapimage] == "" } { return } 3339 set pd $MapProjection 3340 if { [catch {set MAPPARTPROJ($MapProjection)}] } { 3341 foreach e $MAPPROJDATA($MapProjection) { 3342 lappend pd "$e=$MPData($e)" 3343 } 3344 } 3345 set pt $MapTransf 3346 foreach e $MAPTRANSFDATA($MapTransf) { 3347 lappend pt "$e=$MTData($e)" 3348 } 3349 set lg "" ; set lc "" 3350 foreach n [array names MapImageFile] { 3351 if { [string first "," $n] != -1 } { 3352 # image in grid 3353 if { $n != "0,0" } { 3354 lappend lg [list $n $MapImageFile($n)] 3355 } 3356 } else { 3357 lappend lc [list $MapImageNGCs($n) $MapImageFile($n)] 3358 } 3359 } 3360 SaveFileTo $args mapback MapBkInfo $MapImageFile(0,0) $pd $pt $MapScale \ 3361 $lg $lc 3362 return 3363} 3364 3365proc ExportMapTFW {} { 3366 # export parameters of the transformation used for map background image 3367 # as a TFW file 3368 global Map 3369 3370 if { [$Map find withtag mapimage] == "" } { return } 3371 ExportTFW [MapAffineParams] 3372 return 3373} 3374 3375proc SaveMapParams {args} { 3376 # save map projection, transformation, position format of coordinates 3377 # and scale when there is no background image 3378 # $args is either "" or file 3379 global Map MapScale MapProjection MPData MapTransf MTData MapPFormat \ 3380 MAPPARTPROJ MAPPROJDATA MAPTRANSFDATA MapPFDatum 3381 3382 if { [$Map find withtag mapimage] != "" } { return } 3383 set pd $MapProjection 3384 if { [catch {set MAPPARTPROJ($MapProjection)}] } { 3385 foreach e $MAPPROJDATA($MapProjection) { 3386 lappend pd "$e=$MPData($e)" 3387 } 3388 } 3389 set pt $MapTransf 3390 foreach e $MAPTRANSFDATA($MapTransf) { 3391 lappend pt "$e=$MTData($e)" 3392 } 3393 SaveFileTo $args mapinfo MapInfo $pd $pt $MapPFormat $MapPFDatum $MapScale 3394 return 3395} 3396 3397proc ChangeMapBack {} { 3398 # dialog used to change map background images 3399 # this dialog may be changed by proc DefineCtrlPoint 3400 global MapImageGrid MapImageFile TXT EPOSX EPOSY COLOUR MAPCOLOUR \ 3401 MapBackNGSelect MapBackNGIxs MapBackCellW MapBackCellH \ 3402 FixedFont 3403 3404 # name .wchgmapbak used explicitly below 3405 set w .wchgmapbak 3406 if { [winfo exists $w] } { Raise $w ; return } 3407 3408 GMToplevel $w mpbkchg +$EPOSX+$EPOSY {} \ 3409 [list WM_DELETE_WINDOW "destroy $w"] {} 3410 3411 set MapBackNGSelect "" 3412 # width and height of grid cell 3413 set MapBackCellW 43 ; set MapBackCellH 21 3414 3415 frame $w.fr -borderwidth 5 -bg $COLOUR(messbg) 3416 label $w.fr.title -text $TXT(mpbkchg) -relief sunken 3417 frame $w.fr.frg -relief flat -borderwidth 0 3418 frame $w.fr.frng -relief flat -borderwidth 0 3419 3420 ## images in a grid 3421 set rw $MapBackCellW ; set rh $MapBackCellH 3422 set wd [expr 3*$rw] ; set hg [expr 3*$rh] 3423 set cv $w.fr.frg.grid 3424 canvas $cv -width $wd -height $hg -relief sunken \ 3425 -xscrollincrement $rw -yscrollincrement $rh 3426 # make central 3x3 grid: grid canvas 0,0 is upper left corner of -1,-1 slot 3427 for { set dx -1 } { $dx < 2 } { incr dx } { 3428 MapColumnBackGrid $cv $dx -1 3 3429 } 3430 # extend grid if needs be 3431 foreach d "x y" h "Column Row" \ 3432 omin "-1 $MapImageGrid(dxmin)" on "3 $MapImageGrid(dxn)" { 3433 if { [set d0 $MapImageGrid(d${d}min)] < -1 } { 3434 for { set dd $d0 } { $dd < -1 } { incr dd } { 3435 Map${h}BackGrid $cv $dd $omin $on 3436 set bb [$cv bbox all] 3437 set x0 [lindex $bb 0] ; set y0 [lindex $bb 1] 3438 set x1 [lindex $bb 2] ; set y1 [lindex $bb 3] 3439 $cv configure -width [expr $x1-$x0] -height [expr $y1-$y0] 3440 $cv ${d}view scroll -1 units 3441 } 3442 } 3443 if { [set df [expr $d0+$MapImageGrid(d${d}n)]] > 1 } { 3444 for { set dd 2 } { $dd < $df } { incr dd } { 3445 Map${h}BackGrid $cv $dd $omin $on 3446 set bb [$cv bbox all] 3447 set x0 [lindex $bb 0] ; set y0 [lindex $bb 1] 3448 set x1 [lindex $bb 2] ; set y1 [lindex $bb 3] 3449 $cv configure -width [expr $x1-$x0] -height [expr $y1-$y0] 3450 } 3451 } 3452 } 3453 3454 foreach ixs [array names MapImageFile] { 3455 $cv itemconfigure forIm=$ixs -fill $MAPCOLOUR(fullgrid) 3456 } 3457 $cv itemconfigure forIm=0,0 -width 4 -outline $MAPCOLOUR(mapsel) 3458 set it [$cv create text [expr 1.5*$rw] [expr 1.5*$rh] -anchor center \ 3459 -text + -justify center] 3460 $cv bind $it <Enter> "MapBackGridEnter 0 0" 3461 $cv bind $it <Leave> "MapBackGridLeave 0 0" 3462 $cv bind $it <Button-1> "MapBackGridSelect 0 0" 3463 3464 frame $w.fr.frg.cs 3465 label $w.fr.frg.cs.tit -text $TXT(mpbkgrcs): 3466 label $w.fr.frg.cs.cs -text 0,0 3467 3468 frame $w.fr.frg.pt 3469 label $w.fr.frg.pt.tit -text $TXT(file): 3470 label $w.fr.frg.pt.pt -text $MapImageFile(0,0) -width 50 3471 3472 frame $w.fr.frg.bns 3473 button $w.fr.frg.bns.ld -text $TXT(load) \ 3474 -command "MapBackGridLoad ; \ 3475 $w.fr.frg.bns.ld configure -state normal" 3476 button $w.fr.frg.bns.clr -text $TXT(clear) -state disabled \ 3477 -command "MapBackGridClear ; \ 3478 $w.fr.frg.bns.clr configure -state normal" 3479 3480 ## images out of grid 3481 listbox $w.fr.frng.bx -width 50 -height 8 -relief flat -exportselection 1 \ 3482 -yscrollcommand "$w.fr.frng.bscr set" \ 3483 -selectmode single -font $FixedFont 3484 bind $w.fr.frng.bx <Button-1> { MapBackBoxSetSelect [%W nearest %y] } 3485 bind $w.fr.frng.bx <Enter> { MapBackBoxShow } 3486 bind $w.fr.frng.bx <Leave> { .wchgmapbak.fr.frg.grid delete nongrid } 3487 set MapBackNGIxs "" 3488 foreach n [lsort [array names MapImageFile]] { 3489 if { [string first "," $n] == -1 } { 3490 $w.fr.frng.bx insert end $MapImageFile($n) 3491 lappend MapBackNGIxs $n 3492 } 3493 } 3494 scrollbar $w.fr.frng.bscr -command "$w.fr.frng.bx yview" 3495 frame $w.fr.frng.bns 3496 button $w.fr.frng.bns.ld -text $TXT(load) \ 3497 -command "MapBackNGridLoad ; \ 3498 $w.fr.frng.bns.ld configure -state normal" 3499 button $w.fr.frng.bns.clr -text $TXT(clear) -state disabled \ 3500 -command "MapBackNGridClear ; \ 3501 $w.fr.frng.bns.clr configure -state normal" 3502 # frame for defining control waypoint (used by proc DefineCtrlPoint) 3503 frame $w.fr.frng.df 3504 3505 frame $w.fr.bns 3506 button $w.fr.bns.clrall -text $TXT(clearall) -command { 3507 if { [ClearMapBack] } { 3508 destroy .wchgmapbak 3509 } else { 3510 .wchgmapbak.fr.bns.clrall configure -state normal 3511 } 3512 } 3513 button $w.fr.bns.ok -text $TXT(ok) -command "destroy $w" 3514 3515 pack $w.fr.frg.cs.tit $w.fr.frg.cs.cs -side left 3516 pack $w.fr.frg.pt.tit $w.fr.frg.pt.pt -side left 3517 pack $w.fr.frg.bns.ld $w.fr.frg.bns.clr -side left 3518 pack $w.fr.frg.grid $w.fr.frg.cs $w.fr.frg.pt $w.fr.frg.bns -side top \ 3519 -pady 5 3520 3521 pack $w.fr.frng.bns.ld $w.fr.frng.bns.clr -side left 3522 grid configure $w.fr.frng.bx -row 0 -column 0 -sticky nesw 3523 grid configure $w.fr.frng.bscr -row 0 -column 1 -sticky ns 3524 grid configure $w.fr.frng.bns -row 1 -column 0 -columnspan 2 -pady 5 3525 grid configure $w.fr.frng.df -row 2 -column 0 -columnspan 2 -pady 5 3526 3527 pack $w.fr.bns.clrall $w.fr.bns.ok -side left 3528 grid configure $w.fr.title -row 0 -column 0 -columnspan 2 3529 grid configure $w.fr.frg -row 1 -column 0 -sticky nesw -pady 5 3530 grid configure $w.fr.frng -row 1 -column 1 -sticky nesw -pady 5 -padx 3 3531 grid configure $w.fr.bns -row 2 -column 0 -columnspan 2 -pady 5 3532 3533 pack $w.fr 3534 3535 update idletasks 3536 return 3537} 3538 3539proc MapBackGridEnter {dx dy} { 3540 # cursor on image grid slot 3541 global MAPCOLOUR 3542 3543 .wchgmapbak.fr.frg.grid itemconfigure forIm=$dx,$dy \ 3544 -fill $MAPCOLOUR(mapsel) 3545 return 3546} 3547 3548proc MapBackGridLeave {dx dy} { 3549 # cursor out of image grid slot 3550 global MAPCOLOUR MapImageFile 3551 3552 if { [catch {set MapImageFile($dx,$dy)}] } { 3553 set c emptygrid 3554 } else { set c fullgrid } 3555 .wchgmapbak.fr.frg.grid itemconfigure forIm=$dx,$dy -fill $MAPCOLOUR($c) 3556 return 3557} 3558 3559proc MapBackGridSelect {dx dy} { 3560 # click on an image grid slot 3561 global MAPCOLOUR MapImageFile 3562 3563 set fr .wchgmapbak.fr.frg ; set cv $fr.grid 3564 set last [$fr.cs.cs cget -text] 3565 if { [catch {set p $MapImageFile($dx,$dy)}] } { 3566 set p "" 3567 $fr.bns.clr configure -state disabled 3568 } else { 3569 if { "$dx,$dy" != "0,0" } { 3570 $fr.bns.clr configure -state normal 3571 } 3572 } 3573 $cv itemconfigure forIm=$last -width 2 -outline black 3574 $cv itemconfigure forIm=$dx,$dy -width 4 -outline $MAPCOLOUR(mapsel) 3575 .wchgmapbak.fr.frg.cs.cs configure -text $dx,$dy 3576 .wchgmapbak.fr.frg.pt.pt configure -text $p 3577 return 3578} 3579 3580proc MapBackGridLoad {} { 3581 # (re-)load one image for map background 3582 global Map MapImageFile MapImageWidth MapImageHeight MapImageItems \ 3583 MapImageGrid File MESS TXT MAPCOLOUR 3584 3585 set fr .wchgmapbak.fr.frg 3586 scan [set cs [$fr.cs.cs cget -text]] %d,%d dx dy 3587 if { [set f [GMOpenFile $TXT(loadfrm) Image r]] != ".." } { 3588 set filename $File(Image) 3589 if { [BadImage MapImage$cs $filename] } { 3590 GMMessage $MESS(badimage) 3591 return 3592 } 3593 set MapImageFile($cs) [file join [pwd] $filename] 3594 $fr.pt.pt configure -text $MapImageFile($cs) 3595 set cv $fr.grid 3596 $cv itemconfigure forIm=$cs -fill $MAPCOLOUR(fullgrid) 3597 $Map delete forIm=$cs 3598 set x [expr $MapImageWidth*$dx] ; set y [expr $MapImageHeight*$dy] 3599 set it [$Map create image $x $y \ 3600 -image "MapImage$cs" -anchor nw \ 3601 -tags [list map mapimage forIm=$cs]] 3602 $Map lower $it 3603 lappend MapImageItems $it 3604 SetMapBounds 3605 MapWideBackGrid $cv x $dx Column \ 3606 $MapImageGrid(dymin) $MapImageGrid(dyn) 3607 MapWideBackGrid $cv y $dy Row \ 3608 $MapImageGrid(dxmin) $MapImageGrid(dxn) 3609 $fr.bns.clr configure -state normal 3610 } 3611 return 3612} 3613 3614proc MapBackGridClear {} { 3615 # clear one image from map background 3616 global Map MapImageFile MapImageItems MapImageGrid MAPCOLOUR MESS 3617 3618 set fr .wchgmapbak.fr.frg 3619 scan [set cs [$fr.cs.cs cget -text]] %d,%d dx dy 3620 if { [GMConfirm "$MESS(okclrbkim) $cs"] } { 3621 set it [$Map find withtag forIm=$cs] 3622 $Map delete forIm=$cs 3623 SetMapBounds 3624 $fr.bns.clr configure -state disabled 3625 catch {image delete MapImage$cs} 3626 catch {unset MapImageFile($cs)} 3627 if { [set ix [lsearch -exact $MapImageItems $it]] >= 0 } { 3628 set MapImageItems [lreplace $MapImageItems $ix $ix] 3629 } 3630 set cv $fr.grid 3631 $cv itemconfigure forIm=$cs -fill $MAPCOLOUR(emptygrid) 3632 if { ([MapShrinkBackGrid $cv x $dx %d,*] | \ 3633 [MapShrinkBackGrid $cv y $dy *,%d]) && \ 3634 [$cv find withtag forIm=$dx,$dy] == "" } { 3635 $cv itemconfigure forIm=0,0 -outline $MAPCOLOUR(mapsel) 3636 $fr.cs.cs configure -text 0,0 3637 $fr.pt.pt configure -text $MapImageFile(0,0) 3638 } else { 3639 $fr.pt.pt configure -text "" 3640 } 3641 } 3642 return 3643} 3644 3645proc MapColumnBackGrid {gr dx dymin dyn} { 3646 # make column of grid in dialog used to change map 3647 # background images 3648 # $gr: canvas with grid 3649 # $dx: grid coordinate 3650 # $dymin: min grid y-coordinate 3651 # $dyn: number of slots along y-coordinate 3652 global MapImageGrid MAPCOLOUR MapBackCellW MapBackCellH 3653 3654 set m [expr $dymin+$dyn] 3655 set rw $MapBackCellW ; set rh $MapBackCellH 3656 for { set dy $dymin } { $dy < $m } { incr dy } { 3657 set it [$gr create rectangle [expr ($dx+1)*$rw+2] \ 3658 [expr ($dy+1)*$rh+2] [expr ($dx+2)*$rw] \ 3659 [expr ($dy+2)*$rh] -width 2 -fill $MAPCOLOUR(emptygrid) \ 3660 -tags [list grid forIm=$dx,$dy]] 3661 $gr bind $it <Enter> "MapBackGridEnter $dx $dy" 3662 $gr bind $it <Leave> "MapBackGridLeave $dx $dy" 3663 $gr bind $it <Button-1> "MapBackGridSelect $dx $dy" 3664 } 3665 return 3666} 3667 3668proc MapRowBackGrid {gr dy dxmin dxn} { 3669 # make row of grid in dialog used to change map 3670 # background images 3671 # $gr: canvas with grid 3672 # $dy: grid coordinate 3673 # $dxmin: min grid x-coordinate 3674 # $dxn: number of slots along x-coordinate 3675 global MapImageGrid MAPCOLOUR MapBackCellW MapBackCellH 3676 3677 set m [expr $dxmin+$dxn] 3678 set rw $MapBackCellW ; set rh $MapBackCellH 3679 for { set dx $dxmin } { $dx < $m } { incr dx } { 3680 set it [$gr create rectangle [expr ($dx+1)*$rw+2] \ 3681 [expr ($dy+1)*$rh+2] [expr ($dx+2)*$rw] \ 3682 [expr ($dy+2)*$rh] -width 2 -fill $MAPCOLOUR(emptygrid) \ 3683 -tags [list grid forIm=$dx,$dy]] 3684 $gr bind $it <Enter> "MapBackGridEnter $dx $dy" 3685 $gr bind $it <Leave> "MapBackGridLeave $dx $dy" 3686 $gr bind $it <Button-1> "MapBackGridSelect $dx $dy" 3687 } 3688 return 3689} 3690 3691proc MapWideBackGrid {gr dir c how omin on} { 3692 # add external row/column of grid in dialog used to change map 3693 # background images if the external row/column becomes non-empty 3694 # $gr: canvas with grid 3695 # $dir in {x, y} 3696 # $c: grid coordinate along $dir 3697 # $how in {Row, Column} according to $dir 3698 # $omin: min grid coordinate along other direction 3699 # $on: number of slots along other direction 3700 global MapImageGrid 3701 3702 if { $c != 0 } { 3703 set chg 0 ; set dd d$dir 3704 if { $c == [set m $MapImageGrid(${dd}min)] } { 3705 set chg 1 ; set scr -1 3706 incr MapImageGrid(${dd}min) -1 ; incr MapImageGrid(${dd}n) 3707 Map${how}BackGrid $gr $MapImageGrid(${dd}min) $omin $on 3708 } elseif { $c == [expr $MapImageGrid(${dd}n)+$m-1] } { 3709 set chg 1 ; set scr 0 3710 incr MapImageGrid(${dd}n) 3711 Map${how}BackGrid $gr [expr $c+1] $omin $on 3712 } 3713 if { $chg } { 3714 set bb [$gr bbox all] 3715 set x0 [lindex $bb 0] ; set y0 [lindex $bb 1] 3716 set x1 [lindex $bb 2] ; set y1 [lindex $bb 3] 3717 $gr configure -width [expr $x1-$x0] -height [expr $y1-$y0] 3718 $gr ${dir}view scroll $scr units 3719 } 3720 } 3721 return 3722} 3723 3724proc MapShrinkBackGrid {gr dir c fmt} { 3725 # delete external row/column of grid in dialog used to change map 3726 # background images if its neighbour becomes empty (external rows 3727 # and columns are always empty; minimum size is 3x3, as slot with 3728 # origin is never emptied) 3729 # return 1 if there was shrinking 3730 # $gr: canvas with grid 3731 # $dir in {x, y} 3732 # $c: grid coordinate along $dir 3733 # $fmt in {"%d,*", "*,%d"} 3734 global MapImageGrid MapImageFile 3735 3736 set chg 0 3737 if { $c != 0 } { 3738 set dd d$dir ; set patt [format $fmt $c] 3739 if { $c == [set c1 [expr $MapImageGrid(${dd}min)+1]] && \ 3740 [NoBackImageAt $patt] } { 3741 set chg 1 ; set scr 1 ; incr MapImageGrid(${dd}min) 3742 } elseif { $c == [expr $MapImageGrid(${dd}n)+$c1-3] && \ 3743 [NoBackImageAt $patt] } { 3744 set chg 1 ; set scr 0 3745 } 3746 if { $chg } { 3747 incr MapImageGrid(${dd}n) -1 3748 set dc [expr 1-$scr-$scr] 3749 set cd [expr $c+$dc] ; set patt [format $fmt $cd] 3750 foreach it [$gr find withtag grid] { 3751 if { [lsearch -glob [$gr gettags $it] forIm=$patt] != -1 } { 3752 $gr delete $it 3753 } 3754 } 3755 set bb [$gr bbox all] 3756 set x0 [lindex $bb 0] ; set y0 [lindex $bb 1] 3757 set x1 [lindex $bb 2] ; set y1 [lindex $bb 3] 3758 $gr configure -width [expr $x1-$x0] -height [expr $y1-$y0] 3759 $gr ${dir}view scroll $scr units 3760 if { abs($c) != 1 } { 3761 MapShrinkBackGrid $gr $dir [expr $c-$dc] $fmt 3762 } 3763 } 3764 } 3765 return $chg 3766} 3767 3768proc NoBackImageAt {patt} { 3769 # check whether there is a loaded image with coordinates of given pattern 3770 global MapImageFile 3771 3772 if { [lsearch -glob [array names MapImageFile] $patt] == -1 } { 3773 return 1 3774 } 3775 return 0 3776} 3777 3778proc MapBackBoxSetSelect {i} { 3779 # non-grided image selected in listbox corresponds to $i-th file there 3780 global MapBackNGSelect MapBackNGIxs 3781 3782 .wchgmapbak.fr.frg.grid delete nongrid 3783 set MapBackNGSelect [lindex $MapBackNGIxs $i] 3784 .wchgmapbak.fr.frng.bns.clr configure -state normal 3785 MapBackBoxShow 3786 return 3787} 3788 3789proc MapBackBoxShow {} { 3790 # show selected non-grided image over grid if grid canvas is not too small 3791 global Map MapBackNGSelect MapBackCellW MapBackCellH MapImageHeight \ 3792 MapImageWidth MAPCOLOUR MapImageNGW MapImageNGH 3793 3794 if { $MapBackNGSelect != "" } { 3795 foreach "x0 y0" [$Map coords forIm=$MapBackNGSelect] {} 3796 set scx [expr 1.0*$MapBackCellW/$MapImageWidth] 3797 set scy [expr 1.0*$MapBackCellH/$MapImageHeight] 3798 set gx0 [expr $MapBackCellW+$x0*$scx] 3799 set gy0 [expr $MapBackCellH+$y0*$scy] 3800 set gxn [expr $MapBackCellW+($x0+$MapImageNGW($MapBackNGSelect))*$scx] 3801 set gyn [expr $MapBackCellH+($y0+$MapImageNGH($MapBackNGSelect))*$scy] 3802 .wchgmapbak.fr.frg.grid create rectangle $gx0 $gy0 $gxn $gyn \ 3803 -fill $MAPCOLOUR(mapsel) -tags nongrid 3804 } 3805 return 3806} 3807 3808proc MapBackNGridClear {} { 3809 # delete selected non-grided image 3810 global Map MapBackNGSelect MapBackNGIxs MapImageNGrid MapImageFile \ 3811 MapImageNGCs MapImageItems MapImageNGW MapImageNGH 3812 3813 if { $MapBackNGSelect != "" && \ 3814 [set it [$Map find withtag forIm=$MapBackNGSelect]] != "" } { 3815 $Map delete $it 3816 if { $MapImageNGrid == $MapBackNGSelect+1 } { incr MapImageNGrid -1 } 3817 catch { unset MapImageFile($MapBackNGSelect) } 3818 catch { unset MapImageNGCs($MapBackNGSelect) } 3819 catch { unset MapImageNGW($MapBackNGSelect) } 3820 catch { unset MapImageNGH($MapBackNGSelect) } 3821 if { [set i [lsearch -exact $MapImageItems $it]] != -1 } { 3822 set MapImageItems [lreplace $MapImageItems $i $i] 3823 } 3824 if { [set i [lsearch -exact $MapBackNGIxs $MapBackNGSelect]] != -1 } { 3825 set MapBackNGIxs [lreplace $MapBackNGIxs $i $i] 3826 .wchgmapbak.fr.frng.bx delete $i 3827 .wchgmapbak.fr.frng.bx selection clear 0 end 3828 .wchgmapbak.fr.frng.bns.clr configure -state disabled 3829 } 3830 set MapBackNGSelect "" 3831 } 3832 return 3833} 3834 3835proc MapBackNGridLoad {} { 3836 # (re-) load a non-grided image to background 3837 global Map MapImageItems TXT MESS File MapImageNGrid MapImageFile \ 3838 MapImageNGCs MapBackNGIxs MapLoadWPs MapLoadPos WPPosn WPDatum \ 3839 MapImageNGW MapImageNGH 3840 3841 if { [set f [GMOpenFile $TXT(loadfrm) Image r]] != ".." } { 3842 set filename $File(Image) ; set n $MapImageNGrid 3843 if { [BadImage MapImage$n $filename] } { 3844 GMMessage $MESS(badimage) 3845 return 3846 } 3847 set iwd [image width MapImage$n] ; set iht [image height MapImage$n] 3848 # geo-reference with 1 ctrl waypoint 3849 if { [MapLoadWPSelect 1] == -1 || \ 3850 ( $MapLoadWPs == -1 && \ 3851 [DefineCtrlPoint .wchgmapbak.fr.frng.df 0 "" 1] == -1 ) || \ 3852 [MapBackNGPlaceWP $n $iwd $iht] == -1 } { 3853 image delete MapImage$n 3854 return 3855 } 3856 # compute image NW corner canvas coordinates $x,$y 3857 # WP canvas coordinates 3858 set ix $MapLoadWPs 3859 set p [MapFromPosn [lindex $WPPosn($ix) 0] [lindex $WPPosn($ix) 1] \ 3860 $WPDatum($ix)] 3861 set x [expr round([lindex $p 0]-$MapLoadPos(0,x))] 3862 set y [expr round([lindex $p 1]-$MapLoadPos(0,y))] 3863 # display image 3864 set it [$Map create image $x $y -image "MapImage$n" -anchor nw \ 3865 -tags [list map mapimage forIm=$n]] 3866 $Map lower $it 3867 lappend MapImageItems $it 3868 SetMapBounds 3869 # update image data 3870 set MapImageFile($n) [file join [pwd] $filename] 3871 set MapImageNGCs($n) $x,$y 3872 set MapImageNGW($n) $iwd ; set MapImageNGH($n) $iht 3873 incr MapImageNGrid 3874 # update dialog 3875 .wchgmapbak.fr.frng.bx insert end $MapImageFile($n) 3876 .wchgmapbak.fr.frng.bx selection clear 0 end 3877 lappend MapBackNGIxs $n 3878 } 3879 return 3880} 3881 3882proc MapBackNGPlaceWP {imno wd ht} { 3883 # display image MapImage$imno ($wd x $ht) in a canvas and let the user 3884 # place WP with index $MapLoadWPs (!= -1) in it 3885 # return -1 if operation is cancelled; otherwise WP canvas coordinates 3886 # (NW corner of image at 0,0) will be stored in MapLoadPos(0,_) 3887 global MapLoadWPs TXT MESS Dfctrl MPOSX MPOSY MapHeight MapWidth COLOUR \ 3888 MapNGLoading MapNGRangex MapNGRangey 3889 3890 # window name used elsewhere 3891 set w .mapng ; set Dfctrl 0 3892 if { [set mw $MapWidth] > $wd } { set mw $wd } 3893 if { [set mh $MapHeight] > $ht } { set mh $ht } 3894 destroy $w 3895 GMToplevel $w mpbkchg +$MPOSX+$MPOSY {} \ 3896 {WM_DELETE_WINDOW {set Dfctrl 0}} {} 3897 3898 set MapNGLoading 1 3899 set MapNGRangex $wd ; set MapNGRangey $ht 3900 3901 frame $w.fr -relief flat -borderwidth 2 -bg $COLOUR(dialbg) 3902 message $w.fr.text -aspect 800 -text $MESS(mapadjust) 3903 set map $w.fr.map 3904 canvas $map -borderwidth 5 -relief groove -confine true \ 3905 -scrollregion [list 0 0 $wd $ht] -width $mw -height $mh \ 3906 -xscrollincrement 1 -yscrollincrement 1 \ 3907 -xscrollcommand "$w.fr.mhscr set" \ 3908 -yscrollcommand "$w.fr.mvscr set" 3909 scrollbar $w.fr.mhscr -orient horizontal -command "MapNGScroll x" 3910 scrollbar $w.fr.mvscr -command "MapNGScroll y" 3911 $map create image 0 0 -anchor nw -image MapImage$imno 3912 MapNGSetVOrigin x ; MapNGSetVOrigin y 3913 $map configure -cursor crosshair 3914 bind $map <Enter> "focus $map ; MapNGCursor" 3915 bind $map <Leave> { focus . ; UnMapNGCursor } 3916 bind $map <Motion> "$map scan mark %x %y; MapNGCursorMotion %x %y" 3917 bind $map <Button-1> { MarkMapNGPoint %x %y } 3918 bind $map <Return> { MarkMapNGPoint %x %y } 3919 3920 # scrolling/panning bindings as for $Map 3921 bind $map <Key-Up> { MapNGScroll y scroll -1 units ; MapNGCursorUpdate } 3922 bind $map <Key-Delete> { MapNGScroll y scroll -1 pages 3923 MapNGCursorUpdate } 3924 bind $map <Key-space> { MapNGScroll y scroll 1 pages ; MapNGCursorUpdate } 3925 bind $map <Key-Down> { MapNGScroll y scroll 1 units ; MapNGCursorUpdate } 3926 bind $map <Key-Left> { MapNGScroll x scroll -1 units ; MapNGCursorUpdate } 3927 bind $map <Key-Right> { MapNGScroll x scroll 1 units ; MapNGCursorUpdate } 3928 bind $map <Shift-Up> { MapNGScroll y scroll -1 units 3929 MapNGScroll x scroll 1 units ; MapNGCursorUpdate } 3930 bind $map <Shift-Down> { MapNGScroll y scroll 1 units 3931 MapNGScroll x scroll -1 units ; MapNGCursorUpdate } 3932 bind $map <Shift-Left> { MapNGScroll y scroll -1 units 3933 MapNGScroll x scroll -1 units ; MapNGCursorUpdate } 3934 bind $map <Shift-Right> { MapNGScroll y scroll 1 units 3935 MapNGScroll x scroll 1 units ; MapNGCursorUpdate } 3936 bind $map <Control-Motion> "$map scan dragto %x %y 1; \ 3937 MapNGSetVOrigin x ; MapNGSetVOrigin y ; MapNGCursorUpdate" 3938 bind $map <B2-Motion> "$map scan dragto %x %y ; MapNGSetVOrigin x ; \ 3939 MapNGSetVOrigin y ; MapNGCursorUpdate" 3940 bind $map <Button-5> { MapNGScroll y scroll 25 units ; MapNGCursorUpdate } 3941 bind $map <Button-4> { MapNGScroll y scroll -25 units ; MapNGCursorUpdate } 3942 bind $map <Shift-Button-5> { MapNGScroll y scroll 1 pages 3943 MapNGCursorUpdate } 3944 bind $map <Shift-Button-4> { MapNGScroll y scroll -1 pages 3945 MapNGCursorUpdate } 3946 bind $map <Control-Button-5> { MapNGScroll x scroll 1 pages 3947 MapNGCursorUpdate } 3948 bind $map <Control-Button-4> { MapNGScroll x scroll -1 pages 3949 MapNGCursorUpdate } 3950 bind $map <Alt-Button-5> { MapNGScroll x scroll 25 units 3951 MapNGCursorUpdate } 3952 bind $map <Alt-Button-4> { MapNGScroll x scroll -25 units 3953 MapNGCursorUpdate } 3954 3955 frame $w.fr.frbs 3956 button $w.fr.frbs.ok -text $TXT(ok) -command { set Dfctrl 1 } \ 3957 -state disabled 3958 button $w.fr.frbs.cnc -text $TXT(cancel) -command { set Dfctrl 0 } 3959 3960 pack $w.fr.frbs.ok $w.fr.frbs.cnc -side left 3961 grid configure $w.fr.text -row 0 -column 0 -columnspan 2 3962 grid configure $map -row 1 -column 0 -sticky nesw 3963 grid configure $w.fr.mvscr -row 1 -column 1 -sticky ns 3964 grid configure $w.fr.mhscr -row 2 -column 0 -sticky ew 3965 grid configure $w.fr.frbs -row 3 -column 0 -columnspan 2 -pady 5 3966 pack $w.fr 3967 # control is taken by the cursor procs; the "Ok" button is only 3968 # enabled when the WP is placed in which case the relevant coordinates 3969 # are stored in $MapLoadPos(0,x) and $MapLoadPos(0,y) 3970 update idletasks 3971 set gs [grab current] 3972 grab $w 3973 RaiseWindow $w 3974 tkwait variable Dfctrl 3975 DestroyRGrabs $w $gs 3976 if { $Dfctrl == 0 } { return -1 } 3977 return 0 3978} 3979 3980proc MapNGScroll {dim args} { 3981 # scroll non-grid image map and set corresponding coordinate of origin 3982 # of visible region 3983 # $dim in {x, y}, $args suitable to xview/yview commands 3984 # scrollbar 3985 3986 eval .mapng.fr.map ${dim}view $args 3987 MapNGSetVOrigin $dim 3988 return 3989} 3990 3991proc MapNGSetVOrigin {dim} { 3992 # set coordinate of origin of visible region of non-grid image map 3993 # $dim in {x, y} 3994 global MapNGOV$dim MapNGRange$dim 3995 3996 set sc [lindex [.mapng.fr.map ${dim}view] 0] 3997 set MapNGOV$dim [expr $sc*[set MapNGRange$dim]] 3998 return 3999} 4000 4001proc MapNGCursor {} { 4002 # start following pointer on non-grid image map while waypoint is not 4003 # placed 4004 # name of WP to place is in $MapLoadWPNs 4005 global MapLoadWPNs MAPCOLOUR MapNGLoading 4006 4007 if { $MapNGLoading } { 4008 set map .mapng.fr.map 4009 $map delete mapfix 4010 $map create text 100 100 -fill $MAPCOLOUR(mapsel) -anchor sw \ 4011 -text $MapLoadWPNs -justify left -tags mapfix 4012 } 4013 return 4014} 4015 4016proc UnMapNGCursor {} { 4017 # stop following pointer on non-grid image map 4018 4019 .mapng.fr.map delete mapfix 4020 return 4021} 4022 4023proc MapNGCursorMotion {x y} { 4024 # follow pointer on non-grid image map 4025 global MapNGOVx MapNGOVy CRHAIRx CRHAIRy MapNGCursorPos 4026 4027 set MapNGCursorPos [list $x $y] 4028 .mapng.fr.map coords mapfix [expr $MapNGOVx+$x-$CRHAIRx] \ 4029 [expr $MapNGOVy+$y-$CRHAIRy] 4030 return 4031} 4032 4033proc MapNGCursorUpdate {} { 4034 # update cursor coordinates after scrolling 4035 global MapNGCursorPos 4036 4037 if { ! [catch {set MapNGCursorPos}] } { 4038 eval MapNGCursorMotion $MapNGCursorPos 4039 } 4040 return 4041} 4042 4043proc MarkMapNGPoint {x y} { 4044 # place waypoint on non-grid image map 4045 global MapNGOVx MapNGOVy CRHAIRx CRHAIRy MapLoadPos MapNGLoading \ 4046 MAPCOLOUR ICONHEIGHT MapFont MapLoadWPs MapLoadWPNs WPSymbol 4047 4048 if { $MapNGLoading } { 4049 set MapNGLoading 0 4050 set map .mapng.fr.map 4051 $map delete mapfix 4052 set x [expr $MapNGOVx+$x-$CRHAIRx] ; set y [expr $MapNGOVy+$y-$CRHAIRy] 4053 set MapLoadPos(0,x) $x ; set MapLoadPos(0,y) $y 4054 $map create rectangle [expr $x-1] [expr $y-1] \ 4055 [expr $x+1] [expr $y+1] -fill $MAPCOLOUR(WP) \ 4056 -outline $MAPCOLOUR(WP) 4057 $map create text $x [expr $y-6-$ICONHEIGHT/2.0] \ 4058 -text $MapLoadWPNs -fill $MAPCOLOUR(WP) -font $MapFont \ 4059 -justify center 4060 set syim [lindex [SymbolImageName $WPSymbol($MapLoadWPs)] 0] 4061 $map create image $x $y -anchor center -image $syim 4062 .mapng.fr.frbs.ok configure -state normal 4063 } 4064 return 4065} 4066 4067## BSB contribution 4068 4069proc LoadIndexedMap {path} { 4070 # this loads a fixed or geo-referenced image as background for the map 4071 4072 set r [LoadMapFixedBk $path] 4073 switch -- [lindex $r 0] { 4074 0 { 4075 # no geo-referencing during auto-load 4076 } 4077 1 { 4078 eval LoadMapBackGeoRef [lrange $r 1 end] 4079 } 4080 } 4081 return 4082} 4083 4084 4085#### locate or clear items on map 4086 4087proc Locate {wh ix it} { 4088 # scroll map to get displayed item on centre 4089 # $wh in $TYPES 4090 # $ix (not in use) is item index 4091 # $it is map item for main element of (data-base) item 4092 global Map OVx OVy MAPW2 MAPH2 PrevCentre 4093 4094 if { [set cs [$Map coords $it]] != "" } { 4095 set PrevCentre [list [lindex [$Map xview] 0] [lindex [$Map yview] 0]] 4096 ScrollMapTo [lindex $cs 0] [lindex $cs 1] \ 4097 [expr $OVx+$MAPW2] [expr $OVy+$MAPH2] 4098 } 4099 return 4100} 4101 4102proc LocatePrevious {} { 4103 # scroll map to get back to previous centre 4104 global Map PrevCentre 4105 4106 if { [set p $PrevCentre] != "" } { 4107 set PrevCentre [list [lindex [$Map xview] 0] [lindex [$Map yview] 0]] 4108 ScrollMap x moveto [lindex $p 0] 4109 ScrollMap y moveto [lindex $p 1] 4110 } 4111 return 4112} 4113 4114proc SelectApplyMapped {wh mode comm} { 4115 # select one or more items currently displayed on map and apply 4116 # a command to them 4117 # $wh is type (in $TYPES except GR) of items 4118 # $mode is selection mode (1st arg to proc GMChooseFrom) 4119 # $comm is command to invoke with the following arguments: 4120 # $wh, item index and map item 4121 # if $wh in {RT, TR, LN} the map item is for the first point 4122 # of the selected item 4123 global Map TXT LISTWIDTH RTIdNumber RTWPoints TRName LNName 4124 4125 set ns "" ; set ixmits "" 4126 switch $wh { 4127 WP { 4128 foreach it [$Map find withtag WP&&sq2] { 4129 set ts [$Map gettags $it] 4130 if { [set k1 [lsearch -glob $ts WP=*]] != -1 && \ 4131 [set k2 [lsearch -glob $ts forWP=*]] != -1 } { 4132 regsub WP= [lindex $ts $k1] "" n 4133 regsub forWP= [lindex $ts $k2] "" ix 4134 lappend ns [list $n $ix $it] 4135 } 4136 } 4137 } 4138 RT { 4139 foreach it [$Map find withtag WP&&sq2] { 4140 set ts [$Map gettags $it] 4141 if { [set k1 [lsearch -glob $ts inRT=*]] != -1 && \ 4142 [set k2 [lsearch -glob $ts WP=*]] != -1 } { 4143 regsub inRT= [lindex $ts $k1] "" ix 4144 regsub WP= [lindex $ts $k2] "" wpn 4145 if { [lindex $RTWPoints($ix) 0] == $wpn } { 4146 lappend ns [list $RTIdNumber($ix) $ix $it] 4147 } 4148 } 4149 } 4150 } 4151 TR - LN { 4152 foreach it [$Map find withtag ${wh}first] { 4153 set ts [$Map gettags $it] 4154 if { [set k [lsearch -glob $ts ${wh}=*]] != -1 } { 4155 regsub ${wh}= [lindex $ts $k] "" ix 4156 if { $ix != -1 } { 4157 # test as in previous version... 4158 lappend ns [list [set ${wh}Name($ix)] $ix $it] 4159 } 4160 } 4161 } 4162 } 4163 } 4164 if { [set ns [lsort -dictionary -index 0 $ns]] == "" } { return } 4165 set lns "" ; set lvs "" 4166 foreach t $ns { 4167 lappend lns [lindex $t 0] 4168 lappend lvs [lreplace $t 0 0] 4169 } 4170 foreach p [GMChooseFrom $mode [list $TXT(select) $TXT(name$wh)] \ 4171 $LISTWIDTH $lns $lvs] { 4172 $comm $wh [lindex $p 0] [lindex $p 1] 4173 } 4174 return 4175} 4176 4177proc SelectApplyUnmapped {wh mode comm} { 4178 # select one or more items not currently displayed on map and apply 4179 # a command to them 4180 # $wh is type (in $TYPES) of items 4181 # $mode is selection mode (1st arg to proc GMChooseFrom) 4182 # $comm is command to invoke with the following arguments: 4183 # $wh, item index 4184 global Map TXT TYPES LISTWIDTH Storage 4185 4186 set ids [lindex $Storage($wh) 0] 4187 global $ids ${wh}Displ 4188 4189 set ns "" 4190 foreach ix [array names $ids] { 4191 if { ! [set ${wh}Displ($ix)] } { 4192 lappend ns [list [set [set ids]($ix)] $ix] 4193 } 4194 } 4195 if { [set ns [lsort -dictionary -index 0 $ns]] == "" } { return } 4196 set lns "" ; set lvs "" 4197 foreach p $ns { 4198 lappend lns [lindex $p 0] ; lappend lvs [lindex $p 1] 4199 } 4200 foreach ix [GMChooseFrom $mode [list $TXT(select) $TXT(name$wh)] \ 4201 $LISTWIDTH $lns $lvs] { 4202 $comm $wh $ix 4203 } 4204 return 4205} 4206 4207### DJG contribution 4208proc NewGroupFromMap {mapped} { 4209 # Create a group based on the currently mapped (or unmapped) data 4210 global TXT Storage TYPES 4211 4212 set ixmits "" 4213 # MF change: using $TYPES 4214 set whs [Delete $TYPES GR] 4215 #-- 4216 if ($mapped) { 4217 set namebase $TXT(dispitems) 4218 foreach wh $whs { 4219 set ${wh}ns "" 4220 set ids [lindex $Storage($wh) 0] 4221 global $ids ${wh}Displ 4222 foreach ix [array names $ids] { 4223 if { [set ${wh}Displ($ix)] } { 4224 lappend ${wh}ns [set [set ids]($ix)] 4225 } 4226 } 4227 } 4228 } else { 4229 set namebase $TXT(hiditems) 4230 foreach wh $whs { 4231 set ${wh}ns "" 4232 set ids [lindex $Storage($wh) 0] 4233 global $ids ${wh}Displ 4234 foreach ix [array names $ids] { 4235 if { ! [set ${wh}Displ($ix)] } { 4236 lappend ${wh}ns [set [set ids]($ix)] 4237 } 4238 } 4239 } 4240 } 4241 # MF change: leaving out void types and returning if there are no items 4242 set contents "" 4243 foreach wh $whs { 4244 if { [set ${wh}ns] != "" } { 4245 lappend contents [list $wh [set ${wh}ns]] 4246 } 4247 } 4248 if { $contents == "" } { bell ; return } 4249 #-- 4250 # Now find a name for this group 4251 # MF change: using proc CreateGRFor 4252 CreateGRFor "=$namebase" "" $contents 4253 return 4254} 4255 4256