1#!/bin/sh 2# -*- tcl -*- \ 3exec tclsh8.5 "$0" ${1+"$@"} 4# ### ### ### ######### ######### ######### 5 6## DEMO. Uses openstreetmap to show a tile-based world map. 7 8## Call without arguments for a plain web-served map. 9## Call with single argument (dir path) to use a tile cache. 10 11## Syntax: osm ?cachedir? 12 13## -- Note: The cache may not exist, it is automatically filled and/or 14## extended from the web-served data. This cache can grow very 15## large very quickly (I have currently seen ranging in size from 16## 4K (water) to 124K (dense urban area)). 17 18## Note: The editing of waypoints shows my inexperience with the 19## canvas. Adding points is with <1>, bound to the canvas 20## itself. Removing is with <3>, bound to the item 21## itself. However, often it doesn't work, or rather, only if a 22## add a new point X via <1> over the point of interest, and 23## then remove both X and the point of interest by using <3> 24## twice. 25## 26## Oh, and removal via <1> bound the item works not at all, 27## because this triggers the global binding as well, re-adding 28## the point immediately after its removal. Found no way of 29## blocking that. 30## 31## Note: Currently new point can be added only at the end of the 32## trail. No insertion in the middle possible, although deletion 33## in the middle works. No moving points, yet. 34## 35## Note: This demo is reaching a size there it should be shifted to 36## tclapps for further development, and cleaned up, with many of 37## the messes encapsulated into snit types or other niceties, 38## separate packages, etc. 39 40 41## Ideas: 42## == DONE == 43## -- Add zoom-control to switch between zoom levels. This has to 44## adjust the scroll-region as well. The control can be something 45## using basic Tk widgets (scale, button), or maybe some constructed 46## from canvas items, to make the map look more like the web-based 47## map displays. For the latter we have to get viewport tracking 48## data out of the canvas::sqmap to move the item-group in sync 49## with scrolling, so that they appear to stay in place. 50## 51## == DONE == 52## -- Add a filesystem based tile cache to speed up their loading. The 53## pure http access is slow (*) OTOH, this makes the workings of 54## sqmap more observable, as things do not happen as fast as for 55## puzzle and city. (*) The xy store generates some output so you 56## can see that something is happening. 57## 58## -- Yes, it is possible to use google maps as well. Spying on a 59## browser easily shows the urls needed. But, they are commercial, 60## and some of the servers (sat image data) want some auth cookie. 61## Without they deliver a few proper tiles and then return errors. 62## 63## Hence this demo uses the freely available openstreetmap(.org) 64## data instead. 65## 66## == DONE == 67## -- Select two locations, then compute the geo distance between 68## them. Or, select a series of location, like following a road, 69## and compute the partial and total distances. 70 71## == DONE == (roughly) 72## -- Mark, save, load series of points (gps tracks, own tracks). 73## Name point series. Name individual points (location marks). 74 75# ### ### ### ######### ######### ######### 76## Other requirements for this example. 77 78package require Tcl 8.5 79package require Tk 80package require widget::scrolledwindow 81package require canvas::sqmap 82package require canvas::zoom 83package require crosshair 84package require img::png 85package require tooltip 86 87package require map::slippy ; # Slippy utilities 88package require map::slippy::fetcher ; # Slippy server access 89package require map::slippy::cache ; # Local slippy tile cache 90#package require map::slippy::prefetcher ; # Agressive prefetch 91 92package require snit ; # canvas::sqmap dependency 93package require uevent::onidle ; # ditto 94package require cache::async 0.2 ; # ditto 95 96set defaultLocations { 97} 98set cities { 99 "Aachen" {50.7764185111 6.086769104} 100 "Anchorage" {61.218333 -149.899167} 101 "Banff" {51.1653 -115.5322} 102 "Beijing" {39.913889 116.391667} 103 "Boston " {42.35 -71.066666} 104 "Buenos Aires" {-34.603333 -58.381667} 105 "Chicago" {41.8675 -87.6243} 106 "Denver" {39.75 -104.98} 107 "Honolulu" {21.31 -157.83} 108 "Johannesburg" {-26.204444 28.045556} 109 "London" {51.508056 -0.124722} 110 "Los Angeles" {34.054 -118.245} 111 "Mexico City" {19.433333 -99.133333} 112 "Moscow" {55.751667 37.617778} 113 "New York" {40.7563 -73.9865} 114 "Palo Alto" {37.429167 -122.138056} 115 "Paris" {48.856667 2.350833} 116 "San Francisco" {37.77 -122.43} 117 "Sydney" {-33.859972 151.211111} 118 "Tokyo" {35.700556 139.715} 119 "Vancouver (Lost Lagoon)" {49.30198 -123.13724} 120 "Washington DC" {38.9136 -77.0132} 121} 122 123# ### ### ### ######### ######### ######### 124 125proc Main {} { 126 InitModel 127 GUI 128 LoadInitialMarks 129 130 # Hack to get display to show nicely while the initial maps are 131 # loading 132 set gridInfo [grid info .sw] 133 grid forget .sw 134 update 135 grid .sw {*}$gridInfo 136 137 SetRegion $::zoom ; # Force initial region as the zoom control 138 # will not call us initially, only on 139 # future changes. 140 GetInitialMark 141} 142 143# ### ### ### ######### ######### ######### 144 145proc InitModel {} { 146 global argv cachedir loaddir provider zoom 147 148 set zoom 12 149 set cachedir "" 150 set loaddir [pwd] 151 152 # OpenStreetMap. Mapnik rendered tiles. 153 # alternative http://tah.openstreetmap.org/Tiles/tile 154 155 if {"FETCH" in [info commands]} { rename FETCH {}} ;# KPV, allow re-loading 156 set provider [map::slippy::fetcher FETCH 19 http://tile.openstreetmap.org] 157 158 # Nothing to do if no cache is specified, and fail for wrong#args 159 160 if {![llength $argv]} return 161 if {[llength $argv] > 1} Usage 162 163 # A cache is specified. Create the directory, if necessary, and 164 # initialize the necessary objects. 165 166 set cachedir [lindex $argv 0] 167 set loaddir $cachedir 168 set provider [map::slippy::cache CACHE $cachedir FETCH] 169 170 # Pre-filling the cache based on map requests. Half-baked. Takes 171 # currently to much cycles from the main requests themselves. set 172 #provider [map::slippy::prefetcher PREFE CACHE] 173 return 174} 175 176proc Usage {} { 177 global argv0 178 puts stderr "wrong\#args, expected: $argv0 ?cachedir?" 179 exit 1 180} 181 182# ### ### ### ######### ######### ######### 183 184proc GUI {} { 185 global provider 186 # --------------------------------------------------------- 187 # The gui elements, plus connections. 188 189 widget::scrolledwindow .sw 190 widget::scrolledwindow .sl 191 192 set th [$provider tileheight] 193 set tw [$provider tilewidth] 194 195 canvas::sqmap .map -closeenough 3 \ 196 -viewport-command VPTRACK -grid-cell-command GET \ 197 -grid-cell-width $tw -grid-cell-height $th -bg yellow 198 199 canvas::zoom .z -variable ::zoom -command ZOOM \ 200 -orient vertical -levels [$provider levels] 201 202 label .loc -textvariable ::location \ 203 -bd 2 -relief sunken -bg white -width 20 -anchor w 204 label .dist -textvariable ::distance \ 205 -bd 2 -relief sunken -bg white -width 20 -anchor w 206 207 listbox .lm -listvariable ::locations \ 208 -selectmode single -exportselection 0 209 210 button .exit -command exit -text Exit 211 button .goto -command GotoMark -text Goto 212 button .clr -command ClearPoints -text {Clear Points} 213 button .ld -command LoadPoints -text {Load Points} 214 button .sv -command SavePoints -text {Save Points} 215 216 .sw setwidget .map 217 .sl setwidget .lm 218 219 # --------------------------------------------------------- 220 # layout of the elements 221 222 grid .sl -row 1 -column 0 -sticky swen -columnspan 2 223 #grid .z -row 1 -column 2 -sticky wen 224 grid .sw -row 1 -column 3 -sticky swen -columnspan 6 225 226 place .z -in .map -x .2i -y .2i -anchor nw 227 228 grid .exit -row 0 -column 0 -sticky wen 229 grid .goto -row 0 -column 1 -sticky wen 230 grid .clr -row 0 -column 3 -sticky wen 231 grid .ld -row 0 -column 4 -sticky wen 232 grid .sv -row 0 -column 5 -sticky wen 233 grid .loc -row 0 -column 6 -sticky wen 234 grid .dist -row 0 -column 7 -sticky wen 235 236 grid rowconfigure . 0 -weight 0 237 grid rowconfigure . 1 -weight 1 238 239 grid columnconfigure . 0 -weight 0 240 grid columnconfigure . 1 -weight 0 241 grid columnconfigure . 2 -weight 0 242 grid columnconfigure . 3 -weight 0 243 grid columnconfigure . 8 -weight 1 244 245 # --------------------------------------------------------- 246 # Behaviours 247 248 # Panning via mouse 249 bind .map <ButtonPress-2> {%W scan mark %x %y} 250 bind .map <B2-Motion> {%W scan dragto %x %y} 251 252 # Mark/unmark a point on the canvas 253 bind .map <1> {RememberPoint %x %y} 254 255 # Double clicking location selects it 256 bind .lm <Double-Button-1> GotoMark 257 258 # Double-clicking right button centers map to mouse location. 259 bind .map <Double-Button-3> GotoMouse 260 261 # Cross hairs ... 262 .map configure -cursor tcross 263 crosshair::crosshair .map -width 0 -fill \#999999 -dash {.} 264 crosshair::track on .map TRACK 265 266 # --------------------------------------------------------- 267 return 268} 269 270# ### ### ### ######### ######### ######### 271 272set location "location" ; # geo location of the mouse in the canvas (crosshair) 273set distance "distance" ; # distance between marks 274 275proc VPTRACK {xl yt xr yb} { 276 # args = viewport, pixels, see also canvas::sqmap, SetPixelView. 277 global viewport 278 set viewport [list $xl $yt $xr $yb] 279 #puts VP-TRACK($viewport) 280 return 281} 282 283proc TRACK {win x y args} { 284 # args = viewport, pixels, see also canvas::sqmap, SetPixelView. 285 global location zoom clat clon 286 287 # Convert pixels to geographic location. 288 set point [list $zoom $y $x] 289 foreach {_ clat clon} [map::slippy point 2geo $point] break 290 291 # Update entry field. 292 set location [PrettyLatLon $clat $clon] 293 return 294} 295 296# ### ### ### ######### ######### ######### 297# Basic callback structure, log for logging, facade to transform the 298# cache/tiles result into what xcanvas is expecting. 299 300proc GET {__ at donecmd} { 301 global provider zoom 302 set tile [linsert $at 0 $zoom] 303 304 if {![map::slippy tile valid $tile [$provider levels]]} { 305 GOT $donecmd unset $tile 306 return 307 } 308 309 #puts "GET ($tile) ($donecmd)" 310 $provider get $tile [list GOT $donecmd] 311 return 312} 313 314proc GOT {donecmd what tile args} { 315 #puts "\tGOT $donecmd $what ($tile) $args" 316 set at [lrange $tile 1 end] 317 if {[catch { 318 uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]] 319 }]} { puts $::errorInfo } 320 return 321} 322 323# ### ### ### ######### ######### ######### 324 325proc ZOOM {w level} { 326 # The variable 'zoom' is already set to level, as the -variable of 327 # our zoom control .z 328 329 #puts ".z = $level" 330 331 SetRegion $level 332 ShowPoints 333 return 334} 335 336proc SetRegion {level} { 337 set rlength [map::slippy length $level] 338 set region [list 0 0 $rlength $rlength] 339 340 .map configure -scrollregion $region 341 return 342} 343 344# ### ### ### ######### ######### ######### 345 346proc Goto {geo} { 347 global zoom 348 349 #puts Jump($geo) 350 351 # The geo location is converted to pixels, then to a fraction of 352 # the scrollregion. This is adjusted so that the fraction 353 # specifies the center of the viewed region, and not the upper 354 # left corner. for this translation we need the viewport data of 355 # VPTRACK. 356 357 foreach {z y x} [map::slippy geo 2point $geo] break 358 set zoom $z 359 after 200 [list Jigger $z $y $x] 360 #.map xview moveto $ofx 361 #.map yview moveto $ofy 362 return 363} 364 365proc Jigger {z y x} { 366 global viewport 367 set len [map::slippy length $z] 368 foreach {l t r b} $viewport break 369 set ofy [expr {($y - ($b - $t)/2.0)/$len}] 370 set ofx [expr {($x - ($r - $l)/2.0)/$len}] 371 372 .map xview moveto $ofx 373 .map yview moveto $ofy 374 return 375} 376 377# ### ### ### ######### ######### ######### 378 379set points {} ; # way-points loaded list (list (lat lon comment)) 380set locations {} ; # Location markers (locationmark.gps) 381set lmarks {} ; # Coordinates for items in location 382 383proc SavePoints {} { 384 global loaddir 385 386 set chosen [tk_getSaveFile -defaultextension .gps \ 387 -filetypes { 388 {GPS {.gps}} 389 {ALL {*}} 390 } \ 391 -initialdir $loaddir \ 392 -title {Save waypoints} \ 393 -parent .map] 394 395 if {$chosen eq ""} return 396 397 global points 398 set lines {} 399 foreach p $points { 400 foreach {lat lon comment} $p break 401 lappend lines [list waypoint $lat $lon $comment] 402 } 403 404 fileutil::writeFile $chosen [join $lines \n]\n 405 return 406} 407 408proc LoadPoints {} { 409 global loaddir 410 411 set chosen [tk_getOpenFile -defaultextension .gps \ 412 -filetypes { 413 {GPS {.gps}} 414 {ALL {*}} 415 } \ 416 -initialdir $loaddir \ 417 -title {Load waypoints} \ 418 -parent .map] 419 420 if {$chosen eq ""} return 421 if {[catch { 422 set waypoints [fileutil::cat $chosen] 423 }]} { 424 return 425 } 426 427 set loaddir [file dirname $chosen] 428 429 ClearPoints 430 # Content is TRUSTED. In a proper app this has to be isolated from 431 # the main system through a safe interp. 432 #eval $waypoints 433 ProcessFile $waypoints 434 ShowPoints 435 return 436} 437##+########################################################################## 438# 439# Safer way of processing our GPS file data. Only two commands 440# allowed: "poi lat lon comment" and "waypoint lat lon comment" 441# 442proc ProcessFile {data} { 443 foreach line [split $data \n] { 444 set line [string trim $line] 445 if {$line eq "" || [string match "#*" $line]} continue 446 447 set n [catch {set len [llength $line]}] 448 if {$n || $len != 4} { 449 puts "bad line: '$line'" 450 continue 451 } 452 lassign $line cmd lat lon comment 453 if {$cmd ne "poi" && $cmd ne "waypoint"} { 454 puts "bad command: '$line'" 455 continue 456 } 457 $cmd $lat $lon $comment 458 } 459} 460 461proc waypoint {lat lon comment} { 462 global points 463 lappend points [list $lat $lon $comment] 464 return 465} 466 467proc ShowPoints {} { 468 global points zoom distance 469 470 if {![llength $points]} return 471 472 set cmds {} 473 set cmd [list .map create line] 474 475 set lat0 {} 476 set lon0 {} 477 set dist 0 478 479 foreach point $points { 480 foreach {lat lon comment} $point break 481 foreach {_ y x} [map::slippy geo 2point [list $zoom $lat $lon]] break 482 lappend cmd $x $y 483 lappend cmds [list POI $y $x $lat $lon $comment -fill salmon -tags Series] 484 485 if {$lat0 ne {}} { 486 set leg [GreatCircleDistance $lat0 $lon0 $lat $lon] 487 set dist [expr {$dist + $leg}] 488 } 489 set lat0 $lat 490 set lon0 $lon 491 } 492 lappend cmd -width 2 -tags Series -capstyle round ;#-smooth 1 493 494 if {[llength $points] > 1} { 495 set cmds [linsert $cmds 0 $cmd] 496 } 497 498 .map delete Series 499 #puts [join $cmds \n] 500 eval [join $cmds \n] 501 set distance [PrettyDistance $dist] 502 return 503} 504proc PrettyLatLon {lat lon} { 505 return [format "%.6f %.6f" $lat $lon] 506} 507 508global pcounter 509set pcounter 0 510proc RememberPoint {x y} { 511 #puts REMEMBER/// 512 global pcounter zoom 513 incr pcounter 514 515 set point [list $zoom [.map canvasy $y] [.map canvasx $x]] 516 foreach {_ lat lon} [map::slippy point 2geo $point] break 517 lassign [PrettyLatLon $lat $lon] lat lon 518 519 set comment "$pcounter:<$lat,$lon>" 520 #puts $x/$y/$lat/$lon/$comment/$pcounter 521 522 global points 523 lappend points [list $lat $lon $comment $pcounter] 524 ShowPoints 525 526 # This is handled weird. Placing the mouse on top of a point 527 # doesn't trigger, however when I create a new point <1> at the 528 # position, and then immediately after use <3> I can remove the 529 # new point, and the second click the point underneath triggers as 530 # well. Could this be a stacking issue? 531 .map bind T/$comment <3> "[list ForgetPoint $pcounter];break" 532 533 # Alternative: Bind <3> and the top level and use 'find 534 # overlapping'. In that case however either we, or the sqmap 535 # should filter out the background items. 536 537 return 538} 539 540proc ForgetPoint {pid} { 541 542 # puts [.map find overlapping $x $y $x $y] 543 #return 544 545 #puts //FORGET//$pid 546 547 global points 548 set pos -1 549 foreach p $points { 550 incr pos 551 foreach {lat lon comment id} $p break 552 if {$id != $pid} continue 553 #puts \tFound/$pos 554 set points [lreplace $points $pos $pos] 555 if {![llength $points]} { 556 ClearPoints 557 } else { 558 ShowPoints 559 } 560 return 561 } 562 #puts Missed 563 return 564} 565# See http://wiki.tcl.tk/8447 566proc GreatCircleDistance {lat1 lon1 lat2 lon2} { 567 set y1 $lat1 568 set x1 $lon1 569 set y2 $lat2 570 set x2 $lon2 571 572 set pi [expr {acos(-1)}] 573 set x1 [expr {$x1 *2*$pi/360.0}] ;# Convert degrees to radians 574 set x2 [expr {$x2 *2*$pi/360.0}] 575 set y1 [expr {$y1 *2*$pi/360.0}] 576 set y2 [expr {$y2 *2*$pi/360.0}] 577 # calculate distance: 578 ##set d [expr {acos(sin($y1)*sin($y2)+cos($y1)*cos($y2)*cos($x1-$x2))}] 579 set d [expr {sin($y1)*sin($y2)+cos($y1)*cos($y2)*cos($x1-$x2)}] 580 if {abs($d) > 1.0} { ;# Rounding error 581 set d [expr {$d > 0 ? 1.0 : -1.0}] 582 } 583 set d [expr {acos($d)}] 584 585 set meters [expr {20001600/$pi*$d}] 586 return $meters 587} 588proc PrettyDistance {dist} { 589 if {$dist == 0} { return "distance" } 590 set meters [expr {round($dist)}] 591 if {$meters == 1} { return "1 meter"} 592 if {$meters < 1000} { return "$meters meters"} 593 return [format "%.1f km" [expr {$dist/1000.0}]] 594} 595proc POI {y x lat lon comment args} { 596 set x1 [expr { $x + 6 }] 597 set y1 [expr { $y + 6 }] 598 set x [expr { $x - 6 }] 599 set y [expr { $y - 6 }] 600 601 set id [eval [linsert $args 0 .map create oval $x $y $x1 $y1]] 602 if {$comment eq ""} return 603 tooltip::tooltip .map -item $id $comment 604 .map addtag T/$comment withtag $id 605 return 606} 607 608proc ClearPoints {} { 609 global points 610 set points {} 611 .map delete Series 612 set ::distance "distance" 613 return 614} 615 616proc LoadInitialMarks {} { 617 foreach {name latlon} $::cities { 618 lassign $latlon lat lon 619 poi $lat $lon $name 620 } 621} 622 623proc ClearMarks {} { 624 global lmarks locations 625 set lmarks {} 626 set locations {} 627 return 628} 629 630proc poi {lat lon comment} { 631 global lmarks locations 632 lappend lmarks [list $lat $lon] 633 lappend locations $comment 634 return 635} 636 637proc ShowMarks {} { 638 # locations traced by .lm 639 return 640} 641 642proc GotoMouse {} { 643 global clat clon zoom 644 Goto [list $zoom $clat $clon] 645 return 646} 647 648proc GotoMark {} { 649 global lmarks zoom 650 set sel [.lm curselection] 651 if {![llength $sel]} return 652 set sel [lindex $sel 0] 653 set sel [lindex $lmarks $sel] 654 foreach {lat lon} $sel break 655 Goto [list $zoom $lat $lon] 656 return 657} 658proc GetInitialMark {} { 659 set n [expr {int(rand()*[llength $::locations])}] 660 .lm selection clear 0 end 661 .lm selection set $n 662 .lm selection anchor $n 663 GotoMark 664} 665# ### ### ### ######### ######### ######### 666 667proc ShowGrid {} { 668 # Activating the grid leaks items = memory 669 .map configure -grid-show-borders 1 670 .map flush 671 return 672} 673 674# ### ### ### ######### ######### ######### 675# ### ### ### ######### ######### ######### 676Main 677 678