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