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