config

Personal configuration.
git clone git://code.dwrz.net/config
Log | Files | Refs

osm.el (70466B)


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