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