1# wdgeomap.tcl -- 2# 3# This file provides the tkgeomap_procs package, which augments the 4# tkgeolinearray and tkgeoplace extensions. See the tkgeomap_procs (n) 5# man page for details. 6# 7# Copyright (c) 2005 Gordon D. Carrie. All rights reserved. 8# 9# Licensed under the Open Software License version 2.1 10# 11# Please address questions and feedback to user0@tkgeomap.org 12# 13# @(#) $Id: wdgeomap.tcl,v 1.50 2009/10/23 20:37:25 tkgeomap Exp $ 14 15package require tkgeomap 2 16package require tclgeomap_procs 2 17package provide wdgeomap 2.11.6 18 19namespace eval ::geomap::wdgeomap {} 20 21# ::geomap::wdgeomap::create -- 22# 23# This procedure creates an interactive geographic 24# 25# Arguments: 26# map - map identifier, name of map command. 27# map_frame - frame to hold map and controls. 28# args - configuration arguments. 29# 30# Results: 31# See the user documentation. 32 33proc ::geomap::wdgeomap::create {map map_frame args} { 34 35 # Create widgets and initialize a private namespace for the map. 36 37 set ns ::geomap::wdgeomap::$map 38 set ns [namespace eval $ns {namespace current}] 39 variable map_ns 40 set map_ns($map) $ns 41 frame $map_frame 42 set ${ns}::map_frame $map_frame 43 variable map_tl 44 set toplev [winfo toplevel $map_frame] 45 set map_tl($toplev) $map 46 set map_canvas ${map_frame}.canvas 47 canvas $map_canvas 48 set ${ns}::map_canvas $map_canvas 49 50 # This list determines the stacking order for map items. 51 52 set ${ns}::layers {} 53 54 # These bindtags will be used to adjust motion bindings as map position 55 # and projection change. 56 57 bindtags $map_canvas \ 58 [linsert [bindtags $map_canvas] 0 geomap_center geomap_motion] 59 60 # These are the canvas coordinates of the map center. 61 # Initialize them with bogus values, then set them properly with the 62 # setcenter procedure, which is defined below. 63 64 set ${ns}::xCtr 0 65 set ${ns}::yCtr 0 66 setcenter $map 67 bind geomap_center <Configure> [namespace code [list setcenter $map]] 68 69 # Initialize map parameters. 70 71 variable ${ns}::refpoint [list 0.0 0.0] 72 variable ${ns}::projname Mercator 73 variable ${ns}::projId [::geomap::projection Mercator 0.0] 74 variable ${ns}::scale 1.0e-7 75 variable ${ns}::boundcirclecolor Black 76 variable ${ns}::update "" 77 variable ${ns}::bindings {} 78 variable ${ns}::lazy 0 79 variable ${ns}::projections {CylEqDist Mercator CylEqArea LambertConfConic \ 80 LambertEqArea Stereographic PolarStereographic Orthographic} 81 variable ${ns}::scales {1:10000000 1:20000000 1:30000000 1:45000000 \ 82 1:60000000 1:90000000 1:120000000} 83 variable ${ns}::rotationmenu 1 84 85 # Create the menu bar and default menus. 86 87 set ${ns}::mbar [frame ${map_frame}.mbar -relief raised -borderwidth 3] 88 set m [addmenu $map "File"] 89 $m add command -label "Postscript" \ 90 -command [namespace code [list postscript $map]] 91 $m add command -label "Quit" -command {exit} 92 addmenu $map "Projection" 93 addmenu $map "Scale" 94 set m [addmenu $map "Top"] 95 foreach r {north ne east se south sw west nw} { 96 set cmd [namespace code [list configure $map -rotation $r]] 97 $m add command -label $r -command $cmd 98 } 99 unset -nocomplain r 100 101 # Pack widgets in main frame. 102 # Frame should be positioned by caller. 103 104 pack forget $map_canvas 105 pack ${map_frame}.mbar -fill x 106 pack $map_canvas -fill both -expand true 107 108 # Create a bogus item. This ensures that calculations that 109 # assume the existence of at least one item with the geomap tag 110 # will always work. 111 112 draw $map geomap_place "" 113 114 # Initialize configuration 115 116 configure $map -projname $projname -projections $projections \ 117 -scales $scales -rotationmenu $rotationmenu 118 if {[llength $args] > 0} { 119 set cmd [linsert $args 0 configure $map] 120 eval $cmd 121 } 122} 123 124# ::geomap::wdgeomap::map_proc -- 125# 126# This is the callback for map commands created by the wdgeomap 127# procedure. 128# 129# Arguments: 130# map - map identifier. 131# cmd - command to execute. 132# args - options to the command. 133# 134# Results: 135# A procedure corresponding to cmd is called with map as one of 136# its arguments. 137 138proc ::geomap::wdgeomap::map_proc {map cmd args} { 139 set commands [list \ 140 "create" "map_proc" "name" "canvas" "mbar" "color_dialog" \ 141 "xytolatlon" "latlontoxy" \ 142 "setcenter" "configure" "cget" "draw" "erase" \ 143 "set_layers" "get_layers" "add_layer" "rm_layer" \ 144 "layers_dlg_drag" "layers_dlg_brelease" "set_layers_dlg" \ 145 "item_cmp" "y_cart" "y_canvas" \ 146 "addmenu" "getmenu" "deletemenu" \ 147 "ctr_reflon" "ctr_refpt" \ 148 "setcolor" "setcolorscript" "getcolor" \ 149 "choose_color" "load_colors" "save_colors" "undo_colors" \ 150 "set_colors_dlg" "postscript" "delete"] 151 if {[lsearch -exact $commands $cmd] < 0} { 152 error "$map: unknown subcommand \"$cmd\"" 153 } 154 eval [linsert $args 0 $cmd $map] 155} 156 157# ::geomap::wdgeomap::name -- 158# 159# Create a unique map name. This should be used in window titles, 160# widget names, and other places that need an identifier that will 161# not conflict with other map names. 162# 163# Arguments: 164# map - map identifier 165# 166# Results: 167# Return value is fully qualified map name, with the :: separators 168# replaced with _ characters. 169 170proc ::geomap::wdgeomap::name {map} { 171 return [string map {:: _} [string range $map 2 end]] 172} 173 174# ::geomap::wdgeomap::map_canvas -- 175# 176# Return the name of the map_canvas. 177# 178# Arguments: 179# map - map identifier 180 181proc ::geomap::wdgeomap::map_canvas {map} { 182 variable map_ns 183 set ns $map_ns($map) 184 variable ${ns}::map_canvas 185 return $map_canvas 186} 187 188# ::geomap::wdgeomap::mbar -- 189# 190# Return the name of the menu bar. 191# 192# Arguments: 193# map - map identifier 194 195proc ::geomap::wdgeomap::mbar {map} { 196 variable map_ns 197 set ns $map_ns($map) 198 variable ${ns}::mbar 199 return $mbar 200} 201 202# ::geomap::wdgeomap::xytolatlon -- 203# 204# Convert x y canvas coordinates in 205# the map canvas to {latitude longitude} 206# 207# Arguments: 208# map - map identifier. 209# args - list of canvas coordinates of form 210# {?-catch? x1 y1 x2 y2 ...} 211# If first word of args is "-catch" skip points that 212# cannot be converted. 213# 214# Results: 215# Return value is a list of form {{lat1 lon1} {lat2 lon2} ...} 216# giving the geographic coordinates of the canvas points. 217 218proc ::geomap::wdgeomap::xytolatlon {map args} { 219 variable map_ns 220 set ns $map_ns($map) 221 variable ${ns}::map_canvas 222 variable ${ns}::refpoint 223 variable ${ns}::projId 224 variable ${ns}::scale 225 226 if {[lindex $args 0] == "-catch"} { 227 set catch 1 228 set args [lrange $args 1 end] 229 } else { 230 set catch 0 231 } 232 233 # Map coordinates of reference point 234 235 set mpt0 [::geomap::scalept [$projId fmlatlon $refpoint] $scale] 236 set abs0 [lindex $mpt0 0] 237 set ord0 [lindex $mpt0 1] 238 239 # Map coordinates of args = {x y ...} 240 241 set coords [$map_canvas coords geomap] 242 set x0 [lindex $coords 0] 243 set y0 [lindex $coords 1] 244 set mPerPx [expr {0.0254 / 72.0 / [tk scaling]}] 245 set l [llength $args] 246 set s_inv [expr {1.0 / $scale}] 247 if {$l == 2} { 248 set x [lindex $args 0] 249 set y [lindex $args 1] 250 set abs [expr {$abs0 - ($x0 - $x) * $mPerPx}] 251 set ord [expr {$ord0 + ($y0 - $y) * $mPerPx}] 252 set mpt [list $abs $ord] 253 set mpt [::geomap::scalept $mpt $s_inv] 254 if $catch { 255 if {[catch [list $projId tolatlon $mpt] gpt] == 0} { 256 return $gpt 257 } else { 258 return {} 259 } 260 } else { 261 return [$projId tolatlon $mpt] 262 } 263 } elseif {$l % 2 == 0} { 264 set r {} 265 if $catch { 266 foreach {x y} $args { 267 set abs [expr {$abs0 - ($x0 - $x) * $mPerPx}] 268 set ord [expr {$ord0 + ($y0 - $y) * $mPerPx}] 269 set mpt [list $abs $ord] 270 set mpt [::geomap::scalept $mpt $s_inv] 271 if {[catch [list $projId tolatlon $mpt] gpt] == 0} { 272 lappend r $gpt 273 } 274 } 275 } else { 276 foreach {x y} $args { 277 set abs [expr {$abs0 - ($x0 - $x) * $mPerPx}] 278 set ord [expr {$ord0 + ($y0 - $y) * $mPerPx}] 279 set mpt [list $abs $ord] 280 set mpt [::geomap::scalept $mpt $s_inv] 281 lappend r [$projId tolatlon $mpt] 282 } 283 } 284 return $r 285 } else { 286 error "Number of coordinates cannot be odd" 287 } 288} 289 290# ::geomap::wdgeomap::latlontoxy -- 291# 292# Convert a lat-lon values to x y 293# coordinates in the map_canvas window. 294# 295# Arguments: 296# map - map identifier. 297# args - a list of form {-catch {lat1 lon1} {lat2 lon2} ...} 298# giving geographic locations. 299# 300# Results: 301# Return value is a list of form {x1 y1 x2 y2 ...} giving the 302# canvas coordinates corresponding to the input lat-lon's. 303 304proc ::geomap::wdgeomap::latlontoxy {map args} { 305 variable map_ns 306 set ns $map_ns($map) 307 variable ${ns}::map_canvas 308 variable ${ns}::refpoint 309 variable ${ns}::projId 310 variable ${ns}::scale 311 312 if {[lindex $args 0] == "-catch"} { 313 set catch 1 314 set args [lrange $args 1 end] 315 } else { 316 set catch 0 317 } 318 319 set coords [$map_canvas coords geomap] 320 set x0 [lindex $coords 0] 321 set y0 [lindex $coords 1] 322 set pxPerM [expr {72.0 * [tk scaling] / 0.0254}] 323 324 # Map coordinates of reference point 325 326 set mpt0 [::geomap::scalept [$projId fmlatlon $refpoint] $scale] 327 set absC [lindex $mpt0 0] 328 set ordC [lindex $mpt0 1] 329 330 # Map coordinates of point 331 332 set r {} 333 if $catch { 334 foreach geoPt $args { 335 if {[catch [::geomap::scalept [$projId fmlatlon $geoPt] $scale] mpt] 336 == 0} { 337 set abs [lindex $mpt 0] 338 set ord [lindex $mpt 1] 339 set x [expr {$x0 + ($abs - $absC) * $pxPerM}] 340 set y [expr {$y0 - ($ord - $ordC) * $pxPerM}] 341 lappend r $x $y 342 } 343 } 344 } else { 345 foreach geoPt $args { 346 set mpt [::geomap::scalept [$projId fmlatlon $geoPt] $scale] 347 set abs [lindex $mpt 0] 348 set ord [lindex $mpt 1] 349 set x [expr {$x0 + ($abs - $absC) * $pxPerM}] 350 set y [expr {$y0 - ($ord - $ordC) * $pxPerM}] 351 lappend r $x $y 352 } 353 } 354 return $r 355} 356 357# ::geomap::wdgeomap::setcenter -- 358# 359# Put the map refpoint at the canvas 360# center. 361# 362# Arguments: 363# map - map identifier. 364# 365# Results: 366# coords are set for geomap_lnarr and geomap_place items in the 367# canvas. 368# Return value is list of coordinates of map_canvas center. 369 370proc ::geomap::wdgeomap::setcenter {map} { 371 variable map_ns 372 set ns $map_ns($map) 373 variable ${ns}::map_canvas 374 variable ${ns}::xCtr 375 variable ${ns}::yCtr 376 377 set xCtr [expr {[winfo width $map_canvas] / 2}] 378 set yCtr [expr {[winfo height $map_canvas] / 2}] 379 foreach item [$map_canvas find withtag geomap] { 380 $map_canvas coords $item $xCtr $yCtr 381 } 382 return [list $xCtr $yCtr] 383} 384 385# ::geomap::wdgeomap::configure -- 386# 387# Configure map. 388# 389# Arguments: 390# map - map identifier. 391# args - a list of form {-opt arg ?-opt arg ...?} specifying 392# the configuration options and values. 393# 394# Results: 395# Namespace variables and the associated widgets are updated. 396 397proc ::geomap::wdgeomap::configure {map args} { 398 variable map_ns 399 set ns $map_ns($map) 400 variable ${ns}::map_frame 401 variable ${ns}::map_canvas 402 variable ${ns}::mbar 403 variable ${ns}::refpoint 404 variable ${ns}::projname 405 variable ${ns}::projId 406 variable ${ns}::scale 407 variable ${ns}::lazy 408 variable ${ns}::projections 409 variable ${ns}::scales 410 variable ${ns}::rotationmenu 411 variable ${ns}::bindings 412 variable ${ns}::update 413 variable ${ns}::boundcirclecolor 414 415 set bound_circle ${ns}::bound_circle 416 foreach {opt arg} $args { 417 switch -- $opt { 418 -refpoint { 419 $map_canvas itemconfigure geomap -refpoint $arg 420 set refpoint $arg 421 uplevel #0 $update 422 } 423 -projname { 424 set projections [::geomap::projections] 425 if {[lsearch $projections $arg] < 0} { 426 error "Projection must be one of $projections" 427 } 428 set projname $arg 429 430 # Delete old bound circle 431 432 if {[namespace which -command $bound_circle] != ""} { 433 erase $map geomap_lnarr bound_circle 434 rename $bound_circle {} 435 } 436 437 # Set projection 438 439 set proj_info [::geomap::proj_info [cget $map -projname]] 440 set ref [lindex $proj_info 0] 441 set domain [lindex $proj_info 1] 442 if {$ref == "longitude"} { 443 set lon [::geomap::longitude $refpoint] 444 eval $projId set $projname $lon 445 } elseif {$ref == "point"} { 446 if {$projname == "PolarStereographic"} { 447 set lat [::geomap::latitude $refpoint] 448 if {$lat > 0.0} { 449 set refpoint {90.0 0.0} 450 eval $projId set PolarStereographic N 451 } else { 452 set refpoint {-90.0 0.0} 453 eval $projId set PolarStereographic S 454 } 455 } else { 456 eval $projId set $projname $refpoint 457 } 458 } else { 459 error "Unable to set $projname projection" 460 } 461 462 # If necessary, draw new bound circle 463 464 if {$ref == "point" && $domain == "hemisphere"} { 465 ::geomap::lnarr fmlist $bound_circle \ 466 [::geomap::circle $refpoint 89.9] 467 draw $map geomap_lnarr $bound_circle \ 468 -outline $boundcirclecolor \ 469 -tags "bound_circle" 470 } 471 472 # Run update script 473 474 uplevel #0 $update 475 } 476 -scale { 477 if ![string is double $arg] { 478 set scale [::geomap::cartg $arg] 479 } else { 480 set scale $arg 481 } 482 $map_canvas itemconfigure geomap -scale $scale 483 uplevel #0 $update 484 } 485 -rotation { 486 $projId rotation $arg 487 uplevel #0 $update 488 } 489 -boundcirclecolor { 490 $map_canvas itemconfigure bound_circle -outline $arg 491 set boundcirclecolor $arg 492 } 493 -update { 494 set update $arg 495 } 496 -colormenu { 497 if ![string is boolean $arg] { 498 error "lazy must be boolean" 499 } 500 set mb [getmenu $map "File"] 501 set m [$mb cget -menu] 502 if $arg { 503 if {[catch [list $m index "Colors"]] != 0} { 504 set cmd [namespace code [list set_colors_dlg $map]] 505 $m insert 0 command -label "Colors" -command $cmd 506 } 507 variable ${ns}::color_dlg .[name $map]_colors 508 } else { 509 if {[catch [list $m index "Colors"] i] == 0} { 510 $m delete $i 511 } 512 } 513 } 514 -layermenu { 515 if ![string is boolean $arg] { 516 error "lazy must be boolean" 517 } 518 set mb [getmenu $map "File"] 519 set m [$mb cget -menu] 520 if $arg { 521 if {[catch [list $m index "Layers"]] != 0} { 522 set cmd [namespace code [list set_layers_dlg $map]] 523 $m insert 0 command -label "Layers" -command $cmd 524 } 525 } else { 526 if {[catch [list $m index "Layers"] i] == 0} { 527 $m delete $i 528 } 529 } 530 } 531 -lazy { 532 if ![string is boolean $arg] { 533 error "lazy must be boolean" 534 } 535 set lazy $arg 536 } 537 -projections { 538 # Replace the selections in the Projections menu 539 # with the given list. 540 541 set projections $arg 542 set mb [getmenu $map "Projection"] 543 set m [$mb cget -menu] 544 $m delete 2 end 545 if {[llength $projections] == 0} { 546 pack forget $mb 547 } else { 548 foreach p $projections { 549 set cmd [namespace code \ 550 [list configure $map -projname $p]] 551 $m add command -label $p -command $cmd 552 } 553 pack $mb -side left 554 } 555 } 556 -scales { 557 # Replace the selections in the Scales menu 558 # with the given list. 559 560 set scales $arg 561 set mb [getmenu $map "Scale"] 562 set m [$mb cget -menu] 563 $m delete 0 end 564 if {[llength $scales] == 0} { 565 pack forget $mb 566 } else { 567 foreach s $scales { 568 set cmd [namespace code [list configure $map -scale $s]] 569 $m add command -label $s -command $cmd 570 } 571 pack $mb -side left 572 } 573 } 574 -rotationmenu { 575 # Display or hide the rotations menu as requested. 576 577 set rotationmenu $arg 578 set mb [getmenu $map "Top"] 579 if {$rotationmenu} { 580 pack $mb -side left 581 } else { 582 pack forget $mb 583 } 584 } 585 default { 586 if {[catch [list $map_canvas configure $opt $arg] msg] != 0} { 587 error "Could not configure $opt" 588 } 589 } 590 } 591 } 592} 593 594# ::geomap::wdgeomap::cget -- 595# 596# Retrieve a configuration option. 597# 598# Arguments: 599# map - map identifier. 600# option - configuration option whose value is sought. 601# 602# Results: 603# The value of a configuration option. 604 605proc ::geomap::wdgeomap::cget {map option} { 606 variable map_ns 607 set ns $map_ns($map) 608 variable ${ns}::map_canvas 609 variable ${ns}::refpoint 610 variable ${ns}::projname 611 variable ${ns}::projId 612 variable ${ns}::scale 613 variable ${ns}::boundcirclecolor 614 variable ${ns}::lazy 615 variable ${ns}::projections 616 variable ${ns}::scales 617 variable ${ns}::rotationmenu 618 619 switch -- $option { 620 -refpoint { 621 return $refpoint 622 } 623 -projname { 624 return $projname 625 } 626 -scale { 627 return $scale 628 } 629 -rotation { 630 return [$projId rotation] 631 } 632 -boundcirclecolor { 633 return $boundcirclecolor 634 } 635 -projname { 636 return $projname 637 } 638 -lazy { 639 return $lazy 640 } 641 -projections { 642 return $projections 643 } 644 -scales { 645 return $scales 646 } 647 -rotationmenu { 648 return $rotationmenu 649 } 650 default { 651 if {[catch [list $map_canvas cget $option $arg] msg] != 0} { 652 error "Unknown configuration option $option" 653 } 654 } 655 } 656} 657 658# ::geomap::wdgeomap::draw -- 659# 660# Create a new geomap_lnarr or geomap_place item, 661# or re-configures an old one. 662# 663# Arguments: 664# map - map identifier. 665# type - geomap_lnarr or geomap_place 666# name - fully qualified name of the lnarr or place. 667# args - list of form {-option arg ?-option arg ...?} giving 668# options to pass to the item. See the tkgeomap (n) 669# man page for details. 670# 671# Results: 672# An item is created or configured. 673# Return value is the item identifier for new or modified item. 674 675proc ::geomap::wdgeomap::draw {map type name args} { 676 variable map_ns 677 set ns $map_ns($map) 678 variable ${ns}::map_canvas 679 variable ${ns}::xCtr 680 variable ${ns}::yCtr 681 variable ${ns}::refpoint 682 variable ${ns}::projId 683 variable ${ns}::scale 684 685 array set config $args 686 switch -exact -- $type { 687 geomap_lnarr { 688 array set config [list -lnarr $name -refpoint $refpoint \ 689 -projection $projId -scale $scale] 690 if {$name != "" 691 && [set id [$map_canvas find withtag $name]] != "" 692 && [$map_canvas type $id] == "geomap_lnarr"} { 693 # Configure pre-existing geomap_lnarr item. 694 695 eval $map_canvas itemconfigure $id [array get config] 696 } else { 697 # Create new geomap_lnarr item. 698 699 set id [eval $map_canvas create geomap_lnarr \ 700 $xCtr $yCtr [array get config]] 701 } 702 } 703 geomap_place { 704 array set config [list -place $name -refpoint $refpoint \ 705 -projection $projId -scale $scale] 706 if {$name != "" 707 && [set id [$map_canvas find withtag $name]] != "" 708 && [$map_canvas type $id] == "geomap_place"} { 709 # Configure pre-existing geomap_place item. 710 711 eval $map_canvas itemconfigure $id $args 712 } else { 713 # Create new geomap_place item. 714 715 set id [eval $map_canvas create geomap_place \ 716 $xCtr $yCtr [array get config]] 717 } 718 } 719 default { 720 error "Type must be \"geomap_lnarr\" or \"geomap_place\"" 721 } 722 } 723 $map_canvas addtag $name withtag $id 724 $map_canvas addtag geomap withtag $id 725 return $id 726} 727 728# ::geomap::wdgeomap::erase -- 729# 730# Deletes and item created with the draw command. 731# 732# Arguments: 733# map - map identifier. 734# type - geomap_lnarr or geomap_place 735# name - the name of the place or linearray given to the draw 736# command. 737# 738# Results: 739# None. 740 741proc ::geomap::wdgeomap::erase {map type name} { 742 variable map_ns 743 set ns $map_ns($map) 744 variable ${ns}::map_canvas 745 746 if {$type != "geomap_lnarr" && $type != "geomap_place"} { 747 error "Type must be \"geomap_lnarr\" or \"geomap_place\"" 748 } 749 foreach id [$map_canvas find withtag $name] { 750 if {[$map_canvas type $id] == $type} { 751 $map_canvas delete $id 752 break 753 } 754 } 755} 756 757# ::geomap::wdgeomap::set_layers -- 758# 759# Sets the drawing sequence for certain canvas items. 760# 761# Arguments: 762# map - map identifier. 763# 764# Results: 765# The drawing sequence for items in the canvas may be changed. 766 767proc ::geomap::wdgeomap::set_layers {map} { 768 variable map_ns 769 set ns $map_ns($map) 770 variable ${ns}::map_canvas 771 variable ${ns}::layers 772 773 if { ![info exists layers] } { 774 return 775 } 776 foreach layer $layers { 777 if {[llength [$map_canvas find withtag $layer]] > 0} { 778 if { [info exists aboveThis] } { 779 $map_canvas raise $layer $aboveThis 780 } else { 781 $map_canvas raise $layer 782 } 783 set aboveThis $layer 784 } 785 } 786 787 788 # Update layer dialog if present 789 790 variable ${ns}::layer_dlg 791 if {[info exists layer_dlg] && [winfo exists $layer_dlg]} { 792 set_layers_dlg $map 793 } 794} 795 796# ::geomap::wdgeomap::get_layers -- 797# 798# Retrieve the map's layer list. 799# 800# Arguments: 801# map - map identifier. 802# 803# Results: 804# Return value is the map's layer list. 805 806proc ::geomap::wdgeomap::get_layers {map} { 807 variable map_ns 808 set ns $map_ns($map) 809 variable ${ns}::layers 810 811 if { ![info exists layers] } { 812 set layers {} 813 } 814 return $layers 815} 816 817# ::geomap::wdgeomap::add_layer -- 818# 819# Add a set of items to the layer list. 820# 821# Arguments: 822# map - map identifier. 823# layer - name for the layer. The map layer procedures will 824# manage the stacking order for items with tag "$layer". 825# 826# Results: 827# The map's layer list is modified. The stacking order for items 828# in the canvas might change. 829 830proc ::geomap::wdgeomap::add_layer {map layer} { 831 variable map_ns 832 set ns $map_ns($map) 833 variable ${ns}::layers 834 835 # Skip if layer is already in layers 836 837 if {[lsearch $layers $layer] >= 0} { 838 return 839 } 840 841 # Find out if layer belongs in a hierarchy in layers. 842 # If so, insert it at the end of that tree. Otherwise, 843 # insert it at the end of the layers list. 844 845 set sub {} 846 foreach elem $layer { 847 lappend sub $elem 848 lappend subs $sub 849 } 850 set long "" 851 set i 0 852 set i_long [llength $layers] 853 foreach layer0 $layers { 854 foreach sub $subs { 855 set ll [expr {[llength $sub] - 1}] 856 set sub0 [lrange $layer0 0 $ll] 857 if {$sub0 == $sub && [llength $sub0] >= [llength $long]} { 858 set long $sub0 859 set i_long $i 860 } 861 } 862 incr i 863 } 864 set layers [linsert $layers [expr {$i_long + 1}] $layer] 865} 866 867# ::geomap::wdgeomap::update_tree -- 868# 869# Update the layer hierarchy 870# 871# Arguments: 872# map - map identifier. 873# 874# Results: 875# The map's layer list is modified. The stacking order for items 876# in the canvas might change. 877 878proc ::geomap::wdgeomap::update_tree {map} { 879 variable map_ns 880 set ns $map_ns($map) 881 variable ${ns}::layers 882 variable ${ns}::items 883 variable ${ns}::leaves 884 variable ${ns}::parent 885 variable ${ns}::children 886 variable ${ns}::all_children 887 variable ${ns}::leaves 888 889 set items {} 890 array unset children 891 array unset all_children 892 array unset leaves 893 array unset parent 894 foreach layer $layers { 895 set ll [llength $layer] 896 for {set i 0} {$i < $ll} {incr i} { 897 set item [lrange $layer 0 $i] 898 if {[lsearch $items $item] < 0} { 899 lappend items $item 900 set children($item) {} 901 set all_children($item) {} 902 set leaves($item) {} 903 set parent($item) {} 904 } 905 lappend leaves($item) $layer 906 set i1 [expr {$i + 1}] 907 if {$i1 < $ll} { 908 set child [lrange $layer 0 $i1] 909 if {$child != ""} { 910 lappend children($item) $child 911 } 912 set child $item 913 foreach addit [lrange $layer $i1 end] { 914 lappend child $addit 915 lappend all_children($item) $child 916 } 917 } 918 } 919 } 920 foreach item $items { 921 foreach child $children($item) { 922 set parent($child) $item 923 } 924 } 925} 926 927# ::geomap::wdgeomap::rm_layer -- 928# 929# Removes items from the layer list. 930# 931# Arguments: 932# map - map identifier. 933# layer - the layers to remove. 934# 935# Results: 936# The map layers list and geomap default layers list are updated. 937 938proc ::geomap::wdgeomap::rm_layer {map layer} { 939 variable map_ns 940 set ns $map_ns($map) 941 variable ${ns}::layers 942 943 if { ![info exists layers] } { 944 return 945 } 946 set l [lsearch $layers $layer] 947 set layers [lreplace $layers $l $l] 948} 949 950# ::geomap::wdgeomap::set_layers_dlg -- 951# 952# This procedure creates a window in which the user can 953# change the layer order by dragging associated canvas items. 954# 955# Arguments: 956# map - map identifier. 957# 958# Results: 959# A dialog appears with items that represent layers. 960# Map layer sequence changes as user drags items in the dialog. 961 962proc ::geomap::wdgeomap::set_layers_dlg {map} { 963 variable map_ns 964 set ns $map_ns($map) 965 variable ${ns}::margin 24 966 variable ${ns}::layers 967 variable ${ns}::items 968 variable ${ns}::children 969 variable ${ns}::leaves 970 variable ${ns}::item_fm_id 971 variable ${ns}::text_id 972 variable ${ns}::box_id 973 variable ${ns}::line_id 974 variable ${ns}::column 975 variable ${ns}::layer_dlg .[name $map]_layers 976 variable ${ns}::layer_cvs ${layer_dlg}.c 977 978 update_tree $map 979 980 # Create a toplevel widget and canvas for the dialog. 981 982 if { ![winfo exists $layer_dlg] } { 983 toplevel $layer_dlg 984 bindtags $layer_dlg [linsert [bindtags $layer_dlg] 0 wdgeomap_layer_dlg] 985 } else { 986 raise $layer_dlg 987 } 988 if { ![winfo exists $layer_cvs] } { 989 ::canvas $layer_cvs 990 } 991 set layer_close ${layer_dlg}.close 992 if { ![winfo exists $layer_close] } { 993 button $layer_close -text "Close" -command "destroy $layer_dlg" 994 } 995 996 # Create or recreate items 997 998 $layer_cvs delete layer 999 1000 set widest 0.0 1001 set tallest 0.0 1002 set c_max -1 1003 1004 array unset column 1005 foreach item $items { 1006 set c [llength $item] 1007 set c_max [expr {($c > $c_max) ? $c : $c_max}] 1008 if { ![info exists column($c)] || [lsearch $column($c) $item] < 0} { 1009 lappend column($c) $item 1010 } 1011 set txt [lindex $item end] 1012 set id [$layer_cvs create text 0 0 -text $txt \ 1013 -fill yellow -anchor w -tags [list layer text $item]] 1014 set text_id($item) $id 1015 set item_fm_id($id) $item 1016 set font_desc [$layer_cvs itemcget $id -font] 1017 set asc [font metrics $font_desc -ascent] 1018 set des [font metrics $font_desc -descent] 1019 set h [expr {$asc + $des + 4}] 1020 set tallest [expr {($h > $tallest) ? $h : $tallest}] 1021 set w [font measure $font_desc $txt] 1022 set widest [expr {($w > $widest) ? $w : $widest}] 1023 } 1024 1025 # Postion items 1026 1027 set y $margin 1028 foreach layer $layers { 1029 set c [llength $layer] 1030 set x [expr {$margin + ($c - 1) * $widest + 3}] 1031 $layer_cvs coords $text_id($layer) $x [y_canvas $map $y] 1032 set y [expr {$y + $tallest + 3}] 1033 } 1034 1035 set jj [array names column] 1036 set l [llength $jj] 1037 foreach j [lrange [lsort -integer -decreasing $jj] 1 [expr {$l - 1}]] { 1038 foreach item $column($j) { 1039 if {[llength $children($item)] > 0} { 1040 # Position parent halfway up column of children 1041 1042 set c [llength [split $item :]] 1043 set x [expr {$margin + ($c - 1) * $widest + 3}] 1044 set ids {} 1045 foreach child $children($item) { 1046 lappend ids $text_id($child) 1047 } 1048 set bbox [eval $layer_cvs bbox $ids] 1049 set y1 [lindex $bbox 1] 1050 set y2 [lindex $bbox 3] 1051 set y [expr {0.5 * ($y1 + $y2) + 3}] 1052 $layer_cvs coords $text_id($item) $x $y 1053 1054 # Draw lines from parent to children 1055 1056 set p1 [$layer_cvs coords $text_id($item)] 1057 foreach child $children($item) { 1058 set p2 [$layer_cvs coords $text_id($child)] 1059 set id [$layer_cvs create line [concat $p1 $p2] \ 1060 -fill black -tags [list layer line $item]] 1061 set parent_id $text_id($item) 1062 set child_id $text_id($child) 1063 set line_id(${parent_id},${child_id}) $id 1064 } 1065 } 1066 } 1067 } 1068 1069 # Give the text a black background 1070 1071 foreach item $items { 1072 set bbox [$layer_cvs bbox $text_id($item)] 1073 set id [$layer_cvs create rectangle $bbox -fill black \ 1074 -tags [list layer rect $item]] 1075 set box_id($item) $id 1076 set item_fm_id($id) $item 1077 } 1078 $layer_cvs raise layer&&text 1079 1080 # Make everything visible. 1081 1082 set bbox [$layer_cvs bbox layer] 1083 if {[llength $bbox] == 4} { 1084 set y1 [expr {[lindex $bbox 1]}] 1085 $layer_cvs move layer 0 [expr {-$y1 + $margin}] 1086 } 1087 set bbox [$layer_cvs bbox layer] 1088 if {[llength $bbox] == 4} { 1089 set x2 [expr {[lindex $bbox 2] + $margin}] 1090 set y2 [expr {[lindex $bbox 3] + $margin}] 1091 $layer_cvs configure -width $x2 -height $y2 1092 } 1093 pack $layer_cvs 1094 pack ${layer_dlg}.close 1095 1096 # The items representing the layers can be moved up 1097 # and down by dragging. At button release, the new 1098 # layer sequence is applied to the map. 1099 1100 $layer_cvs bind layer&&(text||rect) <Button-1> \ 1101 [namespace code [list set ${ns}::y0 %y]] 1102 $layer_cvs bind layer&&(text||rect) <B1-Motion> \ 1103 [namespace code [list layers_dlg_drag $map %y]] 1104 $layer_cvs bind layer&&(text||rect) <ButtonRelease-1> \ 1105 [namespace code [list layers_dlg_brelease $map]] 1106} 1107 1108# ::geomap::wdgeomap::layers_dlg_drag -- 1109# 1110# This is the callback for drag events in a layer dialog. 1111# 1112# Arguments: 1113# map - map identifier. 1114# y - cursor y coordinate 1115# 1116# Results: 1117# A layer item and its children are repositioned on the canvas. 1118 1119proc ::geomap::wdgeomap::layers_dlg_drag {map y} { 1120 variable map_ns 1121 set ns $map_ns($map) 1122 variable ${ns}::layer_cvs 1123 variable ${ns}::y0 1124 variable ${ns}::item_fm_id 1125 variable ${ns}::items 1126 variable ${ns}::line_id 1127 variable ${ns}::text_id 1128 variable ${ns}::box_id 1129 variable ${ns}::children 1130 variable ${ns}::all_children 1131 1132 set dy [expr {$y - $y0}] 1133 set curr_id [$layer_cvs find withtag current] 1134 set item $item_fm_id($curr_id) 1135 $layer_cvs move $text_id($item) 0 $dy 1136 $layer_cvs move $box_id($item) 0 $dy 1137 foreach child $all_children($item) { 1138 $layer_cvs move $text_id($child) 0 $dy 1139 $layer_cvs move $box_id($child) 0 $dy 1140 } 1141 1142 # Update lines 1143 1144 foreach item $items { 1145 if {[llength $children($item)] > 0} { 1146 set p1 [$layer_cvs coords $text_id($item)] 1147 foreach child $children($item) { 1148 set p2 [$layer_cvs coords $text_id($child)] 1149 set parent_id $text_id($item) 1150 set child_id $text_id($child) 1151 set id $line_id(${parent_id},${child_id}) 1152 $layer_cvs coords $id [concat $p1 $p2] 1153 } 1154 } 1155 } 1156 set y0 $y 1157} 1158 1159# ::geomap::wdgeomap::layers_dlg_brelease -- 1160# 1161# This is the callback for button release events in a layer dialog. 1162# 1163# Arguments: 1164# map - map identifier. 1165# 1166# Results: 1167# The layer dialog is updated. 1168# Stacking order of map items assigned to layers is adjusted to 1169# match the final sequence in the dialog. 1170 1171proc ::geomap::wdgeomap::layers_dlg_brelease {map} { 1172 variable map_ns 1173 set ns $map_ns($map) 1174 variable ${ns}::layer_cvs 1175 variable ${ns}::item_fm_id 1176 variable ${ns}::parent 1177 variable ${ns}::children 1178 variable ${ns}::column 1179 variable ${ns}::leaves 1180 variable ${ns}::layers 1181 1182 # At end of drag, rearrange layer order according to the vertical 1183 # sequence in the layer display. 1184 1185 # siblings are items at the same depth and with the same parent 1186 # as the item that just moved. Only the dragged item, its siblings, 1187 # and their associated children will move, and they will only move 1188 # relative to each other. Thus, an item cannot be dragged to another 1189 # branch in the layer hierarchy. 1190 1191 # The all_leaves list contains layers descended from the item and its 1192 # siblings. It is a sublist from the layers list. all_leaves is 1193 # removed from the layers list, re-ordered according to the vertical 1194 # sequence of siblings in the display (determined by the item_cmp proc), 1195 # and reinserted into the layers list at the same place. 1196 1197 set curr_id [$layer_cvs find withtag current] 1198 set item $item_fm_id($curr_id) 1199 if {$parent($item) != ""} { 1200 set p $parent($item) 1201 set siblings $children($p) 1202 } else { 1203 set siblings $column(1) 1204 } 1205 set all_leaves {} 1206 foreach sibling $siblings { 1207 set all_leaves [concat $all_leaves $leaves($sibling)] 1208 } 1209 set start [lsearch $layers [lindex $all_leaves 0]] 1210 set len [llength $all_leaves] 1211 set last [expr {$start + $len - 1}] 1212 set layers [lreplace $layers $start $last] 1213 set sort_cmd [namespace code [list item_cmp $map]] 1214 set siblings [lsort -command $sort_cmd $siblings] 1215 set all_leaves {} 1216 foreach sibling $siblings { 1217 set all_leaves [concat $all_leaves $leaves($sibling)] 1218 } 1219 set layers [eval linsert \$layers $start $all_leaves] 1220 set_layers $map 1221} 1222 1223# Compare two items by distance up. 1224 1225proc ::geomap::wdgeomap::item_cmp {map item1 item2} { 1226 variable map_ns 1227 set ns $map_ns($map) 1228 variable ${ns}::layer_cvs 1229 variable ${ns}::text_id 1230 set y1 [y_cart $map $layer_cvs $text_id($item1)] 1231 set y2 [y_cart $map $layer_cvs $text_id($item2)] 1232 expr {$y1 < $y2 ? -1 : $y2 < $y1 ? 1 : 0} 1233} 1234 1235# Return cartesian y (distance up from y=0) for an item. 1236 1237proc ::geomap::wdgeomap::y_cart {map cvs item} { 1238 set y_cvs [lindex [$cvs coords $item] 1] 1239 return [expr {-$y_cvs}] 1240} 1241 1242# Return canvas y from cartresian y 1243 1244proc ::geomap::wdgeomap::y_canvas {map y_cart} { 1245 return [expr {-$y_cart}] 1246} 1247 1248# ::geomap::wdgeomap::addmenu -- 1249# 1250# Add a menu to the wdgeomap menu bar. 1251# 1252# Arguments: 1253# map - map identifier. 1254# name - menu name. The will be the label on the menu button 1255# and the part of the path name of the new button and 1256# menu. 1257# The name also refers to the menu later, such as when 1258# it is deleted. 1259# 1260# Results: 1261# Return value is the path name of the new menu. 1262# A menu button is added to the menu bar. 1263 1264proc ::geomap::wdgeomap::addmenu {map name} { 1265 variable map_ns 1266 set ns $map_ns($map) 1267 variable ${ns}::mbar 1268 variable ${ns}::mbutton 1269 1270 if [regexp {\s} $name] { 1271 error "Menu name cannot contain whitespace" 1272 } 1273 set lName [string tolower $name] 1274 set button_path ${mbar}.$lName 1275 set menu_path ${button_path}.menu 1276 if { [winfo exists $button_path] } { 1277 return $menu_path 1278 } 1279 menubutton $button_path -text $name -menu $menu_path 1280 menu $menu_path 1281 pack $button_path -side left 1282 set mbutton($name) $button_path 1283 return $menu_path 1284} 1285 1286# ::geomap::wdgeomap::getmenu -- 1287# 1288# Retrieve the path name of a menu button. 1289# 1290# Arguments: 1291# map - map identifier. 1292# name - menu name, should have been given to addmenu. 1293# 1294# Results: 1295# Return value is the path name of the menu button associated with name, 1296# or "" if there is no menu by that name. 1297 1298proc ::geomap::wdgeomap::getmenu {map name} { 1299 variable map_ns 1300 set ns $map_ns($map) 1301 variable ${ns}::mbutton 1302 1303 if [info exists mbutton($name)] { 1304 return $mbutton($name) 1305 } else { 1306 return "" 1307 } 1308} 1309 1310# ::geomap::wdgeomap::deletemenu -- 1311# 1312# Deletes a menu created with addmenu. 1313# 1314# Arguments: 1315# map - map identifier. 1316# name - menu name that was given to addmenu 1317# 1318# Results: 1319# A menu button and its child are destroyed. 1320 1321proc ::geomap::wdgeomap::deletemenu {map name} { 1322 variable map_ns 1323 set ns $map_ns($map) 1324 variable ${ns}::mbutton 1325 1326 destroy $mbutton($name) 1327 unset mbutton($name) 1328} 1329 1330# ::geomap::wdgeomap::ctr_reflon -- 1331# 1332# Reset the map when the mouse button is released. It is used 1333# in bind scripts for certain projections. 1334# 1335# Arguments: 1336# map - map identifier. 1337# 1338# Results: 1339# Items in the map_canvas canvas are reconfigured. 1340 1341proc ::geomap::wdgeomap::ctr_reflon {map} { 1342 variable map_ns 1343 set ns $map_ns($map) 1344 variable ${ns}::map_canvas 1345 variable ${ns}::projname 1346 variable ${ns}::lazy 1347 variable ${ns}::update 1348 1349 set toplevel [winfo toplevel $map_canvas] 1350 set oldCursor [$toplevel cget -cursor] 1351 $toplevel configure -cursor watch 1352 update 1353 1354 # Save the update script so we don't run it twice 1355 # (once for refpoint, again for projection) 1356 1357 set tmp_update $update 1358 set update {} 1359 1360 set xCtr [expr {[winfo width $map_canvas] / 2}] 1361 set yCtr [expr {[winfo height $map_canvas] / 2}] 1362 configure $map -refpoint [xytolatlon $map $xCtr $yCtr] 1363 foreach item [$map_canvas find withtag geomap] { 1364 $map_canvas coords $item $xCtr $yCtr 1365 } 1366 if !$lazy { 1367 configure $map -projname $projname 1368 } 1369 1370 # Now, run the update script and restore it. 1371 1372 set update $tmp_update 1373 uplevel #0 $update 1374 $toplevel configure -cursor $oldCursor 1375} 1376 1377# ::geomap::wdgeomap::ctr_refpt -- 1378# 1379# Sets the map and projection reference points to the given point, 1380# and resets the bindings. It is used in bind scripts for reference 1381# point projections. 1382# 1383# Arguments: 1384# map - map identifier. 1385# x, y - canvas coordinates of the point which will become 1386# the new map refpoint and projection reference point. 1387# 1388# Results: 1389# geomap_lnarr and geomap_place items in the canvas are 1390# reconfigured. 1391 1392proc ::geomap::wdgeomap::ctr_refpt {map x y} { 1393 variable map_ns 1394 set ns $map_ns($map) 1395 variable ${ns}::map_canvas 1396 variable ${ns}::projname 1397 1398 set toplevel [winfo toplevel $map_canvas] 1399 set oldCursor [$toplevel cget -cursor] 1400 $toplevel configure -cursor watch 1401 update 1402 configure $map -refpoint [xytolatlon $map $x $y] 1403 if {$projname == "PolarStereographic"} { 1404 configure $map -projname Stereographic 1405 } else { 1406 configure $map -projname $projname 1407 } 1408 $toplevel configure -cursor $oldCursor 1409} 1410 1411# ::geomap::wdgeomap::setcolor -- 1412# 1413# Sets a color in the map. 1414# 1415# Arguments: 1416# map - map identifier. 1417# elem - a color element, e.g. land, rivers, places, 1418# etc. to choose the color for. 1419# value - what color to use when displaying the element. 1420# If value is "", the element is deleted. 1421# 1422# Results: 1423# Map arrays are updated. The colorscript for the element 1424# is evaluated. 1425 1426proc ::geomap::wdgeomap::setcolor {map elem value} { 1427 variable map_ns 1428 set ns $map_ns($map) 1429 variable ${ns}::colorval 1430 variable ${ns}::colorscript 1431 variable ${ns}::colorvals 1432 1433 # Save the current color configuration in the colorvals list 1434 # for later undo. 1435 1436 if { [info exists colorvals] } { 1437 set colorvals [linsert $colorvals 0 [array get colorval]] 1438 } else { 1439 set colorvals [list [array get colorval]] 1440 } 1441 1442 # Update the colored element with user selection 1443 1444 if {$value != ""} { 1445 set colorval($elem) $value 1446 if [info exists colorscript($elem)] { 1447 namespace eval :: $colorscript($elem) 1448 } else { 1449 set colorscript($elem) {} 1450 } 1451 } else { 1452 array unset colorval $elem 1453 array unset colorscript $elem 1454 } 1455} 1456 1457# ::geomap::wdgeomap::setcolorscript -- 1458# 1459# Specify a script to run when a color changes. 1460# 1461# Arguments: 1462# map - map identifier. 1463# elem - a color element, e.g. land, rivers, places, 1464# etc. to choose the color for. 1465# script - script to run when the color of elem changes. 1466# 1467# Results: 1468 1469proc ::geomap::wdgeomap::setcolorscript {map elem script} { 1470 variable map_ns 1471 set ns $map_ns($map) 1472 variable ${ns}::colorscript 1473 set colorscript($elem) $script 1474} 1475 1476# ::geomap::wdgeomap::getcolor -- 1477# 1478# Get the color specified for an element in a map. 1479# 1480# Arguments: 1481# map - map identifier. 1482# elem - a color element, e.g. land, rivers, places, 1483# etc. to choose the color for. 1484# 1485# Results: 1486# Returns the color to use when displaying the element in the map, 1487# or "" if their is no color for the element. 1488 1489proc ::geomap::wdgeomap::getcolor {map elem} { 1490 variable map_ns 1491 set ns $map_ns($map) 1492 variable ${ns}::colorval 1493 if [info exists colorval($elem)] { 1494 return $colorval($elem) 1495 } else { 1496 return "" 1497 } 1498} 1499 1500# ::geomap::wdgeomap::choose_color -- 1501# 1502# Ask user to choose a new color in a dialog. This is the callback 1503# for buttons created by the File->Colors menu. When activated by a 1504# button press, it prompts the user for a color to use in the map. 1505# 1506# Arguments: 1507# map - map identifier. 1508# elem - a color element, e.g. land, rivers, places, 1509# etc. to choose the color for. 1510# 1511# Results: 1512# Return value should be ignored. 1513# colorval($elem) is set to the value chosen by the 1514# user. The colorval array is dumped to the colorvals list 1515# for later retrieval with the Undo and Redo buttons. 1516 1517proc ::geomap::wdgeomap::choose_color {map elem} { 1518 variable map_ns 1519 set ns $map_ns($map) 1520 variable ${ns}::colorval 1521 variable ${ns}::colorscript 1522 variable ${ns}::colorvals 1523 variable ${ns}::color_dlg 1524 1525 set new [tk_chooseColor -title "$map $elem" -initialcolor $colorval($elem)] 1526 if {[string length $new] > 0} { 1527 setcolor $map $elem $new 1528 set btn ${color_dlg}.[string tolower $elem] 1529 $btn configure -background $colorval($elem) 1530 ${color_dlg}.f.undo configure -state normal 1531 } 1532} 1533 1534# ::geomap::wdgeomap::load_colors 1535# 1536# Modify map colors as directed from a file. 1537# 1538# Arguments: 1539# map - map identifier. 1540# 1541# Results: 1542# User selects a file from a dialog. Map colors change according 1543# to file contents. 1544 1545proc ::geomap::wdgeomap::load_colors {map} { 1546 variable map_ns 1547 set ns $map_ns($map) 1548 variable ${ns}::colorval 1549 variable ${ns}::colorscript 1550 variable ${ns}::colorvals 1551 variable ${ns}::color_dlg 1552 1553 set f [tk_getOpenFile] 1554 if {$f != ""} { 1555 1556 # Search the input file for a line starting with "colors:" 1557 # and set the colorval array from its contents. 1558 1559 set in [open $f] 1560 while {[gets $in line] >= 0} { 1561 if [regexp {^colors:[ ]*(.*)} $line m arr] { 1562 1563 # Save the current color configuration in the 1564 # colorvals list for later undo. 1565 1566 if { [info exists colorvals] } { 1567 set colorvals [linsert $colorvals 0 [array get colorval]] 1568 } else { 1569 set colorvals [list [array get colorval]] 1570 } 1571 ${color_dlg}.f.undo configure -state normal 1572 1573 # Set the new color configuration 1574 1575 array set colorval $arr 1576 foreach elem [array names colorval] { 1577 set btn ${color_dlg}.[string tolower $elem] 1578 $btn configure -background $colorval($elem) 1579 namespace eval :: $colorscript($elem) 1580 } 1581 } 1582 } 1583 close $in 1584 } 1585} 1586 1587# ::geomap::wdgeomap::save_colors 1588# 1589# Save map colors into a file readable with the load_colors procedure. 1590# 1591# Arguments: 1592# map - map identifier. 1593# 1594# Results: 1595# User selects a file from a dialog. Map colors change according 1596# to file contents. 1597 1598proc ::geomap::wdgeomap::save_colors {map} { 1599 variable map_ns 1600 set ns $map_ns($map) 1601 variable ${ns}::colorval 1602 1603 set f [tk_getSaveFile] 1604 if {$f != ""} { 1605 set out [open $f w] 1606 puts $out " 1607# Map colors -- 1608# The list following \"colors:\" below specifies map color scheme. 1609# The list is a set of key value pairs. The keys identify items to be 1610# colored, such as \"water\" or \"land.\" Each key is followed by a color 1611# value, such as \"Blue4\" or \"wheat\" indicating the color to use for the 1612# corresponding item. 1613 " 1614 puts $out "colors: [array get colorval]" 1615 close $out 1616 } 1617} 1618 1619# ::geomap::wdgeomap::undo_colors 1620# 1621# Revert to previous color scheme. 1622# 1623# Arguments: 1624# map - map identifier. 1625# 1626# Results: 1627# Colors in the map revert to the previous scheme. 1628# colorval array and colorvals list are updated. 1629# Scripts from the colorscript array are called. 1630 1631proc ::geomap::wdgeomap::undo_colors {map} { 1632 variable map_ns 1633 set ns $map_ns($map) 1634 variable ${ns}::colorval 1635 variable ${ns}::colorscript 1636 variable ${ns}::colorvals 1637 variable ${ns}::color_dlg 1638 1639 array set colorval [lindex $colorvals 0] 1640 set colorvals [lrange $colorvals 1 end] 1641 if {[llength $colorvals] == 0} { 1642 ${color_dlg}.f.undo configure -state disabled 1643 } 1644 foreach elem [array names colorval] { 1645 set btn ${color_dlg}.[string tolower $elem] 1646 $btn configure -background $colorval($elem) 1647 if { [info exists colorscript($elem)] } { 1648 namespace eval :: $colorscript($elem) 1649 } 1650 } 1651} 1652 1653# ::geomap::wdgeomap::set_colors_dlg 1654# 1655# Creates a dialog in which the user can choose new colors for 1656# certain map items. 1657# 1658# Arguments: 1659# map - map identifier. 1660# 1661# Results: 1662# A dialog box appears that enables modification of certain canvas 1663# items. The dialog does not block the application. It exists 1664# until the user destroys it. 1665 1666proc ::geomap::wdgeomap::set_colors_dlg {map} { 1667 variable map_ns 1668 set ns $map_ns($map) 1669 variable ${ns}::colorval 1670 variable ${ns}::colorscript 1671 variable ${ns}::colorvals 1672 1673 variable ${ns}::color_dlg .[name $map]_colors 1674 if { [winfo exists $color_dlg] } { 1675 raise $color_dlg 1676 return 1677 } 1678 1679 # Create a dialog box 1680 1681 toplevel $color_dlg 1682 bindtags $color_dlg [linsert [bindtags $color_dlg] 0 wdgeomap_color_dlg] 1683 1684 # For each color element in the map, create a 1685 # button to modify the color. 1686 1687 foreach elem [lsort [array names colorval]] { 1688 set btn $color_dlg.[string tolower $elem] 1689 set cmd [namespace code [list choose_color $map $elem]] 1690 button $btn -text $elem -background $colorval($elem) -command $cmd 1691 pack $btn -fill x 1692 } 1693 1694 # Button row for action buttons 1695 1696 frame ${color_dlg}.f 1697 button ${color_dlg}.f.load -text "Load" \ 1698 -command [namespace code [list load_colors $map]] 1699 button ${color_dlg}.f.save -text "Save" \ 1700 -command [namespace code [list save_colors $map]] 1701 1702 # "Undo" button moves one element down in the colorvals list and 1703 # displays the color scheme stored in that element in the dialog. 1704 # If we end up at start of colorvals list, dim the "Undo" button. 1705 1706 if {[info exists colorvals] && [llength $colorvals] > 0} { 1707 set st "normal" 1708 } else { 1709 set st "disabled" 1710 } 1711 button ${color_dlg}.f.undo -text "Undo" -state $st \ 1712 -command [namespace code [list undo_colors $map]] 1713 1714 # Close button 1715 1716 button ${color_dlg}.f.close -text "Close" -command "destroy $color_dlg" 1717 1718 pack ${color_dlg}.f.undo ${color_dlg}.f.save ${color_dlg}.f.load \ 1719 ${color_dlg}.f.close -side left 1720 pack ${color_dlg}.f 1721} 1722 1723# postscript -- 1724# 1725# Generates postscript for the canvas based on user input from 1726# a dialog box. 1727# 1728# Arguments: 1729# map - map identifier. 1730# 1731# Results: 1732# A dialog box appears in which the user gives the name of a 1733# postscript file. The dialog does not block the application, 1734# and it remains until the user destroys it. 1735 1736proc ::geomap::wdgeomap::postscript {map} { 1737 variable map_ns 1738 set ns $map_ns($map) 1739 variable ${ns}::map_canvas 1740 variable ${ns}::postscript_file 1741 variable ${ns}::color_mode 1742 variable ${ns}::ps_dlg 1743 1744 set ps_dlg .[name $map]_postscript 1745 if [winfo exists $ps_dlg] { 1746 raise $ps_dlg 1747 return 1748 } 1749 1750 # Create a dialog box prompting user for a name for a postscript file. 1751 1752 toplevel $ps_dlg 1753 bindtags $ps_dlg [linsert [bindtags $ps_dlg] 0 wdgeomap_ps_dlg] 1754 set x [expr {[winfo x $map_canvas] + 200}] 1755 set y [expr {[winfo y $map_canvas] + 200}] 1756 wm geometry $ps_dlg +$x+$y 1757 label ${ps_dlg}.msg -text "Send postscript to file" 1758 entry ${ps_dlg}.e 1759 if ![info exists postscript_file] { 1760 set postscript_file "c.ps" 1761 } 1762 ${ps_dlg}.e insert 0 $postscript_file 1763 1764 # Radio buttons for colormode 1765 1766 if { ![info exists color_mode] } { 1767 set color_mode gray 1768 } 1769 frame ${ps_dlg}.r 1770 radiobutton ${ps_dlg}.r.color -text color \ 1771 -variable ${ns}::color_mode -value color 1772 radiobutton ${ps_dlg}.r.gray -text gray \ 1773 -variable ${ns}::color_mode -value gray 1774 radiobutton ${ps_dlg}.r.mono -text mono \ 1775 -variable ${ns}::color_mode -value mono 1776 pack ${ps_dlg}.r.color ${ps_dlg}.r.gray ${ps_dlg}.r.mono \ 1777 -side left -expand 1 -fill x 1778 1779 # OK and Cancel 1780 1781 frame ${ps_dlg}.b 1782 set callback [list namespace eval $ns { 1783 set postscript_file [${ps_dlg}.e get] 1784 if {[string length $postscript_file] == 0} { 1785 tk_messageBox -title "Error" -type ok \ 1786 -message "Must have postscript file name" 1787 destroy $ps_dlg 1788 return 1789 } 1790 $map_canvas postscript -colormode $color_mode -file $postscript_file 1791 destroy $ps_dlg 1792 tk_messageBox -message "Created $postscript_file" 1793 }] 1794 bind ${ps_dlg}.e <Return> $callback 1795 button ${ps_dlg}.b.ok -text OK -command $callback 1796 button ${ps_dlg}.b.cancel -text Cancel -command [list destroy $ps_dlg] 1797 1798 pack ${ps_dlg}.b.ok ${ps_dlg}.b.cancel -side left 1799 pack ${ps_dlg}.msg ${ps_dlg}.e ${ps_dlg}.r ${ps_dlg}.b 1800} 1801 1802# ::geomap::wdgeomap::delete -- 1803# 1804# Delete the map and associated commands and variables. 1805# 1806# Arguments: 1807# map - map identifier. 1808# 1809# Results: 1810# The namespace for the map, and its associated commands and 1811# variables are deleted. 1812 1813# This procedure should be called to delete the map. 1814 1815proc ::geomap::wdgeomap::delete {map} { 1816 variable map_ns 1817 set ns $map_ns($map) 1818 variable ${ns}::map_frame 1819 variable ${ns}::projId 1820 1821 destroy $map_frame 1822 rename $projId {} 1823 namespace delete $ns 1824} 1825 1826# ::geomap::wdgeomap::set_motion_bindings -- 1827# 1828# This procedure sets the bindings that allow the user to move a map 1829# and adjust its reference point. 1830# 1831# Arguments: 1832# modifier - event modifier, e.g. "Control" or "Shift" to require 1833# for mouse actions intended to move the map. 1834# button - mouse button to push to move the map. 1835# 1836# Results: 1837# Bindings to widgets with the geomap_motion tag are modified. 1838 1839proc ::geomap::wdgeomap::set_motion_bindings {modifier button} { 1840 set mods [list {} Alt Control Shift] 1841 if {[lsearch -exact $mods $modifier] < 0} { 1842 error "Modifier must be one of $mods" 1843 } 1844 if {$modifier != ""} { 1845 set modifier ${modifier}- 1846 } 1847 if ![string is integer $button] { 1848 error "Button identifier must be an integer" 1849 } 1850 1851 foreach binding [bind geomap_motion] { 1852 bind geomap_motion $binding {} 1853 } 1854 1855 # Update map bindings. 1856 1857 set double "<${modifier}Double-Button-$button>" 1858 set press "<${modifier}Button-$button>" 1859 set motion "<${modifier}Button$button-Motion>" 1860 set release "<${modifier}ButtonRelease-$button>" 1861 1862 # If map projection uses reference longitude, dragging moves the map. 1863 1864 bind geomap_motion $press [namespace code { 1865 set toplev [winfo toplevel %W] 1866 set map $map_tl($toplev) 1867 set proj_info [::geomap::proj_info [cget $map -projname]] 1868 set ref [lindex $proj_info 0] 1869 if {$ref == "longitude"} { 1870 set x00 %x 1871 set y00 %y 1872 set x0 %x 1873 set y0 %y 1874 } 1875 }] 1876 bind geomap_motion $motion [namespace code { 1877 set toplev [winfo toplevel %W] 1878 set map $map_tl($toplev) 1879 set proj_info [::geomap::proj_info [cget $map -projname]] 1880 set ref [lindex $proj_info 0] 1881 if {$ref == "longitude"} { 1882 set map_canvas [map_canvas $map] 1883 if {[info exists x0] && [info exists y0]} { 1884 $map_canvas move geomap [expr {%x - $x0}] [expr {%y - $y0}] 1885 } 1886 set x0 %x 1887 set y0 %y 1888 } 1889 break 1890 }] 1891 bind geomap_motion $release [namespace code { 1892 set toplev [winfo toplevel %W] 1893 set map $map_tl($toplev) 1894 set proj_info [::geomap::proj_info [cget $map -projname]] 1895 set ref [lindex $proj_info 0] 1896 if {$ref == "longitude"} { 1897 if {[info exists x00] && [info exists y00]} { 1898 if {%x != $x00 && %y != $y00} { 1899 ctr_reflon $map 1900 } 1901 unset -nocomplain x00 1902 unset -nocomplain y00 1903 } 1904 unset -nocomplain x0 1905 unset -nocomplain y0 1906 } 1907 }] 1908 1909 # If map projection uses a reference point, double clicking moves 1910 # the map. 1911 1912 bind geomap_motion $double [namespace code { 1913 set toplev [winfo toplevel %W] 1914 set map $map_tl($toplev) 1915 set proj_info [::geomap::proj_info [cget $map -projname]] 1916 set ref [lindex $proj_info 0] 1917 if {$ref == "point"} { 1918 ctr_refpt $map %x %y 1919 } 1920 }] 1921} 1922 1923# ::geomap::wdgeomap::get_motion_bindings -- 1924# 1925# This procedure sets the bindings that allow the user to move a map 1926# and adjust its reference point. 1927# 1928# Arguments: 1929# None. 1930# 1931# Results: 1932# Return value is a list of bindings for the geomap_motion tag. 1933 1934proc ::geomap::wdgeomap::get_motion_bindings {} { 1935 return [bind geomap_motion] 1936} 1937