;;; osm.el --- OpenStreetMap viewer -*- lexical-binding: t -*- ;; Copyright (C) 2022-2026 Free Software Foundation, Inc. ;; Author: Daniel Mendler ;; Maintainer: Daniel Mendler ;; Created: 2022 ;; Version: 2.2 ;; Package-Requires: ((emacs "29.1") (compat "31")) ;; URL: https://github.com/minad/osm ;; Keywords: network, multimedia, hypermedia, mouse ;; This file is part of GNU Emacs. ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Osm.el is a tile-based map viewer, with a responsive movable and ;; zoomable display. The map can be controlled with the keyboard or with ;; the mouse. The viewer fetches the map tiles in parallel from tile ;; servers via the `curl' program. The package comes with a list of ;; multiple preconfigured tile servers. You can bookmark your favorite ;; locations using regular Emacs bookmarks or create links from Org files ;; to locations. Furthermore the package provides commands to measure ;; distances, search for locations and routes by name and to open and ;; display GPX or TCX tracks. ;; osm.el requires Emacs 29 and depends on the external `curl' program. ;; Emacs must be built with libxml, librsvg, libjpeg, libpng ;; and libwebp support. ;;; Code: (require 'compat) (require 'bookmark) (require 'dom) (eval-when-compile (require 'cl-lib) (require 'subr-x)) (defgroup osm nil "OpenStreetMap viewer." :link '(info-link :tag "Info Manual" "(osm)") :link '(url-link :tag "Website" "https://github.com/minad/osm") :link '(url-link :tag "Wiki" "https://github.com/minad/osm/wiki") :link '(emacs-library-link :tag "Library Source" "osm.el") :group 'web :prefix "osm-") (defcustom osm-curl-options "--user-agent emacs-osm/1.0 --fail --location --silent --max-time 30" "Curl command line options." :type 'string) (defcustom osm-search-language "en" "Language used for search results. Use RFC 1766 abbreviations, e.g.: `en' for English, `de' for German. A comma-separated specifies descending order of preference. See also `url-mime-language-string'." :type 'string) (defcustom osm-search-server "https://nominatim.openstreetmap.org" "Server used to search for location names. The server must offer the nominatim.org API." :type 'string) (defcustom osm-route-server "https://routing.openstreetmap.de/routed-%b/route/v1/driving/%x,%y;%X,%Y?steps=false&overview=full&alternatives=false&geometries=geojson" "Server used for route planning. The server must offer the OSRM API." :type 'string) (defcustom osm-server-defaults '( :min-zoom 2 :max-zoom 19 :download-batch 5 :max-connections 2) "Default server properties. See also `osm-server-list'." :type 'plist) (defcustom osm-server-list (let ((copyright-fix "{Fix the map|https://www.openstreetmap.org/fixthemap}") (copyright-data "Map data © {OpenStreetMap|https://www.openstreetmap.org/copyright} contributors")) `((default :name "Carto" :description "Standard Carto map provided by OpenStreetMap" :url "https://tile.openstreetmap.org/%z/%x/%y.png" :group "Standard" :copyright (,copyright-data "Map style © {OpenStreetMap Standard|https://www.openstreetmap.org/copyright}" ,copyright-fix)) (de :name "Carto(de)" :description "Localized Carto map provided by OpenStreetMap Germany" :url "https://tile.openstreetmap.de/%z/%x/%y.png" :group "Standard" :copyright (,copyright-data "Map style © {OpenStreetMap Deutschland|https://www.openstreetmap.de/germanstyle.html}" ,copyright-fix)) (fr :name "Carto(fr)" :description "Localized Carto map by OpenStreetMap France" :url "https://a.tile.openstreetmap.fr/osmfr/%z/%x/%y.png" :group "Standard" :copyright (,copyright-data "Map style © {OpenStreetMap France|https://www.openstreetmap.fr/mentions-legales/}" ,copyright-fix)) (humanitarian :name "Humanitarian" :description "Humanitarian map provided by OpenStreetMap France" :url "https://a.tile.openstreetmap.fr/hot/%z/%x/%y.png" :group "Special Purpose" :copyright (,copyright-data "Map style © {Humanitarian OpenStreetMap Team|https://www.hotosm.org/}" ,copyright-fix)) (cyclosm :name "CyclOSM" :description "Bicycle-oriented map provided by OpenStreetMap France" :url "https://a.tile-cyclosm.openstreetmap.fr/cyclosm/%z/%x/%y.png" :group "Transportation" :copyright (,copyright-data "Map style © {CyclOSM|https://www.cyclosm.org/} contributors" ,copyright-fix)) (openriverboatmap :name "OpenRiverBoatMap" :description "Waterways map provided by OpenStreetMap France" :url "https://a.tile.openstreetmap.fr/openriverboatmap/%z/%x/%y.png" :group "Transportation" :copyright (,copyright-data "Map style © {OpenRiverBoatMap|https://github.com/tilery/OpenRiverboatMap}" ,copyright-fix)) (opvn :name "ÖPNV" :max-zoom 18 :description "Base layer with public transport information" :url "http://tileserver.memomaps.de/tilegen/%z/%x/%y.png" :group "Transportation" :copyright (,copyright-data "Map style © {ÖPNVKarte|https://www.öpnvkarte.de}" ,copyright-fix)))) "List of tile servers. Allowed keys: :name Server name :description Server description :copyright Copyright information :group Name of server groups for related servers :url Url with placeholders :ext File name extension :min-zoom Minimum zoom level :max-zoom Maximum zoom level :download-batch Number of tiles downloaded via a single connection :max-connections Maximum number of parallel connections See also `osm-server-defaults' for default values used for a server if the property is missing. The :url of each server should specify %x, %y and %z placeholders for the map coordinates. It can optionally use a %k placeholder for an apikey. The apikey will be retrieved via `auth-source-search' with the :host set to the domain name and the :user to the string \"apikey\"." :type '(alist :key-type symbol :value-type plist)) (defcustom osm-copyright t "Display the copyright information above the map." :type 'boolean) (defcustom osm-pin-colors '((osm-selected . "#e20") (osm-bookmark . "#f80") (osm-home . "#a0f") (osm-track . "#f0f") (osm-file . "#03f") (osm-route . "#00e")) "Colors of pins." :type '(alist :key-type symbol :value-type string)) (defcustom osm-track-style "stroke-width:5;stroke-linejoin:round;stroke-linecap:round;opacity:0.6;" "SVG style used to draw tracks." :type 'string) (defcustom osm-default-zoom 15 "Default zoom level." :type 'natnum) (defcustom osm-default-server 'default "Default tile server." :type 'symbol) (defcustom osm-home (let ((lat (bound-and-true-p calendar-latitude)) (lon (bound-and-true-p calendar-longitude))) (if (and lat lon) (list lat lon osm-default-zoom) (list 0 0 3))) "Home coordinates, latitude, longitude and zoom level." :type '(list :tag "Coordinates" (number :tag "Latitude ") (number :tag "Longitude ") (number :tag "Zoom "))) (defcustom osm-large-step 256 "Scroll step in pixel." :type 'natnum) (defcustom osm-small-step 16 "Scroll step in pixel." :type 'natnum) (defcustom osm-tile-border nil "Set to t to display thin tile borders. For debugging set the value to `debug', such that a border is shown around SVG tiles." :type '(choice boolean (const debug))) (defcustom osm-tile-directory (expand-file-name (file-name-concat (or (getenv "XDG_CACHE_HOME") "~/.cache/") "emacs/osm/")) "Tile cache directory." :type 'string) (defcustom osm-max-age 14 "Maximum tile age in days. Should be at least 7 days according to the server usage policies." :type '(choice (const nil) natnum)) (defcustom osm-max-tiles 256 "Number of tiles to keep in the memory cache." :type '(choice (const nil) natnum)) (defun osm--menu-item (menu) "Generate menu item from MENU." `(menu-item "" nil :filter ,(lambda (&optional _) (select-window (posn-window (event-start last-input-event))) (if (functionp menu) (funcall menu) menu)))) (defun osm--mouse-ignore-wheel (_prompt) "Ignore mouse wheel events during key translation." (pcase (this-single-command-raw-keys) ((and `[,e] (let y (event-basic-type e)) (guard (symbolp y)) (guard (string-search "wheel-" (symbol-name y)))) []) (k k))) (defvar-keymap osm-prefix-map :doc "Global prefix map of OSM entry points." "h" #'osm-home "s" #'osm-search "v" #'osm-server "t" #'osm-goto "u" #'osm-url "j" #'osm-jump "r" #'osm-route "f" #'osm-open) ;;;###autoload (autoload 'osm-prefix-map "osm" nil t 'keymap) (defalias 'osm-prefix-map osm-prefix-map) ;; TODO add support for touchscreen-pinch for zooming. (defvar-keymap osm-mode-map :doc "Keymap used by `osm-mode'." :parent (make-composed-keymap osm-prefix-map special-mode-map) "" #'osm-home "+" #'osm-zoom-in "-" #'osm-zoom-out "SPC" #'osm-zoom-in "S-SPC" #'osm-zoom-out "" #'osm-mouse-pin "" 'org-store-link "" #'osm-bookmark-set "S-" #'ignore "S-" #'osm-mouse-track "" #'osm-mouse-drag "" #'osm-mouse-drag "" #'osm-mouse-drag "" #'ignore "" #'ignore "" #'ignore "" #'osm-up "" #'osm-down "" #'osm-left "" #'osm-right "C-" #'osm-up-up "C-" #'osm-down-down "C-" #'osm-left-left "C-" #'osm-right-right "M-" #'osm-up-up "M-" #'osm-down-down "M-" #'osm-left-left "M-" #'osm-right-right "S-" #'osm-up-up "S-" #'osm-down-down "S-" #'osm-left-left "S-" #'osm-right-right "n" #'osm-rename "d" #'osm-delete "DEL" #'osm-delete "" #'osm-delete "c" #'osm-center "o" #'clone-buffer "u" #'osm-save-url "l" 'org-store-link "b" #'osm-bookmark-set "F" #'osm-hide "R" #'osm-hide " " #'osm-down " " #'osm-up "<" nil ">" nil) (dolist (pin osm-pin-colors) (setq pin (vector (car pin))) (define-key key-translation-map pin #'osm--mouse-ignore-wheel) (define-key osm-mode-map pin #'osm-mouse-select)) (easy-menu-define osm-mode-menu osm-mode-map "Menu for `osm-mode'." '("OSM" ["Go home" osm-home] ["Center" osm-center] ["Go to coordinates" osm-goto] ["Go to URL" osm-url] ["Jump to pin" osm-jump] ["Change tile server" osm-server] "--" ["Search by name" osm-search] ["Plan route" osm-route] "--" ["Org link" org-store-link] ["Geo URL" osm-save-url] ["Elisp link" (osm-save-url t)] ("Bookmark" ["Set" osm-bookmark-set] ["Jump" osm-bookmark-jump] ["Rename" osm-bookmark-rename] ["Delete" osm-bookmark-delete]) "--" ["Open geometry file" osm-open] ["Hide file or route" osm-hide] "--" ["Clone buffer" clone-buffer] ["Revert buffer" revert-buffer] "--" ["Manual" (info "(osm)")] ["Customize" (customize-group 'osm)])) (defconst osm--placeholder '( :type svg :width 256 :height 256 :data " ") "Placeholder image for tiles.") (defvar osm--search-history nil "Minibuffer history used by command `osm-search'.") (defvar osm--jump-history nil "Minibuffer history used by command `osm-jump'.") (defvar osm--server-history nil "Minibuffer history used by command `osm-server'.") (defvar osm--purge-directory 0 "Last time the tile cache was cleaned.") (defvar osm--tile-cache nil "Global tile memory cache.") (defvar osm--tile-age 0 "Tile age, incremented on every update.") (defvar osm--datasets nil "Global list of loaded data sets.") (defvar osm--track nil "List of track coordinates.") (defvar osm--download-processes nil "Globally active download processes.") (defvar osm--download-active nil "Globally active download jobs.") (defvar-local osm--download-queue nil "Buffer-local tile download queue.") (defvar-local osm--wx 0 "Half window width in pixel.") (defvar-local osm--wy 0 "Half window height in pixel.") (defvar-local osm--nx 0 "Number of tiles in x direction.") (defvar-local osm--ny 0 "Number of tiles in y direction.") (defvar-local osm--server nil "Server of the map.") (defvar-local osm--zoom nil "Zoom level of the map.") (defvar-local osm--lat nil "Latitude coordinate.") (defvar-local osm--lon nil "Longitude coordinate.") (defvar-local osm--overlays nil "Overlay hash table. Local per buffer since the overlays depend on the zoom level.") (defvar-local osm--pin nil "Currently selected pin.") (defmacro osm--each (&rest body) "Execute BODY in each `osm-mode' buffer." (cl-with-gensyms (buf) `(dolist (,buf (buffer-list)) (when (eq (buffer-local-value 'major-mode ,buf) #'osm-mode) (with-current-buffer ,buf ,@body))))) (defun osm--server-menu () "Generate server menu." (let (menu last-group) (dolist (server osm-server-list) (let* ((plist (cdr server)) (group (plist-get plist :group))) (unless (equal last-group group) (push (format "─── %s ───" group) menu) (setq last-group group)) (push `[,(plist-get plist :name) (osm-server ',(car server)) :style toggle :selected (eq osm--server ',(car server))] menu))) (easy-menu-create-menu "Server" (nreverse menu)))) (defsubst osm--server-get (prop &optional server) "Return server property PROP for SERVER." (or (plist-get (alist-get (or server osm--server) osm-server-list) prop) (plist-get osm-server-defaults prop))) (defsubst osm--lon-to-normalized-x (lon) "Convert LON to normalized x coordinate." (/ (+ lon 180.0) 360.0)) (defsubst osm--lat-to-normalized-y (lat) "Convert LAT to normalized y coordinate." (setq lat (* lat (/ float-pi 180.0))) (- 0.5 (/ (log (+ (tan lat) (/ 1.0 (cos lat)))) float-pi 2))) (defun osm--bb-to-zoom (bb) "Zoom level from bounding box BB." (pcase-let ((`(,min-lat ,max-lat ,min-lon ,max-lon) bb) (w (/ (frame-pixel-width) 256)) (h (/ (frame-pixel-height) 256))) (max (osm--server-get :min-zoom) (min (osm--server-get :max-zoom) (min (logb (/ w (abs (- (osm--lon-to-normalized-x min-lon) (osm--lon-to-normalized-x max-lon))))) (logb (/ h (abs (- (osm--lat-to-normalized-y min-lat) (osm--lat-to-normalized-y max-lat)))))))))) (defun osm--bb-center (bb) "Center of bounding box BB." (pcase-let ((`(,min-lat ,max-lat ,min-lon ,max-lon) bb)) (cons (/ (+ min-lat max-lat) 2) (/ (+ min-lon max-lon) 2)))) (defun osm--bb-from-track (track waypoints) "Compute bounding box from TRACK and WAYPOINTS." (let ((min-lat 90) (max-lat -90) (min-lon 180) (max-lon -180)) (cl-loop for seg in track do (cl-loop for (lat . lon) in seg do (setq min-lat (min lat min-lat) max-lat (max lat max-lat) min-lon (min lon min-lon) max-lon (max lon max-lon)))) (cl-loop for (lat lon . _) in waypoints do (setq min-lat (min lat min-lat) max-lat (max lat max-lat) min-lon (min lon min-lon) max-lon (max lon max-lon))) (list min-lat max-lat min-lon max-lon))) (defun osm--x-to-lon (x zoom) "Return longitude in degrees for X/ZOOM." (- (/ (* x 360.0) 256.0 (expt 2.0 zoom)) 180.0)) (defun osm--y-to-lat (y zoom) "Return latitude in degrees for Y/ZOOM." (setq y (* float-pi (- 1 (* 2 (/ y 256.0 (expt 2.0 zoom)))))) (/ (* 180 (atan (/ (- (exp y) (exp (- y))) 2))) float-pi)) (defsubst osm--lon-to-x (lon zoom) "Convert LON/ZOOM to x coordinate in pixel." (floor (* 256 (expt 2.0 zoom) (osm--lon-to-normalized-x lon)))) (defsubst osm--lat-to-y (lat zoom) "Convert LAT/ZOOM to y coordinate in pixel." (floor (* 256 (expt 2.0 zoom) (osm--lat-to-normalized-y lat)))) (defsubst osm--x () "Return longitude in pixel of map center." (osm--lon-to-x osm--lon osm--zoom)) (defsubst osm--y () "Return latitude in pixel of map center." (osm--lat-to-y osm--lat osm--zoom)) (defsubst osm--x0 () "Return longitude in pixel of top left corner." (- (osm--x) osm--wx)) (defsubst osm--y0 () "Return latitude in pixel of top left corner." (- (osm--y) osm--wy)) (defun osm--tile-url (x y zoom) "Return tile url for coordinate X, Y and ZOOM." (let ((url (osm--server-get :url)) (key (osm--server-get :key))) (when (and (string-search "%k" url) (not key)) (require 'auth-source) (declare-function auth-source-search "auth-source") (let ((host (string-join (last (split-string (cadr (split-string url "/" t)) "\\.") 2) "."))) (setq key (plist-get (car (auth-source-search :require '(:user :host :secret) :host host :user "apikey")) :secret)) (unless key (warn "No auth source secret found for apikey@%s" host) (setq key "")) (setf (plist-get (alist-get osm--server osm-server-list) :key) key))) (format-spec url `((?z . ,zoom) (?x . ,x) (?y . ,y) (?k . ,(if (functionp key) (funcall key) key)))))) (defun osm--tile-file (x y zoom) "Return tile file name for coordinate X, Y and ZOOM." (file-name-concat (expand-file-name osm-tile-directory) (symbol-name osm--server) (format "%d-%d-%d.%s" zoom x y (or (osm--server-get :ext) (file-name-extension (url-file-nondirectory (osm--server-get :url))))))) (defun osm--enqueue-download (x y) "Enqueue tile X/Y for download." (when (let ((n (expt 2 osm--zoom))) (and (>= x 0) (>= y 0) (< x n) (< y n))) (let ((job (list osm--server osm--zoom x y))) (unless (or (member job osm--download-queue) (member job osm--download-active)) (setq osm--download-queue (nconc osm--download-queue (list job))))))) (defun osm--download-filter (output) "Filter function for the download process which receives OUTPUT." (while (string-match "\\`\\([0-9]+\\) \\(.*?/\\([^/]+\\)/\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\.[^\r\n]+\\)\r?\n" output) (let ((status (match-string 1 output)) (file (match-string 2 output)) (server (intern-soft (match-string 3 output))) (zoom (string-to-number (match-string 4 output))) (x (string-to-number (match-string 5 output))) (y (string-to-number (match-string 6 output)))) (setq output (substring output (match-end 0))) (when (equal status "200") (ignore-errors (rename-file file (string-remove-suffix ".tmp" file) t)) (osm--each (when (and (= osm--zoom zoom) (eq osm--server server)) (osm--display-tile x y (osm--get-tile x y))))) (cl-callf2 delete (list server zoom x y) osm--download-active) (delete-file file))) output) (defun osm--download-command () "Build download command." (let* ((count 0) (batch (osm--server-get :download-batch)) (parallel (osm--server-get :max-connections)) args jobs job) (while (and (< count batch) (setq job (nth (* count parallel) osm--download-queue))) (pcase-let ((`(,_server ,zoom ,x ,y) job)) (setq args `(,(osm--tile-url x y zoom) ,(concat (osm--tile-file x y zoom) ".tmp") "--output" ,@args)) (push job jobs) (push job osm--download-active) (incf count))) (osm--each (dolist (job jobs) (cl-callf2 delq job osm--download-queue))) (cons `("curl" "--disable" "--write-out" "%{http_code} %{filename_effective}\n" ,@(split-string-and-unquote osm-curl-options) ,@(nreverse args)) jobs))) (defun osm--download () "Download next tiles from the queue." (when (and (< (length (alist-get osm--server osm--download-processes)) (osm--server-get :max-connections)) osm--download-queue) (pcase-let ((`(,command . ,jobs) (osm--download-command)) (dir (file-name-concat (expand-file-name osm-tile-directory) (symbol-name osm--server))) (server osm--server)) (make-directory dir t) (push (make-process :name "*osm curl*" :connection-type 'pipe :noquery t :command command :filter (let ((output "")) (lambda (_proc out) (setq output (osm--download-filter (concat output out))) (force-mode-line-update t))) :sentinel (lambda (proc _status) (dolist (job jobs) (cl-callf2 delq job osm--download-active)) (cl-callf2 delq proc (alist-get server osm--download-processes nil t)) (force-mode-line-update t) (osm--download))) (alist-get server osm--download-processes)) (force-mode-line-update t) (osm--download)))) (defun osm-mouse-drag (event) "Handle drag EVENT." (declare (completion ignore)) (interactive "@e") (pcase-let* ((`(,sx . ,sy) (posn-x-y (event-start event))) (win (selected-window)) (map (define-keymap "" (lambda (event) (interactive "e") (setq event (event-start event)) (when (eq win (posn-window event)) (pcase-let ((`(,ex . ,ey) (posn-x-y event))) (osm--move (- sx ex) (- sy ey)) (setq sx ex sy ey) (osm--update))))))) (setq track-mouse 'dragging) (set-transient-map map (lambda () (eq (car-safe last-command-event) 'mouse-movement)) (lambda () (setq track-mouse nil))))) (defun osm--zoom-in-wheel (_n) "Zoom in with the mouse wheel." (pcase-let ((`(,x . ,y) (posn-x-y (event-start last-input-event)))) (when (< osm--zoom (osm--server-get :max-zoom)) (osm--move (/ (- x osm--wx) 2) (/ (- y osm--wy) 2)) (osm-zoom-in)))) (defun osm--zoom-out-wheel (_n) "Zoom out with the mouse wheel." (pcase-let ((`(,x . ,y) (posn-x-y (event-start last-input-event)))) (when (> osm--zoom (osm--server-get :min-zoom)) (osm--move (- osm--wx x) (- osm--wy y)) (osm-zoom-out)))) (defun osm-center () "Center to location of selected pin." (interactive nil osm-mode) (osm--barf-unless-osm) (pcase osm--pin (`(,lat ,lon ,_id ,name) (setq osm--lat lat osm--lon lon) (message "%s" name) (osm--update)))) (defun osm--haversine (lat1 lon1 lat2 lon2) "Compute distance between LAT1/LON1 and LAT2/LON2 in km." ;; https://en.wikipedia.org/wiki/Haversine_formula (let* ((rad (/ float-pi 180)) (y (sin (* 0.5 rad (- lat2 lat1)))) (x (sin (* 0.5 rad (- lon2 lon1)))) (h (+ (* x x) (* (cos (* rad lat1)) (cos (* rad lat2)) y y)))) (* 2 6371 (atan (sqrt h) (sqrt (- 1 h)))))) (defun osm-mouse-track (event) "Set track pin at location of the click EVENT." (declare (completion ignore)) (interactive "@e") (pcase osm--pin ((and (guard (not osm--track)) `(,lat ,lon ,_id ,_name)) (push (list lat lon "WP1") osm--track))) (osm--set-pin-event event 'osm-track (format "WP%s" (1+ (length osm--track))) 'quiet) (pcase-let ((`(,lat ,lon ,_id ,name) osm--pin)) (push (list lat lon name) osm--track)) (osm--revert) (osm--track-length)) (defun osm--track-length () "Echo track length." (when (cdr osm--track) (pcase-let* ((len1 0) (len2 0) (p osm--track) (`(,sel-lat ,sel-lon ,_ ,sel-name) osm--pin)) (while (and (cdr p) (not (and (equal (caar p) sel-lat) (equal (cadar p) sel-lon)))) (incf len2 (osm--haversine (caar p) (cadar p) (caadr p) (cadadr p))) (pop p)) (while (cdr p) (incf len1 (osm--haversine (caar p) (cadar p) (caadr p) (cadadr p))) (pop p)) (message "%s way points, length %.2fkm, %s" (length osm--track) (+ len1 len2) (if (or (= len1 0) (= len2 0)) sel-name (format "%.2fkm ⟶ %s ⟶ %.2fkm" len1 sel-name len2)))))) (defun osm--pin-at (event &optional type) "Get pin of TYPE at EVENT." (let* ((xy (posn-x-y (event-start event))) (x (+ (osm--x0) (car xy))) (y (+ (osm--y0) (cdr xy))) (min most-positive-fixnum) found) (dolist (pin (car (osm--get-overlays (/ x 256) (/ y 256)))) (pcase-let ((`(,p ,q ,_lat ,_lon ,id ,_name) pin)) (when (or (not type) (eq type id)) (let ((d (+ (* (- p x) (- p x)) (* (- q y) (- q y))))) (when (and (>= q y) (< q (+ y 50)) (>= p (- x 20)) (< p (+ x 20)) (< d min)) (setq min d found pin)))))) (cddr found))) (defun osm-mouse-pin (event) "Create location pin at the click EVENT." (declare (completion ignore)) (interactive "@e") (osm--set-pin-event event) (osm--update)) (defun osm-mouse-select (event) "Select pin at position of click EVENT." (declare (completion ignore)) (interactive "@e") (when (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3)) (pcase (osm--pin-at event) (`(,lat ,lon ,id ,name) (osm--set-pin id lat lon name (eq id 'osm-track)) (when (eq id 'osm-track) (osm--track-length)) (osm--update))))) (defun osm-zoom-in (&optional n) "Zoom N times into the map." (interactive "p" osm-mode) (osm--barf-unless-osm) (setq osm--zoom (max (osm--server-get :min-zoom) (min (osm--server-get :max-zoom) (+ osm--zoom (or n 1))))) (osm--update)) (defun osm-zoom-out (&optional n) "Zoom N times out of the map." (interactive "p" osm-mode) (osm-zoom-in (- (or n 1)))) (defun osm--move (dx dy) "Move by DX/DY." (osm--barf-unless-osm) (setq osm--lon (osm--x-to-lon (+ (osm--x) dx) osm--zoom) osm--lat (osm--y-to-lat (+ (osm--y) dy) osm--zoom))) (defun osm-right (&optional n) "Move N small steps to the right." (interactive "p" osm-mode) (osm--move (* (or n 1) osm-small-step) 0) (osm--update)) (defun osm-down (&optional n) "Move N small steps down." (interactive "p" osm-mode) (osm--move 0 (* (or n 1) osm-small-step)) (osm--update)) (defun osm-up (&optional n) "Move N small steps up." (interactive "p" osm-mode) (osm-down (- (or n 1)))) (defun osm-left (&optional n) "Move N small steps to the left." (interactive "p" osm-mode) (osm-right (- (or n 1)))) (defun osm-right-right (&optional n) "Move N large steps to the right." (interactive "p" osm-mode) (osm--move (* (or n 1) osm-large-step) 0) (osm--update)) (defun osm-down-down (&optional n) "Move N large steps down." (interactive "p" osm-mode) (osm--move 0 (* (or n 1) osm-large-step)) (osm--update)) (defun osm-up-up (&optional n) "Move N large steps up." (interactive "p" osm-mode) (osm-down-down (- (or n 1)))) (defun osm-left-left (&optional n) "Move N large steps to the left." (interactive "p" osm-mode) (osm-right-right (- (or n 1)))) (defun osm--purge-directory () "Clean tile directory." (when (and (integerp osm-max-age) (> (- (float-time) osm--purge-directory) (* 60 60 24))) (setq osm--purge-directory (float-time)) (run-with-idle-timer 30 nil (lambda () (dolist (dir (directory-files osm-tile-directory t "\\`[^.]+\\'" t)) (dolist (file (directory-files dir t "\\.\\(?:png\\|jpe?g\\|webp\\)\\(?:\\.tmp\\)?\\'" t)) (when (> (float-time (time-since (file-attribute-modification-time (file-attributes file)))) (* 60 60 24 osm-max-age)) (delete-file file))) (when (directory-empty-p dir) (ignore-errors (delete-directory dir)))))))) (defun osm--check-libraries () "Check that Emacs is compiled with the necessary libraries." (let (req) (unless (display-graphic-p) (push "graphical display" req)) (dolist (type '(svg jpeg png webp)) (unless (image-type-available-p type) (push (format "%s support" type) req))) (unless (libxml-available-p) (push "libxml" req)) (unless (json-available-p) (push "libjansson" req)) (when req (warn "osm: Please compile Emacs with the required libraries, %s needed" (string-join req ", "))))) (define-derived-mode osm-mode special-mode "Osm" "OpenStreetMap viewer mode." :interactive nil :abbrev-table nil :syntax-table nil (osm--check-libraries) (setq-local osm--server osm-default-server line-spacing nil cursor-type nil cursor-in-non-selected-windows nil left-fringe-width 1 right-fringe-width 1 left-margin-width 0 right-margin-width 0 truncate-lines t show-trailing-whitespace nil display-line-numbers nil buffer-read-only t fringe-indicator-alist '((truncation . nil)) revert-buffer-function #'osm--revert mode-line-process '(:eval (osm--download-queue-info)) mode-line-position nil mode-line-modified nil mode-line-mule-info nil mode-line-remote nil default-directory (expand-file-name "~/") eldoc-documentation-functions nil mouse-wheel-progressive-speed nil mwheel-scroll-up-function #'osm--zoom-out-wheel mwheel-scroll-down-function #'osm--zoom-in-wheel mwheel-scroll-left-function #'osm--zoom-out-wheel mwheel-scroll-right-function #'osm--zoom-in-wheel bookmark-make-record-function #'osm--bookmark-record-default imenu-create-index-function #'osm--imenu-index mouse-shift-adjust-mode nil) (when (boundp 'mwheel-coalesce-scroll-events) (setq-local mwheel-coalesce-scroll-events t)) (when (boundp 'pixel-scroll-precision-mode) (setq-local pixel-scroll-precision-mode nil)) (add-hook 'change-major-mode-hook #'osm--barf-change-mode nil 'local) (add-hook 'write-contents-functions #'osm--barf-write nil 'local) (add-hook 'window-size-change-functions ;; On Emacs 31 `window-size-change-functions' run in current buffer (static-if (>= emacs-major-version 31) #'osm--update (let ((buf (current-buffer))) (lambda (_) (with-current-buffer buf (osm--update))))) nil 'local)) (defun osm--barf-write () "Barf for write operation." (set-buffer-modified-p nil) (setq buffer-read-only t) (set-visited-file-name nil) (error "Writing the buffer to a file is not supported")) (defun osm--barf-change-mode () "Barf for change mode operation." (error "Changing the major mode is not supported")) (defun osm--barf-unless-osm () "Barf if not an `osm-mode' buffer." (unless (eq major-mode #'osm-mode) (error "Not an `osm-mode' buffer"))) (defun osm--each-pin (fun) "Call FUN for each pin on the map." (pcase osm-home (`(,lat ,lon ,zoom) (funcall fun 'osm-home lat lon zoom "Home"))) (bookmark-maybe-load-default-file) (cl-loop for bm in bookmark-alist if (eq (bookmark-prop-get bm 'handler) #'osm-bookmark-jump) do (pcase-let ((`(,lat ,lon ,zoom) (bookmark-prop-get bm 'coordinates))) (funcall fun 'osm-bookmark lat lon zoom (car bm)))) (cl-loop for (dname id segs waypoints) in osm--datasets do (when-let* ((start (caar segs))) (funcall fun id (car start) (cdr start) osm-default-zoom (propertize dname 'osm-dataset dname))) (cl-loop for (lat lon name) in waypoints do (funcall fun id lat lon osm-default-zoom (propertize (format "%s [%s]" name dname) 'osm-dataset dname)))) (cl-loop for (lat lon name) in osm--track do (funcall fun 'osm-track lat lon osm-default-zoom name))) (defun osm--pin-inside-p (x y lat lon) "Return non-nil if pin at LAT/LON is inside tile X/Y." (let ((p (/ (osm--lon-to-x lon osm--zoom) 256.0)) (q (/ (osm--lat-to-y lat osm--zoom) 256.0))) (and (>= p (- x 0.125)) (< p (+ x 1.125)) (>= q y) (< q (+ y 1.25))))) (defun osm--add-pin (pins id lat lon _zoom name) "Add pin at LAT/LON with NAME and ID to the PINS hash table." (let* ((x (osm--lon-to-x lon osm--zoom)) (y (osm--lat-to-y lat osm--zoom)) (x0 (/ x 256)) (y0 (/ y 256)) (pin (list x y lat lon id name))) (push pin (gethash (cons x0 y0) pins)) (cl-loop for i from -1 to 1 do (cl-loop for j from -1 to 0 do (let ((x1 (/ (+ x (* 32 i)) 256)) (y1 (/ (+ y (* 64 j)) 256))) (unless (and (= x0 x1) (= y0 y1)) (push pin (gethash (cons x1 y1) pins)))))))) ;; TODO: The Bresenham algorithm used here to add the line segments to the tiles ;; has the issue that lines which go along a tile border may be drawn only ;; partially. Use a more precise algorithm instead. (defun osm--add-track (tracks id seg) "Add track segment SEG with ID to TRACKS hash table." (when seg (let ((p0 (cons (osm--lon-to-x (or (car-safe (cdar seg)) (cdar seg)) osm--zoom) (osm--lat-to-y (caar seg) osm--zoom)))) (dolist (pt (cdr seg)) (let* ((px1 (cdr pt)) (px1 (osm--lon-to-x (if (consp px1) (car px1) px1) osm--zoom)) (py1 (osm--lat-to-y (car pt) osm--zoom)) (pdx (- px1 (car p0))) (pdy (- py1 (cdr p0)))) ;; Ignore point if too close to last point (unless (< (+ (* pdx pdx) (* pdy pdy)) 50) (let* ((p1 (cons px1 py1)) (line (cons p0 p1)) (x0 (/ (car p0) 256)) (y0 (/ (cdr p0) 256)) (x1 (/ px1 256)) (y1 (/ py1 256)) (sx (if (< x0 x1) 1 -1)) (sy (if (< y0 y1) 1 -1)) (dx (* sx (- x1 x0))) (dy (* sy (- y0 y1))) (err (+ dx dy))) ;; Bresenham (while (let ((ey (> (* err 2) dy)) (ex (< (* err 2) dx))) (push line (alist-get id (gethash (cons x0 y0) tracks))) (unless (and (= x0 x1) (= y0 y1)) (when (and ey ex) (push line (alist-get id (gethash (cons x0 (+ y0 sy)) tracks))) (push line (alist-get id (gethash (cons (+ x0 sx) y0) tracks)))) (when ey (incf err dy) (incf x0 sx)) (when ex (incf err dx) (incf y0 sy)) t))) (setq p0 p1)))))))) (defun osm--get-overlays (x y) "Compute overlays and return the overlays in tile X/Y." (unless (eq (car osm--overlays) osm--zoom) ;; TODO: Do not compute overlays for the entire map, only for a reasonable ;; view port around the current center, depending on the size of the ;; window. Otherwise the spatial hash map for the tracks gets very large if ;; a line segment spans many tiles. (let ((pins (make-hash-table :test #'equal)) (tracks (make-hash-table :test #'equal))) (osm--each-pin (apply-partially #'osm--add-pin pins)) (cl-loop for (_dname id segs _waypoints) in osm--datasets do (dolist (seg segs) (osm--add-track tracks id seg))) (osm--add-track tracks 'osm-track osm--track) (setq osm--overlays (list osm--zoom pins tracks)))) (let ((pins (gethash (cons x y) (cadr osm--overlays))) (tracks (gethash (cons x y) (caddr osm--overlays)))) (and (or pins tracks) (cons pins tracks)))) (defun osm--draw-tile (x y tpin) "Make tile at X/Y from FILE. TPIN is an optional pin." (let ((file (osm--tile-file x y osm--zoom)) overlays) (when (file-exists-p file) (if (or (setq overlays (osm--get-overlays x y)) (eq osm-tile-border t) tpin) (let* ((areas nil) (x0 (* 256 x)) (y0 (* 256 y)) (svg-track (lambda (track) (format "" osm-track-style (cdr (assq (car track) osm-pin-colors)) (let (last) (mapconcat (pcase-lambda (`(,beg . ,end)) (prog1 (if (equal beg last) (format "L%s %s" (- (car end) x0) (- (cdr end) y0)) (format "M%s %sL%s %s" (- (car beg) x0) (- (cdr beg) y0) (- (car end) x0) (- (cdr end) y0))) (setq last end))) (cdr track) ""))))) (svg-pin (lambda (pin) (pcase-let* ((`(,p ,q ,_lat ,_lon ,id ,name) pin) (bg (cdr (assq id osm-pin-colors)))) (setq p (- p x0) q (- q y0)) (push `((poly . [,p ,q ,(- p 20) ,(- q 40) ,p ,(- q 50) ,(+ p 20) ,(- q 40) ]) ,id (help-echo ,(truncate-string-to-width name 40 0 nil t))) areas) ;; https://commons.wikimedia.org/wiki/File:Simpleicons_Places_map-marker-1.svg (format " " bg p q)))) (svg-text (concat " " (mapconcat svg-track (cdr overlays) "") (pcase-exhaustive osm-tile-border ('nil nil) ('debug "") ('t "")) (mapconcat svg-pin (car overlays) "") (and tpin (funcall svg-pin tpin)) ""))) (list 'image :width 256 :height 256 :type 'svg :base-uri file :data svg-text :map areas)) (list 'image :width 256 :height 256 :file file :type (let ((ext (intern (file-name-extension file)))) (if (eq ext 'jpg) 'jpeg ext))))))) (defun osm--get-tile (x y) "Get tile at X/Y." (pcase osm--pin ((and `(,lat ,lon ,_id ,name) (guard (osm--pin-inside-p x y lat lon))) (osm--draw-tile x y (list (osm--lon-to-x lon osm--zoom) (osm--lat-to-y lat osm--zoom) lat lon 'osm-selected name))) (_ (let* ((key `(,osm--server ,osm--zoom ,x . ,y)) (tile (and osm--tile-cache (gethash key osm--tile-cache)))) (if tile (progn (setcar tile osm--tile-age) (cdr tile)) (setq tile (osm--draw-tile x y nil)) (when tile (when osm-max-tiles (unless osm--tile-cache (setq osm--tile-cache (make-hash-table :test #'equal :size osm-max-tiles))) (puthash key (cons osm--tile-age tile) osm--tile-cache)) tile)))))) (defun osm--display-tile (x y tile) "Display TILE at X/Y." (let ((i (- x (/ (osm--x0) 256))) (j (- y (/ (osm--y0) 256)))) (when (and (>= i 0) (< i osm--nx) (>= j 0) (< j osm--ny)) (let* ((mx (if (= 0 i) (mod (osm--x0) 256) 0)) (my (if (= 0 j) (mod (osm--y0) 256) 0)) (pos (+ (point-min) (* j (1+ osm--nx)) i))) (unless tile (setq tile (cons 'image osm--placeholder))) (with-silent-modifications (put-text-property pos (1+ pos) 'display (if (or (/= 0 mx) (/= 0 my)) `((slice ,mx ,my ,(- 256 mx) ,(- 256 my)) ,tile) tile))))))) ;;;###autoload (defun osm-home () "Go to home coordinates." (interactive) (pcase osm-home (`(,lat ,lon ,zoom) (osm--goto lat lon zoom nil 'osm-home "Home")))) (defun osm--download-queue-info () "Return queue info string." (when osm--download-processes (format "[%s/%s/%s]" (cl-loop for (_ . p) in osm--download-processes sum (length p)) (length osm--download-active) (length osm--download-queue)))) (defun osm--revert (&rest _) "Revert osm buffers." (clear-image-cache t) ;; Make absolutely sure that the tiles are redrawn. (setq osm--tile-cache nil) (osm--each (setq osm--overlays nil) (osm--update))) (defun osm--header-button (text action) "Format header line button with TEXT and ACTION." (propertize text 'keymap (define-keymap " " (if (commandp action) (lambda () (interactive "@") (call-interactively action)) action)) 'face '(:box (:line-width -2 :style released-button)) 'mouse-face '(:box (:line-width -2 :style pressed-button)))) (defun osm--update-header () "Update header line." (let* ((meter-per-pixel (/ (* 156543.03 (cos (/ osm--lat (/ 180.0 float-pi)))) (expt 2 osm--zoom))) (server (osm--server-get :name)) (meter 1) (idx 0) (factor '(2 2.5 2)) (sep #(" " 0 1 (display (space :width (1)))))) (while (and (< idx 20) (< (/ (* meter (nth (mod idx 3) factor)) meter-per-pixel) 150)) (setq meter (round (* meter (nth (mod idx 3) factor)))) (incf idx)) (setq-local header-line-format (list (osm--header-button " ☰ " (osm--menu-item osm-mode-menu)) sep (osm--header-button (format " %s " server) (osm--menu-item #'osm--server-menu)) sep (osm--header-button " + " #'osm-zoom-in) sep (osm--header-button " - " #'osm-zoom-out) (format " Z%-2d " osm--zoom) #(" " 0 1 (display (space :align-to (- center 15)))) (format #(" %7.2f° %7.2f°" 0 14 (face bold)) osm--lat osm--lon) #(" " 0 1 (display (space :align-to (- right 20)))) (format "%3s " (if (>= meter 1000) (/ meter 1000) meter)) (if (>= meter 1000) "km " "m ") #(" " 0 1 (face (:inverse-video t) display (space :width (3)))) (propertize " " 'face '(:strike-through t) 'display `(space :width (,(floor (/ meter meter-per-pixel))))) #(" " 0 1 (face (:inverse-video t) display (space :width (3)))))))) (defun osm--update (&optional _) "Update map display." (osm--barf-unless-osm) (osm--purge-tile-cache) (osm--purge-directory) (osm--rename-buffer) (osm--update-sizes) (osm--update-header) (osm--update-buffer) (osm--update-copyright) (osm--process-download-queue)) (defun osm--update-sizes () "Update window sizes." (let* ((windows (or (get-buffer-window-list) (list (frame-root-window)))) (win-width (cl-loop for w in windows maximize (window-pixel-width w))) (win-height (cl-loop for w in windows maximize (window-pixel-height w)))) (setq osm--wx (/ win-width 2) osm--wy (/ win-height 2) osm--nx (1+ (ceiling win-width 256)) osm--ny (1+ (ceiling win-height 256))))) (defun osm--copyright-link (text url) "Format link with TEXT to URL." (propertize text 'face 'button 'mouse-face 'highlight 'help-echo (format "Go to %s" url) 'keymap (define-keymap " " (lambda () (interactive) (browse-url url))))) (defun osm--update-copyright () "Update copyright info." (let ((copyright (and osm-copyright (osm--server-get :copyright)))) (if (not copyright) (when (eq 'osm-copyright (car-safe tab-line-format)) (kill-local-variable 'tab-line-format)) (setq copyright (replace-regexp-in-string "{\\(.*?\\)|\\(.*?\\)}" (lambda (str) (osm--copyright-link (match-string 1 str) (match-string 2 str))) (concat " " (string-join (ensure-list copyright) " | ") #(" " 0 1 (display (space :align-to (+ 42 right))))))) (add-face-text-property 0 (length copyright) '(:inherit (header-line variable-pitch) :height 0.65) t copyright) (setq-local tab-line-format (list 'osm-copyright copyright))))) (defun osm--update-buffer () "Update buffer display." (with-silent-modifications (erase-buffer) (dotimes (_j osm--ny) (insert (make-string osm--nx ?\s) "\n")) (put-text-property (point-min) (point-max) 'pointer 'arrow) (goto-char (point-min)) (let ((tx (/ (osm--x0) 256)) (ty (/ (osm--y0) 256))) (dotimes (j osm--ny) (dotimes (i osm--nx) (let* ((x (+ i tx)) (y (+ j ty)) (tile (osm--get-tile x y))) (osm--display-tile x y tile) (unless tile (osm--enqueue-download x y)))))))) (defun osm--process-download-queue () "Process the download queue." (setq osm--download-queue (sort (cl-loop with tx = (/ (osm--x0) 256) with ty = (/ (osm--y0) 256) for job in osm--download-queue for (_server zoom x y) = job if (and (= zoom osm--zoom) (>= x tx) (< x (+ tx osm--nx)) (>= y ty) (< y (+ ty osm--ny))) collect job) (let ((tx (/ (osm--x) 256)) (ty (/ (osm--y) 256))) (pcase-lambda (`(,_s1 ,_z1 ,x1 ,y1) `(,_s2 ,_z2 ,x2 ,y2)) (setq x1 (- x1 tx) y1 (- y1 ty) x2 (- x2 tx) y2 (- y2 ty)) (< (+ (* x1 x1) (* y1 y1)) (+ (* x2 x2) (* y2 y2))))))) (osm--download)) (defun osm--purge-tile-cache () "Purge old tiles from the tile cache." (incf osm--tile-age) (when (and osm--tile-cache (> (hash-table-count osm--tile-cache) osm-max-tiles)) (let (items) (maphash (lambda (k v) (push (list (car v) (cdr v) k) items)) osm--tile-cache) (setq items (sort items #'car-less-than-car)) (cl-loop repeat (- (hash-table-count osm--tile-cache) osm-max-tiles) for (_age tile key) in items do (image-flush tile t) (remhash key osm--tile-cache))))) (defun osm--bookmark-record-default () "Make osm bookmark record." (osm--bookmark-record (osm--bookmark-name osm--lat osm--lon nil) osm--lat osm--lon nil)) (defun osm--bookmark-record (name lat lon loc) "Make osm bookmark record with NAME and LOC description at LAT/LON." (setq bookmark-current-bookmark nil) ;; Reset bookmark to use new name `(,name (location . ,(osm--location-name lat lon loc 6)) (coordinates ,lat ,lon ,osm--zoom) (server . ,osm--server) (handler . ,#'osm-bookmark-jump))) (defun osm--org-link-props () "Return Org link properties." (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Org Link")) (name (osm--location-name lat lon loc 2))) (list :type "geo" :description (if (eq osm--server osm-default-server) (string-remove-suffix (concat " " (osm--server-get :name)) name) name) :link (format "geo:%.6f,%.6f;z=%s%s" lat lon osm--zoom (if (eq osm--server osm-default-server) "" (format ";s=%s" osm--server)))))) (defun osm--rename-buffer () "Rename current buffer." (setq list-buffers-directory (osm--location-name osm--lat osm--lon nil 6)) (rename-buffer (format "*osm: %s*" (osm--location-name osm--lat osm--lon nil 2)) 'unique)) (defun osm--location-name (lat lon loc prec) "Format location string LAT/LON with optional LOC description. The coordinates are formatted with precision PREC." (format (format "%%s%%.%df° %%.%df° Z%%s %%s" prec prec) (if loc (concat loc ", ") "") lat lon osm--zoom (osm--server-get :name))) (defun osm--bookmark-name (lat lon loc) "Return bookmark name for LAT/LON/LOC." (concat "osm: " (osm--location-name lat lon loc 2))) (defun osm--goto (lat lon zoom server id name) "Go to LAT/LON/ZOOM, change SERVER. Optionally place pin with ID and NAME." ;; Server not found (unless (assq server osm-server-list) (setq server nil)) (let ((def-server (or server osm-default-server)) (def-lat (or lat (car osm-home))) (def-lon (or lon (cadr osm-home))) (def-zoom (or zoom (if (and lat lon) osm-default-zoom (caddr osm-home))))) (with-current-buffer (or (and (eq major-mode #'osm-mode) (current-buffer)) ;; Search for existing buffer (cl-loop for buf in (buffer-list) thereis (and (equal (buffer-local-value 'major-mode buf) #'osm-mode) (equal (buffer-local-value 'osm--server buf) def-server) (equal (buffer-local-value 'osm--zoom buf) def-zoom) (equal (buffer-local-value 'osm--lat buf) def-lat) (equal (buffer-local-value 'osm--lon buf) def-lon) buf)) (generate-new-buffer "*osm*")) (unless (eq major-mode #'osm-mode) (osm-mode)) (when (and server (not (eq osm--server server))) (setq osm--server server osm--download-queue nil)) (when (or (not (and osm--lon osm--lat)) lat) (setq osm--lat def-lat osm--lon def-lon osm--zoom def-zoom) (when id (osm--set-pin id osm--lat osm--lon name))) (prog1 (pop-to-buffer (current-buffer)) (osm--update))))) (defun osm--set-pin (id lat lon name &optional quiet) "Set pin at LAT/LON with ID and NAME. Print NAME if not QUIET." (setq name (or name (format "Location %.6f° %.6f°" lat lon))) (setq osm--pin (list lat lon (or id 'osm-selected) name)) (unless quiet (message "%s" name))) (defun osm--set-pin-event (event &optional id name quiet) "Set selection pin with ID and NAME at location of EVENT. Print NAME if not QUIET." (pcase-let ((`(,x . ,y) (posn-x-y (event-start event)))) (osm--set-pin id (osm--y-to-lat (+ (osm--y0) y) osm--zoom) (osm--x-to-lon (+ (osm--x0) x) osm--zoom) name quiet))) ;;;###autoload (defun osm-goto (lat lon zoom) "Go to LAT/LON/ZOOM." (interactive (pcase-let ((`(,lat ,lon ,zoom) (mapcar #'string-to-number (split-string (read-string "Lat Lon (Zoom): ") nil t)))) (setq zoom (or zoom osm--zoom 11)) (unless (and (numberp lat) (numberp lon) (numberp zoom)) (error "Invalid coordinate")) (list lat lon zoom))) (osm--goto lat lon zoom nil 'osm-selected nil) nil) ;;;###autoload (defun osm-url (url &rest _) "Go to standard Geo, OpenStreetMap or Google Maps URL. See also `osm-save-url'." (interactive "sGeo URL: ") (cond ;; Standard Geo URL ((string-match "\\`geo:\\([0-9.-]+\\),\\([0-9.-]+\\)\\(?:,[0-9.-]+\\)?\\(;.+\\'\\|\\'\\)" url) (let* ((lat (string-to-number (match-string 1 url))) (lon (string-to-number (match-string 2 url))) (args (url-parse-args (match-string 3 url) "")) (zoom (cdr (assoc "z" args))) (server (cdr (assoc "s" args)))) (osm--goto lat lon (and zoom (string-to-number zoom)) (and server (intern-soft server)) 'osm-selected "Geo Link"))) ;; Google Maps ((or (string-match "goo.*!3d\\([0-9.-]+\\)!4d\\([0-9.-]+\\)!\\([0-9]+\\)" url) (string-match "goo.*@\\([0-9.-]+\\),\\([0-9.-]+\\),\\([0-9]+\\)" url) (string-match "goo.*/search/\\([0-9.+-]+\\),\\([0-9.+-]+\\)" url)) (let ((lat (string-to-number (match-string 1 url))) (lon (string-to-number (match-string 2 url))) (zoom (and (match-end 3) (string-to-number (match-string 3 url))))) (osm--goto lat lon zoom nil 'osm-selected "Geo Link"))) ;; OpenStreetMap.org ((string-match "map=\\([0-9]+\\)/\\([0-9.-]+\\)/\\([0-9.-]+\\)" url) (let ((lat (string-to-number (match-string 2 url))) (lon (string-to-number (match-string 3 url))) (zoom (string-to-number (match-string 1 url)))) (osm--goto lat lon zoom nil 'osm-selected "Geo Link"))) ;; Short URLs ((string-match-p "\\`https?://.*\\(openstreetmap\\|osm\\|goo.*maps\\|maps.*goo\\)" url) (osm-url (replace-regexp-in-string "\\`https?://" "" (osm--fetch-redirect url)))) (t (user-error "Invalid URL")))) ;;;###autoload (defun osm (&rest link) "Go to LINK. When called interactively, call the function `osm-home'." (interactive (list 'home)) (pcase link ('(home) (osm-home)) (`(,lat ,lon ,zoom . ,server) (setq server (car server)) (unless (and server (symbolp server)) (setq server nil)) ;; Ignore comment (osm--goto lat lon zoom server 'osm-selected "Elisp Link")) ((and `(,str) (guard (stringp str))) (if (string-match-p "\\`\\(geo:\\|https?://\\)" str) (osm-url str) (osm-search str))) (_ (error "Invalid Osm link")))) ;;;###autoload (defun osm-bookmark-jump (bm) "Jump to Osm bookmark BM." (interactive (list (osm--bookmark-read))) (pcase-let ((`(,lat ,lon ,zoom) (bookmark-prop-get bm 'coordinates))) (set-buffer (osm--goto lat lon zoom (bookmark-prop-get bm 'server) 'osm-bookmark (car bm))))) (put 'osm-bookmark-jump 'bookmark-handler-type "Osm") ;;;###autoload (defun osm-bookmark-delete (bm) "Delete Osm bookmark BM." (interactive (list (osm--bookmark-read))) (when (y-or-n-p (format "Delete bookmark `%s'? " bm)) (bookmark-delete bm) (setq osm--pin nil) (osm--revert))) ;;;###autoload (defun osm-bookmark-rename (old-name) "Rename Osm bookmark OLD-NAME." (interactive (list (car (osm--bookmark-read)))) (let ((new-name (read-from-minibuffer "New name: " old-name nil nil 'bookmark-history old-name))) (when osm--pin (setf (cadddr osm--pin) new-name)) (bookmark-rename old-name new-name) (osm--revert))) (defun osm--bookmark-read () "Read bookmark name." (bookmark-maybe-load-default-file) (or (assoc (pcase osm--pin (`(,_lat ,_lon osm-bookmark ,name) name) (_ (completing-read "Bookmark: " (or (cl-loop for bm in bookmark-alist if (eq (bookmark-prop-get bm 'handler) #'osm-bookmark-jump) collect (car bm)) (error "No bookmarks found")) nil t nil 'bookmark-history))) bookmark-alist) (error "No bookmark selected"))) (defun osm-bookmark-set () "Create Osm bookmark." (interactive nil osm-mode) (osm--barf-unless-osm) (unwind-protect (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Bookmark")) (def (osm--bookmark-name lat lon loc)) (name (read-from-minibuffer "Bookmark name: " def nil nil 'bookmark-history def)) (bookmark-make-record-function (lambda () (osm--bookmark-record name lat lon loc)))) (bookmark-set name) (message "Stored bookmark: %s" name) (setf (caddr osm--pin) 'osm-bookmark)) (osm--revert))) (defun osm--fetch-location-data (name) "Fetch location info for NAME." (when (mouse-event-p last-input-event) (osm--set-pin-event last-input-event 'osm-selected name)) (let ((lat (or (car osm--pin) osm--lat)) (lon (or (cadr osm--pin) osm--lon))) (osm--set-pin 'osm-selected lat lon name 'quiet) ;; Redisplay before slow fetching (osm--update) (redisplay) (list lat lon (ignore-errors (alist-get 'display_name (osm--fetch-json (format "%s/reverse?format=json&accept-language=%s&zoom=%s&lat=%s&lon=%s" osm-search-server osm-search-language (min 18 (max 3 osm--zoom)) lat lon))))))) (defun osm--track-index () "Return index of selected track way point." (cl-loop for idx from 0 for (lat lon _) in osm--track if (and (equal lat (car osm--pin)) (equal lon (cadr osm--pin))) return idx)) (defun osm--track-delete () "Delete track way point." (when-let* ((idx (osm--track-index))) ;; Delete pin (cl-callf2 delq (nth idx osm--track) osm--track) (setq osm--pin nil idx (min idx (1- (length osm--track)))) ;; Select next pin (pcase (nth idx osm--track) (`(,lat ,lon ,name) (osm--set-pin 'osm-track lat lon name 'quiet))) ;; Rename pins after deletion (cl-loop for idx from (length osm--track) downto 1 for pt in osm--track if (string-match-p "\\`WP[0-9]+\\'" (caddr pt)) do (setf (caddr pt) (format "WP%s" idx))) (osm--track-length) (osm--revert))) (defun osm--track-rename () "Rename track way point." (when-let* ((pt (nth (osm--track-index) osm--track)) (old-name (caddr pt)) (new-name (read-from-minibuffer "New name: " old-name nil nil nil old-name))) (setf (caddr pt) new-name (cadddr osm--pin) new-name) (osm--revert))) (defun osm-delete () "Delete selected pin (bookmark or way point)." (interactive nil osm-mode) (osm--barf-unless-osm) (pcase-let ((`(,_lat ,_lon ,id ,name) osm--pin)) (pcase id ('nil nil) ('osm-bookmark (osm-bookmark-delete name)) ('osm-track (osm--track-delete)) ((or 'osm-file 'osm-route) (setq osm--pin nil) (osm-hide (get-text-property 0 'osm-dataset name))) (_ (setq osm--pin nil) (osm--update))))) (defun osm-rename () "Rename selected pin (bookmark or way point)." (interactive nil osm-mode) (osm--barf-unless-osm) (pcase-let ((`(,_lat ,_lon ,id ,name) osm--pin)) (pcase id ('osm-bookmark (osm-bookmark-rename name)) ('osm-track (osm--track-rename))))) ;;;###autoload (defun osm-jump () "Jump to named pin." (interactive) (let (pins) (osm--each-pin (lambda (id lat lon zoom name) (push (list name (capitalize (substring (symbol-name id) 4)) id lat lon zoom) pins))) (pcase (assoc (completing-read "Jump: " (completion-table-with-metadata pins `((group-function . ,(lambda (pin transform) (if transform pin (cadr (assoc pin pins))))))) nil t nil 'osm--jump-history) pins) (`(,name ,_group ,id ,lat ,lon ,zoom) (osm--goto lat lon zoom nil id name)) (_ (user-error "No pin selected"))))) (defun osm--imenu-index () "Create Imenu index." (let (index) (osm--each-pin (lambda (id lat lon zoom name) (push (list name (vector lat lon zoom) #'osm--imenu-goto) (alist-get (capitalize (substring (symbol-name id) 4)) index nil nil #'equal)))) (sort index (lambda (x y) (string< (car x) (car y)))))) (defun osm--imenu-goto (_name pos) "Go to Imenu POS." (osm--goto (aref pos 0) (aref pos 1) (aref pos 2) nil nil nil)) (defun osm--fetch-json (url) "Get JSON from URL." (osm--check-libraries) (message "Contacting %s..." (replace-regexp-in-string "https://\\|/.*" "" url)) (with-temp-buffer (let* ((default-process-coding-system '(utf-8-unix . utf-8-unix)) (status (apply #'call-process "curl" nil (current-buffer) nil `("--disable" ,@(split-string-and-unquote osm-curl-options) ,url)))) (unless (eq status 0) (error "Fetching %s exited with status %s" url status))) (goto-char (point-min)) (json-parse-buffer :array-type 'list :object-type 'alist))) (defun osm--fetch-redirect (url) "Get redirect location from URL." (osm--check-libraries) (message "Contacting %s..." (replace-regexp-in-string "https://\\|/.*" "" url)) (with-temp-buffer (let* ((default-process-coding-system '(utf-8-unix . utf-8-unix)) (status (apply #'call-process "curl" nil (current-buffer) nil `("--disable" ,@(split-string-and-unquote osm-curl-options) "-I" ,url)))) (unless (eq status 0) (error "Fetching %s exited with status %s" url status))) (goto-char (point-max)) (if (re-search-backward "^location: \\([^\n\r]+\\)" nil t) (match-string 1) (error "Invalid redirect %s" url)))) (defun osm--search-request (needle) "Globally search for NEEDLE and return the list of results." (mapcar (lambda (x) (let ((lat (string-to-number (alist-get 'lat x))) (lon (string-to-number (alist-get 'lon x)))) `(,(format "%s (%.6f° %.6f°)" (alist-get 'display_name x) lat lon) ,lat ,lon ,@(mapcar #'string-to-number (alist-get 'boundingbox x))))) (osm--fetch-json (format "%s/search?format=json&accept-language=%s&q=%s" osm-search-server osm-search-language (url-encode-url needle))))) (defun osm--search-read (prompt) "Read location via `completing-read' with PROMPT." (minibuffer-with-setup-hook (lambda () (when (eq (keymap-local-lookup "SPC") #'minibuffer-complete-word) ;; Override dreaded `minibuffer-complete-word' for default ;; completion. When will this keybinding finally get removed from ;; default completion? (use-local-map (make-composed-keymap (define-keymap "SPC" nil) (current-local-map))))) (completing-read prompt (completion-table-with-metadata ;; Vertico only deletes consecutive duplicates for ;; performance, and we preserve order by using the ;; identity sort function. (delete-dups (copy-sequence osm--search-history)) '((display-sort-function . identity) (cycle-sort-function . identity))) nil nil nil 'osm--search-history))) (defun osm--search-select (needle lucky) "Search for NEEDLE and return selected result. Take first result if LUCKY is non-nil." (let ((results (or (osm--search-request needle) (error "No results for `%s'" needle)))) (or (and (or lucky (not (cdr results))) (car results)) (assoc (completing-read (format "Matches for '%s': " needle) (completion-table-with-metadata results '((display-sort-function . identity) (cycle-sort-function . identity) (eager-display . t))) nil t nil t) results) (error "No selection")))) ;;;###autoload (defun osm-search (needle &optional lucky) "Globally search for NEEDLE on `osm-search-server' and display the map. If the prefix argument LUCKY is non-nil take the first result and jump there. See `osm-search-server' and `osm-search-language' for customization." (interactive (list (osm--search-read "Location: ") current-prefix-arg)) (let ((selected (osm--search-select needle lucky))) ;; TODO: Add search bounded to current viewbox, bounded=1, viewbox=x1,y1,x2,y2 (osm--goto (cadr selected) (caddr selected) (osm--bb-to-zoom (cdddr selected)) nil 'osm-selected (car selected)))) ;;;###autoload (defun osm-route () "Fetch a route between two locations." (interactive) (let* ((from-name (osm--search-read "Route from: ")) (from (osm--search-select from-name nil)) (to-name (osm--search-read "Route to: ")) (to (osm--search-select to-name nil)) (by (completing-read "Go by: " '("Car" "Bike" "Foot") nil t nil t)) (data (osm--fetch-json (format-spec osm-route-server `((?b . ,(downcase by)) (?x . ,(caddr from)) (?y . ,(cadr from)) (?X . ,(caddr to)) (?Y . ,(cadr to)))))) (route (car (alist-get 'routes data))) (coords (or (alist-get 'coordinates (alist-get 'geometry route)) (error "No route available"))) (waypoints (alist-get 'waypoints data))) (osm--add-dataset (format "%s ⟶ %s (%s, %skm, %s)" from-name to-name by (round (alist-get 'distance route) 1000) (seconds-to-string (alist-get 'duration route))) 'osm-route (list (mapcar (lambda (x) (cons (cadr x) (car x))) coords)) (mapcar (lambda (x) (let ((l (alist-get 'location x))) (list (cadr l) (car l) (alist-get 'name x)))) waypoints)))) ;;;###autoload (defun osm-open (file) "Show the tracks of GPX or TCX FILE in an `osm-mode' buffer." (interactive "fGPX or TCX file: ") (osm--check-libraries) (let ((dom (with-temp-buffer (insert-file-contents file) (libxml-parse-xml-region (point-min) (point-max)))) (file (abbreviate-file-name file))) (if (eq 'TrainingCenterDatabase (dom-tag dom)) (osm--add-dataset file 'osm-file (osm--tcx-track dom) (osm--tcx-waypoints dom)) (unless (eq 'gpx (dom-tag dom)) (setq dom (dom-child-by-tag dom 'gpx))) (unless (and dom (eq 'gpx (dom-tag dom))) (error "Not a GPX or TCX file")) (osm--add-dataset file 'osm-file (osm--gpx-track dom) (osm--gpx-waypoints dom))))) ;; Prevent deprecation warning (defalias 'osm--dom-text 'dom-text) (defsubst osm--tcx-position (pos) "Convert POS to a cons of (lat . lon)." (let ((lat (dom-child-by-tag pos 'LatitudeDegrees)) (lon (dom-child-by-tag pos 'LongitudeDegrees))) (cons (string-to-number (osm--dom-text lat)) (string-to-number (osm--dom-text lon))))) (defun osm--tcx-waypoints (dom) "Return waypoints contained in tcx DOM." (cl-loop with courses = (dom-child-by-tag dom 'Courses) for course in (dom-by-tag courses 'Course) nconc (cl-loop for pt in (dom-by-tag course 'CoursePoint) for pos = (osm--tcx-position (dom-child-by-tag pt 'Position)) for name = (dom-by-tag pt 'Name) collect (list (car pos) (cdr pos) (osm--dom-text name))))) (defun osm--tcx-track (dom) "Return track points contained in tcx DOM." (cl-loop with activities = (dom-child-by-tag dom 'Activities) for activity in (dom-by-tag activities 'Activity) nconc (cl-loop for lap in (dom-by-tag activity 'Lap) nconc (cl-loop for track in (dom-by-tag lap 'Track) collect (cl-loop for pt in (dom-by-tag track 'Trackpoint) for pos = (dom-child-by-tag pt 'Position) if pos collect (osm--tcx-position pos)))))) (defun osm--gpx-track (dom) "Return track points contained in gpx DOM." (cl-loop for trk in (dom-children dom) if (eq (dom-tag trk) 'trk) nconc (cl-loop for seg in (dom-children trk) if (eq (dom-tag seg) 'trkseg) collect (cl-loop for pt in (dom-children seg) if (eq (dom-tag pt) 'trkpt) collect (cons (string-to-number (dom-attr pt 'lat)) (string-to-number (dom-attr pt 'lon))))))) (defun osm--gpx-waypoints (dom) "Return waypoints contained in gpx DOM." (cl-loop for pt in (dom-children dom) if (eq (dom-tag pt) 'wpt) collect (list (string-to-number (dom-attr pt 'lat)) (string-to-number (dom-attr pt 'lon)) (osm--dom-text (dom-child-by-tag pt 'name))))) (defun osm--add-dataset (name id track waypoints) "Add dataset with NAME and ID consisting of TRACK and WAYPOINTS." (let* ((bb (osm--bb-from-track track waypoints)) (center (osm--bb-center bb))) (setf (alist-get name osm--datasets nil nil #'equal) (list id track waypoints)) (osm--revert) (osm--goto (car center) (cdr center) (osm--bb-to-zoom bb) nil nil nil))) (defun osm-hide (name) "Hide dataset with NAME." (interactive (list (completing-read "Hide: " (or osm--datasets (error "No datasets shown")) nil t nil 'file-name-history))) (cl-callf2 assoc-delete-all name osm--datasets) (osm--revert)) (defun osm--server-annotation (cand) "Annotation for server CAND." (when-let* ((copyright (osm--server-get :copyright (get-text-property 0 'osm--server cand))) (str (replace-regexp-in-string "{\\(.*?\\)|.*?}" (lambda (str) (match-string 1 str)) (string-join (ensure-list copyright) " | ") copyright))) (concat (propertize " " 'display `(space :align-to (- right ,(length str) 2))) " " str))) (defun osm--server-group (cand transform) "Group function for server CAND with candidate TRANSFORM." (if transform cand (osm--server-get :group (get-text-property 0 'osm--server cand)))) ;;;###autoload (defun osm-server (server) "Select tile SERVER." (interactive (let* ((max-name (cl-loop for (_ . x) in osm-server-list maximize (length (plist-get x :name)))) (fmt (concat (propertize (format "%%-%ds " max-name) 'face 'font-lock-comment-face) " %s")) (servers (mapcar (lambda (x) (propertize (format fmt (plist-get (cdr x) :name) (or (plist-get (cdr x) :description) "")) 'osm--server (car x))) osm-server-list)) (selected (completing-read "Server: " (completion-table-with-metadata servers `((annotation-function . ,(and osm-copyright #'osm--server-annotation)) (group-function . ,#'osm--server-group))) nil t nil 'osm--server-history (format fmt (osm--server-get :name) (or (osm--server-get :description) ""))))) (list (get-text-property 0 'osm--server (or (car (member selected servers)) (error "No server selected")))))) (osm--goto nil nil nil server nil nil)) (defun osm-save-url (&optional arg) "Save coordinates as URL in the kill ring. If prefix ARG is given, store URL as Elisp expression." (interactive "P" osm-mode) (osm--barf-unless-osm) (pcase-let* ((`(,lat ,lon ,loc) (osm--fetch-location-data "New Link")) (server (and (not (eq osm--server osm-default-server)) osm--server)) (url (if arg (format "(osm %.6f %.6f %s%s%s)" lat lon osm--zoom (if server (format " '%s" server) "") (if loc (format " %S" loc) "")) (format "geo:%.6f,%.6f;z=%s%s%s" lat lon osm--zoom (if server (format ";s=%s" server) "") (if loc (format " (%s)" loc) ""))))) (kill-new url) (message "Saved in the kill ring: %s" url))) (cl-defun osm-add-server (server &rest properties &key name description group url ext max-connections max-zoom min-zoom download-batch copyright) "Add SERVER with PROPERTIES to `osm-server-list'. The properties are checked as keyword arguments. See `osm-server-list' for documentation of the keywords." (declare (indent 1)) (ignore name description group url ext max-connections max-zoom min-zoom download-batch copyright) (dolist (sym '(:name :description :group :url)) (unless (stringp (plist-get properties sym)) (error "Server property %s is required" sym))) (unless (and server (symbolp server)) (error "Server id must be a symbol")) (setf (alist-get server osm-server-list) properties) nil) ;;;###autoload (progn (add-to-list 'browse-url-default-handlers '("\\`geo:" . osm-url)) (add-to-list 'browse-url-default-handlers '("\\`https?://\\(www\\.\\)?\\(osm\\|openstreetmap\\)\\.org/\\(go/\\|\\??#map=\\)" . osm-url)) (add-to-list 'browse-url-default-handlers '("\\`https?://\\(maps\\.app\\.goo\\.gl/\\|.*goo.*/maps/@\\)" . osm-url))) ;;;###autoload (eval-after-load 'ol (lambda () (declare-function org-link-set-parameters "ol") (declare-function osm--org-link-props "ext:osm") (org-link-set-parameters "geo" :follow (lambda (link _) (osm (concat "geo:" link))) :store (lambda () (when (eq major-mode 'osm-mode) (apply 'org-link-store-props (osm--org-link-props))))))) (provide 'osm) ;;; osm.el ends here