osm.el (70795B)
1 ;;; osm.el --- OpenStreetMap viewer -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2022-2024 Free Software Foundation, Inc. 4 5 ;; Author: Daniel Mendler <mail@daniel-mendler.de> 6 ;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> 7 ;; Created: 2022 8 ;; Package-Version: 20241119.2137 9 ;; Package-Revision: ab76f8a9e79e 10 ;; Package-Requires: ((emacs "28.1") (compat "30")) 11 ;; URL: https://github.com/minad/osm 12 ;; Keywords: network, multimedia, hypermedia, mouse 13 14 ;; This file is part of GNU Emacs. 15 16 ;; This program is free software: you can redistribute it and/or modify 17 ;; it under the terms of the GNU General Public License as published by 18 ;; the Free Software Foundation, either version 3 of the License, or 19 ;; (at your option) any later version. 20 21 ;; This program is distributed in the hope that it will be useful, 22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 24 ;; GNU General Public License for more details. 25 26 ;; You should have received a copy of the GNU General Public License 27 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 28 29 ;;; Commentary: 30 31 ;; Osm.el is a tile-based map viewer, with a responsive movable and 32 ;; zoomable display. The map can be controlled with the keyboard or with 33 ;; the mouse. The viewer fetches the map tiles in parallel from tile 34 ;; servers via the `curl' program. The package comes with a list of 35 ;; multiple preconfigured tile servers. You can bookmark your favorite 36 ;; locations using regular Emacs bookmarks or create links from Org files 37 ;; to locations. Furthermore the package provides commands to measure 38 ;; distances, search for locations by name and to open and display GPX 39 ;; tracks. 40 41 ;; osm.el requires Emacs 28 and depends on the external `curl' program. 42 ;; Emacs must be built with libxml, libjansson, librsvg, libjpeg and 43 ;; libpng support. 44 45 ;;; Code: 46 47 (require 'compat) 48 (require 'bookmark) 49 (require 'dom) 50 (eval-when-compile 51 (require 'cl-lib) 52 (require 'subr-x)) 53 54 (defgroup osm nil 55 "OpenStreetMap viewer." 56 :link '(info-link :tag "Info Manual" "(osm)") 57 :link '(url-link :tag "Website" "https://github.com/minad/osm") 58 :link '(url-link :tag "Wiki" "https://github.com/minad/osm/wiki") 59 :link '(emacs-library-link :tag "Library Source" "osm.el") 60 :group 'web 61 :prefix "osm-") 62 63 (defcustom osm-curl-options 64 "--disable --fail --location --silent --max-time 30" 65 "Curl command line options." 66 :type 'string) 67 68 (defcustom osm-search-language "en" 69 "Language used for search results. 70 Use RFC 1766 abbreviations, e.g.: `en' for English, `de' for German. 71 A comma-separated specifies descending order of preference. See also 72 `url-mime-language-string'." 73 :type 'string) 74 75 (defcustom osm-search-server 76 "https://nominatim.openstreetmap.org" 77 "Server used to search for location names. 78 The server must offer the nominatim.org API." 79 :type 'string) 80 81 (defcustom osm-server-defaults 82 '(:min-zoom 2 83 :max-zoom 19 84 :download-batch 4 85 :max-connections 2 86 :subdomains ("a" "b" "c")) 87 "Default server properties. 88 See also `osm-server-list'." 89 :type 'plist) 90 91 (defcustom osm-server-list 92 '((default 93 :name "Carto" 94 :description "Standard Carto map provided by OpenStreetMap" 95 :url "https://%s.tile.openstreetmap.org/%z/%x/%y.png" 96 :group "Standard" 97 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 98 "Map style © {OpenStreetMap Standard|https://www.openstreetmap.org/copyright}")) 99 (de 100 :name "Carto(de)" 101 :description "Localized Carto map provided by OpenStreetMap Germany" 102 :url "https://%s.tile.openstreetmap.de/%z/%x/%y.png" 103 :group "Standard" 104 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 105 "Map style © {OpenStreetMap Deutschland|https://www.openstreetmap.de/germanstyle.html}")) 106 (fr 107 :name "Carto(fr)" 108 :description "Localized Carto map by OpenStreetMap France" 109 :url "https://%s.tile.openstreetmap.fr/osmfr/%z/%x/%y.png" 110 :group "Standard" 111 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 112 "Map style © {OpenStreetMap France|https://www.openstreetmap.fr/mentions-legales/}")) 113 (humanitarian 114 :name "Humanitarian" 115 :description "Humanitarian map provided by OpenStreetMap France" 116 :url "https://%s.tile.openstreetmap.fr/hot/%z/%x/%y.png" 117 :group "Special Purpose" 118 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 119 "Map style © {Humanitarian OpenStreetMap Team|https://www.hotosm.org/updates/2013-09-29_a_new_window_on_openstreetmap_data}")) 120 (cyclosm 121 :name "CyclOSM" 122 :description "Bicycle-oriented map provided by OpenStreetMap France" 123 :url "https://%s.tile-cyclosm.openstreetmap.fr/cyclosm/%z/%x/%y.png" 124 :group "Transportation" 125 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 126 "Map style © {CyclOSM|https://www.cyclosm.org/} contributors")) 127 (openriverboatmap 128 :name "OpenRiverBoatMap" 129 :description "Waterways map provided by OpenStreetMap France" 130 :url "https://%s.tile.openstreetmap.fr/openriverboatmap/%z/%x/%y.png" 131 :group "Transportation" 132 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 133 "Map style © {OpenRiverBoatMap|https://github.com/tilery/OpenRiverboatMap}")) 134 (opentopomap 135 :name "OpenTopoMap" 136 :description "Topographical map provided by OpenTopoMap" 137 :url "https://%s.tile.opentopomap.org/%z/%x/%y.png" 138 :group "Topographical" 139 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 140 "Map style © {OpenTopoMap|https://www.opentopomap.org} ({CC-BY-SA|https://creativecommons.org/licenses/by-sa/3.0/})" 141 "Elevation data: {SRTM|https://www2.jpl.nasa.gov/srtm/}")) 142 (opvn 143 :name "ÖPNV" :max-zoom 18 144 :description "Base layer with public transport information" 145 :url "http://%s.tile.memomaps.de/tilegen/%z/%x/%y.png" 146 :group "Transportation" 147 :copyright ("Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors" 148 "Map style © {ÖPNVKarte|https://www.öpnvkarte.de}"))) 149 "List of tile servers. 150 151 Allowed keys: 152 :name Server name 153 :description Server description 154 :copyright Copyright information 155 :group Name of server groups for related servers 156 :url Url with placeholders 157 :ext File name extension 158 :min-zoom Minimum zoom level 159 :max-zoom Maximum zoom level 160 :download-batch Number of tiles downloaded via a single connection 161 :max-connections Maximum number of parallel connections 162 :subdomains Subdomains used for the %s placeholder 163 164 See also `osm-server-defaults' for default values used for a 165 server if the property is missing. 166 167 The :url of each server should specify %x, %y, %z and %s placeholders 168 for the map coordinates. It can optionally use an %s placeholder 169 for the subdomain and a %k placeholder for an apikey. The apikey 170 will be retrieved via `auth-source-search' with the :host set to 171 the domain name and the :user to the string \"apikey\"." 172 :type '(alist :key-type symbol :value-type plist)) 173 174 (defcustom osm-copyright t 175 "Display the copyright information above the map." 176 :type 'boolean) 177 178 (defcustom osm-pin-colors 179 '((osm-selected . "#e20") 180 (osm-bookmark . "#f80") 181 (osm-poi . "#88f") 182 (osm-home . "#80f") 183 (osm-track . "#00a")) 184 "Colors of pins." 185 :type '(alist :key-type symbol :value-type string)) 186 187 (defcustom osm-track-style 188 "stroke:#00a;stroke-width:5;stroke-linejoin:round;stroke-linecap:round;opacity:0.4;" 189 "SVG style used to draw tracks." 190 :type 'string) 191 192 (defcustom osm-home 193 (let ((lat (bound-and-true-p calendar-latitude)) 194 (lon (bound-and-true-p calendar-longitude))) 195 (if (and lat lon) 196 (list lat lon 12) 197 (list 0 0 3))) 198 "Home coordinates, latitude, longitude and zoom level." 199 :type '(list :tag "Coordinates" 200 (number :tag "Latitude ") 201 (number :tag "Longitude ") 202 (number :tag "Zoom "))) 203 204 (defcustom osm-large-step 256 205 "Scroll step in pixel." 206 :type 'natnum) 207 208 (defcustom osm-tile-border nil 209 "Set to t to display thin tile borders. 210 For debugging set the value to `debug', such that a border is 211 shown around SVG tiles." 212 :type '(choice boolean (const debug))) 213 214 (defcustom osm-small-step 16 215 "Scroll step in pixel." 216 :type 'natnum) 217 218 (defcustom osm-server 'default 219 "Tile server name." 220 :type 'symbol) 221 222 (defcustom osm-tile-directory 223 (expand-file-name "var/osm/" user-emacs-directory) 224 "Tile cache directory." 225 :type 'string) 226 227 (defcustom osm-max-age 14 228 "Maximum tile age in days. 229 Should be at least 7 days according to the server usage policies." 230 :type '(choice (const nil) natnum)) 231 232 (defcustom osm-max-tiles 256 233 "Number of tiles to keep in the memory cache." 234 :type '(choice (const nil) natnum)) 235 236 (defun osm--menu-item (menu) 237 "Generate menu item from MENU." 238 `(menu-item 239 "" nil :filter 240 ,(lambda (&optional _) 241 (select-window 242 (posn-window 243 (event-start last-input-event))) 244 (if (functionp menu) 245 (funcall menu) 246 menu)))) 247 248 (defun osm--mouse-ignore-wheel (_prompt) 249 "Ignore mouse wheel events during key translation." 250 (pcase (this-single-command-raw-keys) 251 ((and `[,e] 252 (let y (event-basic-type e)) 253 (guard (symbolp y)) 254 (guard (string-search "wheel-" (symbol-name y)))) 255 []) 256 (k k))) 257 258 (defvar-keymap osm-prefix-map 259 :doc "Global prefix map of OSM entry points." 260 "h" #'osm-home 261 "s" #'osm-search 262 "v" #'osm-server 263 "t" #'osm-goto 264 "j" #'osm-jump 265 "x" #'osm-gpx-show 266 "X" #'osm-gpx-hide) 267 268 ;;;###autoload (autoload 'osm-prefix-map "osm" nil t 'keymap) 269 (defalias 'osm-prefix-map osm-prefix-map) 270 271 (defvar-keymap osm-mode-map 272 :doc "Keymap used by `osm-mode'." 273 :parent (make-composed-keymap osm-prefix-map special-mode-map) 274 "<home>" #'osm-home 275 "+" #'osm-zoom-in 276 "-" #'osm-zoom-out 277 "SPC" #'osm-zoom-in 278 "S-SPC" #'osm-zoom-out 279 "<mouse-1>" #'osm-mouse-pin 280 "<mouse-2>" 'org-store-link 281 "<mouse-3>" #'osm-bookmark-set 282 "S-<down-mouse-1>" #'ignore 283 "S-<mouse-1>" #'osm-mouse-track 284 "<down-mouse-1>" #'osm-mouse-drag 285 "<down-mouse-2>" #'osm-mouse-drag 286 "<down-mouse-3>" #'osm-mouse-drag 287 "<drag-mouse-1>" #'ignore 288 "<drag-mouse-2>" #'ignore 289 "<drag-mouse-3>" #'ignore 290 "<up>" #'osm-up 291 "<down>" #'osm-down 292 "<left>" #'osm-left 293 "<right>" #'osm-right 294 "C-<up>" #'osm-up-up 295 "C-<down>" #'osm-down-down 296 "C-<left>" #'osm-left-left 297 "C-<right>" #'osm-right-right 298 "M-<up>" #'osm-up-up 299 "M-<down>" #'osm-down-down 300 "M-<left>" #'osm-left-left 301 "M-<right>" #'osm-right-right 302 "S-<up>" #'osm-up-up 303 "S-<down>" #'osm-down-down 304 "S-<left>" #'osm-left-left 305 "S-<right>" #'osm-right-right 306 "n" #'osm-rename 307 "d" #'osm-delete 308 "DEL" #'osm-delete 309 "<deletechar>" #'osm-delete 310 "c" #'osm-center 311 "o" #'clone-buffer 312 "u" #'osm-save-url 313 "l" 'org-store-link 314 "b" #'osm-bookmark-set 315 "X" #'osm-gpx-hide 316 "<remap> <scroll-down-command>" #'osm-down 317 "<remap> <scroll-up-command>" #'osm-up 318 "<" nil 319 ">" nil) 320 321 (dolist (pin osm-pin-colors) 322 (setq pin (vector (car pin))) 323 (define-key key-translation-map pin #'osm--mouse-ignore-wheel) 324 (define-key osm-mode-map pin #'osm-mouse-select)) 325 326 (easy-menu-define osm-mode-menu osm-mode-map 327 "Menu for `osm-mode'." 328 '("OSM" 329 ["Go home" osm-home] 330 ["Center" osm-center] 331 ["Go to coordinates" osm-goto] 332 ["Jump to pin" osm-jump] 333 ["Search by name" osm-search] 334 ["Change tile server" osm-server] 335 "--" 336 ["Org Link" org-store-link] 337 ["Geo Url" osm-save-url] 338 ["Elisp Link" (osm-save-url t)] 339 ("Bookmark" 340 ["Set" osm-bookmark-set] 341 ["Jump" osm-bookmark-jump] 342 ["Rename" osm-bookmark-rename] 343 ["Delete" osm-bookmark-delete]) 344 "--" 345 ["Show GPX file" osm-gpx-show] 346 ["Hide GPX file" osm-gpx-hide] 347 "--" 348 ["Clone buffer" clone-buffer] 349 ["Revert buffer" revert-buffer] 350 "--" 351 ["Manual" (info "(osm)")] 352 ["Customize" (customize-group 'osm)])) 353 354 (defconst osm--placeholder 355 '(:type svg :width 256 :height 256 356 :data "<svg width='256' height='256' version='1.1' xmlns='http://www.w3.org/2000/svg'> 357 <defs> 358 <pattern id='grid' width='16' height='16' patternUnits='userSpaceOnUse'> 359 <path d='m 0 0 l 0 16 16 0' fill='none' stroke='#888888'/> 360 </pattern> 361 </defs> 362 <rect width='256' height='256' fill='url(#grid)'/> 363 </svg>") 364 "Placeholder image for tiles.") 365 366 (defvar osm--search-history nil 367 "Minibuffer history used by command `osm-search'.") 368 369 (defvar osm--jump-history nil 370 "Minibuffer history used by command `osm-jump'.") 371 372 (defvar osm--server-history nil 373 "Minibuffer history used by command `osm-server'.") 374 375 (defvar osm--purge-directory 0 376 "Last time the tile cache was cleaned.") 377 378 (defvar osm--tile-cache nil 379 "Global tile memory cache.") 380 381 (defvar osm--tile-age 0 382 "Tile age, incremented on every update.") 383 384 (defvar osm--gpx-files nil 385 "Global list of loaded tracks.") 386 387 (defvar osm--track nil 388 "List of track coordinates.") 389 390 (defvar osm--download-processes nil 391 "Globally active download processes.") 392 393 (defvar osm--download-active nil 394 "Globally active download jobs.") 395 396 (defvar osm--download-subdomain nil 397 "Subdomain indices to query the servers in a round-robin fashion.") 398 399 (defvar-local osm--download-queue nil 400 "Buffer-local tile download queue.") 401 402 (defvar-local osm--wx 0 403 "Half window width in pixel.") 404 405 (defvar-local osm--wy 0 406 "Half window height in pixel.") 407 408 (defvar-local osm--nx 0 409 "Number of tiles in x direction.") 410 411 (defvar-local osm--ny 0 412 "Number of tiles in y direction.") 413 414 (defvar-local osm--zoom nil 415 "Zoom level of the map.") 416 417 (defvar-local osm--lat nil 418 "Latitude coordinate.") 419 420 (defvar-local osm--lon nil 421 "Longitude coordinate.") 422 423 (defvar-local osm--overlays nil 424 "Overlay hash table. 425 Local per buffer since the overlays depend on the zoom level.") 426 427 (defvar-local osm--pin nil 428 "Currently selected pin.") 429 430 (defmacro osm--each (&rest body) 431 "Execute BODY in each `osm-mode' buffer." 432 (cl-with-gensyms (buf) 433 `(dolist (,buf (buffer-list)) 434 (when (eq (buffer-local-value 'major-mode ,buf) #'osm-mode) 435 (with-current-buffer ,buf 436 ,@body))))) 437 438 (defun osm--server-menu () 439 "Generate server menu." 440 (let (menu last-group) 441 (dolist (server osm-server-list) 442 (let* ((plist (cdr server)) 443 (group (plist-get plist :group))) 444 (unless (equal last-group group) 445 (push (format "─── %s ───" group) menu) 446 (setq last-group group)) 447 (push 448 `[,(plist-get plist :name) 449 (osm-server ',(car server)) 450 :style toggle 451 :selected (eq osm-server ',(car server))] 452 menu))) 453 (easy-menu-create-menu "Server" (nreverse menu)))) 454 455 (defsubst osm--lon-to-normalized-x (lon) 456 "Convert LON to normalized x coordinate." 457 (/ (+ lon 180.0) 360.0)) 458 459 (defsubst osm--lat-to-normalized-y (lat) 460 "Convert LAT to normalized y coordinate." 461 (setq lat (* lat (/ float-pi 180.0))) 462 (- 0.5 (/ (log (+ (tan lat) (/ 1.0 (cos lat)))) float-pi 2))) 463 464 (defun osm--boundingbox-to-zoom (lat1 lat2 lon1 lon2) 465 "Compute zoom level from boundingbox LAT1 to LAT2 and LON1 to LON2." 466 (let ((w (/ (frame-pixel-width) 256)) 467 (h (/ (frame-pixel-height) 256))) 468 (max (osm--server-property :min-zoom) 469 (min 470 (osm--server-property :max-zoom) 471 (min (logb (/ w (abs (- (osm--lon-to-normalized-x lon1) (osm--lon-to-normalized-x lon2))))) 472 (logb (/ h (abs (- (osm--lat-to-normalized-y lat1) (osm--lat-to-normalized-y lat2)))))))))) 473 474 (defun osm--x-to-lon (x zoom) 475 "Return longitude in degrees for X/ZOOM." 476 (- (/ (* x 360.0) 256.0 (expt 2.0 zoom)) 180.0)) 477 478 (defun osm--y-to-lat (y zoom) 479 "Return latitude in degrees for Y/ZOOM." 480 (setq y (* float-pi (- 1 (* 2 (/ y 256.0 (expt 2.0 zoom)))))) 481 (/ (* 180 (atan (/ (- (exp y) (exp (- y))) 2))) float-pi)) 482 483 (defsubst osm--lon-to-x (lon zoom) 484 "Convert LON/ZOOM to x coordinate in pixel." 485 (floor (* 256 (expt 2.0 zoom) (osm--lon-to-normalized-x lon)))) 486 487 (defsubst osm--lat-to-y (lat zoom) 488 "Convert LAT/ZOOM to y coordinate in pixel." 489 (floor (* 256 (expt 2.0 zoom) (osm--lat-to-normalized-y lat)))) 490 491 (defsubst osm--x () 492 "Return longitude in pixel of map center." 493 (osm--lon-to-x osm--lon osm--zoom)) 494 495 (defsubst osm--y () 496 "Return latitude in pixel of map center." 497 (osm--lat-to-y osm--lat osm--zoom)) 498 499 (defsubst osm--x0 () 500 "Return longitude in pixel of top left corner." 501 (- (osm--x) osm--wx)) 502 503 (defsubst osm--y0 () 504 "Return latitude in pixel of top left corner." 505 (- (osm--y) osm--wy)) 506 507 (defun osm--server-property (prop &optional server) 508 "Return server property PROP for SERVER." 509 (or (plist-get (alist-get (or server osm-server) osm-server-list) prop) 510 (plist-get osm-server-defaults prop))) 511 512 (defun osm--tile-url (x y zoom) 513 "Return tile url for coordinate X, Y and ZOOM." 514 (let ((url (osm--server-property :url)) 515 (sub (osm--server-property :subdomains)) 516 (key (osm--server-property :key))) 517 (when (and (string-search "%k" url) (not key)) 518 (require 'auth-source) 519 (declare-function auth-source-search "auth-source") 520 (let ((host (string-join 521 (last (split-string (cadr (split-string url "/" t)) "\\.") 2) 522 "."))) 523 (setq key (plist-get 524 (car (auth-source-search :require '(:user :host :secret) 525 :host host 526 :user "apikey")) 527 :secret)) 528 (unless key 529 (warn "No auth source secret found for apikey@%s" host) 530 (setq key "")) 531 (setf (plist-get (alist-get osm-server osm-server-list) :key) key))) 532 (format-spec 533 url `((?z . ,zoom) (?x . ,x) (?y . ,y) 534 (?k . ,(if (functionp key) (funcall key) key)) 535 (?s . ,(nth (mod (alist-get osm-server osm--download-subdomain 0) 536 (length sub)) 537 sub)))))) 538 539 (defun osm--tile-file (x y zoom) 540 "Return tile file name for coordinate X, Y and ZOOM." 541 (file-name-concat 542 (expand-file-name osm-tile-directory) 543 (symbol-name osm-server) 544 (format "%d-%d-%d.%s" 545 zoom x y 546 (or (osm--server-property :ext) 547 (file-name-extension 548 (url-file-nondirectory 549 (osm--server-property :url))))))) 550 551 (defun osm--enqueue-download (x y) 552 "Enqueue tile X/Y for download." 553 (when (let ((n (expt 2 osm--zoom))) (and (>= x 0) (>= y 0) (< x n) (< y n))) 554 (let ((job (list osm-server osm--zoom x y))) 555 (unless (or (member job osm--download-queue) (member job osm--download-active)) 556 (setq osm--download-queue (nconc osm--download-queue (list job))))))) 557 558 (defun osm--download-filter (output) 559 "Filter function for the download process which receives OUTPUT." 560 (while (string-match 561 "\\`\\([0-9]+\\) \\(.*?/\\([^/]+\\)/\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\.[^\r\n]+\\)\r?\n" 562 output) 563 (let ((status (match-string 1 output)) 564 (file (match-string 2 output)) 565 (server (intern-soft (match-string 3 output))) 566 (zoom (string-to-number (match-string 4 output))) 567 (x (string-to-number (match-string 5 output))) 568 (y (string-to-number (match-string 6 output)))) 569 (setq output (substring output (match-end 0))) 570 (when (equal status "200") 571 (ignore-errors (rename-file file (string-remove-suffix ".tmp" file) t)) 572 (osm--each 573 (when (and (= osm--zoom zoom) (eq osm-server server)) 574 (osm--display-tile x y (osm--get-tile x y))))) 575 (cl-callf2 delete (list server zoom x y) osm--download-active) 576 (delete-file file))) 577 output) 578 579 (defun osm--download-command () 580 "Build download command." 581 (let* ((count 0) 582 (batch (osm--server-property :download-batch)) 583 (subs (length (osm--server-property :subdomains))) 584 (parallel (* subs (osm--server-property :max-connections))) 585 args jobs job) 586 (while (and (< count batch) 587 (setq job (nth (* count parallel) osm--download-queue))) 588 (pcase-let ((`(,_server ,zoom ,x ,y) job)) 589 (setq args `(,(osm--tile-url x y zoom) 590 ,(concat (osm--tile-file x y zoom) ".tmp") 591 "--output" 592 ,@args)) 593 (push job jobs) 594 (push job osm--download-active) 595 (cl-incf count))) 596 (osm--each 597 (dolist (job jobs) 598 (cl-callf2 delq job osm--download-queue))) 599 (cl-callf (lambda (s) (mod (1+ s) subs)) 600 (alist-get osm-server osm--download-subdomain 0)) 601 (cons `("curl" "--write-out" "%{http_code} %{filename_effective}\n" 602 ,@(split-string-and-unquote osm-curl-options) ,@(nreverse args)) 603 jobs))) 604 605 (defun osm--download () 606 "Download next tiles from the queue." 607 (when (and (< (length (alist-get osm-server osm--download-processes)) 608 (* (length (osm--server-property :subdomains)) 609 (osm--server-property :max-connections))) 610 osm--download-queue) 611 (pcase-let ((`(,command . ,jobs) (osm--download-command)) 612 (dir (file-name-concat (expand-file-name osm-tile-directory) 613 (symbol-name osm-server))) 614 (server osm-server)) 615 (make-directory dir t) 616 (push 617 (make-process 618 :name "*osm curl*" 619 :connection-type 'pipe 620 :noquery t 621 :command command 622 :filter 623 (let ((output "")) 624 (lambda (_proc out) 625 (setq output (osm--download-filter (concat output out))) 626 (force-mode-line-update t))) 627 :sentinel 628 (lambda (proc _status) 629 (dolist (job jobs) 630 (cl-callf2 delq job osm--download-active)) 631 (cl-callf2 delq proc (alist-get server osm--download-processes nil t)) 632 (force-mode-line-update t) 633 (osm--download))) 634 (alist-get server osm--download-processes)) 635 (force-mode-line-update t) 636 (osm--download)))) 637 638 (defun osm-mouse-drag (event) 639 "Handle drag EVENT." 640 (declare (completion ignore)) 641 (interactive "@e") 642 (pcase-let* ((`(,sx . ,sy) (posn-x-y (event-start event))) 643 (win (selected-window)) 644 (map (define-keymap 645 "<mouse-movement>" 646 (lambda (event) 647 (interactive "e") 648 (setq event (event-start event)) 649 (when (eq win (posn-window event)) 650 (pcase-let ((`(,ex . ,ey) (posn-x-y event))) 651 (osm--move (- sx ex) (- sy ey)) 652 (setq sx ex sy ey) 653 (osm--update))))))) 654 (setq track-mouse 'dragging) 655 (set-transient-map map 656 (lambda () (eq (car-safe last-input-event) 'mouse-movement)) 657 (lambda () (setq track-mouse nil))))) 658 659 (defun osm--zoom-in-wheel (_n) 660 "Zoom in with the mouse wheel." 661 (pcase-let ((`(,x . ,y) (posn-x-y (event-start last-input-event)))) 662 (when (< osm--zoom (osm--server-property :max-zoom)) 663 (osm--move (/ (- x osm--wx) 2) (/ (- y osm--wy) 2)) 664 (osm-zoom-in)))) 665 666 (defun osm--zoom-out-wheel (_n) 667 "Zoom out with the mouse wheel." 668 (pcase-let ((`(,x . ,y) (posn-x-y (event-start last-input-event)))) 669 (when (> osm--zoom (osm--server-property :min-zoom)) 670 (osm--move (- osm--wx x) (- osm--wy y)) 671 (osm-zoom-out)))) 672 673 (defun osm-center () 674 "Center to location of selected pin." 675 (interactive nil osm-mode) 676 (osm--barf-unless-osm) 677 (pcase osm--pin 678 (`(,lat ,lon ,_id ,name) 679 (setq osm--lat lat osm--lon lon) 680 (message "%s" name) 681 (osm--update)))) 682 683 (defun osm--haversine (lat1 lon1 lat2 lon2) 684 "Compute distance between LAT1/LON1 and LAT2/LON2 in km." 685 ;; https://en.wikipedia.org/wiki/Haversine_formula 686 (let* ((rad (/ float-pi 180)) 687 (y (sin (* 0.5 rad (- lat2 lat1)))) 688 (x (sin (* 0.5 rad (- lon2 lon1)))) 689 (h (+ (* x x) (* (cos (* rad lat1)) (cos (* rad lat2)) y y)))) 690 (* 2 6371 (atan (sqrt h) (sqrt (- 1 h)))))) 691 692 (defun osm-mouse-track (event) 693 "Set track pin at location of the click EVENT." 694 (declare (completion ignore)) 695 (interactive "@e") 696 (pcase osm--pin 697 ((and (guard (not osm--track)) `(,lat ,lon ,_id ,_name)) 698 (push (list lat lon "WP1") osm--track))) 699 (osm--set-pin-event event 'osm-track 700 (format "WP%s" (1+ (length osm--track))) 'quiet) 701 (pcase-let ((`(,lat ,lon ,_id ,name) osm--pin)) 702 (push (list lat lon name) osm--track)) 703 (osm--revert) 704 (osm--track-length)) 705 706 (defun osm--track-length () 707 "Echo track length." 708 (when (cdr osm--track) 709 (pcase-let* ((len1 0) 710 (len2 0) 711 (p osm--track) 712 (`(,sel-lat ,sel-lon ,_ ,sel-name) osm--pin)) 713 (while (and (cdr p) (not (and (equal (caar p) sel-lat) 714 (equal (cadar p) sel-lon)))) 715 (cl-incf len2 (osm--haversine (caar p) (cadar p) 716 (caadr p) (cadadr p))) 717 (pop p)) 718 (while (cdr p) 719 (cl-incf len1 (osm--haversine (caar p) (cadar p) 720 (caadr p) (cadadr p))) 721 (pop p)) 722 (message "%s way points, length %.2fkm, %s" 723 (length osm--track) (+ len1 len2) 724 (if (or (= len1 0) (= len2 0)) 725 sel-name 726 (format "%.2fkm → %s → %.2fkm" 727 len1 sel-name len2)))))) 728 729 (defun osm--pin-at (event &optional type) 730 "Get pin of TYPE at EVENT." 731 (let* ((xy (posn-x-y (event-start event))) 732 (x (+ (osm--x0) (car xy))) 733 (y (+ (osm--y0) (cdr xy))) 734 (min most-positive-fixnum) 735 found) 736 (dolist (pin (car (osm--get-overlays (/ x 256) (/ y 256)))) 737 (pcase-let ((`(,p ,q ,_lat ,_lon ,id ,_name) pin)) 738 (when (or (not type) (eq type id)) 739 (let ((d (+ (* (- p x) (- p x)) (* (- q y) (- q y))))) 740 (when (and (>= q y) (< q (+ y 50)) (>= p (- x 20)) (< p (+ x 20)) (< d min)) 741 (setq min d found pin)))))) 742 (cddr found))) 743 744 (defun osm-mouse-pin (event) 745 "Create location pin at the click EVENT." 746 (declare (completion ignore)) 747 (interactive "@e") 748 (osm--set-pin-event event) 749 (osm--update)) 750 751 (defun osm-mouse-select (event) 752 "Select pin at position of click EVENT." 753 (declare (completion ignore)) 754 (interactive "@e") 755 (when (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3)) 756 (pcase (osm--pin-at event) 757 (`(,lat ,lon ,id ,name) 758 (osm--set-pin id lat lon name (eq id 'osm-track)) 759 (when (eq id 'osm-track) (osm--track-length)) 760 (osm--update))))) 761 762 (defun osm-zoom-in (&optional n) 763 "Zoom N times into the map." 764 (interactive "p" osm-mode) 765 (osm--barf-unless-osm) 766 (setq osm--zoom (max (osm--server-property :min-zoom) 767 (min (osm--server-property :max-zoom) 768 (+ osm--zoom (or n 1))))) 769 (osm--update)) 770 771 (defun osm-zoom-out (&optional n) 772 "Zoom N times out of the map." 773 (interactive "p" osm-mode) 774 (osm-zoom-in (- (or n 1)))) 775 776 (defun osm--move (dx dy) 777 "Move by DX/DY." 778 (osm--barf-unless-osm) 779 (setq osm--lon (osm--x-to-lon (+ (osm--x) dx) osm--zoom) 780 osm--lat (osm--y-to-lat (+ (osm--y) dy) osm--zoom))) 781 782 (defun osm-right (&optional n) 783 "Move N small steps to the right." 784 (interactive "p" osm-mode) 785 (osm--move (* (or n 1) osm-small-step) 0) 786 (osm--update)) 787 788 (defun osm-down (&optional n) 789 "Move N small steps down." 790 (interactive "p" osm-mode) 791 (osm--move 0 (* (or n 1) osm-small-step)) 792 (osm--update)) 793 794 (defun osm-up (&optional n) 795 "Move N small steps up." 796 (interactive "p" osm-mode) 797 (osm-down (- (or n 1)))) 798 799 (defun osm-left (&optional n) 800 "Move N small steps to the left." 801 (interactive "p" osm-mode) 802 (osm-right (- (or n 1)))) 803 804 (defun osm-right-right (&optional n) 805 "Move N large steps to the right." 806 (interactive "p" osm-mode) 807 (osm--move (* (or n 1) osm-large-step) 0) 808 (osm--update)) 809 810 (defun osm-down-down (&optional n) 811 "Move N large steps down." 812 (interactive "p" osm-mode) 813 (osm--move 0 (* (or n 1) osm-large-step)) 814 (osm--update)) 815 816 (defun osm-up-up (&optional n) 817 "Move N large steps up." 818 (interactive "p" osm-mode) 819 (osm-down-down (- (or n 1)))) 820 821 (defun osm-left-left (&optional n) 822 "Move N large steps to the left." 823 (interactive "p" osm-mode) 824 (osm-right-right (- (or n 1)))) 825 826 (defun osm--purge-directory () 827 "Clean tile directory." 828 (when (and (integerp osm-max-age) 829 (> (- (float-time) osm--purge-directory) (* 60 60 24))) 830 (setq osm--purge-directory (float-time)) 831 (run-with-idle-timer 832 30 nil 833 (lambda () 834 (dolist (dir (directory-files osm-tile-directory t "\\`[^.]+\\'" t)) 835 (dolist (file (directory-files 836 dir t "\\.\\(?:png\\|jpe?g\\)\\(?:\\.tmp\\)?\\'" t)) 837 (when (> (float-time (time-since 838 (file-attribute-modification-time 839 (file-attributes file)))) 840 (* 60 60 24 osm-max-age)) 841 (delete-file file))) 842 (when (directory-empty-p dir) 843 (ignore-errors (delete-directory dir)))))))) 844 845 (defun osm--check-libraries () 846 "Check that Emacs is compiled with the necessary libraries." 847 (let (req) 848 (unless (display-graphic-p) 849 (push "graphical display" req)) 850 (dolist (type '(svg jpeg png)) 851 (unless (image-type-available-p type) 852 (push (format "%s support" type) req))) 853 (unless (libxml-available-p) 854 (push "libxml" req)) 855 (unless (json-available-p) 856 (push "libjansson" req)) 857 (when req 858 (error "Osm: Please compile Emacs with the required libraries, %s needed to proceed" 859 (string-join req ", "))))) 860 861 (define-derived-mode osm-mode special-mode "Osm" 862 "OpenStreetMap viewer mode." 863 :interactive nil :abbrev-table nil :syntax-table nil 864 (osm--check-libraries) 865 (setq-local osm-server osm-server 866 line-spacing nil 867 cursor-type nil 868 cursor-in-non-selected-windows nil 869 left-fringe-width 1 870 right-fringe-width 1 871 left-margin-width 0 872 right-margin-width 0 873 truncate-lines t 874 show-trailing-whitespace nil 875 display-line-numbers nil 876 buffer-read-only t 877 fringe-indicator-alist '((truncation . nil)) 878 revert-buffer-function #'osm--revert 879 mode-line-process '(:eval (osm--download-queue-info)) 880 mode-line-position nil 881 mode-line-modified nil 882 mode-line-mule-info nil 883 mode-line-remote nil 884 default-directory (expand-file-name "~/") 885 eldoc-documentation-functions nil 886 mouse-wheel-progressive-speed nil 887 mwheel-scroll-up-function #'osm--zoom-out-wheel 888 mwheel-scroll-down-function #'osm--zoom-in-wheel 889 mwheel-scroll-left-function #'osm--zoom-out-wheel 890 mwheel-scroll-right-function #'osm--zoom-in-wheel 891 bookmark-make-record-function #'osm--bookmark-record-default) 892 (when (boundp 'mwheel-coalesce-scroll-events) 893 (setq-local mwheel-coalesce-scroll-events t)) 894 (when (boundp 'pixel-scroll-precision-mode) 895 (setq-local pixel-scroll-precision-mode nil)) 896 (add-hook 'change-major-mode-hook #'osm--barf-change-mode nil 'local) 897 (add-hook 'write-contents-functions #'osm--barf-write nil 'local) 898 (add-hook 'window-size-change-functions #'osm--resize nil 'local)) 899 900 (defun osm--barf-write () 901 "Barf for write operation." 902 (set-buffer-modified-p nil) 903 (setq buffer-read-only t) 904 (set-visited-file-name nil) 905 (error "Writing the buffer to a file is not supported")) 906 907 (defun osm--barf-change-mode () 908 "Barf for change mode operation." 909 (error "Changing the major mode is not supported")) 910 911 (defun osm--barf-unless-osm () 912 "Barf if not an `osm-mode' buffer." 913 (unless (eq major-mode #'osm-mode) 914 (error "Not an `osm-mode' buffer"))) 915 916 (defun osm--each-pin (fun) 917 "Call FUN for each pin on the map." 918 (pcase osm-home 919 (`(,lat ,lon ,zoom) 920 (funcall fun 'osm-home lat lon zoom "Home"))) 921 (bookmark-maybe-load-default-file) 922 (cl-loop for bm in bookmark-alist 923 if (eq (bookmark-prop-get bm 'handler) #'osm-bookmark-jump) do 924 (pcase-let ((`(,lat ,lon ,zoom) (bookmark-prop-get bm 'coordinates))) 925 (funcall fun 'osm-bookmark lat lon zoom (car bm)))) 926 (dolist (file osm--gpx-files) 927 (cl-loop for (lat lon name) in (cddr file) do 928 (funcall fun 'osm-poi lat lon 15 name))) 929 (cl-loop for (lat lon name) in osm--track do 930 (funcall fun 'osm-track lat lon 15 name))) 931 932 (defun osm--pin-inside-p (x y lat lon) 933 "Return non-nil if pin at LAT/LON is inside tile X/Y." 934 (let ((p (/ (osm--lon-to-x lon osm--zoom) 256.0)) 935 (q (/ (osm--lat-to-y lat osm--zoom) 256.0))) 936 (and (>= p (- x 0.125)) (< p (+ x 1.125)) 937 (>= q y) (< q (+ y 1.25))))) 938 939 (defun osm--add-pin (pins id lat lon _zoom name) 940 "Add pin at LAT/LON with NAME and ID to the PINS hash table." 941 (let* ((x (osm--lon-to-x lon osm--zoom)) 942 (y (osm--lat-to-y lat osm--zoom)) 943 (x0 (/ x 256)) 944 (y0 (/ y 256)) 945 (pin (list x y lat lon id name))) 946 (push pin (gethash (cons x0 y0) pins)) 947 (cl-loop 948 for i from -1 to 1 do 949 (cl-loop 950 for j from -1 to 0 do 951 (let ((x1 (/ (+ x (* 32 i)) 256)) 952 (y1 (/ (+ y (* 64 j)) 256))) 953 (unless (and (= x0 x1) (= y0 y1)) 954 (push pin (gethash (cons x1 y1) pins)))))))) 955 956 ;; TODO: The Bresenham algorithm used here to add the line segments to the tiles 957 ;; has the issue that lines which go along a tile border may be drawn only 958 ;; partially. Use a more precise algorithm instead. 959 (defun osm--add-track (tracks seg) 960 "Add track segment SEG to TRACKS hash table." 961 (when seg 962 (let ((p0 (cons (osm--lon-to-x (or (car-safe (cdar seg)) (cdar seg)) osm--zoom) 963 (osm--lat-to-y (caar seg) osm--zoom)))) 964 (dolist (pt (cdr seg)) 965 (let* ((px1 (cdr pt)) 966 (px1 (osm--lon-to-x (if (consp px1) (car px1) px1) osm--zoom)) 967 (py1 (osm--lat-to-y (car pt) osm--zoom)) 968 (pdx (- px1 (car p0))) 969 (pdy (- py1 (cdr p0)))) 970 ;; Ignore point if too close to last point 971 (unless (< (+ (* pdx pdx) (* pdy pdy)) 50) 972 (let* ((p1 (cons px1 py1)) 973 (line (cons p0 p1)) 974 (x0 (/ (car p0) 256)) 975 (y0 (/ (cdr p0) 256)) 976 (x1 (/ px1 256)) 977 (y1 (/ py1 256)) 978 (sx (if (< x0 x1) 1 -1)) 979 (sy (if (< y0 y1) 1 -1)) 980 (dx (* sx (- x1 x0))) 981 (dy (* sy (- y0 y1))) 982 (err (+ dx dy))) 983 ;; Bresenham 984 (while 985 (let ((ey (> (* err 2) dy)) 986 (ex (< (* err 2) dx))) 987 (push line (gethash (cons x0 y0) tracks)) 988 (unless (and (= x0 x1) (= y0 y1)) 989 (when (and ey ex) 990 (push line (gethash (cons x0 (+ y0 sy)) tracks)) 991 (push line (gethash (cons (+ x0 sx) y0) tracks))) 992 (when ey 993 (cl-incf err dy) 994 (cl-incf x0 sx)) 995 (when ex 996 (cl-incf err dx) 997 (cl-incf y0 sy)) 998 t))) 999 (setq p0 p1)))))))) 1000 1001 (defun osm--get-overlays (x y) 1002 "Compute overlays and return the overlays in tile X/Y." 1003 (unless (eq (car osm--overlays) osm--zoom) 1004 ;; TODO: Do not compute overlays for the entire map, only for a reasonable 1005 ;; view port around the current center, depending on the size of the 1006 ;; window. Otherwise the spatial hash map for the tracks gets very large if 1007 ;; a line segment spans many tiles. 1008 (let ((pins (make-hash-table :test #'equal)) 1009 (tracks (make-hash-table :test #'equal))) 1010 (osm--each-pin (apply-partially #'osm--add-pin pins)) 1011 (dolist (file osm--gpx-files) 1012 (dolist (seg (cadr file)) 1013 (osm--add-track tracks seg))) 1014 (osm--add-track tracks osm--track) 1015 (setq osm--overlays (list osm--zoom pins tracks)))) 1016 (let ((pins (gethash (cons x y) (cadr osm--overlays))) 1017 (tracks (gethash (cons x y) (caddr osm--overlays)))) 1018 (and (or pins tracks) (cons pins tracks)))) 1019 1020 (autoload 'svg--image-data "svg") 1021 (defun osm--draw-tile (x y tpin) 1022 "Make tile at X/Y from FILE. 1023 TPIN is an optional pin." 1024 (let ((file (osm--tile-file x y osm--zoom)) 1025 overlays) 1026 (when (file-exists-p file) 1027 (if (or (setq overlays (osm--get-overlays x y)) (eq osm-tile-border t) tpin) 1028 (let* ((areas nil) 1029 (x0 (* 256 x)) 1030 (y0 (* 256 y)) 1031 (svg-pin 1032 (lambda (pin) 1033 (pcase-let* ((`(,p ,q ,_lat ,_lon ,id ,name) pin) 1034 (bg (cdr (assq id osm-pin-colors)))) 1035 (setq p (- p x0) q (- q y0)) 1036 (push `((poly . [,p ,q ,(- p 20) ,(- q 40) ,p ,(- q 50) ,(+ p 20) ,(- q 40) ]) 1037 ,id (help-echo ,(truncate-string-to-width name 40 0 nil t))) 1038 areas) 1039 ;; https://commons.wikimedia.org/wiki/File:Simpleicons_Places_map-marker-1.svg 1040 (format " 1041 <g fill='%s' stroke='#000' stroke-width='9' transform='translate(%s %s) scale(0.09) translate(-256 -512)'> 1042 <path d='M256 0C167.641 0 96 71.625 96 160c0 24.75 5.625 48.219 15.672 1043 69.125C112.234 230.313 256 512 256 512l142.594-279.375 1044 C409.719 210.844 416 186.156 416 160C416 71.625 344.375 1045 0 256 0z M256 256c-53.016 0-96-43-96-96s42.984-96 96-96 1046 c53 0 96 43 96 96S309 256 256 256z'/> 1047 </g>" bg p q)))) 1048 (svg-text 1049 (concat "<svg width='256' height='256' version='1.1' 1050 xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'> 1051 <image xlink:href='" 1052 (file-name-nondirectory file) 1053 "' height='256' width='256'/>" 1054 (when-let (track (cdr overlays)) 1055 (format 1056 "<path style='%s' d='%s'/>" 1057 osm-track-style 1058 (let (last) 1059 (mapconcat 1060 (pcase-lambda (`(,beg . ,end)) 1061 (prog1 1062 (if (equal beg last) 1063 (format "L%s %s" (- (car end) x0) (- (cdr end) y0)) 1064 (format "M%s %sL%s %s" 1065 (- (car beg) x0) (- (cdr beg) y0) 1066 (- (car end) x0) (- (cdr end) y0))) 1067 (setq last end))) 1068 track "")))) 1069 (pcase-exhaustive osm-tile-border 1070 ('nil nil) 1071 ('debug "<path d='M 1 1 L 1 255 255 255 255 1 Z' stroke='#000' stroke-width='2' fill='none'/>") 1072 ('t "<path d='M 0 0 L 0 256 256 256' stroke='#000' fill='none'/>")) 1073 (mapconcat svg-pin (car overlays) "") 1074 (and tpin (funcall svg-pin tpin)) 1075 "</svg>"))) 1076 (list 'image :width 256 :height 256 :type 'svg :base-uri file :data svg-text :map areas)) 1077 (list 'image :width 256 :height 256 :file file :type 1078 (if (member (file-name-extension file) '("jpg" "jpeg")) 1079 'jpeg 'png)))))) 1080 1081 (defun osm--get-tile (x y) 1082 "Get tile at X/Y." 1083 (pcase osm--pin 1084 ((and `(,lat ,lon ,_id ,name) 1085 (guard (osm--pin-inside-p x y lat lon))) 1086 (osm--draw-tile x y (list (osm--lon-to-x lon osm--zoom) 1087 (osm--lat-to-y lat osm--zoom) 1088 lat lon 'osm-selected name))) 1089 (_ 1090 (let* ((key `(,osm-server ,osm--zoom ,x . ,y)) 1091 (tile (and osm--tile-cache (gethash key osm--tile-cache)))) 1092 (if tile 1093 (progn (setcar tile osm--tile-age) (cdr tile)) 1094 (setq tile (osm--draw-tile x y nil)) 1095 (when tile 1096 (when osm-max-tiles 1097 (unless osm--tile-cache 1098 (setq osm--tile-cache (make-hash-table :test #'equal :size osm-max-tiles))) 1099 (puthash key (cons osm--tile-age tile) osm--tile-cache)) 1100 tile)))))) 1101 1102 (defun osm--display-tile (x y tile) 1103 "Display TILE at X/Y." 1104 (let ((i (- x (/ (osm--x0) 256))) 1105 (j (- y (/ (osm--y0) 256)))) 1106 (when (and (>= i 0) (< i osm--nx) (>= j 0) (< j osm--ny)) 1107 (let* ((mx (if (= 0 i) (mod (osm--x0) 256) 0)) 1108 (my (if (= 0 j) (mod (osm--y0) 256) 0)) 1109 (pos (+ (point-min) (* j (1+ osm--nx)) i))) 1110 (unless tile 1111 (setq tile (cons 'image osm--placeholder))) 1112 (with-silent-modifications 1113 (put-text-property 1114 pos (1+ pos) 'display 1115 (if (or (/= 0 mx) (/= 0 my)) 1116 `((slice ,mx ,my ,(- 256 mx) ,(- 256 my)) ,tile) 1117 tile))))))) 1118 1119 ;;;###autoload 1120 (defun osm-home () 1121 "Go to home coordinates." 1122 (interactive) 1123 (pcase osm-home 1124 (`(,lat ,lon ,zoom) 1125 (osm--goto lat lon zoom nil 'osm-home "Home")))) 1126 1127 (defun osm--download-queue-info () 1128 "Return queue info string." 1129 (when osm--download-processes 1130 (format "[%s/%s/%s]" 1131 (cl-loop for (_ . p) in osm--download-processes sum (length p)) 1132 (length osm--download-active) 1133 (length osm--download-queue)))) 1134 1135 (defun osm--revert (&rest _) 1136 "Revert osm buffers." 1137 (clear-image-cache t) ;; Make absolutely sure that the tiles are redrawn. 1138 (setq osm--tile-cache nil) 1139 (osm--each 1140 (setq osm--overlays nil) 1141 (osm--update))) 1142 1143 (defun osm--resize (&rest _) 1144 "Resize buffer." 1145 (when (eq major-mode #'osm-mode) 1146 (osm--update))) 1147 1148 (defun osm--header-button (text action) 1149 "Format header line button with TEXT and ACTION." 1150 (propertize text 1151 'keymap (define-keymap "<header-line> <mouse-1>" 1152 (if (commandp action) 1153 (lambda () 1154 (interactive "@") 1155 (call-interactively action)) 1156 action)) 1157 'face '(:box (:line-width -2 :style released-button)) 1158 'mouse-face '(:box (:line-width -2 :style pressed-button)))) 1159 1160 (defun osm--update-header () 1161 "Update header line." 1162 (let* ((meter-per-pixel (/ (* 156543.03 (cos (/ osm--lat (/ 180.0 float-pi)))) (expt 2 osm--zoom))) 1163 (server (osm--server-property :name)) 1164 (meter 1) (idx 0) 1165 (factor '(2 2.5 2)) 1166 (sep #(" " 0 1 (display (space :width (1)))))) 1167 (while (and (< idx 20) (< (/ (* meter (nth (mod idx 3) factor)) meter-per-pixel) 150)) 1168 (setq meter (round (* meter (nth (mod idx 3) factor)))) 1169 (cl-incf idx)) 1170 (setq-local 1171 header-line-format 1172 (list 1173 (osm--header-button " ☰ " (osm--menu-item osm-mode-menu)) sep 1174 (osm--header-button (format " %s " server) 1175 (osm--menu-item #'osm--server-menu)) sep 1176 (osm--header-button " + " #'osm-zoom-in) sep 1177 (osm--header-button " - " #'osm-zoom-out) 1178 (format " Z%-2d " osm--zoom) 1179 #(" " 0 1 (display (space :align-to (- center 15)))) 1180 (format #(" %7.2f° %7.2f°" 0 14 (face bold)) osm--lat osm--lon) 1181 #(" " 0 1 (display (space :align-to (- right 20)))) 1182 (format "%3s " (if (>= meter 1000) (/ meter 1000) meter)) 1183 (if (>= meter 1000) "km " "m ") 1184 #(" " 0 1 (face (:inverse-video t) display (space :width (3)))) 1185 (propertize " " 'face '(:strike-through t) 1186 'display `(space :width (,(floor (/ meter meter-per-pixel))))) 1187 #(" " 0 1 (face (:inverse-video t) display (space :width (3)))))))) 1188 1189 (defun osm--update () 1190 "Update map display." 1191 (osm--barf-unless-osm) 1192 (osm--purge-tile-cache) 1193 (osm--purge-directory) 1194 (osm--rename-buffer) 1195 (osm--update-sizes) 1196 (osm--update-header) 1197 (osm--update-buffer) 1198 (osm--update-copyright) 1199 (osm--process-download-queue)) 1200 1201 (defun osm--update-sizes () 1202 "Update window sizes." 1203 (let* ((windows (or (get-buffer-window-list) (list (frame-root-window)))) 1204 (win-width (cl-loop for w in windows maximize (window-pixel-width w))) 1205 (win-height (cl-loop for w in windows maximize (window-pixel-height w)))) 1206 (setq osm--wx (/ win-width 2) 1207 osm--wy (/ win-height 2) 1208 osm--nx (1+ (ceiling win-width 256)) 1209 osm--ny (1+ (ceiling win-height 256))))) 1210 1211 (defun osm--copyright-link (text url) 1212 "Format link with TEXT to URL." 1213 (propertize text 1214 'face 'button 1215 'mouse-face 'highlight 1216 'help-echo 1217 (format "Go to %s" url) 1218 'keymap 1219 (define-keymap "<tab-line> <mouse-1>" 1220 (lambda () 1221 (interactive) 1222 (browse-url url))))) 1223 1224 (defun osm--update-copyright () 1225 "Update copyright info." 1226 (let ((copyright (and osm-copyright (osm--server-property :copyright)))) 1227 (if (not copyright) 1228 (when (eq 'osm-copyright (car-safe tab-line-format)) 1229 (kill-local-variable 'tab-line-format)) 1230 (setq copyright (replace-regexp-in-string 1231 "{\\(.*?\\)|\\(.*?\\)}" 1232 (lambda (str) 1233 (osm--copyright-link 1234 (match-string 1 str) 1235 (match-string 2 str))) 1236 (concat 1237 " " 1238 (string-join (ensure-list copyright) " | ") 1239 #(" " 0 1 (display (space :align-to (+ 42 right))))))) 1240 (add-face-text-property 1241 0 (length copyright) 1242 '(:inherit (header-line variable-pitch) :height 0.65) 1243 t copyright) 1244 (setq-local tab-line-format (list 'osm-copyright copyright))))) 1245 1246 (defun osm--update-buffer () 1247 "Update buffer display." 1248 (with-silent-modifications 1249 (erase-buffer) 1250 (dotimes (_j osm--ny) 1251 (insert (make-string osm--nx ?\s) "\n")) 1252 (put-text-property (point-min) (point-max) 'pointer 'arrow) 1253 (goto-char (point-min)) 1254 (let ((tx (/ (osm--x0) 256)) 1255 (ty (/ (osm--y0) 256))) 1256 (dotimes (j osm--ny) 1257 (dotimes (i osm--nx) 1258 (let* ((x (+ i tx)) 1259 (y (+ j ty)) 1260 (tile (osm--get-tile x y))) 1261 (osm--display-tile x y tile) 1262 (unless tile (osm--enqueue-download x y)))))))) 1263 1264 (defun osm--process-download-queue () 1265 "Process the download queue." 1266 (setq osm--download-queue 1267 (sort 1268 (cl-loop with tx = (/ (osm--x0) 256) 1269 with ty = (/ (osm--y0) 256) 1270 for job in osm--download-queue 1271 for (_server zoom x y) = job 1272 if (and (= zoom osm--zoom) 1273 (>= x tx) (< x (+ tx osm--nx)) 1274 (>= y ty) (< y (+ ty osm--ny))) 1275 collect job) 1276 (let ((tx (/ (osm--x) 256)) 1277 (ty (/ (osm--y) 256))) 1278 (pcase-lambda (`(,_s1 ,_z1 ,x1 ,y1) `(,_s2 ,_z2 ,x2 ,y2)) 1279 (setq x1 (- x1 tx) y1 (- y1 ty) x2 (- x2 tx) y2 (- y2 ty)) 1280 (< (+ (* x1 x1) (* y1 y1)) (+ (* x2 x2) (* y2 y2))))))) 1281 (osm--download)) 1282 1283 (defun osm--purge-tile-cache () 1284 "Purge old tiles from the tile cache." 1285 (cl-incf osm--tile-age) 1286 (when (and osm--tile-cache (> (hash-table-count osm--tile-cache) osm-max-tiles)) 1287 (let (items) 1288 (maphash (lambda (k v) (push (list (car v) (cdr v) k) items)) osm--tile-cache) 1289 (setq items (sort items #'car-less-than-car)) 1290 (cl-loop repeat (- (hash-table-count osm--tile-cache) osm-max-tiles) 1291 for (_age tile key) in items do 1292 (image-flush tile t) 1293 (remhash key osm--tile-cache))))) 1294 1295 (defun osm--bookmark-record-default () 1296 "Make osm bookmark record." 1297 (osm--bookmark-record (osm--bookmark-name osm--lat osm--lon nil) 1298 osm--lat osm--lon nil)) 1299 1300 (defun osm--bookmark-record (name lat lon loc) 1301 "Make osm bookmark record with NAME and LOC description at LAT/LON." 1302 (setq bookmark-current-bookmark nil) ;; Reset bookmark to use new name 1303 `(,name 1304 (location . ,(osm--location-name lat lon loc 6)) 1305 (coordinates ,lat ,lon ,osm--zoom) 1306 (server . ,osm-server) 1307 (handler . ,#'osm-bookmark-jump))) 1308 1309 (defun osm--org-link-props () 1310 "Return Org link properties." 1311 (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Org Link")) 1312 (name (osm--location-name lat lon loc 2))) 1313 (list :type "geo" 1314 :description 1315 (if (eq osm-server (default-value 'osm-server)) 1316 (string-remove-suffix (concat " " (osm--server-property :name)) 1317 name) 1318 name) 1319 :link 1320 (format "geo:%.6f,%.6f;z=%s%s" 1321 lat lon osm--zoom 1322 (if (eq osm-server (default-value 'osm-server)) "" 1323 (format ";s=%s" osm-server)))))) 1324 1325 (defun osm--rename-buffer () 1326 "Rename current buffer." 1327 (setq list-buffers-directory (osm--location-name osm--lat osm--lon nil 6)) 1328 (rename-buffer 1329 (format "*osm: %s*" (osm--location-name osm--lat osm--lon nil 2)) 1330 'unique)) 1331 1332 (defun osm--location-name (lat lon loc prec) 1333 "Format location string LAT/LON with optional LOC description. 1334 The coordinates are formatted with precision PREC." 1335 (format (format "%%s%%.%df° %%.%df° Z%%s %%s" prec prec) 1336 (if loc (concat loc ", ") "") 1337 lat lon osm--zoom (osm--server-property :name))) 1338 1339 (defun osm--bookmark-name (lat lon loc) 1340 "Return bookmark name for LAT/LON/LOC." 1341 (concat "osm: " (osm--location-name lat lon loc 2))) 1342 1343 (defun osm--goto (lat lon zoom server id name) 1344 "Go to LAT/LON/ZOOM, change SERVER. 1345 Optionally place pin with ID and NAME." 1346 ;; Server not found 1347 (when (and server (not (assq server osm-server-list))) (setq server nil)) 1348 (with-current-buffer 1349 (or 1350 (and (eq major-mode #'osm-mode) (current-buffer)) 1351 (let ((def-server (or server osm-server)) 1352 (def-lat (or lat (nth 0 osm-home))) 1353 (def-lon (or lon (nth 1 osm-home))) 1354 (def-zoom (or zoom (nth 2 osm-home)))) 1355 ;; Search for existing buffer 1356 (cl-loop 1357 for buf in (buffer-list) thereis 1358 (and (equal (buffer-local-value 'major-mode buf) #'osm-mode) 1359 (equal (buffer-local-value 'osm-server buf) def-server) 1360 (equal (buffer-local-value 'osm--zoom buf) def-zoom) 1361 (equal (buffer-local-value 'osm--lat buf) def-lat) 1362 (equal (buffer-local-value 'osm--lon buf) def-lon) 1363 buf))) 1364 (generate-new-buffer "*osm*")) 1365 (unless (eq major-mode #'osm-mode) 1366 (osm-mode)) 1367 (when (and server (not (eq osm-server server))) 1368 (setq-local osm-server server 1369 osm--download-queue nil)) 1370 (when (or (not (and osm--lon osm--lat)) lat) 1371 (setq osm--lat (or lat (nth 0 osm-home)) 1372 osm--lon (or lon (nth 1 osm-home)) 1373 osm--zoom (or zoom (nth 2 osm-home))) 1374 (when id 1375 (osm--set-pin id osm--lat osm--lon name))) 1376 (prog1 (pop-to-buffer (current-buffer)) 1377 (osm--update)))) 1378 1379 (defun osm--set-pin (id lat lon name &optional quiet) 1380 "Set pin at LAT/LON with ID and NAME. 1381 Print NAME if not QUIET." 1382 (setq name (or name (format "Location %.6f° %.6f°" lat lon))) 1383 (setq osm--pin (list lat lon (or id 'osm-selected) name)) 1384 (unless quiet (message "%s" name))) 1385 1386 (defun osm--set-pin-event (event &optional id name quiet) 1387 "Set selection pin with ID and NAME at location of EVENT. 1388 Print NAME if not QUIET." 1389 (pcase-let ((`(,x . ,y) (posn-x-y (event-start event)))) 1390 (osm--set-pin id 1391 (osm--y-to-lat (+ (osm--y0) y) osm--zoom) 1392 (osm--x-to-lon (+ (osm--x0) x) osm--zoom) 1393 name quiet))) 1394 1395 ;;;###autoload 1396 (defun osm-goto (lat lon zoom) 1397 "Go to LAT/LON/ZOOM." 1398 (interactive 1399 (pcase-let ((`(,lat ,lon ,zoom) 1400 (mapcar #'string-to-number 1401 (split-string (read-string "Lat Lon (Zoom): ") nil t)))) 1402 (setq zoom (or zoom osm--zoom 11)) 1403 (unless (and (numberp lat) (numberp lon) (numberp zoom)) 1404 (error "Invalid coordinate")) 1405 (list lat lon zoom))) 1406 (osm--goto lat lon zoom nil 'osm-selected nil) 1407 nil) 1408 1409 ;;;###autoload 1410 (defun osm (&rest link) 1411 "Go to LINK. 1412 When called interactively, call the function `osm-home'." 1413 (interactive (list 'home)) 1414 (pcase link 1415 ('(home) 1416 (osm-home)) 1417 (`(,lat ,lon ,zoom . ,server) 1418 (setq server (car server)) 1419 (unless (and server (symbolp server)) (setq server nil)) ;; Ignore comment 1420 (osm--goto lat lon zoom server 'osm-selected "Elisp Link")) 1421 ((and `(,url . ,_) (guard (stringp url))) 1422 (if (string-match 1423 "\\`geo:\\([0-9.-]+\\),\\([0-9.-]+\\)\\(?:,[0-9.-]+\\)?\\(;.+\\'\\|\\'\\)" url) 1424 (let* ((lat (string-to-number (match-string 1 url))) 1425 (lon (string-to-number (match-string 2 url))) 1426 (args (url-parse-args (match-string 3 url) "")) 1427 (zoom (cdr (assoc "z" args))) 1428 (server (cdr (assoc "s" args)))) 1429 (osm--goto lat lon 1430 (and zoom (string-to-number zoom)) 1431 (and server (intern-soft server)) 1432 'osm-selected "Geo Link")) 1433 (osm-search (string-remove-prefix "geo:" url)))) 1434 (_ (error "Invalid osm link")))) 1435 1436 ;;;###autoload 1437 (defun osm-bookmark-jump (bm) 1438 "Jump to osm bookmark BM." 1439 (interactive (list (osm--bookmark-read))) 1440 (pcase-let ((`(,lat ,lon ,zoom) (bookmark-prop-get bm 'coordinates))) 1441 (set-buffer (osm--goto lat lon zoom 1442 (bookmark-prop-get bm 'server) 1443 'osm-bookmark (car bm))))) 1444 (put 'osm-bookmark-jump 'bookmark-handler-type "Osm") 1445 1446 ;;;###autoload 1447 (defun osm-bookmark-delete (bm) 1448 "Delete osm bookmark BM." 1449 (interactive (list (osm--bookmark-read))) 1450 (when (y-or-n-p (format "Delete bookmark `%s'? " bm)) 1451 (bookmark-delete bm) 1452 (setq osm--pin nil) 1453 (osm--revert))) 1454 1455 ;;;###autoload 1456 (defun osm-bookmark-rename (old-name) 1457 "Rename osm bookmark OLD-NAME." 1458 (interactive (list (car (osm--bookmark-read)))) 1459 (let ((new-name (read-from-minibuffer "New name: " old-name nil nil 1460 'bookmark-history old-name))) 1461 (when osm--pin (setf (cadddr osm--pin) new-name)) 1462 (bookmark-rename old-name new-name) 1463 (osm--revert))) 1464 1465 (defun osm--bookmark-read () 1466 "Read bookmark name." 1467 (bookmark-maybe-load-default-file) 1468 (or (assoc 1469 (pcase osm--pin 1470 (`(,_lat ,_lon osm-bookmark ,name) name) 1471 (_ (completing-read 1472 "Bookmark: " 1473 (or (cl-loop for bm in bookmark-alist 1474 if (eq (bookmark-prop-get bm 'handler) #'osm-bookmark-jump) 1475 collect (car bm)) 1476 (error "No bookmarks found")) 1477 nil t nil 'bookmark-history))) 1478 bookmark-alist) 1479 (error "No bookmark selected"))) 1480 1481 (defun osm-bookmark-set () 1482 "Create osm bookmark." 1483 (interactive nil osm-mode) 1484 (osm--barf-unless-osm) 1485 (unwind-protect 1486 (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Bookmark")) 1487 (def (osm--bookmark-name lat lon loc)) 1488 (name (read-from-minibuffer "Bookmark name: " def nil nil 'bookmark-history def)) 1489 (bookmark-make-record-function 1490 (lambda () (osm--bookmark-record name lat lon loc)))) 1491 (bookmark-set name) 1492 (message "Stored bookmark: %s" name) 1493 (setf (caddr osm--pin) 'osm-bookmark)) 1494 (osm--revert))) 1495 1496 (defun osm--fetch-location-data (name) 1497 "Fetch location info for NAME." 1498 (when (mouse-event-p last-input-event) 1499 (osm--set-pin-event last-input-event 'osm-selected name)) 1500 (let ((lat (or (car osm--pin) osm--lat)) 1501 (lon (or (cadr osm--pin) osm--lon))) 1502 (osm--set-pin 'osm-selected lat lon name 'quiet) 1503 (message "%s: Fetching name of %.2f° %.2f° from %s..." name lat lon osm-search-server) 1504 ;; Redisplay before slow fetching 1505 (osm--update) 1506 (redisplay) 1507 (list lat lon 1508 (ignore-errors 1509 (alist-get 1510 'display_name 1511 (osm--fetch-json 1512 (format "%s/reverse?format=json&accept-language=%s&zoom=%s&lat=%s&lon=%s" 1513 osm-search-server osm-search-language 1514 (min 18 (max 3 osm--zoom)) lat lon))))))) 1515 1516 (defun osm--track-index () 1517 "Return index of selected track way point." 1518 (cl-loop for idx from 0 for (lat lon _) in osm--track 1519 if (and (equal lat (car osm--pin)) (equal lon (cadr osm--pin))) 1520 return idx)) 1521 1522 (defun osm--track-delete () 1523 "Delete track way point." 1524 (when-let ((idx (osm--track-index))) 1525 ;; Delete pin 1526 (cl-callf2 delq (nth idx osm--track) osm--track) 1527 (setq osm--pin nil 1528 idx (min idx (1- (length osm--track)))) 1529 ;; Select next pin 1530 (pcase (nth idx osm--track) 1531 (`(,lat ,lon ,name) 1532 (osm--set-pin 'osm-track lat lon name 'quiet))) 1533 ;; Rename pins after deletion 1534 (cl-loop for idx from (length osm--track) downto 1 1535 for pt in osm--track 1536 if (string-match-p "\\`WP[0-9]+\\'" (caddr pt)) do 1537 (setf (caddr pt) (format "WP%s" idx))) 1538 (osm--track-length) 1539 (osm--revert))) 1540 1541 (defun osm--track-rename () 1542 "Rename track way point." 1543 (when-let ((pt (nth (osm--track-index) osm--track)) 1544 (old-name (caddr pt)) 1545 (new-name (read-from-minibuffer "New name: " old-name nil nil nil old-name))) 1546 (setf (caddr pt) new-name 1547 (cadddr osm--pin) new-name) 1548 (osm--revert))) 1549 1550 (defun osm-delete () 1551 "Delete selected pin (bookmark or way point)." 1552 (interactive nil osm-mode) 1553 (osm--barf-unless-osm) 1554 (pcase (caddr osm--pin) 1555 ('nil nil) 1556 ('osm-bookmark (osm-bookmark-delete (cadddr osm--pin))) 1557 ('osm-track (osm--track-delete)) 1558 (_ (setq osm--pin nil) (osm--update)))) 1559 1560 (defun osm-rename () 1561 "Rename selected pin (bookmark or way point)." 1562 (interactive nil osm-mode) 1563 (osm--barf-unless-osm) 1564 (pcase (caddr osm--pin) 1565 ('osm-bookmark (osm-bookmark-rename (cadddr osm--pin))) 1566 ('osm-track (osm--track-rename)))) 1567 1568 ;;;###autoload 1569 (defun osm-jump () 1570 "Jump to named pin." 1571 (interactive) 1572 (let (pins) 1573 (osm--each-pin (lambda (id lat lon zoom name) 1574 (push (list name (capitalize (substring (symbol-name id) 4)) 1575 id lat lon zoom) 1576 pins))) 1577 (pcase (assoc (completing-read 1578 "Jump: " 1579 (lambda (str pred action) 1580 (if (eq action 'metadata) 1581 `(metadata 1582 (group-function 1583 . ,(lambda (pin transform) 1584 (if transform pin 1585 (cadr (assoc pin pins)))))) 1586 (complete-with-action action pins str pred))) 1587 nil t nil 'osm--jump-history) 1588 pins) 1589 (`(,name ,_group ,id ,lat ,lon ,zoom) (osm--goto lat lon zoom nil id name)) 1590 (_ (user-error "No pin selected"))))) 1591 1592 (defun osm--fetch-json (url) 1593 "Get json from URL." 1594 (osm--check-libraries) 1595 (with-temp-buffer 1596 (let* ((default-process-coding-system '(utf-8-unix . utf-8-unix)) 1597 (status (apply #'call-process "curl" nil (current-buffer) nil 1598 `(,@(split-string-and-unquote osm-curl-options) ,url)))) 1599 (unless (eq status 0) 1600 (error "Fetching %s exited with status %s" url status))) 1601 (goto-char (point-min)) 1602 (json-parse-buffer :array-type 'list :object-type 'alist))) 1603 1604 (defun osm--search (needle) 1605 "Globally search for NEEDLE and return the list of results." 1606 (message "Contacting %s" osm-search-server) 1607 (mapcar 1608 (lambda (x) 1609 (let ((lat (string-to-number (alist-get 'lat x))) 1610 (lon (string-to-number (alist-get 'lon x)))) 1611 `(,(format "%s (%.6f° %.6f°)" 1612 (alist-get 'display_name x) 1613 lat lon) 1614 ,lat ,lon 1615 ,@(mapcar #'string-to-number (alist-get 'boundingbox x))))) 1616 (osm--fetch-json 1617 (format "%s/search?format=json&accept-language=%s&q=%s" 1618 osm-search-server osm-search-language 1619 (url-encode-url needle))))) 1620 1621 ;;;###autoload 1622 (defun osm-search (needle &optional lucky) 1623 "Globally search for NEEDLE on `osm-search-server' and display the map. 1624 If the prefix argument LUCKY is non-nil take the first result and jump there. 1625 See `osm-search-server' and `osm-search-language' for customization." 1626 (interactive 1627 (list 1628 (minibuffer-with-setup-hook 1629 (lambda () 1630 (when (and (eq completing-read-function #'completing-read-default) 1631 (not (bound-and-true-p vertico-mode))) 1632 ;; Override dreaded `minibuffer-complete-word' for default 1633 ;; completion. When will this keybinding finally get removed from 1634 ;; default completion? 1635 (use-local-map (make-composed-keymap 1636 (define-keymap "SPC" nil) 1637 (current-local-map))))) 1638 (completing-read "Location: " 1639 (osm--sorted-table osm--search-history) 1640 nil nil nil 'osm--search-history)) 1641 current-prefix-arg)) 1642 ;; TODO: Add search bounded to current viewbox, bounded=1, viewbox=x1,y1,x2,y2 1643 (let* ((results (or (osm--search needle) (error "No results for `%s'" needle))) 1644 (selected 1645 (or 1646 (and (or lucky (not (cdr results))) (car results)) 1647 (assoc 1648 (minibuffer-with-setup-hook 1649 (lambda () 1650 (when (and (eq completing-read-function #'completing-read-default) 1651 (not (bound-and-true-p vertico-mode)) 1652 (not (bound-and-true-p icomplete-mode))) 1653 (let ((message-log-max nil) 1654 (inhibit-message t)) 1655 ;; Show matches immediately for default completion. 1656 (minibuffer-completion-help)))) 1657 (completing-read 1658 (format "Matches for '%s': " needle) 1659 (osm--sorted-table results) 1660 nil t nil t)) 1661 results) 1662 (error "No selection")))) 1663 (osm--goto (cadr selected) (caddr selected) 1664 (apply #'osm--boundingbox-to-zoom (cdddr selected)) 1665 nil 'osm-selected (car selected)))) 1666 1667 (defun osm--sorted-table (coll) 1668 "Sorted completion table from COLL." 1669 (lambda (str pred action) 1670 (if (eq action 'metadata) 1671 '(metadata (display-sort-function . identity) 1672 (cycle-sort-function . identity)) 1673 (complete-with-action action coll str pred)))) 1674 1675 ;;;###autoload 1676 (defun osm-gpx-show (file) 1677 "Show the tracks of gpx FILE in an `osm-mode' buffer." 1678 (interactive "fGPX file: ") 1679 (osm--check-libraries) 1680 (let ((dom (with-temp-buffer 1681 (insert-file-contents file) 1682 (libxml-parse-xml-region (point-min) (point-max)))) 1683 (min-lat 90) (max-lat -90) (min-lon 180) (max-lon -180)) 1684 (unless (eq 'gpx (dom-tag dom)) 1685 (setq dom (dom-child-by-tag dom 'gpx))) 1686 (unless (and dom (eq 'gpx (dom-tag dom))) 1687 (error "Not a GPX file")) 1688 (setf (alist-get (abbreviate-file-name file) osm--gpx-files nil nil #'equal) 1689 (cons 1690 (cl-loop 1691 for trk in (dom-children dom) 1692 if (eq (dom-tag trk) 'trk) nconc 1693 (cl-loop 1694 for seg in (dom-children trk) 1695 if (eq (dom-tag seg) 'trkseg) collect 1696 (cl-loop 1697 for pt in (dom-children seg) 1698 if (eq (dom-tag pt) 'trkpt) collect 1699 (let ((lat (string-to-number (dom-attr pt 'lat))) 1700 (lon (string-to-number (dom-attr pt 'lon)))) 1701 (setq min-lat (min lat min-lat) 1702 max-lat (max lat max-lat) 1703 min-lon (min lon min-lon) 1704 max-lon (max lon max-lon)) 1705 (cons lat lon))))) 1706 (cl-loop 1707 for pt in (dom-children dom) 1708 if (eq (dom-tag pt) 'wpt) collect 1709 (let ((lat (string-to-number (dom-attr pt 'lat))) 1710 (lon (string-to-number (dom-attr pt 'lon)))) 1711 (setq min-lat (min lat min-lat) 1712 max-lat (max lat max-lat) 1713 min-lon (min lon min-lon) 1714 max-lon (max lon max-lon)) 1715 (list lat lon (dom-text (dom-child-by-tag pt 'name))))))) 1716 (osm--revert) 1717 (osm--goto (/ (+ min-lat max-lat) 2) (/ (+ min-lon max-lon) 2) 1718 (osm--boundingbox-to-zoom min-lat max-lat min-lon max-lon) 1719 nil nil nil))) 1720 1721 (defun osm-gpx-hide (file) 1722 "Show the tracks of gpx FILE in an `osm-mode' buffer." 1723 (interactive (list (completing-read "GPX file: " 1724 (or osm--gpx-files 1725 (error "No GPX files shown")) 1726 nil t nil 'file-name-history))) 1727 (cl-callf2 assoc-delete-all file osm--gpx-files) 1728 (osm--revert)) 1729 1730 (defun osm--server-annotation (cand) 1731 "Annotation for server CAND." 1732 (when-let ((copyright (osm--server-property :copyright (get-text-property 0 'osm--server cand))) 1733 (str 1734 (replace-regexp-in-string 1735 "{\\(.*?\\)|.*?}" 1736 (lambda (str) (match-string 1 str)) 1737 (string-join (ensure-list copyright) " | ") copyright))) 1738 (concat (propertize " " 'display `(space :align-to (- right ,(length str) 2))) 1739 " " 1740 str))) 1741 1742 (defun osm--server-group (cand transform) 1743 "Group function for server CAND with candidate TRANSFORM." 1744 (if transform 1745 cand 1746 (osm--server-property :group (get-text-property 0 'osm--server cand)))) 1747 1748 ;;;###autoload 1749 (defun osm-server (server) 1750 "Select tile SERVER." 1751 (interactive 1752 (let* ((max-name (cl-loop for (_ . x) in osm-server-list 1753 maximize (length (plist-get x :name)))) 1754 (fmt (concat 1755 (propertize (format "%%-%ds " max-name) 1756 'face 'font-lock-comment-face) 1757 " %s")) 1758 (servers 1759 (mapcar 1760 (lambda (x) 1761 (propertize 1762 (format fmt 1763 (plist-get (cdr x) :name) 1764 (or (plist-get (cdr x) :description) "")) 1765 'osm--server (car x))) 1766 osm-server-list)) 1767 (selected (completing-read 1768 "Server: " 1769 (lambda (str pred action) 1770 (if (eq action 'metadata) 1771 `(metadata 1772 (annotation-function 1773 . ,(and osm-copyright #'osm--server-annotation)) 1774 (group-function . ,#'osm--server-group)) 1775 (complete-with-action action servers str pred))) 1776 nil t nil 'osm--server-history 1777 (format fmt 1778 (osm--server-property :name) 1779 (or (osm--server-property :description) ""))))) 1780 (list 1781 (get-text-property 0 'osm--server 1782 (or (car (member selected servers)) 1783 (error "No server selected")))))) 1784 (osm--goto nil nil nil server nil nil)) 1785 1786 (defun osm-save-url (&optional arg) 1787 "Save coordinates as url in the kill ring. 1788 If prefix ARG is given, store url as Elisp expression." 1789 (interactive "P" osm-mode) 1790 (osm--barf-unless-osm) 1791 (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Link")) 1792 (server (and (not (eq osm-server (default-value 'osm-server))) osm-server)) 1793 (url (if arg 1794 (format "(osm %.6f %.6f %s%s%s)" 1795 lat lon osm--zoom 1796 (if server (format " '%s" osm-server) "") 1797 (if loc (format " %S" loc) "")) 1798 (format "geo:%.6f,%.6f;z=%s%s%s" 1799 lat lon osm--zoom 1800 (if server (format ";s=%s" osm-server) "") 1801 (if loc (format " (%s)" loc) ""))))) 1802 (kill-new url) 1803 (message "Saved in the kill ring: %s" url))) 1804 1805 (cl-defun osm-add-server (server 1806 &rest properties 1807 &key name description group url ext max-connections 1808 max-zoom min-zoom download-batch subdomains copyright) 1809 "Add SERVER with PROPERTIES to `osm-server-list'. 1810 The properties are checked as keyword arguments. See 1811 `osm-server-list' for documentation of the keywords." 1812 (declare (indent 1)) 1813 (ignore name description group url max-connections max-zoom 1814 min-zoom download-batch subdomains copyright) 1815 (dolist (sym '(:name :description :group :url)) 1816 (unless (stringp (plist-get properties sym)) 1817 (error "Server property %s is required" sym))) 1818 (unless (and server (symbolp server)) 1819 (error "Server id must be a symbol")) 1820 (setf (alist-get server osm-server-list) properties) 1821 nil) 1822 1823 ;;;###autoload 1824 (add-to-list 'browse-url-default-handlers '("\\`geo:" . osm)) 1825 1826 ;;;###autoload 1827 (eval-after-load 'ol 1828 (lambda () 1829 (declare-function org-link-set-parameters "ol") 1830 (declare-function osm--org-link-props "ext:osm") 1831 (org-link-set-parameters 1832 "geo" 1833 :follow (lambda (link _) (osm (concat "geo:" link))) 1834 :store (lambda () 1835 (when (eq major-mode 'osm-mode) 1836 (apply 'org-link-store-props (osm--org-link-props))))))) 1837 1838 (provide 'osm) 1839 ;;; osm.el ends here