1#! /bin/sh 2# the next line restarts with tclsh \ 3exec tclsh "$0" ${1+"$@"} 4 5# tkmap.tcl -- 6# 7# Example application demonstrating the use of Tcllib's 'mapproj' 8# package. 9 10package require Tcl 8.4 11package require Tk 8.4 12package require mapproj 1.0 13 14#---------------------------------------------------------------------- 15# 16# Module for reading NCAR DS780.0 is included literally 17# 18 19namespace eval ncar780_0 { 20 variable libdir [file dirname [info script]] 21 variable mapFile [file join $libdir ncar780.txt] 22 namespace export readMap cancelReadMap 23} 24 25#---------------------------------------------------------------------- 26# 27# ncar780_0::readMap -- 28# 29# Read in the continental outlines from NCAR data set 780.0. 30# 31# Parameters: 32# lineCallback 33# Callback to make after each polyline is read. 34# doneCallback 35# Callback to make when the entire map has been 36# read. 37# 38# Results: 39# An integer that identifies the map-reading task. 40# 41# Side effects: 42# A chain of `after' callbacks is initiated to read the map. 43# 44# When the ncar780_0::readMap procedure is invoked, it reads in 45# the list of line segments from the data set. Rather than freeze 46# the user interface for the amount of time that it takes to 47# process this large file, it sets up `after' callbacks that 48# actually do the work. 49# 50# For each polyline that is read from the file, the `lineCallback' 51# is executed at global level. To the callback are appended 52# six parameters: the `group ID' (see the documentation for 53# NCAR 780.0 for an explanation), the minimum latitude and longitude 54# of the line, the maximum latitude and longitude of the line, 55# and a list of co-ordinates that have longitude and latitude 56# values alternating: {lon1 lat1 lon2 lat2 ...}. 57# 58# At the end of the file, the `doneCallback' is evaluated at global 59# level. 60# 61# The ncar780_0::cancelReadMap procedure may be used to cancel 62# a ncar780_0::readMap call before the map has been completely read 63# in. 64# 65#---------------------------------------------------------------------- 66 67proc ncar780_0::readMap {lineCallback doneCallback} { 68 variable mapFile 69 variable mapReaders 70 if {![info exists mapReaders]} { 71 set mapReaders 0 72 } else { 73 incr mapReaders 74 } 75 upvar #0 [namespace current]::mapReader$mapReaders state 76 set state(lineCallback) $lineCallback 77 set state(doneCallback) $doneCallback 78 set state(channel) [open $mapFile RDONLY] 79 readMapGroup $mapReaders 80 return $mapReaders 81} 82 83#---------------------------------------------------------------------- 84# 85# ncar780_0::cancelReadMap -- 86# 87# Cancel the operation begun by ncar780_0::readMap 88# 89# Parameters: 90# reader 91# Token returned by ncar780_0::readMap 92# 93# Results: 94# None. 95# 96# Side effects: 97# Cancels the `after' calls set up by ncar780_0::readMap and 98# cleans up variables. 99# 100#---------------------------------------------------------------------- 101 102proc ncar780_0::cancelReadMap {reader} { 103 upvar #0 [namespace current]::mapReader$reader state 104 catch { 105 after cancel $state(idleHandler) 106 } 107 unset [namespace current]::mapReader$reader 108 return 109} 110 111#---------------------------------------------------------------------- 112# 113# ncar780_0::readMapGroup -- 114# 115# Read a single group of points from the NCAR 780.0 data set. 116# 117# Parameters: 118# reader 119# Token identifying the map-reading process. 120# 121# Results: 122# None. 123# 124# Side effects: 125# Reads a group of points from the file, and invokes the 126# line callback (after each group) and the done callback 127# (at end of file). If end of file has not been reached, 128# schedules an `after' callback to process the next group. 129# 130#---------------------------------------------------------------------- 131 132proc ncar780_0::readMapGroup {reader} { 133 upvar #0 [namespace current]::mapReader$reader state 134 135 set f $state(channel) 136 for {set i 0} {$i < 10} {incr i} { 137 set pointList {} 138 if {[gets $f line] >= 0} { 139 regexp {^(........)(.*)} $line junk nPoints line 140 set nPoints [string trim $nPoints] 141 if {$nPoints < 2} { 142 close $f 143 uplevel #0 $state(doneCallback) 144 unset [namespace current]::mapReader$reader 145 return 146 } 147 regexp {^(........)(.*)} $line junk groupId line 148 set groupId [string trim $groupId] 149 regexp {^(........)(.*)} $line junk maxLat line 150 set maxLat [string trim $maxLat] 151 regexp {^(........)(.*)} $line junk minLat line 152 set minLat [string trim $minLat] 153 regexp {^(........)(.*)} $line junk maxLon line 154 set maxLon [string trim $maxLon] 155 regexp {^(........)(.*)} $line junk minLon line 156 set minLon [string trim $minLon] 157 set pointList {} 158 set ptsLeft 0 159 for {set i 0} {$i < $nPoints} {incr i 2} { 160 if {$ptsLeft == 0} { 161 gets $f line 162 set ptsLeft 5 163 } 164 regexp {^(........)(........)(.*)} $line junk lat lon line 165 lappend pointList [string trim $lon] [string trim $lat] 166 incr ptsLeft -1 167 } 168 uplevel \#0 $state(lineCallback) [list $groupId \ 169 $minLat $minLon $maxLat $maxLon \ 170 $pointList] 171 172 } else { 173 unset [namespace current]::mapReader$reader 174 close $f 175 uplevel #0 $doneCallback 176 return 177 } 178 } 179 set state(idleHandler) [after 2 [namespace code \ 180 [list readMapGroup $reader]]] 181 return 182} 183 184# 185#---------------------------------------------------------------------- 186 187# plot -- 188# 189# Plots a line in the '.c' canvas. 190# 191# Parameters: 192# id - Line ID from the NCAR DS780.0 file. 'id$id' will be added as 193# a canvas tag for the plotted line. 194# la0, lo0 - Co-ordinates of the southwest corner of the bounding box 195# la1, lo1 - Co-ordinates of the northeast corenr of the bounding box 196# ptlist - List of points on the line, expressed as alternating 197# longitude and latitude in degrees. 198# 199# Results: 200# None. 201# 202# Side effects: 203# Line is added to the canvas '.c', scaled to 100 pixels per Earth 204# radius. 205 206proc plot {id la0 lo0 la1 lo1 ptlist} { 207 variable toProjCmd 208 set command [list .c create line] 209 foreach {lo la} $ptlist { 210 set ok 0 211 set pcmd $toProjCmd 212 lappend pcmd $lo $la 213 foreach {x y} [eval $pcmd] { 214 set ok 1 215 } 216 if {!$ok 217 || ([info exists lastx] && hypot($x-$lastx, $y-$lasty) > 0.25)} { 218 if {[llength $command] >= 7} { 219 if {$id == 0} { 220 lappend command -fill \#cccccc 221 } else { 222 lappend command -fill \#cc0000 223 } 224 eval $command 225 } 226 set command [list .c create line] 227 } 228 if {$ok} { 229 lappend command [expr {316 + 100 * $x}] \ 230 [expr {316 - 100 * $y}] 231 set lastx $x 232 set lasty $y 233 } 234 } 235 if {[llength $command] >= 7} { 236 if {$id == 0} { 237 lappend command -fill \#cccccc 238 } else { 239 lappend command -fill \#cc0000 240 } 241 lappend command -tags id$id 242 eval $command 243 } 244 return 245} 246 247# done -- 248# 249# Completes the plot of the map 250# 251# Results: 252# None. 253# 254# Side effects: 255# Updates the canvas's scrollregion to its bounding box. 256 257proc done {} { 258 variable reader 259 unset reader 260 .c configure -scrollregion [.c bbox all] 261 return 262} 263 264# locate -- 265# 266# Computes longitude and latitude of a point on the map 267# 268# Parameters: 269# w -- Path name of the canvas showing the map 270# x,y -- Window co-ordinates of the point to convert 271# 272# Results: 273# None. 274# 275# Side effects: 276# Stores longitude and latitude (in degrees) in 'lon' and 'lat'. 277 278proc locate {w x y} { 279 variable lon 280 variable lat 281 variable fromProjCmd 282 set x [$w canvasx $x] 283 set y [$w canvasy $y] 284 set x [expr {($x - 316.) / 100.}] 285 set y [expr {(316. - $y) / 100.}] 286 set pcmd $fromProjCmd 287 lappend pcmd $x $y 288 foreach {lon lat} [eval $pcmd] break 289 return 290} 291 292# showMap -- 293# 294# Redisplays the world map 295# 296# Results: 297# None. 298# 299# Side effects: 300# Launches a reader to read the NCAR data set and plot the continent 301# outlines. Cancels any existing reader. Has a check so that new 302# readers are launched at most every half second. 303 304proc showMap {} { 305 variable showMapScheduled 306 if {[info exists showMapScheduled]} { 307 after cancel $showMapScheduled 308 unset showMapScheduled 309 } 310 set showMapScheduled [after 500 showMap2] 311 return 312} 313proc showMap2 {} { 314 variable showMapScheduled 315 if {[info exists showMapScheduled]} { 316 after cancel $showMapScheduled 317 unset showMapScheduled 318 } 319 variable projection 320 variable fromProjCmd 321 variable toProjCmd 322 variable reader 323 if {[info exists reader]} { 324 ncar780_0::cancelReadMap $reader 325 unset reader 326 } 327 .c delete all 328 329 foreach {toProjCmd fromProjCmd} [makeProjCmds $projection] break 330 for {set m -180} {$m <= 180} {incr m 15} { 331 set plist {} 332 for {set p -89} {$p <= 89} {incr p} { 333 lappend plist $m $p 334 } 335 plot 0 -90.0 $m 90.0 $m $plist 336 } 337 for {set p -75} {$p <= 75} {incr p 15} { 338 set plist {} 339 for {set m -180} {$m <= 180} {incr m} { 340 lappend plist $m $p 341 } 342 plot 0 $p -180.0 $p 180.0 $plist 343 } 344 set reader [ncar780_0::readMap plot done] 345 return 346} 347 348# makeProjCmds -- 349# 350# Switches projections, making commands to convert to/from the new 351# projection. 352# 353# Parameters: 354# pro -- Name of the new projection. 355# comps -- 1 if GUI components for the projection's parameters are 356# required, 0 otherwise. 357# 358# Results: 359# Returns a list of command prefixes, {toProj fromProj}. 'toProj' 360# should have longitude and latitude postpended, and converts to 361# the given projection. 'fromProj' should have canvas x and y appended 362# and converts back to longitude and latitude. 363# 364# Side effects: 365# If requested, changes the GUI to show components for the projection's 366# parameters. 367 368proc makeProjCmds {pro {comps 1}} { 369 variable phi_0 370 variable phi_1 371 variable phi_2 372 variable lambda_0 373 set toProjCmd ::mapproj::to$pro 374 set alist [info args ::mapproj::to$pro] 375 if {[llength $alist] < 2} { 376 return -code error "$toProjCmd has too few args" 377 } 378 if {[lindex $alist end-1] ne {lambda} 379 || [lindex $alist end] ne {phi}} { 380 return -code error "$toProjCmd does not accept lambda and phi" 381 } 382 foreach a [lrange $alist 0 end-2] { 383 switch -exact $a { 384 phi_0 - phi_1 - phi_2 - lambda_0 { 385 lappend toProjCmd [set $a] 386 set have($a) {} 387 } 388 default { 389 return -code error "$toProjCmd accepts an unknown arg $a" 390 } 391 } 392 } 393 set fromProjCmd ::mapproj::from$pro 394 set alist [info args ::mapproj::from$pro] 395 if {[llength $alist] < 2} { 396 return -code error "$fromProjCmd has too few args" 397 } 398 if {[lindex $alist end-1] ne {x} 399 || [lindex $alist end] ne {y}} { 400 return -code error "$fromProjCmd does not accept x and y" 401 } 402 foreach a [lrange $alist 0 end-2] { 403 switch -exact $a { 404 phi_0 - phi_1 - phi_2 - lambda_0 { 405 lappend fromProjCmd [set $a] 406 set have($a) {} 407 } 408 default { 409 return -code error "$fromProjCmd accepts an unknown arg $a" 410 } 411 } 412 } 413 if {$comps} { 414 foreach item {lambda_0 phi_0 phi_1 phi_2} { 415 if {[info exists have($item)] && ![winfo ismapped .extras.$item]} { 416 grid .extras.$item -sticky ew -columnspan 2 417 } elseif {![info exists have($item)] 418 && [winfo ismapped .extras.$item]} { 419 grid forget .extras.$item 420 } 421 } 422 } 423 return [list $toProjCmd $fromProjCmd] 424} 425 426# isProjection -- 427# 428# Tests whether a given name represents a known map projection. 429# 430# Parameters: 431# pro -- Name to test 432# 433# Results: 434# Returns 1 if the name is a known projection, 0 otherwise. 435 436proc isProjection {pro} { 437 if {![catch {makeProjCmds $pro 0} r]} { 438 return 1 439 } else { 440 puts $r 441 return 0 442 } 443} 444 445# Parameters of various projections 446 447set phi_0 15.0; # Reference latitude 448set phi_1 -30.0; # First standard parallel 449set phi_2 60.0; # Second standard parallel 450set lambda_0 12.0; # Reference longitude 451 452# Create a GUI to display the map 453 454canvas .c -width 632 -height 632 -bg white 455listbox .projs -height 10 -width 30 -yscrollcommand [list .projsy set] 456scrollbar .projsy -orient vertical -command [list .projs yview] 457frame .extras 458label .extras.llat -text "Latitude:" -anchor w 459entry .extras.elat -width 20 -textvariable lat -state disabled 460label .extras.llon -text "Longitude:" -anchor w 461entry .extras.elon -width 20 -textvariable lon -state disabled 462scale .extras.phi_0 -label "Reference latitude" \ 463 -variable phi_0 -from -90.0 -to 90.0 -length 180 -orient horizontal 464scale .extras.lambda_0 -label "Reference longitude" \ 465 -variable lambda_0 -from -180.0 -to 180.0 -length 180 -orient horizontal 466scale .extras.phi_1 -label "First standard parallel" \ 467 -variable phi_1 -from -90.0 -to 90.0 -length 180 -orient horizontal 468scale .extras.phi_2 -label "Second standard parallel" \ 469 -variable phi_2 -from -90.0 -to 90.0 -length 180 -orient horizontal 470 471grid .extras.llat .extras.elat -sticky nsew 472grid .extras.llon .extras.elon -sticky nsew 473grid .extras.lambda_0 - -sticky nsew 474grid .extras.phi_0 - -sticky nsew 475grid .extras.phi_1 - -sticky nsew 476grid .extras.phi_2 - -sticky nsew 477 478grid rowconfigure .extras 20 -weight 1 479 480grid .c .projs .projsy -sticky nsew 481grid ^ .extras - -sticky nsew 482 483grid rowconfigure . 1 -weight 1 484grid columnconfigure . 0 -weight 1 485 486foreach cmd [info commands ::mapproj::to*] { 487 if {[regexp ^::mapproj::to(.*) $cmd -> pro] 488 && [namespace origin ::mapproj::from$pro] ne {} 489 && [isProjection $pro]} { 490 lappend prolist $pro 491 } 492} 493 494bind .c <1> {locate %W %x %y} 495bind .projs <<ListboxSelect>> { 496 foreach p [.projs curselection] { 497 set projection [.projs get $p] 498 } 499 showMap 500} 501foreach pro [lsort -dictionary $prolist] { 502 .projs insert end $pro 503} 504 505.projs selection set 0 506event generate .projs <<ListboxSelect>> 507 508trace add variable phi_0 write "showMap;\#" 509trace add variable phi_1 write "showMap;\#" 510trace add variable phi_2 write "showMap;\#" 511trace add variable lambda_0 write "showMap;\#" 512