osm.el (70466B)
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: 20241006.13 9 ;; Package-Revision: e9db7161f624 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 mode-line-modified nil 879 mode-line-mule-info nil 880 mode-line-remote nil 881 default-directory (expand-file-name "~/") 882 eldoc-documentation-functions nil 883 mouse-wheel-progressive-speed nil 884 mwheel-scroll-up-function #'osm--zoom-out-wheel 885 mwheel-scroll-down-function #'osm--zoom-in-wheel 886 mwheel-scroll-left-function #'osm--zoom-out-wheel 887 mwheel-scroll-right-function #'osm--zoom-in-wheel 888 bookmark-make-record-function #'osm--bookmark-record-default) 889 (when (boundp 'mwheel-coalesce-scroll-events) 890 (setq-local mwheel-coalesce-scroll-events t)) 891 (when (boundp 'pixel-scroll-precision-mode) 892 (setq-local pixel-scroll-precision-mode nil)) 893 (add-hook 'change-major-mode-hook #'osm--barf-change-mode nil 'local) 894 (add-hook 'write-contents-functions #'osm--barf-write nil 'local) 895 (add-hook 'window-size-change-functions #'osm--resize nil 'local)) 896 897 (defun osm--barf-write () 898 "Barf for write operation." 899 (set-buffer-modified-p nil) 900 (setq buffer-read-only t) 901 (set-visited-file-name nil) 902 (error "Writing the buffer to a file is not supported")) 903 904 (defun osm--barf-change-mode () 905 "Barf for change mode operation." 906 (error "Changing the major mode is not supported")) 907 908 (defun osm--barf-unless-osm () 909 "Barf if not an `osm-mode' buffer." 910 (unless (eq major-mode #'osm-mode) 911 (error "Not an `osm-mode' buffer"))) 912 913 (defun osm--each-pin (fun) 914 "Call FUN for each pin on the map." 915 (pcase osm-home 916 (`(,lat ,lon ,zoom) 917 (funcall fun 'osm-home lat lon zoom "Home"))) 918 (bookmark-maybe-load-default-file) 919 (cl-loop for bm in bookmark-alist 920 if (eq (bookmark-prop-get bm 'handler) #'osm-bookmark-jump) do 921 (pcase-let ((`(,lat ,lon ,zoom) (bookmark-prop-get bm 'coordinates))) 922 (funcall fun 'osm-bookmark lat lon zoom (car bm)))) 923 (dolist (file osm--gpx-files) 924 (cl-loop for (lat lon name) in (cddr file) do 925 (funcall fun 'osm-poi lat lon 15 name))) 926 (cl-loop for (lat lon name) in osm--track do 927 (funcall fun 'osm-track lat lon 15 name))) 928 929 (defun osm--pin-inside-p (x y lat lon) 930 "Return non-nil if pin at LAT/LON is inside tile X/Y." 931 (let ((p (/ (osm--lon-to-x lon osm--zoom) 256.0)) 932 (q (/ (osm--lat-to-y lat osm--zoom) 256.0))) 933 (and (>= p (- x 0.125)) (< p (+ x 1.125)) 934 (>= q y) (< q (+ y 1.25))))) 935 936 (defun osm--add-pin (pins id lat lon _zoom name) 937 "Add pin at LAT/LON with NAME and ID to the PINS hash table." 938 (let* ((x (osm--lon-to-x lon osm--zoom)) 939 (y (osm--lat-to-y lat osm--zoom)) 940 (x0 (/ x 256)) 941 (y0 (/ y 256)) 942 (pin (list x y lat lon id name))) 943 (push pin (gethash (cons x0 y0) pins)) 944 (cl-loop 945 for i from -1 to 1 do 946 (cl-loop 947 for j from -1 to 0 do 948 (let ((x1 (/ (+ x (* 32 i)) 256)) 949 (y1 (/ (+ y (* 64 j)) 256))) 950 (unless (and (= x0 x1) (= y0 y1)) 951 (push pin (gethash (cons x1 y1) pins)))))))) 952 953 ;; TODO: The Bresenham algorithm used here to add the line segments to the tiles 954 ;; has the issue that lines which go along a tile border may be drawn only 955 ;; partially. Use a more precise algorithm instead. 956 (defun osm--add-track (tracks seg) 957 "Add track segment SEG to TRACKS hash table." 958 (when seg 959 (let ((p0 (cons (osm--lon-to-x (or (car-safe (cdar seg)) (cdar seg)) osm--zoom) 960 (osm--lat-to-y (caar seg) osm--zoom)))) 961 (dolist (pt (cdr seg)) 962 (let* ((px1 (cdr pt)) 963 (px1 (osm--lon-to-x (if (consp px1) (car px1) px1) osm--zoom)) 964 (py1 (osm--lat-to-y (car pt) osm--zoom)) 965 (pdx (- px1 (car p0))) 966 (pdy (- py1 (cdr p0)))) 967 ;; Ignore point if too close to last point 968 (unless (< (+ (* pdx pdx) (* pdy pdy)) 50) 969 (let* ((p1 (cons px1 py1)) 970 (line (cons p0 p1)) 971 (x0 (/ (car p0) 256)) 972 (y0 (/ (cdr p0) 256)) 973 (x1 (/ px1 256)) 974 (y1 (/ py1 256)) 975 (sx (if (< x0 x1) 1 -1)) 976 (sy (if (< y0 y1) 1 -1)) 977 (dx (* sx (- x1 x0))) 978 (dy (* sy (- y0 y1))) 979 (err (+ dx dy))) 980 ;; Bresenham 981 (while 982 (let ((ey (> (* err 2) dy)) 983 (ex (< (* err 2) dx))) 984 (push line (gethash (cons x0 y0) tracks)) 985 (unless (and (= x0 x1) (= y0 y1)) 986 (when (and ey ex) 987 (push line (gethash (cons x0 (+ y0 sy)) tracks)) 988 (push line (gethash (cons (+ x0 sx) y0) tracks))) 989 (when ey 990 (cl-incf err dy) 991 (cl-incf x0 sx)) 992 (when ex 993 (cl-incf err dx) 994 (cl-incf y0 sy)) 995 t))) 996 (setq p0 p1)))))))) 997 998 (defun osm--get-overlays (x y) 999 "Compute overlays and return the overlays in tile X/Y." 1000 (unless (eq (car osm--overlays) osm--zoom) 1001 ;; TODO: Do not compute overlays for the entire map, only for a reasonable 1002 ;; view port around the current center, depending on the size of the 1003 ;; window. Otherwise the spatial hash map for the tracks gets very large if 1004 ;; a line segment spans many tiles. 1005 (let ((pins (make-hash-table :test #'equal)) 1006 (tracks (make-hash-table :test #'equal))) 1007 (osm--each-pin (apply-partially #'osm--add-pin pins)) 1008 (dolist (file osm--gpx-files) 1009 (dolist (seg (cadr file)) 1010 (osm--add-track tracks seg))) 1011 (osm--add-track tracks osm--track) 1012 (setq osm--overlays (list osm--zoom pins tracks)))) 1013 (let ((pins (gethash (cons x y) (cadr osm--overlays))) 1014 (tracks (gethash (cons x y) (caddr osm--overlays)))) 1015 (and (or pins tracks) (cons pins tracks)))) 1016 1017 (autoload 'svg--image-data "svg") 1018 (defun osm--draw-tile (x y tpin) 1019 "Make tile at X/Y from FILE. 1020 TPIN is an optional pin." 1021 (let ((file (osm--tile-file x y osm--zoom)) 1022 overlays) 1023 (when (file-exists-p file) 1024 (if (or (setq overlays (osm--get-overlays x y)) (eq osm-tile-border t) tpin) 1025 (let* ((areas nil) 1026 (x0 (* 256 x)) 1027 (y0 (* 256 y)) 1028 (svg-pin 1029 (lambda (pin) 1030 (pcase-let* ((`(,p ,q ,_lat ,_lon ,id ,name) pin) 1031 (bg (cdr (assq id osm-pin-colors)))) 1032 (setq p (- p x0) q (- q y0)) 1033 (push `((poly . [,p ,q ,(- p 20) ,(- q 40) ,p ,(- q 50) ,(+ p 20) ,(- q 40) ]) 1034 ,id (help-echo ,(truncate-string-to-width name 40 0 nil t))) 1035 areas) 1036 ;; https://commons.wikimedia.org/wiki/File:Simpleicons_Places_map-marker-1.svg 1037 (format " 1038 <g fill='%s' stroke='#000' stroke-width='9' transform='translate(%s %s) scale(0.09) translate(-256 -512)'> 1039 <path d='M256 0C167.641 0 96 71.625 96 160c0 24.75 5.625 48.219 15.672 1040 69.125C112.234 230.313 256 512 256 512l142.594-279.375 1041 C409.719 210.844 416 186.156 416 160C416 71.625 344.375 1042 0 256 0z M256 256c-53.016 0-96-43-96-96s42.984-96 96-96 1043 c53 0 96 43 96 96S309 256 256 256z'/> 1044 </g>" bg p q)))) 1045 (svg-text 1046 (concat "<svg width='256' height='256' version='1.1' 1047 xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'> 1048 <image xlink:href='" 1049 (file-name-nondirectory file) 1050 "' height='256' width='256'/>" 1051 (when-let (track (cdr overlays)) 1052 (format 1053 "<path style='%s' d='%s'/>" 1054 osm-track-style 1055 (let (last) 1056 (mapconcat 1057 (pcase-lambda (`(,beg . ,end)) 1058 (prog1 1059 (if (equal beg last) 1060 (format "L%s %s" (- (car end) x0) (- (cdr end) y0)) 1061 (format "M%s %sL%s %s" 1062 (- (car beg) x0) (- (cdr beg) y0) 1063 (- (car end) x0) (- (cdr end) y0))) 1064 (setq last end))) 1065 track "")))) 1066 (pcase-exhaustive osm-tile-border 1067 ('nil nil) 1068 ('debug "<path d='M 1 1 L 1 255 255 255 255 1 Z' stroke='#000' stroke-width='2' fill='none'/>") 1069 ('t "<path d='M 0 0 L 0 256 256 256' stroke='#000' fill='none'/>")) 1070 (mapconcat svg-pin (car overlays) "") 1071 (and tpin (funcall svg-pin tpin)) 1072 "</svg>"))) 1073 (list 'image :width 256 :height 256 :type 'svg :base-uri file :data svg-text :map areas)) 1074 (list 'image :width 256 :height 256 :file file :type 1075 (if (member (file-name-extension file) '("jpg" "jpeg")) 1076 'jpeg 'png)))))) 1077 1078 (defun osm--get-tile (x y) 1079 "Get tile at X/Y." 1080 (pcase osm--pin 1081 ((and `(,lat ,lon ,_id ,name) 1082 (guard (osm--pin-inside-p x y lat lon))) 1083 (osm--draw-tile x y (list (osm--lon-to-x lon osm--zoom) 1084 (osm--lat-to-y lat osm--zoom) 1085 lat lon 'osm-selected name))) 1086 (_ 1087 (let* ((key `(,osm-server ,osm--zoom ,x . ,y)) 1088 (tile (and osm--tile-cache (gethash key osm--tile-cache)))) 1089 (if tile 1090 (progn (setcar tile osm--tile-age) (cdr tile)) 1091 (setq tile (osm--draw-tile x y nil)) 1092 (when tile 1093 (when osm-max-tiles 1094 (unless osm--tile-cache 1095 (setq osm--tile-cache (make-hash-table :test #'equal :size osm-max-tiles))) 1096 (puthash key (cons osm--tile-age tile) osm--tile-cache)) 1097 tile)))))) 1098 1099 (defun osm--display-tile (x y tile) 1100 "Display TILE at X/Y." 1101 (let ((i (- x (/ (osm--x0) 256))) 1102 (j (- y (/ (osm--y0) 256)))) 1103 (when (and (>= i 0) (< i osm--nx) (>= j 0) (< j osm--ny)) 1104 (let* ((mx (if (= 0 i) (mod (osm--x0) 256) 0)) 1105 (my (if (= 0 j) (mod (osm--y0) 256) 0)) 1106 (pos (+ (point-min) (* j (1+ osm--nx)) i))) 1107 (unless tile 1108 (setq tile (cons 'image osm--placeholder))) 1109 (with-silent-modifications 1110 (put-text-property 1111 pos (1+ pos) 'display 1112 (if (or (/= 0 mx) (/= 0 my)) 1113 `((slice ,mx ,my ,(- 256 mx) ,(- 256 my)) ,tile) 1114 tile))))))) 1115 1116 ;;;###autoload 1117 (defun osm-home () 1118 "Go to home coordinates." 1119 (interactive) 1120 (pcase osm-home 1121 (`(,lat ,lon ,zoom) 1122 (osm--goto lat lon zoom nil 'osm-home "Home")))) 1123 1124 (defun osm--download-queue-info () 1125 "Return queue info string." 1126 (when osm--download-processes 1127 (format "[%s/%s/%s]" 1128 (cl-loop for (_ . p) in osm--download-processes sum (length p)) 1129 (length osm--download-active) 1130 (length osm--download-queue)))) 1131 1132 (defun osm--revert (&rest _) 1133 "Revert osm buffers." 1134 (clear-image-cache t) ;; Make absolutely sure that the tiles are redrawn. 1135 (setq osm--tile-cache nil) 1136 (osm--each 1137 (setq osm--overlays nil) 1138 (osm--update))) 1139 1140 (defun osm--resize (&rest _) 1141 "Resize buffer." 1142 (when (eq major-mode #'osm-mode) 1143 (osm--update))) 1144 1145 (defun osm--header-button (text action) 1146 "Format header line button with TEXT and ACTION." 1147 (propertize text 1148 'keymap (define-keymap "<header-line> <mouse-1>" 1149 (if (commandp action) 1150 (lambda () 1151 (interactive "@") 1152 (call-interactively action)) 1153 action)) 1154 'face '(:box (:line-width -2 :style released-button)) 1155 'mouse-face '(:box (:line-width -2 :style pressed-button)))) 1156 1157 (defun osm--update-header () 1158 "Update header line." 1159 (let* ((meter-per-pixel (/ (* 156543.03 (cos (/ osm--lat (/ 180.0 float-pi)))) (expt 2 osm--zoom))) 1160 (server (osm--server-property :name)) 1161 (meter 1) (idx 0) 1162 (factor '(2 2.5 2)) 1163 (sep #(" " 0 1 (display (space :width (1)))))) 1164 (while (and (< idx 20) (< (/ (* meter (nth (mod idx 3) factor)) meter-per-pixel) 150)) 1165 (setq meter (round (* meter (nth (mod idx 3) factor)))) 1166 (cl-incf idx)) 1167 (setq-local 1168 header-line-format 1169 (list 1170 (osm--header-button " ☰ " (osm--menu-item osm-mode-menu)) sep 1171 (osm--header-button (format " %s " server) 1172 (osm--menu-item #'osm--server-menu)) sep 1173 (osm--header-button " + " #'osm-zoom-in) sep 1174 (osm--header-button " - " #'osm-zoom-out) 1175 (format " Z%-2d " osm--zoom) 1176 #(" " 0 1 (display (space :align-to (- center 15)))) 1177 (format #(" %7.2f° %7.2f°" 0 14 (face bold)) osm--lat osm--lon) 1178 #(" " 0 1 (display (space :align-to (- right 20)))) 1179 (format "%3s " (if (>= meter 1000) (/ meter 1000) meter)) 1180 (if (>= meter 1000) "km " "m ") 1181 #(" " 0 1 (face (:inverse-video t) display (space :width (3)))) 1182 (propertize " " 'face '(:strike-through t) 1183 'display `(space :width (,(floor (/ meter meter-per-pixel))))) 1184 #(" " 0 1 (face (:inverse-video t) display (space :width (3)))))))) 1185 1186 (defun osm--update () 1187 "Update map display." 1188 (osm--barf-unless-osm) 1189 (osm--purge-tile-cache) 1190 (osm--purge-directory) 1191 (osm--rename-buffer) 1192 (osm--update-sizes) 1193 (osm--update-header) 1194 (osm--update-buffer) 1195 (osm--update-copyright) 1196 (osm--process-download-queue)) 1197 1198 (defun osm--update-sizes () 1199 "Update window sizes." 1200 (let* ((windows (or (get-buffer-window-list) (list (frame-root-window)))) 1201 (win-width (cl-loop for w in windows maximize (window-pixel-width w))) 1202 (win-height (cl-loop for w in windows maximize (window-pixel-height w)))) 1203 (setq osm--wx (/ win-width 2) 1204 osm--wy (/ win-height 2) 1205 osm--nx (1+ (ceiling win-width 256)) 1206 osm--ny (1+ (ceiling win-height 256))))) 1207 1208 (defun osm--copyright-link (text url) 1209 "Format link with TEXT to URL." 1210 (propertize text 1211 'face 'button 1212 'mouse-face 'highlight 1213 'help-echo 1214 (format "Go to %s" url) 1215 'keymap 1216 (define-keymap "<tab-line> <mouse-1>" 1217 (lambda () 1218 (interactive) 1219 (browse-url url))))) 1220 1221 (defun osm--update-copyright () 1222 "Update copyright info." 1223 (let ((copyright (and osm-copyright (osm--server-property :copyright)))) 1224 (if (not copyright) 1225 (when (eq 'osm-copyright (car-safe tab-line-format)) 1226 (kill-local-variable 'tab-line-format)) 1227 (setq copyright (replace-regexp-in-string 1228 "{\\(.*?\\)|\\(.*?\\)}" 1229 (lambda (str) 1230 (osm--copyright-link 1231 (match-string 1 str) 1232 (match-string 2 str))) 1233 (concat 1234 " " 1235 (string-join (ensure-list copyright) " | ") 1236 #(" " 0 1 (display (space :align-to (+ 42 right))))))) 1237 (add-face-text-property 1238 0 (length copyright) 1239 '(:inherit (header-line variable-pitch) :height 0.65) 1240 t copyright) 1241 (setq-local tab-line-format (list 'osm-copyright copyright))))) 1242 1243 (defun osm--update-buffer () 1244 "Update buffer display." 1245 (with-silent-modifications 1246 (erase-buffer) 1247 (dotimes (_j osm--ny) 1248 (insert (make-string osm--nx ?\s) "\n")) 1249 (put-text-property (point-min) (point-max) 'pointer 'arrow) 1250 (goto-char (point-min)) 1251 (let ((tx (/ (osm--x0) 256)) 1252 (ty (/ (osm--y0) 256))) 1253 (dotimes (j osm--ny) 1254 (dotimes (i osm--nx) 1255 (let* ((x (+ i tx)) 1256 (y (+ j ty)) 1257 (tile (osm--get-tile x y))) 1258 (osm--display-tile x y tile) 1259 (unless tile (osm--enqueue-download x y)))))))) 1260 1261 (defun osm--process-download-queue () 1262 "Process the download queue." 1263 (setq osm--download-queue 1264 (sort 1265 (cl-loop with tx = (/ (osm--x0) 256) 1266 with ty = (/ (osm--y0) 256) 1267 for job in osm--download-queue 1268 for (_server zoom x y) = job 1269 if (and (= zoom osm--zoom) 1270 (>= x tx) (< x (+ tx osm--nx)) 1271 (>= y ty) (< y (+ ty osm--ny))) 1272 collect job) 1273 (let ((tx (/ (osm--x) 256)) 1274 (ty (/ (osm--y) 256))) 1275 (pcase-lambda (`(,_s1 ,_z1 ,x1 ,y1) `(,_s2 ,_z2 ,x2 ,y2)) 1276 (setq x1 (- x1 tx) y1 (- y1 ty) x2 (- x2 tx) y2 (- y2 ty)) 1277 (< (+ (* x1 x1) (* y1 y1)) (+ (* x2 x2) (* y2 y2))))))) 1278 (osm--download)) 1279 1280 (defun osm--purge-tile-cache () 1281 "Purge old tiles from the tile cache." 1282 (cl-incf osm--tile-age) 1283 (when (and osm--tile-cache (> (hash-table-count osm--tile-cache) osm-max-tiles)) 1284 (let (items) 1285 (maphash (lambda (k v) (push (list (car v) (cdr v) k) items)) osm--tile-cache) 1286 (setq items (sort items #'car-less-than-car)) 1287 (cl-loop repeat (- (hash-table-count osm--tile-cache) osm-max-tiles) 1288 for (_age tile key) in items do 1289 (image-flush tile t) 1290 (remhash key osm--tile-cache))))) 1291 1292 (defun osm--bookmark-record-default () 1293 "Make osm bookmark record." 1294 (osm--bookmark-record (osm--bookmark-name osm--lat osm--lon nil) 1295 osm--lat osm--lon nil)) 1296 1297 (defun osm--bookmark-record (name lat lon loc) 1298 "Make osm bookmark record with NAME and LOC description at LAT/LON." 1299 (setq bookmark-current-bookmark nil) ;; Reset bookmark to use new name 1300 `(,name 1301 (location . ,(osm--location-name lat lon loc 6)) 1302 (coordinates ,lat ,lon ,osm--zoom) 1303 (server . ,osm-server) 1304 (handler . ,#'osm-bookmark-jump))) 1305 1306 (defun osm--org-link-props () 1307 "Return Org link properties." 1308 (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Org Link")) 1309 (name (osm--location-name lat lon loc 2))) 1310 (list :type "geo" 1311 :description 1312 (if (eq osm-server (default-value 'osm-server)) 1313 (string-remove-suffix (concat " " (osm--server-property :name)) 1314 name) 1315 name) 1316 :link 1317 (format "geo:%.6f,%.6f;z=%s%s" 1318 lat lon osm--zoom 1319 (if (eq osm-server (default-value 'osm-server)) "" 1320 (format ";s=%s" osm-server)))))) 1321 1322 (defun osm--rename-buffer () 1323 "Rename current buffer." 1324 (setq list-buffers-directory (osm--location-name osm--lat osm--lon nil 6)) 1325 (rename-buffer 1326 (format "*osm: %s*" (osm--location-name osm--lat osm--lon nil 2)) 1327 'unique)) 1328 1329 (defun osm--location-name (lat lon loc prec) 1330 "Format location string LAT/LON with optional LOC description. 1331 The coordinates are formatted with precision PREC." 1332 (format (format "%%s%%.%df° %%.%df° Z%%s %%s" prec prec) 1333 (if loc (concat loc ", ") "") 1334 lat lon osm--zoom (osm--server-property :name))) 1335 1336 (defun osm--bookmark-name (lat lon loc) 1337 "Return bookmark name for LAT/LON/LOC." 1338 (concat "osm: " (osm--location-name lat lon loc 2))) 1339 1340 (defun osm--goto (lat lon zoom server id name) 1341 "Go to LAT/LON/ZOOM, change SERVER. 1342 Optionally place pin with ID and NAME." 1343 ;; Server not found 1344 (when (and server (not (assq server osm-server-list))) (setq server nil)) 1345 (with-current-buffer 1346 (or 1347 (and (eq major-mode #'osm-mode) (current-buffer)) 1348 (let ((def-server (or server osm-server)) 1349 (def-lat (or lat (nth 0 osm-home))) 1350 (def-lon (or lon (nth 1 osm-home))) 1351 (def-zoom (or zoom (nth 2 osm-home)))) 1352 ;; Search for existing buffer 1353 (cl-loop 1354 for buf in (buffer-list) thereis 1355 (and (equal (buffer-local-value 'major-mode buf) #'osm-mode) 1356 (equal (buffer-local-value 'osm-server buf) def-server) 1357 (equal (buffer-local-value 'osm--zoom buf) def-zoom) 1358 (equal (buffer-local-value 'osm--lat buf) def-lat) 1359 (equal (buffer-local-value 'osm--lon buf) def-lon) 1360 buf))) 1361 (generate-new-buffer "*osm*")) 1362 (unless (eq major-mode #'osm-mode) 1363 (osm-mode)) 1364 (when (and server (not (eq osm-server server))) 1365 (setq-local osm-server server 1366 osm--download-queue nil)) 1367 (when (or (not (and osm--lon osm--lat)) lat) 1368 (setq osm--lat (or lat (nth 0 osm-home)) 1369 osm--lon (or lon (nth 1 osm-home)) 1370 osm--zoom (or zoom (nth 2 osm-home))) 1371 (when id 1372 (osm--set-pin id osm--lat osm--lon name))) 1373 (prog1 (pop-to-buffer (current-buffer)) 1374 (osm--update)))) 1375 1376 (defun osm--set-pin (id lat lon name &optional quiet) 1377 "Set pin at LAT/LON with ID and NAME. 1378 Print NAME if not QUIET." 1379 (setq name (or name (format "Location %.6f° %.6f°" lat lon))) 1380 (setq osm--pin (list lat lon (or id 'osm-selected) name)) 1381 (unless quiet (message "%s" name))) 1382 1383 (defun osm--set-pin-event (event &optional id name quiet) 1384 "Set selection pin with ID and NAME at location of EVENT. 1385 Print NAME if not QUIET." 1386 (pcase-let ((`(,x . ,y) (posn-x-y (event-start event)))) 1387 (osm--set-pin id 1388 (osm--y-to-lat (+ (osm--y0) y) osm--zoom) 1389 (osm--x-to-lon (+ (osm--x0) x) osm--zoom) 1390 name quiet))) 1391 1392 ;;;###autoload 1393 (defun osm-goto (lat lon zoom) 1394 "Go to LAT/LON/ZOOM." 1395 (interactive 1396 (pcase-let ((`(,lat ,lon ,zoom) 1397 (mapcar #'string-to-number 1398 (split-string (read-string "Lat Lon (Zoom): ") nil t)))) 1399 (setq zoom (or zoom osm--zoom 11)) 1400 (unless (and (numberp lat) (numberp lon) (numberp zoom)) 1401 (error "Invalid coordinate")) 1402 (list lat lon zoom))) 1403 (osm--goto lat lon zoom nil 'osm-selected nil) 1404 nil) 1405 1406 ;;;###autoload 1407 (defun osm (&rest link) 1408 "Go to LINK. 1409 When called interactively, call the function `osm-home'." 1410 (interactive (list 'home)) 1411 (pcase link 1412 ('(home) 1413 (osm-home)) 1414 (`(,lat ,lon ,zoom . ,server) 1415 (setq server (car server)) 1416 (unless (and server (symbolp server)) (setq server nil)) ;; Ignore comment 1417 (osm--goto lat lon zoom server 'osm-selected "Elisp Link")) 1418 ((and `(,url . ,_) (guard (stringp url))) 1419 (if (string-match 1420 "\\`geo:\\([0-9.-]+\\),\\([0-9.-]+\\)\\(?:,[0-9.-]+\\)?\\(;.+\\'\\|\\'\\)" url) 1421 (let* ((lat (string-to-number (match-string 1 url))) 1422 (lon (string-to-number (match-string 2 url))) 1423 (args (url-parse-args (match-string 3 url) "")) 1424 (zoom (cdr (assoc "z" args))) 1425 (server (cdr (assoc "s" args)))) 1426 (osm--goto lat lon 1427 (and zoom (string-to-number zoom)) 1428 (and server (intern-soft server)) 1429 'osm-selected "Geo Link")) 1430 (osm-search (string-remove-prefix "geo:" url)))) 1431 (_ (error "Invalid osm link")))) 1432 1433 ;;;###autoload 1434 (defun osm-bookmark-jump (bm) 1435 "Jump to osm bookmark BM." 1436 (interactive (list (osm--bookmark-read))) 1437 (pcase-let ((`(,lat ,lon ,zoom) (bookmark-prop-get bm 'coordinates))) 1438 (set-buffer (osm--goto lat lon zoom 1439 (bookmark-prop-get bm 'server) 1440 'osm-bookmark (car bm))))) 1441 (put 'osm-bookmark-jump 'bookmark-handler-type "Osm") 1442 1443 ;;;###autoload 1444 (defun osm-bookmark-delete (bm) 1445 "Delete osm bookmark BM." 1446 (interactive (list (osm--bookmark-read))) 1447 (when (y-or-n-p (format "Delete bookmark `%s'? " bm)) 1448 (bookmark-delete bm) 1449 (setq osm--pin nil) 1450 (osm--revert))) 1451 1452 ;;;###autoload 1453 (defun osm-bookmark-rename (old-name) 1454 "Rename osm bookmark OLD-NAME." 1455 (interactive (list (car (osm--bookmark-read)))) 1456 (let ((new-name (read-from-minibuffer "New name: " old-name nil nil 1457 'bookmark-history old-name))) 1458 (when osm--pin (setf (cadddr osm--pin) new-name)) 1459 (bookmark-rename old-name new-name) 1460 (osm--revert))) 1461 1462 (defun osm--bookmark-read () 1463 "Read bookmark name." 1464 (bookmark-maybe-load-default-file) 1465 (or (assoc 1466 (pcase osm--pin 1467 (`(,_lat ,_lon osm-bookmark ,name) name) 1468 (_ (completing-read 1469 "Bookmark: " 1470 (or (cl-loop for bm in bookmark-alist 1471 if (eq (bookmark-prop-get bm 'handler) #'osm-bookmark-jump) 1472 collect (car bm)) 1473 (error "No bookmarks found")) 1474 nil t nil 'bookmark-history))) 1475 bookmark-alist) 1476 (error "No bookmark selected"))) 1477 1478 (defun osm-bookmark-set () 1479 "Create osm bookmark." 1480 (interactive nil osm-mode) 1481 (osm--barf-unless-osm) 1482 (unwind-protect 1483 (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Bookmark")) 1484 (def (osm--bookmark-name lat lon loc)) 1485 (name (read-from-minibuffer "Bookmark name: " def nil nil 'bookmark-history def)) 1486 (bookmark-make-record-function 1487 (lambda () (osm--bookmark-record name lat lon loc)))) 1488 (bookmark-set name) 1489 (message "Stored bookmark: %s" name) 1490 (setf (caddr osm--pin) 'osm-bookmark)) 1491 (osm--revert))) 1492 1493 (defun osm--fetch-location-data (name) 1494 "Fetch location info for NAME." 1495 (when (mouse-event-p last-input-event) 1496 (osm--set-pin-event last-input-event 'osm-selected name)) 1497 (let ((lat (or (car osm--pin) osm--lat)) 1498 (lon (or (cadr osm--pin) osm--lon))) 1499 (osm--set-pin 'osm-selected lat lon name 'quiet) 1500 (message "%s: Fetching name of %.2f° %.2f° from %s..." name lat lon osm-search-server) 1501 ;; Redisplay before slow fetching 1502 (osm--update) 1503 (redisplay) 1504 (list lat lon 1505 (ignore-errors 1506 (alist-get 1507 'display_name 1508 (osm--fetch-json 1509 (format "%s/reverse?format=json&accept-language=%s&zoom=%s&lat=%s&lon=%s" 1510 osm-search-server osm-search-language 1511 (min 18 (max 3 osm--zoom)) lat lon))))))) 1512 1513 (defun osm--track-index () 1514 "Return index of selected track way point." 1515 (cl-loop for idx from 0 for (lat lon _) in osm--track 1516 if (and (equal lat (car osm--pin)) (equal lon (cadr osm--pin))) 1517 return idx)) 1518 1519 (defun osm--track-delete () 1520 "Delete track way point." 1521 (when-let ((idx (osm--track-index))) 1522 ;; Delete pin 1523 (cl-callf2 delq (nth idx osm--track) osm--track) 1524 (setq osm--pin nil 1525 idx (min idx (1- (length osm--track)))) 1526 ;; Select next pin 1527 (pcase (nth idx osm--track) 1528 (`(,lat ,lon ,name) 1529 (osm--set-pin 'osm-track lat lon name 'quiet))) 1530 ;; Rename pins after deletion 1531 (cl-loop for idx from (length osm--track) downto 1 1532 for pt in osm--track 1533 if (string-match-p "\\`WP[0-9]+\\'" (caddr pt)) do 1534 (setf (caddr pt) (format "WP%s" idx))) 1535 (osm--track-length) 1536 (osm--revert))) 1537 1538 (defun osm--track-rename () 1539 "Rename track way point." 1540 (when-let ((pt (nth (osm--track-index) osm--track)) 1541 (old-name (caddr pt)) 1542 (new-name (read-from-minibuffer "New name: " old-name nil nil nil old-name))) 1543 (setf (caddr pt) new-name 1544 (cadddr osm--pin) new-name) 1545 (osm--revert))) 1546 1547 (defun osm-delete () 1548 "Delete selected pin (bookmark or way point)." 1549 (interactive nil osm-mode) 1550 (osm--barf-unless-osm) 1551 (pcase (caddr osm--pin) 1552 ('nil nil) 1553 ('osm-bookmark (osm-bookmark-delete (cadddr osm--pin))) 1554 ('osm-track (osm--track-delete)) 1555 (_ (setq osm--pin nil) (osm--update)))) 1556 1557 (defun osm-rename () 1558 "Rename selected pin (bookmark or way point)." 1559 (interactive nil osm-mode) 1560 (osm--barf-unless-osm) 1561 (pcase (caddr osm--pin) 1562 ('osm-bookmark (osm-bookmark-rename (cadddr osm--pin))) 1563 ('osm-track (osm--track-rename)))) 1564 1565 ;;;###autoload 1566 (defun osm-jump () 1567 "Jump to named pin." 1568 (interactive) 1569 (let (pins) 1570 (osm--each-pin (lambda (id lat lon zoom name) 1571 (push (list name (capitalize (substring (symbol-name id) 4)) 1572 id lat lon zoom) 1573 pins))) 1574 (pcase (assoc (completing-read 1575 "Jump: " 1576 (lambda (str pred action) 1577 (if (eq action 'metadata) 1578 `(metadata 1579 (group-function 1580 . ,(lambda (pin transform) 1581 (if transform pin 1582 (cadr (assoc pin pins)))))) 1583 (complete-with-action action pins str pred))) 1584 nil t nil 'osm--jump-history) 1585 pins) 1586 (`(,name ,_group ,id ,lat ,lon ,zoom) (osm--goto lat lon zoom nil id name)) 1587 (_ (user-error "No pin selected"))))) 1588 1589 (defun osm--fetch-json (url) 1590 "Get json from URL." 1591 (osm--check-libraries) 1592 (with-temp-buffer 1593 (let* ((default-process-coding-system '(utf-8-unix . utf-8-unix)) 1594 (status (apply #'call-process "curl" nil (current-buffer) nil 1595 `(,@(split-string-and-unquote osm-curl-options) ,url)))) 1596 (unless (eq status 0) 1597 (error "Fetching %s exited with status %s" url status))) 1598 (goto-char (point-min)) 1599 (json-parse-buffer :array-type 'list :object-type 'alist))) 1600 1601 (defun osm--search (needle) 1602 "Globally search for NEEDLE and return the list of results." 1603 (message "Contacting %s" osm-search-server) 1604 (mapcar 1605 (lambda (x) 1606 (let ((lat (string-to-number (alist-get 'lat x))) 1607 (lon (string-to-number (alist-get 'lon x)))) 1608 `(,(format "%s (%.6f° %.6f°)" 1609 (alist-get 'display_name x) 1610 lat lon) 1611 ,lat ,lon 1612 ,@(mapcar #'string-to-number (alist-get 'boundingbox x))))) 1613 (osm--fetch-json 1614 (format "%s/search?format=json&accept-language=%s&q=%s" 1615 osm-search-server osm-search-language 1616 (url-encode-url needle))))) 1617 1618 ;;;###autoload 1619 (defun osm-search (needle &optional lucky) 1620 "Globally search for NEEDLE on `osm-search-server' and display the map. 1621 If the prefix argument LUCKY is non-nil take the first result and jump there. 1622 See `osm-search-server' and `osm-search-language' for customization." 1623 (interactive 1624 (list 1625 (minibuffer-with-setup-hook 1626 (lambda () 1627 (when (and (eq completing-read-function #'completing-read-default) 1628 (not (bound-and-true-p vertico-mode))) 1629 ;; Override dreaded `minibuffer-complete-word' for default 1630 ;; completion. When will this keybinding finally get removed from 1631 ;; default completion? 1632 (use-local-map (make-composed-keymap 1633 (define-keymap "SPC" nil) 1634 (current-local-map))))) 1635 (completing-read "Location: " 1636 (osm--sorted-table osm--search-history) 1637 nil nil nil 'osm--search-history)) 1638 current-prefix-arg)) 1639 ;; TODO: Add search bounded to current viewbox, bounded=1, viewbox=x1,y1,x2,y2 1640 (let* ((results (or (osm--search needle) (error "No results for `%s'" needle))) 1641 (selected 1642 (or 1643 (and (or lucky (not (cdr results))) (car results)) 1644 (assoc 1645 (minibuffer-with-setup-hook 1646 (lambda () 1647 (when (and (eq completing-read-function #'completing-read-default) 1648 (not (bound-and-true-p vertico-mode)) 1649 (not (bound-and-true-p icomplete-mode))) 1650 (let ((message-log-max nil) 1651 (inhibit-message t)) 1652 ;; Show matches immediately for default completion. 1653 (minibuffer-completion-help)))) 1654 (completing-read 1655 (format "Matches for '%s': " needle) 1656 (osm--sorted-table results) 1657 nil t nil t)) 1658 results) 1659 (error "No selection")))) 1660 (osm--goto (cadr selected) (caddr selected) 1661 (apply #'osm--boundingbox-to-zoom (cdddr selected)) 1662 nil 'osm-selected (car selected)))) 1663 1664 (defun osm--sorted-table (coll) 1665 "Sorted completion table from COLL." 1666 (lambda (str pred action) 1667 (if (eq action 'metadata) 1668 '(metadata (display-sort-function . identity) 1669 (cycle-sort-function . identity)) 1670 (complete-with-action action coll str pred)))) 1671 1672 ;;;###autoload 1673 (defun osm-gpx-show (file) 1674 "Show the tracks of gpx FILE in an `osm-mode' buffer." 1675 (interactive "fGPX file: ") 1676 (osm--check-libraries) 1677 (let ((dom (with-temp-buffer 1678 (insert-file-contents file) 1679 (libxml-parse-xml-region (point-min) (point-max)))) 1680 (min-lat 90) (max-lat -90) (min-lon 180) (max-lon -180)) 1681 (setf (alist-get (abbreviate-file-name file) osm--gpx-files nil nil #'equal) 1682 (cons 1683 (cl-loop 1684 for trk in (dom-children dom) 1685 if (eq (dom-tag trk) 'trk) nconc 1686 (cl-loop 1687 for seg in (dom-children trk) 1688 if (eq (dom-tag seg) 'trkseg) collect 1689 (cl-loop 1690 for pt in (dom-children seg) 1691 if (eq (dom-tag pt) 'trkpt) collect 1692 (let ((lat (string-to-number (dom-attr pt 'lat))) 1693 (lon (string-to-number (dom-attr pt 'lon)))) 1694 (setq min-lat (min lat min-lat) 1695 max-lat (max lat max-lat) 1696 min-lon (min lon min-lon) 1697 max-lon (max lon max-lon)) 1698 (cons lat lon))))) 1699 (cl-loop 1700 for pt in (dom-children dom) 1701 if (eq (dom-tag pt) 'wpt) collect 1702 (let ((lat (string-to-number (dom-attr pt 'lat))) 1703 (lon (string-to-number (dom-attr pt 'lon)))) 1704 (setq min-lat (min lat min-lat) 1705 max-lat (max lat max-lat) 1706 min-lon (min lon min-lon) 1707 max-lon (max lon max-lon)) 1708 (list lat lon (dom-text (dom-child-by-tag pt 'name))))))) 1709 (osm--revert) 1710 (osm--goto (/ (+ min-lat max-lat) 2) (/ (+ min-lon max-lon) 2) 1711 (osm--boundingbox-to-zoom min-lat max-lat min-lon max-lon) 1712 nil nil nil))) 1713 1714 (defun osm-gpx-hide (file) 1715 "Show the tracks of gpx FILE in an `osm-mode' buffer." 1716 (interactive (list (completing-read "GPX file: " 1717 (or osm--gpx-files 1718 (error "No GPX files shown")) 1719 nil t nil 'file-name-history))) 1720 (cl-callf2 assoc-delete-all file osm--gpx-files) 1721 (osm--revert)) 1722 1723 (defun osm--server-annotation (cand) 1724 "Annotation for server CAND." 1725 (when-let ((copyright (osm--server-property :copyright (get-text-property 0 'osm--server cand))) 1726 (str 1727 (replace-regexp-in-string 1728 "{\\(.*?\\)|.*?}" 1729 (lambda (str) (match-string 1 str)) 1730 (string-join (ensure-list copyright) " | ") copyright))) 1731 (concat (propertize " " 'display `(space :align-to (- right ,(length str) 2))) 1732 " " 1733 str))) 1734 1735 (defun osm--server-group (cand transform) 1736 "Group function for server CAND with candidate TRANSFORM." 1737 (if transform 1738 cand 1739 (osm--server-property :group (get-text-property 0 'osm--server cand)))) 1740 1741 ;;;###autoload 1742 (defun osm-server (server) 1743 "Select tile SERVER." 1744 (interactive 1745 (let* ((max-name (cl-loop for (_ . x) in osm-server-list 1746 maximize (length (plist-get x :name)))) 1747 (fmt (concat 1748 (propertize (format "%%-%ds " max-name) 1749 'face 'font-lock-comment-face) 1750 " %s")) 1751 (servers 1752 (mapcar 1753 (lambda (x) 1754 (propertize 1755 (format fmt 1756 (plist-get (cdr x) :name) 1757 (or (plist-get (cdr x) :description) "")) 1758 'osm--server (car x))) 1759 osm-server-list)) 1760 (selected (completing-read 1761 "Server: " 1762 (lambda (str pred action) 1763 (if (eq action 'metadata) 1764 `(metadata 1765 (annotation-function 1766 . ,(and osm-copyright #'osm--server-annotation)) 1767 (group-function . ,#'osm--server-group)) 1768 (complete-with-action action servers str pred))) 1769 nil t nil 'osm--server-history 1770 (format fmt 1771 (osm--server-property :name) 1772 (or (osm--server-property :description) ""))))) 1773 (list 1774 (get-text-property 0 'osm--server 1775 (or (car (member selected servers)) 1776 (error "No server selected")))))) 1777 (osm--goto nil nil nil server nil nil)) 1778 1779 (defun osm-save-url (&optional arg) 1780 "Save coordinates as url in the kill ring. 1781 If prefix ARG is given, store url as Elisp expression." 1782 (interactive "P" osm-mode) 1783 (osm--barf-unless-osm) 1784 (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Link")) 1785 (server (and (not (eq osm-server (default-value 'osm-server))) osm-server)) 1786 (url (if arg 1787 (format "(osm %.6f %.6f %s%s%s)" 1788 lat lon osm--zoom 1789 (if server (format " '%s" osm-server) "") 1790 (if loc (format " %S" loc) "")) 1791 (format "geo:%.6f,%.6f;z=%s%s%s" 1792 lat lon osm--zoom 1793 (if server (format ";s=%s" osm-server) "") 1794 (if loc (format " (%s)" loc) ""))))) 1795 (kill-new url) 1796 (message "Saved in the kill ring: %s" url))) 1797 1798 (cl-defun osm-add-server (server 1799 &rest properties 1800 &key name description group url max-connections 1801 max-zoom min-zoom download-batch subdomains copyright) 1802 "Add SERVER with PROPERTIES to `osm-server-list'. 1803 The properties are checked as keyword arguments. See 1804 `osm-server-list' for documentation of the keywords." 1805 (declare (indent 1)) 1806 (ignore name description group url max-connections max-zoom 1807 min-zoom download-batch subdomains copyright) 1808 (dolist (sym '(:name :description :group :url)) 1809 (unless (stringp (plist-get properties sym)) 1810 (error "Server property %s is required" sym))) 1811 (unless (and server (symbolp server)) 1812 (error "Server id must be a symbol")) 1813 (setf (alist-get server osm-server-list) properties) 1814 nil) 1815 1816 ;;;###autoload 1817 (add-to-list 'browse-url-default-handlers '("\\`geo:" . osm)) 1818 1819 ;;;###autoload 1820 (eval-after-load 'ol 1821 (lambda () 1822 (declare-function org-link-set-parameters "ol") 1823 (declare-function osm--org-link-props "ext:osm") 1824 (org-link-set-parameters 1825 "geo" 1826 :follow (lambda (link _) (osm (concat "geo:" link))) 1827 :store (lambda () 1828 (when (eq major-mode 'osm-mode) 1829 (apply 'org-link-store-props (osm--org-link-props))))))) 1830 1831 (provide 'osm) 1832 ;;; osm.el ends here