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