path: root/config.el

;;; config.el -*- lexical-binding: t; -*-

;; [[file:config.org::*Tangle][Tangle:1]]
(use-package! org-auto-tangle
  :hook (org-mode . org-auto-tangle-mode))
;; Tangle:1 ends here

;; [[file:config.org::*Helper scripts][Helper scripts:1]]
(defun my/program (name)
  "Return the executable NAME, from `exec-path' or this config's bin/ directory.
Signals a `user-error' if it is in neither."
  (or (executable-find name)
      (let ((bundled (expand-file-name (concat "bin/" name) doom-user-dir)))
        (and (file-executable-p bundled) bundled))
      (user-error "%s is not on PATH or in %sbin/" name doom-user-dir)))
;; Helper scripts:1 ends here

;; [[file:config.org::*Fonts][Fonts:1]]
(setq doom-font (font-spec :family "JetBrainsMonoNL Nerd Font" :size 16 :weight 'semi-light))

(custom-set-faces! '(variable-pitch :family "DejaVu Serif" :height 1.3))

(add-hook! 'after-setting-font-hook
  (defun my/variable-pitch-relative-height-h ()
    "Keep `variable-pitch' at a ratio of the default size after Doom font reloads."
    (set-face-attribute 'variable-pitch nil :height 1.3)))

;; Frank Ruehl CLM is the Frank-Rühl book face (1908), the square Hebrew of
;; older printed Qabalah. Its letters only reach JetBrains Mono's x-height, so
;; they're scaled 1.2x to sit between x-height and cap height, which still
;; leaves lines with Hebrew no taller than others. It's part of Culmus
;; (culmus.sourceforge.io). Copying its files into ~/.local/share/fonts is
;; enough; some distribution packages of it also install a fontconfig rule
;; that changes the default Hebrew font in every other program.
(set-fontset-font t 'hebrew (font-spec :family "Frank Ruehl CLM"))
(add-to-list 'face-font-rescale-alist '("Frank Ruehl CLM" . 1.2))

;; Without this, Emacs falls back to whatever font claims the codepoint
;; first, which is rarely one with actual emoji glyphs, hence tofu/mojibake.
;; Any color emoji font works; swap in "Noto Color Emoji" if that's the one
;; installed.
(set-fontset-font t 'emoji (font-spec :family "Apple Color Emoji"))

;; JetBrainsMono has no astrological glyphs, and the fallback for most of
;; them is proportional Noto Sans Symbols (8-11px against a 10px cell), which
;; knocks the planet columns in Org tables out of alignment. DejaVu Sans Mono
;; is a common monospace font that covers ☉, ☽-♇ and ♈-♓.
(dolist (range '(#x2609 (#x263D . #x2653)))
  (set-fontset-font t range (font-spec :family "DejaVu Sans Mono")))

(setq display-line-numbers-type nil)
;; Fonts:1 ends here

;; [[file:config.org::*Theme][Theme:1]]
(use-package! auto-dark
  :defer t
  :init
  (setq! auto-dark-themes '((doom-gruvbox) (doom-gruvbox-light))
         doom-theme nil
         custom-safe-themes t)
  (defun my/auto-dark-init-h ()
    "Enable `auto-dark-mode' once the first frame exists, then unhook."
    (auto-dark-mode +1)
    (remove-hook 'server-after-make-frame-hook #'my/auto-dark-init-h)
    (remove-hook 'after-init-hook #'my/auto-dark-init-h))
  (add-hook (if (daemonp) 'server-after-make-frame-hook 'after-init-hook)
            #'my/auto-dark-init-h -95))
;; Theme:1 ends here

;; [[file:config.org::*Theme][Theme:2]]
(defun my/system-theme (mode)
  "Run `system-theme' MODE (\"light\" or \"dark\"), without waiting for it."
  (call-process (my/program "system-theme") nil 0 nil mode))

(map! :leader
      :desc "System light mode" "t t l" (cmd! (my/system-theme "light"))
      :desc "System dark mode"  "t t d" (cmd! (my/system-theme "dark")))
;; Theme:2 ends here

;; [[file:config.org::*Frames][Frames:1]]
(add-to-list 'default-frame-alist '(alpha-background . 85))

(defun my/undecorate-frame (&optional frame)
  "Remove the titlebar from FRAME, or from the selected frame.
Runs after frame creation because pgtk ignores `undecorated' set any earlier."
  (set-frame-parameter (or frame (selected-frame)) 'undecorated t))

(add-hook 'after-make-frame-functions #'my/undecorate-frame)
(add-hook 'emacs-startup-hook #'my/undecorate-frame)
;; Frames:1 ends here

;; [[file:config.org::*Subprocess environment][Subprocess environment:1]]
(defun my/import-client-display-env-h ()
  "Copy display variables from the new frame's client into `process-environment'.
The daemon may have started before the graphical session exported them."
  (when (display-graphic-p)
    (dolist (var '("WAYLAND_DISPLAY" "DISPLAY" "XDG_SESSION_TYPE" "XDG_CURRENT_DESKTOP"))
      (when-let* ((value (getenv var (selected-frame))))
        (setenv var value)))))

(add-hook 'server-after-make-frame-hook #'my/import-client-display-env-h)
;; Subprocess environment:1 ends here

;; [[file:config.org::*Splash screen][Splash screen:1]]
(defvar my/tarot-deck-dir (expand-file-name "~/.local/share/tarot/thoth")
  "Directory of tarot card images to draw the dashboard spread from.")

(defvar my/tarot-card-count 1
  "Number of tarot cards to draw for the dashboard spread.")

(defvar my/tarot-card-height 500
  "Height in pixels each tarot card is resized to (magick's -resize geometry).")

(defconst my/tarot-card-regexp "\\`[^.].*\\.\\(?:jpe?g\\|png\\|webp\\)\\'"
  "Matches the file name of a card image. Dotfiles never match.")

(defun my/tarot--cards (dir &optional recursive)
  "List the card images in DIR, and in its subdirectories if RECURSIVE."
  ;; `directory-files' matches case-sensitively whatever `case-fold-search'
  ;; says, so filter here instead of passing it the regexp.
  (let ((case-fold-search t))
    (if recursive
        (directory-files-recursively dir my/tarot-card-regexp)
      (seq-filter (lambda (file)
                    (string-match-p my/tarot-card-regexp (file-name-nondirectory file)))
                  (directory-files dir t)))))

(defun my/tarot--shuffle (list)
  "Return a shuffled copy of LIST (Fisher-Yates)."
  (let ((vec (vconcat list)))
    (dotimes (i (length vec))
      (let* ((j (+ i (random (- (length vec) i))))
             (tmp (aref vec i)))
        (aset vec i (aref vec j))
        (aset vec j tmp)))
    (append vec nil)))

(defun my/tarot--montage (cards output &rest options)
  "Tile CARDS side by side into OUTPUT with ImageMagick.
OPTIONS are extra montage arguments, such as -geometry and -background."
  (unless (executable-find "magick")
    (user-error "ImageMagick (magick) is not installed"))
  (unless (zerop (apply #'call-process "magick" nil nil nil "montage"
                        (append cards
                                (list "-tile" (format "%dx1" (length cards)))
                                options
                                (list output))))
    (user-error "ImageMagick montage failed")))

(defun my/tarot-splash-file ()
  "Path to the generated tarot splash image."
  (expand-file-name "doom-tarot-splash.png"
                    (or (getenv "XDG_CACHE_HOME")
                        (expand-file-name "~/.cache"))))

(defun my/tarot--cache-dir ()
  "Directory holding `my/tarot-deck-dir''s cards resized to `my/tarot-card-height'."
  (expand-file-name (format "tarot/%s-x%d"
                            (file-name-nondirectory (directory-file-name my/tarot-deck-dir))
                            my/tarot-card-height)
                    (or (getenv "XDG_CACHE_HOME")
                        (expand-file-name "~/.cache"))))

(defun my/tarot--cached-card (card)
  "Path of CARD's resized copy in `my/tarot--cache-dir', whether or not it exists yet."
  (expand-file-name (concat (file-name-sans-extension
                             (file-relative-name card my/tarot-deck-dir))
                            ".png")
                    (my/tarot--cache-dir)))

(defun my/tarot--resize-command (card output)
  "The magick command that resizes CARD into OUTPUT."
  (list "magick" card "-resize" (format "x%d" my/tarot-card-height) output))

(defun my/tarot--resize-temp-file ()
  "Make an empty file in `my/tarot--cache-dir' to resize a card into.
A resize writes there and is renamed into place only once it finishes,
so an interrupted one never leaves a truncated card in the cache."
  (make-directory (my/tarot--cache-dir) t)
  (make-temp-file (expand-file-name ".resizing-" (my/tarot--cache-dir)) nil ".png"))

(defun my/tarot--install-resized (tmp card)
  "Move TMP, a finished resize of CARD, to CARD's place in the cache.
Returns that place."
  (let ((cached (my/tarot--cached-card card)))
    (make-directory (file-name-directory cached) t)
    (rename-file tmp cached t)
    cached))

(defun my/tarot--cache-card (card)
  "Return CARD's resized copy, resizing it now if it isn't cached yet."
  (let ((cached (my/tarot--cached-card card)))
    (if (file-exists-p cached)
        cached
      (let* ((tmp (my/tarot--resize-temp-file))
             (command (my/tarot--resize-command card tmp)))
        (unless (zerop (apply #'call-process (car command) nil nil nil (cdr command)))
          (delete-file tmp)
          (user-error "ImageMagick could not resize %s" card))
        (my/tarot--install-resized tmp card)))))

(defun my/tarot--cache-in-background (cards)
  "Resize whichever of CARDS aren't cached yet, one background process at a time.
A card that fails to resize is skipped, so it can't stall the ones after it."
  (when-let* ((pending (seq-remove (lambda (card)
                                     (file-exists-p (my/tarot--cached-card card)))
                                   cards)))
    (let ((card (car pending))
          (tmp (my/tarot--resize-temp-file)))
      (make-process
       :name "tarot-cache" :noquery t
       :command (my/tarot--resize-command card tmp)
       :sentinel (lambda (process _event)
                   (unless (process-live-p process)
                     (if (zerop (process-exit-status process))
                         (my/tarot--install-resized tmp card)
                       (delete-file tmp))
                     (my/tarot--cache-in-background (cdr pending))))))))

(defun my/tarot-generate-splash ()
  "Draw a fresh tarot spread into the dashboard splash image, synchronously."
  (let* ((cards (and (file-directory-p my/tarot-deck-dir)
                     (my/tarot--cards my/tarot-deck-dir t)))
         (chosen (seq-take (my/tarot--shuffle cards) my/tarot-card-count)))
    (cond
     ((null chosen)
      (warn "Tarot splash: no card images found in %s" my/tarot-deck-dir))
     ((not (executable-find "magick"))
      (warn "Tarot splash: magick is not on PATH"))
     (t
      (condition-case err
          (let ((resized (mapcar #'my/tarot--cache-card chosen)))
            (if (cdr resized)
                (my/tarot--montage resized (my/tarot-splash-file)
                                   "-geometry" "+0+0" "-background" "black")
              (copy-file (car resized) (my/tarot-splash-file) t)))
        (error (warn "Tarot splash: %s; keeping the previous image"
                     (error-message-string err))))))))

(my/tarot-generate-splash)

(when (and (file-directory-p my/tarot-deck-dir) (executable-find "magick"))
  (run-with-idle-timer 5 nil #'my/tarot--cache-in-background
                       (my/tarot--cards my/tarot-deck-dir t)))

(setq fancy-splash-image (my/tarot-splash-file))

;; Default padding is (2 . 2) character-heights above/below the banner; the
;; auto-centering only balances raw line count, not the image's actual
;; height, so the image sits a bit low. Shift it up by trimming the top pad...
(setq +dashboard-banner-vertical-padding '(0 . 2))

;; ...and once that pad is gone, nudge it up further by trimming lines
;; straight out of `+dashboard-resize-h''s auto-centering padding, since
;; that's computed from raw line count and can't be fixed by the pad above.
(defvar my/dashboard-extra-lift 3
  "Extra lines to shave off the dashboard's auto-centered top padding.")

(defadvice! my/dashboard-lift-a (&rest _)
  "Shift the dashboard content up by `my/dashboard-extra-lift' lines."
  :after #'+dashboard-resize-h
  (when (get-buffer-window (doom-fallback-buffer) t)
    (with-current-buffer (doom-fallback-buffer)
      (with-silent-modifications
        (save-excursion
          (goto-char (point-min))
          (let ((blank-end (progn (skip-chars-forward "\n") (point))))
            (delete-region (point-min)
                           (min blank-end (+ (point-min) my/dashboard-extra-lift)))))))))

(defun my/tarot-reshuffle-splash ()
  "Draw a new tarot spread and redraw the dashboard."
  (interactive)
  (my/tarot-generate-splash)
  ;; Only the splash image: with no argument this would also flush every
  ;; other cached image, like Org's inline images and image-dired thumbnails.
  (clear-image-cache (my/tarot-splash-file))
  (+dashboard-reload t))
;; Splash screen:1 ends here

;; [[file:config.org::*Splash screen][Splash screen:2]]
(remove-hook '+dashboard-functions #'+dashboard-widget-loaded)
(remove-hook '+dashboard-functions #'+dashboard-widget-shortmenu)

(defface my/dashboard-quote-face
  '((t (:inherit (italic variable-pitch))))
  "Face for dashboard quotes.")

(defvar my/dashboard-quotes
  '("Every man and woman is a star."
    "Do as thou wilt shall be the whole of the law."
    "As above, so below.")
  "Quotes shown at random under the dashboard menu.")

(defun my/dashboard-footer ()
  "Insert a random quote from `my/dashboard-quotes'."
  (let ((line (nth (random (length my/dashboard-quotes)) my/dashboard-quotes)))
    (+dashboard-insert
     (with-temp-buffer
       (insert (propertize " " 'display '(space . (:relative-height 2.0))) "\n")
       (insert (propertize (format "❝ %s ❞" line) 'face 'my/dashboard-quote-face))
       (insert "\n")
       (buffer-string)))))

(remove-hook '+dashboard-functions #'+dashboard-widget-footer)
(add-hook '+dashboard-functions #'my/dashboard-footer :append)
;; Splash screen:2 ends here

;; [[file:config.org::*Org][Org:1]]
(setq org-directory "~/Documents/org/"
      org-startup-with-inline-images t
      org-startup-folded 'overview
      org-extend-today-until 8)
;; Org:1 ends here

;; [[file:config.org::*Capture defaults][Capture defaults:1]]
(defvar my/org-capture-hidden-keys nil
  "Capture template keys to omit from the interactive selection menu.
They remain reachable by calling `org-capture' with the key directly.")

(defun my/org-capture-hide-menu-templates-a (fn &optional keys)
  "Hide templates whose key is in `my/org-capture-hidden-keys' from the
interactive template menu, without affecting direct lookups by KEYS."
  (if keys
      (funcall fn keys)
    (let ((org-capture-templates
           (seq-remove (lambda (template) (member (car template) my/org-capture-hidden-keys))
                       org-capture-templates)))
      (funcall fn keys))))

(after! org-capture
  (advice-add #'org-capture-select-template :around #'my/org-capture-hide-menu-templates-a)

  (setq org-capture-templates
        '(("n" "Personal notes" entry
           (file+headline +org-capture-notes-file "Inbox")
           "* %u %?\n%i" :prepend t)
          ("j" "Journal" entry
           (file+olp+datetree +org-capture-journal-file)
           "* %U %?\n%i" :prepend t)

          ("p" "Templates for projects")
          ("pt" "Project-local todo" entry
           (file+headline +org-capture-project-todo-file "Inbox")
           "* TODO %?\n%i" :prepend t)
          ("pn" "Project-local notes" entry
           (file+headline +org-capture-project-notes-file "Inbox")
           "* %U %?\n%i" :prepend t)
          ("pc" "Project-local changelog" entry
           (file+headline +org-capture-project-changelog-file "Unreleased")
           "* %U %?\n%i" :prepend t)

          ("o" "Centralized templates for projects")
          ("ot" "Project todo" entry
           (function +org-capture-central-project-todo-file)
           "* TODO %?\n %i"
           :heading "Tasks"
           :prepend nil)
          ("on" "Project notes" entry
           (function +org-capture-central-project-notes-file)
           "* %U %?\n %i"
           :heading "Notes"
           :prepend t)
          ("oc" "Project changelog" entry
           (function +org-capture-central-project-changelog-file)
           "* %U %?\n %i"
           :heading "Changelog"
           :prepend t))))
;; Capture defaults:1 ends here

;; [[file:config.org::*Vocabulary capture][Vocabulary capture:1]]
(defun my/vocab-capture-template (key description file)
  "Return an org-capture template that files a drill vocabulary entry in FILE."
  (list key description 'entry
        (list 'file+headline file "Vocabulary")
        "* Vocab word :drill:\n%^{Word}\n** Answer:\n%^{Definition}\n"))

(after! org-capture
  (dolist (template (list (my/vocab-capture-template "g" "German vocabulary" "german.org")
                          (my/vocab-capture-template "v" "Latin vocabulary" "latin.org")))
    (add-to-list 'org-capture-templates template)))
;; Vocabulary capture:1 ends here

;; [[file:config.org::*Dream journal][Dream journal:1]]
(after! org-capture
  (add-to-list 'org-capture-templates
               '("d" "Dream" entry
                 (file+olp+datetree +org-capture-journal-file)
                 "* %U %? :dream:\n%i" :prepend t)))
;; Dream journal:1 ends here

;; [[file:config.org::*Grimoire journal][Grimoire journal:1]]
(require 'diary-lib)                    ; `diary-ordinal-suffix', for "3rd decan"

(defconst my/zodiac-signs
  [("Aries" "♈" "IV The Emperor") ("Taurus" "♉" "V The Hierophant")
   ("Gemini" "♊" "VI The Lovers") ("Cancer" "♋" "VII The Chariot")
   ("Leo" "♌" "XI Lust") ("Virgo" "♍" "IX The Hermit")
   ("Libra" "♎" "VIII Adjustment") ("Scorpio" "♏" "XIII Death")
   ("Sagittarius" "♐" "XIV Art") ("Capricornus" "♑" "XV The Devil")
   ("Aquarius" "♒" "XVII The Star") ("Pisces" "♓" "XVIII The Moon")]
  "The twelve signs from 0° Aries, as (NAME GLYPH ATU) -- ATU being the
sign's Thoth trump.")

(defconst my/thoth-small-cards
  '(("Wands" "Dominion" "Virtue" "Completion" "Strife" "Victory" "Valour"
     "Swiftness" "Strength" "Oppression")
    ("Disks" "Change" "Work" "Power" "Worry" "Success" "Failure"
     "Prudence" "Gain" "Wealth")
    ("Swords" "Peace" "Sorrow" "Truce" "Defeat" "Science" "Futility"
     "Interference" "Cruelty" "Ruin")
    ("Cups" "Love" "Abundance" "Luxury" "Disappointment" "Pleasure" "Debauch"
     "Indolence" "Happiness" "Satiety"))
  "Each suit's Thoth titles for the Two through Ten, the suits in the
elemental order the signs repeat from Aries: Fire, Earth, Air, Water.")

(defconst my/thoth-small-card-numbers
  ["Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine" "Ten"])

(defun my/zodiac-position (longitude)
  "Split ecliptic LONGITUDE into (SIGN DEGREE MINUTE): SIGN an index
into `my/zodiac-signs', DEGREE and MINUTE whole numbers within it."
  ;; Through whole arcminutes, so an astrolog position like 20Lib34
  ;; comes back out as 20°34' instead of a float's 20°33'.
  (let ((minutes (mod (round (* longitude 60)) (* 360 60))))
    (list (/ minutes 1800) (/ (mod minutes 1800) 60) (mod minutes 60))))

(defun my/zodiac-position-string (longitude)
  "Format ecliptic LONGITUDE as e.g. \"20°34' ♎ Libra (Atu VIII Adjustment)\"."
  (pcase-let* ((`(,sign ,degree ,minute) (my/zodiac-position longitude))
               (`(,name ,glyph ,atu) (aref my/zodiac-signs sign)))
    (format "%d°%02d' %s %s (Atu %s)" degree minute glyph name atu)))

(defun my/thoth-decan-string (longitude)
  "Describe the decan containing ecliptic LONGITUDE and its Thoth small
card, e.g. \"Four of Swords (Truce): ♃ Jupiter in ♎ Libra, 3rd decan\"."
  (pcase-let* ((`(,sign ,degree ,_) (my/zodiac-position longitude))
               (decan (/ degree 10))
               (`(,suit . ,titles) (nth (mod sign 4) my/thoth-small-cards))
               (rank (+ (* 3 (mod sign 3)) decan))
               (mars (seq-position my/planetary-hours-order "Mars"
                                   (lambda (pair name) (equal (car pair) name))))
               (`(,ruler . ,ruler-glyph)
                (nth (mod (+ mars (* 3 sign) decan) 7) my/planetary-hours-order))
               (`(,name ,glyph ,_) (aref my/zodiac-signs sign)))
    (format "%s of %s (%s): %s %s in %s %s, %d%s decan"
            (aref my/thoth-small-card-numbers rank) suit (nth rank titles)
            ruler-glyph ruler glyph name
            (1+ decan) (diary-ordinal-suffix (1+ decan)))))
;; Grimoire journal:1 ends here

;; [[file:config.org::*Grimoire journal][Grimoire journal:2]]
(defun my/moon-phase-string (sun moon)
  "Describe the Moon's phase from SUN and MOON ecliptic longitudes,
e.g. \"Waxing Gibbous, 78% illuminated\"."
  (let* ((elongation (mod (- moon sun) 360.0))
         (phase (aref my/lunar-phases (mod (round (/ elongation 45.0)) 8))))
    (format "%s, %d%% illuminated"
            (cdr phase)
            (round (* 50 (- 1 (cos (degrees-to-radians elongation))))))))
;; Grimoire journal:2 ends here

;; [[file:config.org::*Grimoire journal][Grimoire journal:3]]
(defconst my/thelemic-weekdays
  ["Solis" "Lunae" "Martis" "Mercurii" "Jovis" "Veneris" "Saturni"]
  "Latin day names, indexed like `calendar-day-of-week' (Sunday first).")

(defun my/roman-numeral (n)
  "Write N in capital Roman numerals, or \"0\" for zero."
  (if (zerop n)
      "0"
    (let ((result ""))
      (pcase-dolist (`(,value . ,numeral)
                     '((100 . "C") (90 . "XC") (50 . "L") (40 . "XL") (10 . "X")
                       (9 . "IX") (5 . "V") (4 . "IV") (1 . "I")))
        (while (>= n value)
          (setq result (concat result numeral)
                n (- n value))))
      result)))

(defun my/thelemic-date-string (time sun moon)
  "Format TIME as a Thelemic date, given the SUN and MOON ecliptic
longitudes at TIME."
  (pcase-let* ((decoded (decode-time time))
               (year (- (decoded-time-year decoded) 1904
                        (if (and (<= (decoded-time-month decoded) 3) (>= sun 180)) 1 0)))
               (`(,sun-sign ,sun-degree ,_) (my/zodiac-position sun))
               (`(,moon-sign ,moon-degree ,_) (my/zodiac-position moon)))
    (format "☉ in %d° %s : ☽ in %d° %s : dies %s : Anno %s%s"
            sun-degree (nth 1 (aref my/zodiac-signs sun-sign))
            moon-degree (nth 1 (aref my/zodiac-signs moon-sign))
            (aref my/thelemic-weekdays (decoded-time-weekday decoded))
            (my/roman-numeral (/ year 22))
            (downcase (my/roman-numeral (mod year 22))))))
;; Grimoire journal:3 ends here

;; [[file:config.org::*Grimoire journal][Grimoire journal:4]]
(defvar my/grimoire-row-functions
  '(my/grimoire-moment-rows my/grimoire-sky-rows my/grimoire-hour-rows
    my/grimoire-weather-rows my/grimoire-answer-rows)
  "Functions that fill in a Grimoire entry, in order. Each is called
with the capture's time and returns a list of rows (LABEL VALUE
PROPERTY): LABEL and VALUE make a row of the entry's table, and PROPERTY
names a property set to VALUE in its drawer. Either LABEL or PROPERTY
may be nil to leave that half out. A function that signals an error
costs the entry only its own rows, with a warning.")

(defun my/grimoire-moment-rows (time)
  "Return TIME in UTC, and the coordinates the planetary hour is worked
out for, as drawer-only rows for a Grimoire entry."
  (cons (list nil (format-time-string (org-time-stamp-format t t) time t) "UTC")
        (and calendar-latitude calendar-longitude
             (list (list nil (format "%.4f, %.4f" calendar-latitude calendar-longitude)
                         "COORDINATES")))))

(defun my/grimoire-sky-rows (time)
  "Return the Sun and Moon at TIME, and any planet retrograde, as rows
for a Grimoire entry."
  (let* ((longitudes (my/planet-positions--longitudes time))
         (sun (nth 1 (assoc "Sun" longitudes)))
         (moon (nth 1 (assoc "Moon" longitudes)))
         (retrograde
          (mapconcat (lambda (planet)
                       (format "%s %s" (cdr planet) (car planet)))
                     (seq-filter (lambda (planet)
                                   (nth 2 (assoc (car planet) longitudes)))
                                 my/planetary-hours-order)
                     ", ")))
    (append
     (list (list "Thelemic date" (my/thelemic-date-string time sun moon) "THELEMIC_DATE")
           (list "Sun" (my/zodiac-position-string sun) "SUN")
           (list nil (format "%.2f" sun) "SUN_LONGITUDE")
           (list "Decan" (my/thoth-decan-string sun) "DECAN")
           (list "Moon" (my/zodiac-position-string moon) "MOON")
           (list nil (format "%.2f" moon) "MOON_LONGITUDE")
           (list "Moon phase" (my/moon-phase-string sun moon) "MOON_PHASE"))
     (unless (string-empty-p retrograde)
       (list (list "Retrograde" retrograde "RETROGRADE"))))))

(defun my/grimoire-hour-rows (time)
  "Return the planetary day and hour at TIME as rows for a Grimoire entry."
  (pcase-let ((`((,day . ,day-glyph) (,hour . ,hour-glyph) ,number ,night)
               (my/planetary-hours-at time)))
    (list (list "Planetary day" (format "%s %s" day-glyph day) "PLANETARY_DAY")
          (list "Planetary hour"
                (format "%s %s, %d%s hour of the %s"
                        hour-glyph hour number (diary-ordinal-suffix number)
                        (if night "night" "day"))
                "PLANETARY_HOUR"))))

(defun my/grimoire-weather-rows (time)
  "Return the weather at TIME, from the cached wttr.in forecast, as a row
for a Grimoire entry: the current conditions for a TIME within an hour
and a half of now, otherwise the 3-hour forecast block TIME falls in."
  (let* ((current (and (equal (alist-get 'date (car (my/weather-days)))
                              (format-time-string "%Y-%m-%d"))
                       (< (abs (float-time (time-subtract time nil))) 5400)
                       (my/weather-current)))
         (block (and (not current)
                     (seq-find (lambda (entry)
                                 (and (not (time-less-p time (nth 0 entry)))
                                      (time-less-p time (time-add (nth 0 entry) (* 3 3600)))))
                               (my/weather--timeline))))
         (condition (or current (nth 2 block))))
    (unless condition
      (error "No forecast cached for %s" (format-time-string "%Y-%m-%d %H:%M" time)))
    (list (list "Weather"
                (concat (format "%s, %s°F, humidity %s%%, wind %s mph %s"
                                (my/weather--desc condition)
                                ;; Current conditions spell it temp_F, hourly entries tempF.
                                (or (alist-get 'temp_F condition) (alist-get 'tempF condition))
                                (alist-get 'humidity condition)
                                (alist-get 'windspeedMiles condition)
                                (alist-get 'winddir16Point condition))
                        (and block
                             (let ((start (alist-get 'time condition)))
                               (format " (forecast for %s–%s)"
                                       (my/weather--hour-label start)
                                       (my/weather--hour-label
                                        (number-to-string
                                         (mod (+ (string-to-number start) 300) 2400)))))))
                "WEATHER"))))

(defun my/grimoire-answer-rows (_time)
  "Return the answers `my/grimoire-capture-ask' collected, as rows for
the Grimoire entry being captured."
  (org-capture-get :grimoire-answers))

(defun my/grimoire-capture-attach ()
  "Fill in the entry the Grimoire capture template just placed from
`my/grimoire-row-functions': their properties in its drawer, folded,
and a table of the rest at point, leaving point below it to write the
entry."
  (let* ((time (or (org-capture-get :default-time) (current-time)))
         (rows (seq-mapcat (lambda (function)
                             (condition-case err
                                 (funcall function time)
                               (error (warn "Grimoire entry has no rows from `%s': %s"
                                            function (error-message-string err))
                                      nil)))
                           my/grimoire-row-functions)))
    (save-excursion
      (pcase-dolist (`(,_ ,value ,property) rows)
        (when property
          (org-entry-put nil property value)))
      (org-fold-hide-drawer-all))
    (when-let* ((table (seq-filter #'car rows)))
      (let ((start (point)))
        (pcase-dolist (`(,label ,value) table)
          ;; A typed | would end the cell; \vert is Org's escape for it.
          (insert "| " label " | " (string-replace "|" "\\vert{}" value) " |\n"))
        (save-excursion (goto-char start) (org-table-align)))
      (insert "\n"))))

(defun my/grimoire-capture-trim ()
  "Delete the blank lines at the end of the Grimoire entry being captured."
  (save-excursion
    (goto-char (point-max))
    (skip-chars-backward " \t\n")
    (delete-region (point) (point-max))
    ;; Filed above a later heading, the newline ending the entry's last
    ;; line lies just outside the capture's narrowing; filed at the end
    ;; of the file, it's inside it, and was just deleted.
    (unless (eq (save-restriction (widen) (char-after)) ?\n)
      (insert "\n"))))
;; Grimoire journal:4 ends here

;; [[file:config.org::*Grimoire journal][Grimoire journal:5]]
(defvar my/grimoire-title-history nil
  "Titles given to the Grimoire capture template.")

(defvar my/grimoire-sleep-history nil
  "Answers given to the Grimoire capture template's Sleep question.")

(defvar my/grimoire-health-history nil
  "Answers given to the Grimoire capture template's Health question.")

(defvar my/grimoire-mood-history nil
  "Answers given to the Grimoire capture template's Mood question.")

(defvar my/grimoire-duration-history nil
  "Answers given to the Grimoire capture template's Duration question.")

(defvar my/grimoire-intruding-thoughts-history nil
  "Answers given to the Grimoire capture template's Intruding thoughts question.")

(defvar my/grimoire-default-answer "Nothing to report"
  "What a Grimoire capture question records when answered with a bare RET.")

(defvar my/grimoire-questions
  '(("Sleep" "SLEEP" "Sleep (when, how long, how well)" my/grimoire-sleep-history)
    ("Health" "HEALTH" "Health" my/grimoire-health-history)
    ("Mood" "MOOD" "Mood" my/grimoire-mood-history)
    ("Duration" "DURATION" "Duration of the practice" my/grimoire-duration-history)
    ("Intruding thoughts" "INTRUDING_THOUGHTS" "Intruding thoughts (number and nature)"
     my/grimoire-intruding-thoughts-history))
  "Questions the Grimoire capture template asks after the title, in order,
as (LABEL PROPERTY PROMPT HISTORY RECALL). Each answer is a row LABEL in
the entry's table and the property PROPERTY in its drawer. PROMPT has no
trailing colon; `format-prompt' adds it along with the default. HISTORY
is the question's minibuffer history variable. With RECALL non-nil,
earlier answers are offered as candidates, the latest first, so RET
repeats it; otherwise, and before there are any, RET records
`my/grimoire-default-answer'.")

(defun my/grimoire-capture-ask ()
  "Prompt for a Grimoire entry's title and then `my/grimoire-questions'.
Return the title, for the template's headline, and store the answers
under :grimoire-answers in the capture, as rows for
`my/grimoire-answer-rows'."
  (prog1 (read-string "Title: " nil 'my/grimoire-title-history)
    (org-capture-put
     :grimoire-answers
     (mapcar (pcase-lambda (`(,label ,property ,prompt ,history ,recall))
               (let* ((earlier (and recall
                                    (delete-dups (copy-sequence (symbol-value history)))))
                      (default (or (car earlier) my/grimoire-default-answer))
                      (answer (string-trim
                               (if recall
                                   (completing-read (format-prompt prompt default)
                                                    earlier nil nil nil history default)
                                 (read-string (format-prompt prompt default)
                                              nil history default)))))
                 (list label (if (string-empty-p answer) default answer) property)))
             my/grimoire-questions))))

(after! org-capture
  (add-to-list 'org-capture-templates
               '("m" "Grimoire" entry
                 (file+olp+datetree "grimoire.org" "Journal")
                 "* %U %(my/grimoire-capture-ask)\n%?%i"
                 :time-prompt t
                 :hook my/grimoire-capture-attach
                 :prepare-finalize my/grimoire-capture-trim)))
;; Grimoire journal:5 ends here

;; [[file:config.org::*Liber Resh journal][Liber Resh journal:1]]
(defconst my/resh-stations
  '(("Sunrise" "Ra" "East")
    ("Noon" "Ahathoor" "South")
    ("Sunset" "Tum" "West")
    ("Midnight" "Khephra" "North"))
  "The adorations of Liber Resh: station, god, and the quarter faced.")

(defvar my/resh-capture-data nil
  "Plist for the adoration `my/resh-log' is logging, bound only while the
\"r\" capture template is filled in. Nil when capturing by hand.")

(defun my/resh-capture-heading ()
  "Return \"STATION, GOD\" for the Liber Resh capture's headline, prompting
for the station when not called through `my/resh-log'. Stores the full plist
under :resh in the capture for the template's :hook and :after-finalize."
  (let* ((data (or my/resh-capture-data
                   (list :station (completing-read "Adoration: " my/resh-stations nil t))))
         (known (or (assoc (plist-get data :station) my/resh-stations)
                    (user-error "Not an adoration of Liber Resh: %s" (plist-get data :station))))
         (data (append data
                       (list :god (nth 1 known)
                             :quarter (nth 2 known)
                             :coordinates (and calendar-latitude calendar-longitude
                                               (format "%.4f, %.4f" calendar-latitude calendar-longitude))))))
    (org-capture-put :resh data)
    (format "%s, %s" (car known) (nth 1 known))))

(defun my/resh-capture-attach ()
  "Fill in the property drawer of the entry the Liber Resh capture template
just placed, and insert the note passed to `my/resh-log' at point."
  (let ((data (org-capture-get :resh)))
    (save-excursion
      (pcase-dolist (`(,key . ,property) '((:god . "GOD")
                                           (:quarter . "QUARTER")
                                           (:sun-time . "SUN_TIME")
                                           (:place . "PLACE")
                                           (:coordinates . "COORDINATES")))
        (let ((value (plist-get data key)))
          (when (and value (not (string-empty-p value)))
            (org-entry-put nil property value)))))
    (let ((note (plist-get data :note)))
      (when (and note (not (string-blank-p note)))
        (insert (string-trim note))))))

(defun my/resh-capture-done ()
  "Record a finished (not aborted) Liber Resh capture in the :done-file
`my/resh-log' was given, so the app can mark the adoration as logged."
  (let* ((data (org-capture-get :resh))
         (file (plist-get data :done-file))
         (line (plist-get data :done-line)))
    (when (and file line (not org-note-abort))
      (make-directory (file-name-directory file) t)
      (write-region (concat line "\n") nil file t 'silent))))

(defun my/resh-log (&rest data)
  "Log an adoration of Liber Resh through the \"r\" capture template.
DATA is a plist: :station (\"Sunrise\", \"Noon\", \"Sunset\" or
\"Midnight\"), and optionally :sun-time, :place, :coordinates, :note,
:done-file and :done-line. With :edit non-nil, open the capture in a
frame to finish by hand; otherwise file it immediately."
  (let ((my/resh-capture-data data))
    (if (plist-get data :edit)
        (+org-capture/open-frame nil "r")
      (require 'org-capture)
      (let ((org-capture-templates
             (mapcar (lambda (template)
                       (if (equal (car template) "r")
                           (append template '(:immediate-finish t))
                         template))
                     org-capture-templates)))
        (org-capture nil "r"))))
  t)

(after! org-capture
  (add-to-list 'org-capture-templates
               '("r" "Liber Resh" entry
                 (file+olp+datetree "grimoire.org" "Journal")
                 "* %U Resh: %(my/resh-capture-heading) :resh:\n%?"
                 :hook my/resh-capture-attach
                 :after-finalize my/resh-capture-done)))
;; Liber Resh journal:1 ends here

;; [[file:config.org::*Astronomy journal][Astronomy journal:1]]
(defun my/astro-capture-utc ()
  "Return the capture's chosen time (the `:time-prompt' answer that
`%U' also expands) as an inactive Org timestamp in UTC."
  (format-time-string (org-time-stamp-format t t)
                      (or (org-capture-get :default-time) (current-time))
                      t))

(defun my/astro-capture-coordinates ()
  "Prompt for the coordinates of an astronomy observation, defaulting to
`calendar-latitude'/`calendar-longitude' when those are set."
  (let ((default (and calendar-latitude calendar-longitude
                      (format "%.4f, %.4f" calendar-latitude calendar-longitude))))
    (read-string (if default
                     (format "Coordinates (default %s): " default)
                   "Coordinates (LAT, LONG): ")
                 nil nil default)))

(defun my/astro-capture-planet-positions ()
  "Insert the planet positions table into the entry the Astronomy capture
template just placed, leaving point where it was. See
`my/astro-insert-planet-positions'."
  (save-excursion
    (condition-case err
        (my/astro-insert-planet-positions)
      (error (warn "Planet positions not inserted: %s"
                   (error-message-string err))))))

(after! org-capture
  (add-to-list 'org-capture-templates
               '("a" "Astronomy" entry
                 (file+olp+datetree +org-capture-journal-file)
                 "* %U %? :astronomy:observation: \n:PROPERTIES:\n:COORDINATES: %(my/astro-capture-coordinates)\n:UTC: %(my/astro-capture-utc)\n:END:\n%i"
                 :prepend t :time-prompt t
                 :hook my/astro-capture-planet-positions)))
;; Astronomy journal:1 ends here

;; [[file:config.org::*Astronomy journal][Astronomy journal:2]]
(defun my/capture-no-extend-today-a (fn &rest args)
  "Ignore `org-extend-today-until' for capture templates that want a
late-night entry to file under and timestamp as its real date/time
instead of 23:59 the previous day (currently Astronomy \"a\",
Grimoire \"m\" and Liber Resh \"r\")."
  (if (member (org-capture-get :key) '("a" "m" "r"))
      (let ((org-extend-today-until 0))
        (apply fn args))
    (apply fn args)))

(advice-add #'org-capture-set-target-location :around #'my/capture-no-extend-today-a)
(advice-add #'org-capture-fill-template :around #'my/capture-no-extend-today-a)
;; Astronomy journal:2 ends here

;; [[file:config.org::*Habits][Habits:1]]
(use-package! org-habit
  :after org
  :config
  (setq org-habit-following-days 7
        org-habit-preceding-days 35))
;; Habits:1 ends here

;; [[file:config.org::*Drill][Drill:1]]
(use-package! org-drill
  :commands (org-drill org-drill-resume org-drill-cram org-drill-tree org-drill-directory))

(setq org-agenda-tag-filter-preset '("-drill"))

(map! :map org-mode-map :localleader :desc "Drill" "D" #'org-drill)
(map! :map org-mode-map :localleader :desc "Drill subtree" "S" #'org-drill-tree)
;; Drill:1 ends here

;; [[file:config.org::*Flashcard capture][Flashcard capture:1]]
(defun my/flashcard-capture-target ()
  "Prompt for a refile location for a new flashcard, using the file open
when capture started as the \"current buffer\" refile candidates. Falls
back to Inbox > Flashcards in the todo file if no location is offered."
  (let* ((original (org-capture-get :original-buffer))
         (loc (condition-case nil
                  (org-refile-get-location "Flashcard location" original 'confirm)
                (error nil))))
    (if loc
        (progn
          (set-buffer (find-file-noselect (nth 1 loc)))
          (goto-char (or (nth 3 loc) (point-max))))
      (set-buffer (find-file-noselect (+org-capture-todo-file)))
      (+org--capture-ensure-heading '("Inbox" "Flashcards")))))

(after! org-capture
  (add-to-list 'org-capture-templates
               '("f" "Flashcard" entry
                 (function my/flashcard-capture-target)
                 "* Flashcard :drill:\n\n%?\n** Answer:\n")))
;; Flashcard capture:1 ends here

;; [[file:config.org::*Custom agenda views][Custom agenda views:1]]
(setq org-agenda-custom-commands
      '(("p" "Public agenda (excludes :private:)" agenda ""
         ((org-agenda-tag-filter-preset '("-drill" "-private"))))
        ("j" "Journal" tags "LEVEL>0"
         ((org-agenda-files (list (expand-file-name "journal.org" org-directory)))))))
;; Custom agenda views:1 ends here

;; [[file:config.org::*LaTeX fragments][LaTeX fragments:1]]
(use-package! org-fragtog
  :hook (org-mode . org-fragtog-mode))
;; LaTeX fragments:1 ends here

;; [[file:config.org::*LaTeX fragments][LaTeX fragments:2]]
(defun my/org-latex-bounded-search-a (fn limit)
  "Keep `org-do-latex-and-related' from searching to the end of the buffer."
  (save-restriction
    (narrow-to-region (point-min) (min (point-max) (+ limit 10000)))
    (funcall fn limit)))
(advice-add #'org-do-latex-and-related :around #'my/org-latex-bounded-search-a)
;; LaTeX fragments:2 ends here

;; [[file:config.org::*Drawing][Drawing:1]]
;;; org-draw

(use-package! org-draw
  :commands (org-draw org-draw-edit org-draw-setup)

  :config
  ;; Store drawings in a "figures" directory relative to the Org file.
  (setq org-draw-directory "figures"

        ;; Require a one-time pairing code when connecting a tablet.
        ;; Recommended if you're on a shared Wi-Fi network.
        org-draw-require-pairing t

        ;; Use a fixed port if you want to make firewall/router
        ;; configuration predictable.
        org-draw-port 8777))
;; Drawing:1 ends here

;; [[file:config.org::*Image attach][Image attach:1]]
(defun my/org-attach-image (file)
  "Attach FILE to the Org heading at point by moving it, and insert a link to it."
  (interactive (list (read-file-name "Image: " "~/Downloads/" nil t)))
  (require 'org-attach)
  (let ((link (car (org-attach-attach file nil 'mv))))
    (insert "[[" link "]]\n")
    (org-display-inline-images)))

(map! :map org-mode-map :localleader :desc "Attach image" "a i" #'my/org-attach-image)
;; Image attach:1 ends here

;; [[file:config.org::*Tables][Tables:1]]
(use-package! valign
  :hook (org-mode . valign-mode)
  :config
  (setq valign-max-table-size 20000)

  (defun my/valign-realign-lazily-a (&rest _)
    "Realign tables as jit-lock shows them, not the whole buffer at once."
    (when valign-mode
      (jit-lock-refontify)))
  (advice-add #'valign--buffer-advice :override #'my/valign-realign-lazily-a))

(put-char-code-property ?| 'bidi-class 'L)
;; Tables:1 ends here

;; [[file:config.org::*Paths][Paths:1]]
(defun my/gtd-file (name)
  "Return the absolute path to the GTD file NAME (in `org-directory')."
  (expand-file-name name org-directory))
;; Paths:1 ends here

;; [[file:config.org::*Agenda files][Agenda files:1]]
(after! org
  (setq org-agenda-files
        (mapcar (lambda (file) (expand-file-name file org-directory))
                '("inbox.org" "gtd.org" "tickler.org" "todo.org" "habits.org"
                  "journal.org" "calendar.org" "notes.org" "grimoire.org"
                  "german.org" "latin.org"))))
;; Agenda files:1 ends here

;; [[file:config.org::*keywords][keywords:1]]
(after! org
  (setq org-todo-keywords
        '((sequence "TODO(t)" "NEXT(n)" "WAITING(w@/!)" "PROJ(p)" "|" "DONE(d)" "CANCELLED(c@)")
          (sequence "[ ](T)" "[-](S)" "[?](W)" "|" "[X](D)")
          (sequence "|" "OKAY(o)" "YES(y)" "NO(N)"))
        org-todo-keyword-faces
        '(("NEXT"      . +org-todo-active)
          ("[-]"       . +org-todo-active)
          ("WAITING"   . +org-todo-onhold)
          ("[?]"       . +org-todo-onhold)
          ("PROJ"      . +org-todo-project)
          ("CANCELLED" . +org-todo-cancel)
          ("NO"        . +org-todo-cancel))
        org-log-done 'time))
;; keywords:1 ends here

;; [[file:config.org::*Context tags][Context tags:1]]
(after! org
  (setq org-tag-alist
        '(("@home"     . ?h)
          ("@computer" . ?c)
          ("@errands"  . ?e)
          ("@phone"    . ?p)
          ("@office"   . ?o))))
;; Context tags:1 ends here

;; [[file:config.org::*Capture][Capture:1]]
(after! org-capture
  (add-to-list 'org-capture-templates
               '("t" "Todo [inbox]" entry
                 (file "inbox.org")
                 "* TODO %i%?"))
  (add-to-list 'org-capture-templates
               '("T" "Tickler" entry
                 (file "tickler.org")
                 "* %i%?\n%U")))
;; Capture:1 ends here

;; [[file:config.org::*Refiling][Refiling:1]]
(after! org
  (setq org-refile-targets
        `((,(my/gtd-file "gtd.org") :maxlevel . 3)
          (,(my/gtd-file "someday.org") :level . 1)
          (,(my/gtd-file "tickler.org") :maxlevel . 2))
        org-refile-use-outline-path 'file
        org-outline-path-complete-in-steps nil
        org-refile-allow-creating-parent-nodes 'confirm))
;; Refiling:1 ends here

;; [[file:config.org::*GTD agenda views][GTD agenda views:1]]
(after! org
  (dolist (cmd '(("n" "Next actions" todo "NEXT")
                  ("h" "At home" tags-todo "@home/NEXT")
                  ("c" "At computer" tags-todo "@computer/NEXT")
                  ("e" "Errands" tags-todo "@errands/NEXT")
                  ("P" "Phone" tags-todo "@phone/NEXT")
                  ("w" "Waiting for" todo "WAITING")
                  ("r" "Weekly review"
                   ((agenda "" ((org-agenda-span 'week)))
                    (todo "NEXT")
                    (todo "WAITING")
                    (todo "PROJ")))))
    (add-to-list 'org-agenda-custom-commands cmd)))
;; GTD agenda views:1 ends here

;; [[file:config.org::*Stuck projects][Stuck projects:1]]
(after! org
  (setq org-stuck-projects '("+LEVEL=2/PROJ" ("NEXT") nil "")))
;; Stuck projects:1 ends here

;; [[file:config.org::*Archiving][Archiving:1]]
(after! org
  (setq org-archive-location (concat (my/gtd-file "archive.org") "::* From %s")))
;; Archiving:1 ends here

;; [[file:config.org::*Keybindings][Keybindings:1]]
(map! :leader
      :desc "GTD inbox"            "n g i" (cmd! (find-file (my/gtd-file "inbox.org")))
      :desc "GTD projects/actions" "n g g" (cmd! (find-file (my/gtd-file "gtd.org")))
      :desc "GTD someday"          "n g s" (cmd! (find-file (my/gtd-file "someday.org")))
      :desc "GTD next actions"     "n g n" (cmd! (org-agenda nil "n"))
      :desc "GTD weekly review"    "n g r" (cmd! (org-agenda nil "r")))
;; Keybindings:1 ends here

;; [[file:config.org::*Blog][Blog:1]]
(defvar my/blog-site-directory nil
  "Directory `my/blog-publish' writes blog.html and blog.rss into.
Nil means no site is set up, and publishing says so.")

(setq org-rss-use-entry-url-as-guid nil)

(defun my/blog-stamp-metadata ()
  "Give every non-draft top-level heading in the current buffer a
:PUBDATE:, :ID:, and :CUSTOM_ID:, unless it already has them. Existing
values are left untouched, so re-publishing a post already on the site
never changes its date, feed guid, or in-page anchor."
  (org-map-entries
   (lambda ()
     (unless (member "draft" (org-element-property :tags (org-element-at-point)))
       (unless (org-entry-get (point) "PUBDATE")
         (org-set-property "PUBDATE" (format-time-string (cdr org-time-stamp-formats))))
       (let ((id (org-id-get-create)))
         (unless (org-entry-get (point) "CUSTOM_ID")
           (org-set-property "CUSTOM_ID" (concat "post-" id))))))
   "LEVEL=1" nil 'comment 'archive))

(defun my/blog-html-headline (headline contents info)
  "Transcode a top-level post HEADLINE for the blog page.
Headings nested inside a post are exported as ordinary HTML."
  (if (> (org-export-get-relative-level headline info) 1)
      (org-export-data-with-backend headline 'html info)
    (let* ((title (org-export-data (org-element-property :title headline) info))
           (anchor (or (org-element-property :CUSTOM_ID headline)
                       (org-export-get-reference headline info)))
           (pubdate (org-element-property :PUBDATE headline))
           (date (and pubdate
                      (format-time-string "%Y-%m-%d" (org-time-string-to-time pubdate)))))
      (format "<h2 id=\"%s\">%s</h2>\n%s%s"
              anchor title
              (if date (format "<p><em>%s</em></p>\n" date) "")
              (or contents "")))))

(defun my/blog-publish ()
  "Export the non-draft posts in blog.org to blog.html and blog.rss in
`my/blog-site-directory'."
  (interactive)
  (unless my/blog-site-directory
    (user-error "Set `my/blog-site-directory' to the site checkout to publish into"))
  (require 'ox-rss)
  (let* ((org-file (expand-file-name "blog.org" org-directory))
         (site-dir (file-name-as-directory (expand-file-name my/blog-site-directory)))
         (html-file (expand-file-name "blog.html" site-dir))
         (rss-file (expand-file-name "blog.rss" site-dir)))
    (with-current-buffer (find-file-noselect org-file)
      (my/blog-stamp-metadata)
      (save-buffer)
      (let ((title (or (cadr (assoc "TITLE" (org-collect-keywords '("TITLE")))) "Blog"))
            ;; Rendered with the Org buffer current, since `with-temp-file'
            ;; below would otherwise make `org-export-as' read from the
            ;; (empty) temp buffer it creates for its body instead.
            (body (org-export-as 'blog-html nil nil t)))
        (with-temp-file html-file
          (insert (format "<h1>%s</h1>\n<hr>\n" title))
          (insert body)))
      (org-export-to-file 'rss rss-file))
    (message "Blog published to %s and %s" html-file rss-file)))

;; A minimal HTML backend for the blog page: like ordinary HTML export,
;; except a top-level post's title gets its publish date shown
;; underneath, and there's no wrapping <div>s, ToC, or preamble to
;; strip via #+OPTIONS. Headings nested inside a post still fall
;; through to plain HTML export. A derived backend can only be
;; registered once its parent is, hence waiting for ox-html.
(after! ox-html
  (org-export-define-derived-backend 'blog-html 'html
    :translate-alist '((headline . my/blog-html-headline))))

(map! :leader :desc "Publish blog" "o u" #'my/blog-publish)
;; Blog:1 ends here

;; [[file:config.org::*Tarot][Tarot:1]]
(defcustom my/tarot-directory "~/.local/share/tarot/"
  "Directory containing one subdirectory of card images per deck."
  :type 'directory)

(defun my/tarot--read-deck ()
  "Prompt for a deck under `my/tarot-directory' and return its directory."
  (let ((decks (seq-filter #'file-directory-p
                           (directory-files my/tarot-directory t "\\`[^.]"))))
    (expand-file-name
     (completing-read "Deck: " (mapcar #'file-name-nondirectory decks) nil t)
     my/tarot-directory)))

(defun my/tarot--attach-montage (cards)
  "Tile CARDS into one image, attach it to the Org heading at point, and link it."
  (require 'org-attach)
  (let ((output (make-temp-file "tarot-" nil ".png")))
    (unwind-protect
        (progn
          (my/tarot--montage cards output "-geometry" "x450>+0+0")
          (insert "[[" (car (org-attach-attach output nil 'cp)) "]]\n")
          (org-display-inline-images))
      (delete-file output))))

(defun my/tarot--attach-random (cards n)
  "Attach a spread of N cards drawn at random from CARDS."
  (unless (<= 1 n (length cards))
    (user-error "Pick between 1 and %d cards" (length cards)))
  (my/tarot--attach-montage (seq-take (my/tarot--shuffle cards) n)))

(defun my/tarot-attach-deck-spread (deck n)
  "Attach a random N-card spread from tarot DECK to the Org heading at point.
DECK is a subdirectory name under `my/tarot-directory'."
  (my/tarot--attach-random (my/tarot--cards (expand-file-name deck my/tarot-directory)) n))

(defun my/tarot-attach-spread ()
  "Attach a random spread from a tarot deck to the Org heading at point."
  (interactive)
  (let ((cards (my/tarot--cards (my/tarot--read-deck))))
    (my/tarot--attach-random
     cards (read-number (format "Cards (1-%d): " (length cards)) 3))))

(defun my/tarot-attach-chosen-spread ()
  "Attach a hand-picked spread from a tarot deck to the Org heading at point.
Prompts for a deck, then repeatedly prompts for a card to add to the spread;
finish by pressing RET on an empty prompt or by quitting the prompt (`C-g')."
  (interactive)
  (let* ((deck-dir (my/tarot--read-deck))
         (names (mapcar #'file-name-nondirectory (my/tarot--cards deck-dir)))
         (selected nil)
         (done nil))
    (while (not done)
      (let ((choice (condition-case nil
                        (completing-read
                         (format "Card %d (empty to finish): " (1+ (length selected)))
                         names nil t)
                      (quit ""))))
        (if (string-empty-p choice)
            (setq done t)
          (push (expand-file-name choice deck-dir) selected))))
    (unless selected
      (user-error "No cards selected"))
    (my/tarot--attach-montage (nreverse selected))))

(map! :map org-mode-map :localleader :desc "Tarot spread" "a t" #'my/tarot-attach-spread)
(map! :map org-mode-map :localleader :desc "Tarot spread (chosen)" "a c" #'my/tarot-attach-chosen-spread)
;; Tarot:1 ends here

;; [[file:config.org::*Astrology][Astrology:1]]
(defconst my/astro-transit-line-re
  (rx bol (* " ") (group (+ digit)) ": trans "
      (group (= 7 anything)) " "
      (any "(" "[") (group (= 3 alpha)) (any ")" "]") " "
      (group (= 3 alpha)) " natal "
      (any "(" "[") (group (= 3 alpha)) (any ")" "]") " "
      (group (= 10 anything)) " - "
      (group (or "pos" "neg")) " "
      (group (+ (not (any " ")))) " - power: " (* " ")
      (group (+ (any digit "."))))
  "Matches one aspect line of astro-transits' -Tn table.")

(defun my/astro--transit-row (line)
  "Parse a -Tn aspect LINE into a list of Org table cells, or nil if it isn't one."
  (when (string-match my/astro-transit-line-re line)
    ;; Collect every group before trimming any of them: `string-trim' calls
    ;; `string-match' itself, which would clobber LINE's match data mid-loop.
    (mapcar #'string-trim
            (mapcar (lambda (n) (match-string n line)) '(1 2 3 4 6 5 7 8 9)))))

(defun my/astro--insert-transit-table (table-file)
  "Insert TABLE-FILE, astro-transits' table output, at point as an Org table."
  (let (header rows footer)
    (with-temp-buffer
      (insert-file-contents table-file)
      (dolist (line (split-string (buffer-string) "\n"))
        (unless (string-empty-p line)
          (let ((row (my/astro--transit-row line)))
            (cond (row (push row rows))
                  (rows (push line footer))
                  (t (push line header)))))))
    (dolist (line (nreverse header)) (insert line "\n"))
    (insert "\n")
    (let ((start (point)))
      (insert "| # | Transiting | Sign | Aspect | Natal | Sign | Dir | Orb | Power |\n")
      (insert "|-\n")
      (dolist (row (nreverse rows))
        (insert "| " (string-join row " | ") " |\n"))
      (save-excursion (goto-char start) (org-table-align)))
    (insert "\n#+begin_example\n")
    (dolist (line (nreverse footer)) (insert line "\n"))
    (insert "#+end_example\n")))

(defun my/astro-attach-transits ()
  "Attach the current biwheel transit chart and table to the Org heading at point."
  (interactive)
  (require 'org-attach)
  (let (table image)
    (with-temp-buffer
      (unless (zerop (call-process (my/program "astro-transits") nil t nil "--emacs"))
        (user-error "astro-transits failed: %s" (buffer-string)))
      (goto-char (point-min))
      (while (re-search-forward "^\\(TABLE\\|IMAGE\\)=\\(.*\\)$" nil t)
        (if (string= (match-string 1) "TABLE")
            (setq table (match-string 2))
          (setq image (match-string 2)))))
    (unless (and table image (file-exists-p table) (file-exists-p image))
      (user-error "astro-transits did not report chart files"))
    (let ((link (car (org-attach-attach image nil 'mv))))
      (insert "[[" link "]]\n\n")
      (my/astro--insert-transit-table table)
      (delete-file table)
      (org-display-inline-images))))

(map! :map org-mode-map :localleader :desc "Astrology transits" "a z" #'my/astro-attach-transits)
;; Astrology:1 ends here

;; [[file:config.org::*Daily divination][Daily divination:1]]
(defun my/divination-capture-attach ()
  "Attach a one-card Thoth tarot draw and the current astrology transits
to the entry just placed by the \"Daily divination\" capture template."
  (my/tarot-attach-deck-spread "thoth" 1)
  (my/astro-attach-transits))

(after! org-capture
  (add-to-list 'org-capture-templates
               '("i" "Daily divination" entry
                 (file+olp+datetree +org-capture-journal-file)
                 "* %U Daily divination :divination:\n%?"
                 :prepend t
                 :hook my/divination-capture-attach)))
;; Daily divination:1 ends here

;; [[file:config.org::*Resume][Resume:1]]
(remove-hook 'org-mode-hook #'resumel-mode--maybe-turn-on)

(defun my/resumel-maybe-turn-on-h ()
  "Turn on `resumel-mode' in a buffer with a #+RESUMEL_TEMPLATE: keyword.
Loads resumel only when there is one."
  (when (save-excursion
          (save-match-data
            (goto-char (point-min))
            (re-search-forward "^[ \t]*#\\+RESUMEL_TEMPLATE:" nil t)))
    (require 'resumel-mode)
    (resumel-mode 1)))

(add-hook 'org-mode-hook #'my/resumel-maybe-turn-on-h)
;; Resume:1 ends here

;; [[file:config.org::*Calibre][Calibre:1]]
(use-package! calibredb
  :commands calibredb
  :init
  (map! :leader :desc "Calibre library" "o c" #'calibredb)
  :config
  (setq calibredb-root-dir "~/Documents/calibre"
        calibredb-db-dir (expand-file-name "metadata.db" calibredb-root-dir)
        calibredb-library-alist `((,calibredb-root-dir))
        calibredb-format-nerd-icons t
        calibredb-comment-width 100
        calibredb-title-width 60
        calibredb-id-width 4
        calibredb-size-show t
        calibredb-download-dir "~/Downloads"
        calibredb-fetch-metadata-source-list '("Google" "Amazon.com" "Douban Books")
        calibredb-list-view-image-max-width 600
        calibredb-list-view-image-max-height 600
        calibredb-detail-view-image-max-width 300
        calibredb-detail-view-image-max-height 300)

  (map! :map calibredb-search-mode-map
        :n "q"         #'calibredb-search-quit
        :n "n"         #'calibredb-virtual-library-next
        :n "N"         #'calibredb-library-next
        :n "p"         #'calibredb-virtual-library-previous
        :n "P"         #'calibredb-library-previous
        :n "l"         #'calibredb-virtual-library-list
        :n "o"         #'calibredb-find-file
        :n "O"         #'calibredb-find-file-other-frame
        :n "V"         #'calibredb-open-file-with-default-tool
        :n "v"         #'calibredb-view
        :n "d"         #'calibredb-remove
        :n "D"         #'calibredb-remove-marked-items
        :n "m"         #'calibredb-mark-and-forward
        :n "s"         #'calibredb-set-metadata-dispatch
        :n "e"         #'calibredb-export-dispatch
        :n "a"         #'calibredb-add
        :n "."         #'calibredb-open-dired
        :n ","         #'calibredb-quick-look
        :n "y"         #'calibredb-yank-dispatch
        :n "u"         #'calibredb-unmark-and-forward
        :n "DEL"       #'calibredb-unmark-and-backward
        :n "?"         #'calibredb-dispatch
        :n "/"         #'calibredb-search-live-filter
        :n "j"         #'calibredb-next-entry
        :n "k"         #'calibredb-previous-entry
        :n "M-f"       #'calibredb-toggle-favorite-at-point
        :n "M-x"       #'calibredb-toggle-archive-at-point
        :n "M-h"       #'calibredb-toggle-highlight-at-point
        :n "M-n"       #'calibredb-show-next-entry
        :n "M-p"       #'calibredb-show-previous-entry
        :n "R"         #'calibredb-search-clear-filter
        :n "r"         #'calibredb-search-refresh-and-clear-filter
        :n "<backtab>" #'calibredb-toggle-view
        :n "<tab>"     #'calibredb-toggle-view-at-point
        :n "TAB"       #'calibredb-toggle-view-at-point
        :n "RET"       #'calibredb-find-file)

  (map! :map calibredb-show-mode-map
        :nie "q"   #'calibredb-entry-quit
        :nie "?"   #'calibredb-entry-dispatch
        :nie "RET" #'calibredb-search-ret))

(add-hook! '(calibredb-search-mode-hook calibredb-show-mode-hook)
           #'doom-mark-buffer-as-real-h)
;; Calibre:1 ends here

;; [[file:config.org::*EPUBs][EPUBs:1]]
(defun my/no-large-file-prompt-for-epub-a (fn size op-type filename &rest args)
  "Open EPUBs without asking, however big they are."
  (unless (string-match-p "\\.epub\\'" filename)
    (apply fn size op-type filename args)))
(advice-add #'abort-if-file-too-large :around #'my/no-large-file-prompt-for-epub-a)

(use-package! shrface
  :defer t
  :config
  (shrface-basic)
  (shrface-trial)
  (setq shrface-href-versatile t))

(use-package! nov
  :mode ("\\.epub\\'" . nov-mode)
  :init
  (add-hook 'nov-mode-hook #'shrface-mode)
  :config
  (require 'shrface)
  (setq nov-text-width 120
        nov-render-html-function #'my/nov-render-html)

  ;; nov signals an error when an EPUB's declared unique identifier cannot be
  ;; resolved, which makes the book unopenable. Return nil instead; such books
  ;; then share one save-place slot, which is a fair trade.
  (defun my/nov-tolerant-unique-identifier-a (orig content)
    (condition-case nil
        (funcall orig content)
      (error nil)))
  (advice-add #'nov-content-unique-identifier
              :around #'my/nov-tolerant-unique-identifier-a)

  (advice-add #'shr-fill-line :around #'my/nov-mark-soft-breaks-a)
  (add-hook 'nov-pre-html-render-hook #'my/nov-mixed-pitch-h)
  (add-hook 'nov-mode-hook #'my/nov-setup-h 90)
  (add-hook 'after-setting-font-hook #'my/nov-font-changed-h)

  (map! :map nov-mode-map
        :n "+" #'text-scale-increase
        :n "-" #'text-scale-decrease
        :n "=" #'my/nov-reset-layout
        :n ">" #'my/nov-widen
        :n "<" #'my/nov-narrow))

(after! eww
  (require 'shrface)
  (add-hook 'eww-after-render-hook #'shrface-mode))
;; EPUBs:1 ends here

;; [[file:config.org::*Justified text][Justified text:1]]
(defun my/nov-mark-soft-breaks-a (fill-line &rest args)
  "Tag the newlines `shr-fill-line' inserts to wrap a line, in nov buffers.
Those lines are the ones to justify. A paragraph's last line, and lines
ended by <br> or the end of a block, keep untagged newlines."
  (if (not (derived-mode-p 'nov-mode))
      (apply fill-line args)
    (let ((start (point)))
      (apply fill-line args)
      (save-excursion
        (let ((end (point)))
          (goto-char start)
          (while (search-forward "\n" end t)
            (put-text-property (1- (point)) (point) 'my/nov-soft-break t)))))))

(defun my/nov--pixel-width (start end)
  "Width in pixels of the text from START to END, all on one line."
  ;; Without an X limit, the measurement stops at the window's edge.
  (car (window-text-pixel-size nil start end t)))

(defun my/nov--justify-line (bol eol width space-widths)
  "Stretch or squeeze the spaces from BOL to EOL to make the line WIDTH pixels.
SPACE-WIDTHS caches the natural width of a space in each face."
  (let ((text-start (save-excursion
                      ;; Past the indentation and any list bullet.
                      (goto-char (+ bol (or (get-text-property bol 'shr-prefix-length) 0)))
                      (skip-chars-forward " " eol)
                      (point)))
        spaces)
    (unless (text-property-not-all text-start eol 'shrface-headline nil)
      (save-excursion
        (goto-char text-start)
        (while (search-forward " " eol t)
          (unless (get-text-property (1- (point)) 'display)
            (push (1- (point)) spaces))))
      (when spaces
        (let* ((space-width (lambda (pos)
                              (let ((face (get-text-property pos 'face)))
                                (or (gethash face space-widths)
                                    (puthash face (my/nov--pixel-width pos (1+ pos))
                                             space-widths)))))
               (count (length spaces))
               (extra (- width (my/nov--pixel-width bol eol))))
          ;; Leave the line ragged if the gaps would swallow it, or would
          ;; have to shrink below a quarter of a space.
          (when (and (/= extra 0)
                     (< extra (/ width 2))
                     (> extra (- (/ (* 3 count (funcall space-width (car spaces))) 4))))
            (let ((each (floor extra count))
                  (leftover (mod extra count)))
              (dolist (pos (nreverse spaces))
                (put-text-property
                 pos (1+ pos) 'display
                 `(space :width (,(+ (funcall space-width pos) each
                                     (if (> leftover 0) 1 0)))))
                (setq leftover (1- leftover))))))))))

(defun my/nov--justify (width)
  "Justify every line in the buffer that shr wrapped, to WIDTH pixels."
  (let ((space-widths (make-hash-table :test #'equal))
        (pos (point-min)))
    (while (setq pos (text-property-any pos (point-max) 'my/nov-soft-break t))
      (my/nov--justify-line (save-excursion (goto-char pos) (line-beginning-position))
                            pos width space-widths)
      (setq pos (1+ pos)))))

(defvar-local my/nov--rendered-layout nil
  "What the current rendering was laid out for, from `my/nov--layout'.")

(defun my/nov--window ()
  "The window the current nov buffer is laid out for, or nil if it isn't shown."
  (if (eq (window-buffer) (current-buffer))
      (selected-window)
    (get-buffer-window nil t)))

(defun my/nov--call-in-window (fn)
  "Call FN with the window the current buffer is laid out for, selected.
nov renders a book before displaying it, and text can only be measured
in a window, so then borrow the selected one, as shr itself does."
  (if-let* ((window (my/nov--window)))
      (with-selected-window window (funcall fn window))
    (save-window-excursion
      (set-window-dedicated-p nil nil)
      (set-window-buffer nil (current-buffer))
      (funcall fn (selected-window)))))

(defun my/nov--columns (window)
  "Columns to fill text to in WINDOW: `nov-text-width', unless WINDOW is narrower."
  (let* ((fringes (window-fringes window))
         (room (- (window-body-width window)
                  ;; Without fringes, the last column goes to the
                  ;; continuation glyph.
                  (if (and (zerop (car fringes)) (zerop (cadr fringes))) 2 1))))
    (if (integerp nov-text-width) (min nov-text-width room) room)))

(defun my/nov--layout (window)
  "Everything a rendering for WINDOW depends on, besides the book itself."
  (list (my/nov--columns window)
        (frame-char-width (window-frame window))
        ;; Font size and mixed-pitch both live here. Copied, because
        ;; `face-remap-add-relative' edits entries in place.
        (copy-tree face-remapping-alist)))

(defun my/nov-render-html ()
  "Like `nov-render-html', but filled to fit the window, then justified."
  (my/nov--call-in-window
   (lambda (window)
     (let* ((columns (my/nov--columns window))
            (em (string-pixel-width (propertize "M" 'face 'shr-text) (current-buffer))))
       (let ((nov-text-width (- columns (ceiling em (frame-char-width))))
             ;; Measure every line whole, even one wider than the window.
             (truncate-lines t))
         (nov-render-html)
         (my/nov--justify (* columns (frame-char-width))))
       (setq my/nov--rendered-layout (my/nov--layout window))))))
;; Justified text:1 ends here

;; [[file:config.org::*Keeping the layout current][Keeping the layout current:1]]
(defun my/nov--text-offset (pos)
  "Number of non-whitespace characters before POS."
  (save-excursion
    (goto-char (point-min))
    (let ((count 0))
      (while (< (point) pos)
        (skip-chars-forward " \t\n\r\f" pos)
        (setq count (+ count (skip-chars-forward "^ \t\n\r\f" pos))))
      count)))

(defun my/nov--text-position (count)
  "Position of the non-whitespace character that COUNT others precede.
The inverse of `my/nov--text-offset'."
  (save-excursion
    (goto-char (point-min))
    (while (and (> count 0) (not (eobp)))
      (skip-chars-forward " \t\n\r\f")
      (let ((moved (skip-chars-forward "^ \t\n\r\f" (min (point-max) (+ (point) count)))))
        (if (zerop moved)
            (goto-char (point-max))
          (setq count (- count moved)))))
    (skip-chars-forward " \t\n\r\f")
    (point)))

(defun my/nov-rerender ()
  "Render the current document again, keeping the same text in view."
  (let* ((window (my/nov--window))
         (start (and window (my/nov--text-offset (window-start window))))
         (pt (my/nov--text-offset (point))))
    (nov-render-document)
    (goto-char (my/nov--text-position pt))
    (when window
      (set-window-start window (save-excursion
                                 (goto-char (my/nov--text-position start))
                                 (line-beginning-position)))
      (set-window-point window (point)))))

(defvar-local my/nov--rerender-timer nil)

(defun my/nov--rerender-if-stale (buffer)
  (when (buffer-live-p buffer)
    (with-current-buffer buffer
      (setq my/nov--rerender-timer nil)
      (when-let* ((window (my/nov--window)))
        (with-selected-window window
          (unless (equal my/nov--rendered-layout (my/nov--layout window))
            (my/nov-rerender)))))))

(defun my/nov--schedule-rerender ()
  "Re-render the current buffer once a burst of changes has settled."
  (when (timerp my/nov--rerender-timer)
    (cancel-timer my/nov--rerender-timer))
  (setq my/nov--rerender-timer
        (run-with-timer 0.2 nil #'my/nov--rerender-if-stale (current-buffer))))

(defun my/nov--window-size-change-h (window)
  (with-current-buffer (window-buffer window)
    (unless (equal my/nov--rendered-layout (my/nov--layout window))
      (my/nov--schedule-rerender))))

(defun my/nov-mixed-pitch-h ()
  "Turn on mixed-pitch before nov's first rendering, not after it."
  (unless (bound-and-true-p mixed-pitch-mode)
    (mixed-pitch-mode 1)))

(defun my/nov-font-changed-h ()
  "Lay nov buffers out again after the frame's font changes size."
  (dolist (buffer (buffer-list))
    (with-current-buffer buffer
      (when (derived-mode-p 'nov-mode)
        (my/nov--fit-zen-width)
        (my/nov--schedule-rerender)))))
;; Keeping the layout current:1 ends here

;; [[file:config.org::*Zen, font size and width][Zen, font size and width:1]]
(defun my/nov--fit-zen-width ()
  "Size zen's writing area to hold `nov-text-width' columns."
  (when (integerp nov-text-width)
    (setq-local writeroom-width
                (ceiling (+ (* nov-text-width (frame-char-width))
                            (/ (frame-char-width) 2))
                         (float (window-font-width))))
    (when (bound-and-true-p writeroom-mode)
      (setq-local visual-fill-column-width writeroom-width)
      (when-let* ((window (my/nov--window)))
        (with-selected-window window
          (visual-fill-column-adjust))))))

(defun my/nov--text-scale-h ()
  (my/nov--fit-zen-width)
  (my/nov--schedule-rerender))

(defun my/nov-setup-h ()
  "Keep a nov buffer's layout matched to its window, font size and zen width."
  (setq-local +zen-text-scale 0)
  (my/nov--fit-zen-width)
  (add-hook 'text-scale-mode-hook #'my/nov--text-scale-h nil t)
  (add-hook 'window-size-change-functions #'my/nov--window-size-change-h nil t)
  ;; nov rendered the book before running this hook, so anything earlier
  ;; in it that remapped faces has made that rendering stale.
  (my/nov--call-in-window
   (lambda (window)
     (unless (equal my/nov--rendered-layout (my/nov--layout window))
       (my/nov-rerender)))))

(defun my/nov--set-width (columns)
  (setq-local nov-text-width (max 20 columns))
  (my/nov--fit-zen-width)
  (my/nov--schedule-rerender)
  (message "Text width: %d columns" nov-text-width))

(defun my/nov-widen (&optional n)
  "Widen the text by 5 columns, or N times that."
  (interactive "p")
  (my/nov--set-width (+ nov-text-width (* 5 n))))

(defun my/nov-narrow (&optional n)
  "Narrow the text by 5 columns, or N times that."
  (interactive "p")
  (my/nov-widen (- n)))

(defun my/nov-reset-layout ()
  "Put this book's font size and text width back to the defaults."
  (interactive)
  (kill-local-variable 'nov-text-width)
  (text-scale-set 0)
  (my/nov--fit-zen-width)
  (my/nov--schedule-rerender))
;; Zen, font size and width:1 ends here

;; [[file:config.org::*Mixed pitch][Mixed pitch:1]]
(use-package! mixed-pitch
  :hook ((org-mode eww-mode) . mixed-pitch-mode))

(setq +zen-mixed-pitch-modes '(adoc-mode rst-mode markdown-mode))

(after! visual-fill-column
  (setq visual-fill-column-adjust-for-text-scale nil))
;; Mixed pitch:1 ends here

;; [[file:config.org::*Mixed pitch][Mixed pitch:2]]
(add-hook 'mixed-pitch-mode-hook
          (defun my/writeroom-scale-width-for-mixed-pitch-h ()
            (when (and mixed-pitch-mode (not (derived-mode-p 'nov-mode)))
              ;; mixed-pitch-mode turns on immediately for every org buffer,
              ;; but writeroom-mode (which defines `writeroom-width') is
              ;; normally only loaded lazily, on first use of zen mode. On
              ;; a fresh daemon, that leaves the variable unbound here,
              ;; which throws mid-hook and silently skips every mode-hook
              ;; function still queued after this one -- including
              ;; `org-modern-mode', which is most of org's highlighting.
              (require 'writeroom-mode)
              (let ((scaled (round (* (default-value 'writeroom-width)
                                       (/ (float (window-font-width nil 'variable-pitch))
                                          (window-font-width nil 'default))))))
                (setq-local writeroom-width scaled)
                (when (bound-and-true-p visual-fill-column-mode)
                  (setq-local visual-fill-column-width scaled))))))
;; Mixed pitch:2 ends here

;; [[file:config.org::*Dired][Dired:1]]
(after! dired-x
  (setq dired-omit-files (concat dired-omit-files "\\|^\\..+\\'")))
;; Dired:1 ends here

;; [[file:config.org::*Reusing Dirvish's window][Reusing Dirvish's window:1]]
(defmacro my/dirvish-reusing-window (&rest body)
  "Run BODY with the selected window's dedication temporarily lifted.
A plain passthrough if Dirvish (and its `dirvish-save-dedication') isn't
loaded."
  (declare (indent 0) (debug (&rest form)))
  `(if (fboundp 'dirvish-save-dedication)
       (dirvish-save-dedication ,@body)
     ,@body))
;; Reusing Dirvish's window:1 ends here

;; [[file:config.org::*Reading the lists][Reading the lists:1]]
(defun my/docsync--xdg-directory (variable fallback)
  "Return docsync's directory under XDG VARIABLE, worked out as the script does."
  (let ((base (getenv variable)))
    (expand-file-name "docsync" (if (member base '(nil "")) fallback base))))

(defun my/docsync--config-file (name)
  "Return the file NAME in docsync's config directory."
  (expand-file-name name (my/docsync--xdg-directory "XDG_CONFIG_HOME" "~/.config")))

(defun my/docsync--state-file (name)
  "Return the file NAME in docsync's state directory."
  (expand-file-name name (my/docsync--xdg-directory "XDG_STATE_HOME" "~/.local/state")))

(defun my/docsync--list-lines (file)
  "Return FILE's entries without comments, blank lines or surrounding space."
  (when (file-readable-p file)
    (with-temp-buffer
      (insert-file-contents file)
      (seq-remove (lambda (line) (or (string-empty-p line) (string-prefix-p "#" line)))
                  (mapcar #'string-trim (split-string (buffer-string) "\n"))))))

(defun my/docsync--include-path (entry)
  "Return include list ENTRY as the absolute path the script backs up."
  (let ((path (string-remove-prefix "~/" entry)))
    (directory-file-name
     (if (file-name-absolute-p path) path (expand-file-name path "~")))))

(defun my/docsync--glob-regexp (glob)
  "Translate restic exclude pattern GLOB into a regexp body.
As in restic, * and ? stay within one path component and **/ spans any
number of them.  Character classes aren't translated; none of the lists
use them."
  (let ((i 0) (n (length glob)) (parts nil))
    (while (< i n)
      (let ((c (aref glob i)))
        (cond ((and (eq c ?*) (< (1+ i) n) (eq (aref glob (1+ i)) ?*))
               (if (and (< (+ i 2) n) (eq (aref glob (+ i 2)) ?/))
                   (progn (push "\\(?:.*/\\)?" parts) (setq i (+ i 3)))
                 (push ".*" parts) (setq i (+ i 2))))
              ((eq c ?*) (push "[^/]*" parts) (setq i (1+ i)))
              ((eq c ??) (push "[^/]" parts) (setq i (1+ i)))
              (t (push (regexp-quote (string c)) parts) (setq i (1+ i))))))
    (apply #'concat (nreverse parts))))

(defun my/docsync--exclude-matcher (entry)
  "Return (ENTRY . REGEXP) for exclude list ENTRY.
REGEXP matches what restic leaves out for it: the path itself and
everything under it, anchored at the root when ENTRY is absolute (or
starts with ~/), and at any directory boundary otherwise."
  (let* ((home-relative (string-prefix-p "~/" entry))
         (pattern (if home-relative
                      (concat (directory-file-name (expand-file-name "~")) "/"
                              (substring entry 2))
                    entry))
         (anchored (string-prefix-p "/" pattern)))
    (cons entry
          (concat (if anchored "\\`" "/")
                  (my/docsync--glob-regexp (if anchored pattern
                                              (string-remove-prefix "/" pattern)))
                  "\\(?:/.*\\)?\\'"))))

(defvar my/docsync--lists-cache nil
  "(INCLUDE-MTIME EXCLUDE-MTIME INCLUDES EXCLUDES) as last read.")

(defun my/docsync--lists ()
  "Return (INCLUDES EXCLUDES), re-reading the list files when they change.
INCLUDES are absolute paths, EXCLUDES are (ENTRY . REGEXP) conses."
  (let* ((include (my/docsync--config-file "include"))
         (exclude (my/docsync--config-file "exclude"))
         (include-mtime (file-attribute-modification-time (file-attributes include)))
         (exclude-mtime (file-attribute-modification-time (file-attributes exclude))))
    (unless (and my/docsync--lists-cache
                 (equal include-mtime (nth 0 my/docsync--lists-cache))
                 (equal exclude-mtime (nth 1 my/docsync--lists-cache)))
      (setq my/docsync--lists-cache
            (list include-mtime exclude-mtime
                  (mapcar #'my/docsync--include-path (my/docsync--list-lines include))
                  (mapcar #'my/docsync--exclude-matcher (my/docsync--list-lines exclude)))))
    (cddr my/docsync--lists-cache)))

(defun my/docsync--excluded-by (file)
  "Return the exclude list entry that leaves FILE out of backups, if any."
  (car (seq-find (lambda (matcher) (string-match-p (cdr matcher) file))
                 (cadr (my/docsync--lists)))))

(defun my/docsync--covering (file)
  "Return the listed path FILE is backed up as part of, if any."
  (seq-find (lambda (path) (string-prefix-p (file-name-as-directory path) file))
            (car (my/docsync--lists))))

(defun my/docsync-state (file)
  "Return how docsync treats FILE.
`listed' when it's in the include list itself, `inherited' when it's
inside a listed directory, `excluded' when it's inside one but an exclude
pattern leaves it out, `partial' for a directory with listed paths inside,
and nil when backups don't touch it."
  (let ((file (directory-file-name (expand-file-name file)))
        (includes (car (my/docsync--lists))))
    (cond ((member file includes) 'listed)
          ((my/docsync--covering file)
           (if (my/docsync--excluded-by file) 'excluded 'inherited))
          ((seq-some (lambda (path) (string-prefix-p (file-name-as-directory file) path))
                     includes)
           'partial))))
;; Reading the lists:1 ends here

;; [[file:config.org::*Changing what's backed up][Changing what's backed up:1]]
(defun my/docsync--list-entry (file &optional tilde)
  "Return FILE as the lists write it: relative to ~ when it's under it.
With TILDE the relative form starts with ~/, which the exclude list needs
to tell a path from a pattern that matches anywhere."
  (let ((file (directory-file-name (expand-file-name file)))
        (home (file-name-as-directory (expand-file-name "~"))))
    (if (string-prefix-p home file)
        (concat (if tilde "~/" "") (substring file (length home)))
      file)))

(defun my/docsync--edit-list (name add remove)
  "Append the entries ADD to list NAME and drop the lines in REMOVE.
Lines are compared after trimming, and comments are kept."
  (let ((file (my/docsync--config-file name)))
    (with-temp-buffer
      (when (file-exists-p file) (insert-file-contents file))
      (goto-char (point-min))
      (while (not (eobp))
        (if (member (string-trim (buffer-substring (line-beginning-position)
                                                   (line-end-position)))
                    remove)
            (delete-region (line-beginning-position)
                           (min (point-max) (1+ (line-end-position))))
          (forward-line 1)))
      (goto-char (point-max))
      (unless (or (bobp) (eq (char-before) ?\n)) (insert "\n"))
      (dolist (entry add) (insert entry "\n"))
      (make-directory (file-name-directory file) t)
      (write-region nil nil file nil 'silent)))
  (setq my/docsync--lists-cache nil)
  (my/docsync--redraw)
  (my/docsync--schedule-scan))

(defun my/docsync--redraw ()
  "Redraw the visible Dired windows and mode lines, whose markers may be stale.
Dirvish renders its attributes as a window is redisplayed, so marking the
windows for redisplay is enough; nothing needs reverting."
  (dolist (window (window-list-1 nil 'nomini 'visible))
    (when (with-current-buffer (window-buffer window) (derived-mode-p 'dired-mode))
      (force-window-update window)))
  (force-mode-line-update t))

(defun my/docsync--marked-files ()
  "Return the marked files in this Dired buffer, or the one at point."
  (or (dired-get-marked-files nil nil nil nil t)
      (user-error "No file on this line")))

(defun my/docsync-toggle (files)
  "Start or stop backing up FILES, the marked files or the one at point.
Files that are already listed come off the include list, and the rest go
on it.  A file only backed up as part of a listed directory stays put:
leaving it out is `my/docsync-toggle-exclude's job."
  (interactive (list (my/docsync--marked-files)) dired-mode)
  (let (add remove)
    (dolist (file files)
      (pcase (my/docsync-state file)
        ('listed (push (directory-file-name (expand-file-name file)) remove))
        ((or 'inherited 'excluded)
         (user-error "%s is backed up as part of %s; use exclude to leave it out"
                     (abbreviate-file-name file)
                     (abbreviate-file-name (my/docsync--covering file))))
        (_ (push file add))))
    (my/docsync--edit-list
     "include"
     (mapcar #'my/docsync--list-entry (nreverse add))
     ;; An entry can be written several ways (~/Documents, Documents,
     ;; /home/.../Documents), so drop whichever lines resolve to the file.
     (seq-filter (lambda (line) (member (my/docsync--include-path line) remove))
                 (my/docsync--list-lines (my/docsync--config-file "include"))))
    (message "docsync: %s"
             (string-join
              (delq nil (list (and add (format "backing up %d more" (length add)))
                              (and remove (format "no longer backing up %d" (length remove)))))
              ", "))))

(defun my/docsync-toggle-exclude (files)
  "Leave FILES out of backups, or put them back if they're left out.
FILES are the marked files or the one at point, and must be inside a
listed directory.  Only exclusions this command wrote (one path per line)
can be taken back here; one from a wider pattern has to be edited in the
list itself."
  (interactive (list (my/docsync--marked-files)) dired-mode)
  (let (add remove)
    (dolist (file files)
      (let ((entry (my/docsync--list-entry file t)))
        (pcase (my/docsync-state file)
          ('inherited (push entry add))
          ('excluded
           (let ((by (my/docsync--excluded-by
                      (directory-file-name (expand-file-name file)))))
             (unless (equal by entry)
               (user-error "%s is left out by the pattern %s in the exclude list"
                           (abbreviate-file-name file) by))
             (push entry remove)))
          (_ (user-error "%s isn't inside a backed-up directory"
                         (abbreviate-file-name file))))))
    (my/docsync--edit-list "exclude" (nreverse add) remove)
    (message "docsync: %s"
             (string-join
              (delq nil (list (and add (format "leaving out %d" (length add)))
                              (and remove (format "backing up %d again" (length remove)))))
              ", "))))

(defun my/docsync-edit-include ()
  "Open docsync's include list."
  (interactive)
  (find-file (my/docsync--config-file "include")))

(defun my/docsync-edit-exclude ()
  "Open docsync's exclude list."
  (interactive)
  (find-file (my/docsync--config-file "exclude")))

(defun my/docsync-list ()
  "Show every listed path in one Dired buffer."
  (interactive)
  (let ((paths (seq-filter #'file-exists-p (car (my/docsync--lists)))))
    (unless paths (user-error "docsync: nothing is listed"))
    (my/dirvish-reusing-window
      (dired (cons "/" paths)))
    (rename-buffer "*docsync paths*" t)))
;; Changing what's backed up:1 ends here

;; [[file:config.org::*What's changed since the last snapshot][What's changed since the last snapshot:1]]
(autoload 'parse-iso8601-time-string "parse-time")

(defvar my/docsync--manifest-cache nil
  "(MTIME SNAPSHOT TABLE) for the manifest as last read.")

(defun my/docsync--unescape-tsv (field)
  "Undo jq's @tsv escaping in FIELD."
  (if (not (string-search "\\" field))
      field
    (replace-regexp-in-string
     "\\\\\\(.\\)"
     (lambda (match)
       (pcase (match-string 1 match) ("t" "\t") ("n" "\n") ("r" "\r") (char char)))
     field t t)))

(defun my/docsync--manifest ()
  "Return (SNAPSHOT TABLE) for the latest snapshot, re-read when it changes.
SNAPSHOT is its ID, nil before the first backup.  TABLE maps each path
in it to (TYPE SIZE MTIME), TYPE a symbol like `file' or `dir' and MTIME
a float."
  (let* ((file (my/docsync--state-file "manifest"))
         (mtime (file-attribute-modification-time (file-attributes file))))
    (unless (and my/docsync--manifest-cache
                 (equal mtime (car my/docsync--manifest-cache)))
      (let ((table (make-hash-table :test #'equal :size 4096))
            snapshot)
        (when mtime
          (with-temp-buffer
            (insert-file-contents file)
            (goto-char (point-min))
            (when (looking-at "# snapshot \\([0-9a-f]+\\)")
              (setq snapshot (match-string 1)))
            (while (re-search-forward
                    "^\\([a-z]+\\)\t\\([0-9]+\\)\t\\([^\t\n]+\\)\t\\(.*\\)$" nil t)
              (puthash (my/docsync--unescape-tsv (match-string 4))
                       (list (intern (match-string 1))
                             (string-to-number (match-string 2))
                             ;; t keeps the nanoseconds, which restic records
                             (float-time (parse-iso8601-time-string (match-string 3) t)))
                       table))))
        (setq my/docsync--manifest-cache (list mtime snapshot table))))
    (cdr my/docsync--manifest-cache)))

(defvar my/docsync--changes nil
  "Paths that differ from the latest snapshot, nil until first compared.
A hash table from path to `changed', `new' or `deleted'.")

(defvar my/docsync--changed-dirs nil
  "Hash table of every directory above a path in `my/docsync--changes'.")

(defvar my/docsync--last-compared nil
  "(LISTING MANIFEST LISTS) from the last comparison, to skip repeating it.")

(defvar my/docsync--scanned-manifest nil
  "The manifest's modification time when the last comparison started.")

(defvar my/docsync--scan-process nil
  "The running `find' behind `my/docsync-scan', if any.")

(defvar my/docsync--scan-again nil
  "Non-nil when a comparison was asked for while one was running.")

(defvar my/docsync--scan-timer nil
  "Pending timer from `my/docsync--schedule-scan'.")

(defun my/docsync--schedule-scan (&optional delay)
  "Compare with the latest snapshot in DELAY seconds (default 1).
Calls arriving while one is pending fold into it."
  (unless my/docsync--scan-timer
    (setq my/docsync--scan-timer
          (run-at-time (or delay 1) nil
                       (lambda ()
                         (setq my/docsync--scan-timer nil)
                         (my/docsync-scan))))))

(defun my/docsync--check-manifest ()
  "Schedule a comparison if a backup has rewritten the manifest since the last."
  (unless (equal (file-attribute-modification-time
                  (file-attributes (my/docsync--state-file "manifest")))
                 my/docsync--scanned-manifest)
    (my/docsync--schedule-scan 0)))

(defun my/docsync--prune-paths (excludes)
  "Return the absolute paths among EXCLUDES that need no glob matching.
`find' can skip these whole, which keeps it out of large left-out trees."
  (let ((home (file-name-as-directory (expand-file-name "~"))))
    (seq-keep (lambda (matcher)
                (let ((entry (car matcher)))
                  (when (string-prefix-p "~/" entry)
                    (setq entry (concat home (substring entry 2))))
                  (and (string-prefix-p "/" entry)
                       (not (string-match-p "[*?[]" entry))
                       (directory-file-name entry))))
              excludes)))

(defun my/docsync-scan ()
  "Compare the backed-up files with the latest snapshot, in the background.
`find' lists them with their sizes and modification times, which is all
local and takes well under a second; the comparison with the manifest
happens when it's done, and redraws the markers."
  (interactive)
  (if (process-live-p my/docsync--scan-process)
      (setq my/docsync--scan-again t)
    (pcase-let* ((`(,includes ,excludes) (my/docsync--lists))
                 (roots (seq-filter #'file-exists-p includes))
                 (prunes (my/docsync--prune-paths excludes))
                 (output (generate-new-buffer " *docsync-scan*"))
                 (errors (generate-new-buffer " *docsync-scan-errors*")))
      (setq my/docsync--scanned-manifest
            (file-attribute-modification-time
             (file-attributes (my/docsync--state-file "manifest"))))
      (if (null roots)
          (progn (kill-buffer output) (kill-buffer errors)
                 (my/docsync--compare nil nil))
        (setq my/docsync--scan-process
              (make-process
               :name "docsync-scan" :buffer output :stderr errors
               :connection-type 'pipe :noquery t
               :command `("find" ,@roots
                          ,@(when prunes
                              `("(" ,@(cdr (mapcan (lambda (path) (list "-o" "-path" path))
                                                   prunes))
                                ")" "-prune" "-o"))
                          "-printf" "%y\t%s\t%T@\t%p\\0")
               :sentinel
               (lambda (process _event)
                 (unless (process-live-p process)
                   (when (buffer-live-p errors) (kill-buffer errors))
                   (let ((listing (with-current-buffer output (buffer-string))))
                     (kill-buffer output)
                     (my/docsync--compare roots listing))
                   (when my/docsync--scan-again
                     (setq my/docsync--scan-again nil)
                     (my/docsync--schedule-scan 0))))))))))

(defun my/docsync--compare (roots listing)
  "Compare `find' LISTING of ROOTS with the manifest and redraw the markers.
A file is changed when its size or modification time differs from the
snapshot's, which is how restic itself decides what to read again, new
when the snapshot lacks it, and deleted when only the snapshot has it.
Most rescans find nothing new, so an identical listing against the same
manifest and lists returns at once."
  (let ((key (list listing (my/docsync--manifest) (my/docsync--lists))))
    (unless (and my/docsync--changes
                 (equal (car key) (car my/docsync--last-compared))
                 (eq (nth 1 key) (nth 1 my/docsync--last-compared))
                 (eq (nth 2 key) (nth 2 my/docsync--last-compared)))
      (setq my/docsync--last-compared key)
      (my/docsync--compare-1 roots listing))))

(defun my/docsync--compare-1 (roots listing)
  "Do the comparison `my/docsync--compare' describes."
  (let ((manifest (cadr (my/docsync--manifest)))
        (changes (make-hash-table :test #'equal))
        (dirs (make-hash-table :test #'equal))
        (seen (make-hash-table :test #'equal :size 4096)))
    (dolist (record (and listing (split-string listing "\0" t)))
      (let* ((fields (split-string record "\t"))
             (type (nth 0 fields))
             (size (string-to-number (nth 1 fields)))
             (mtime (string-to-number (nth 2 fields)))
             (path (string-join (nthcdr 3 fields) "\t"))
             (was (gethash path manifest)))
        (unless (or (member type '("s" "p")) (my/docsync--excluded-by path))
          (puthash path t seen)
          (cond ((null was) (puthash path 'new changes))
                ((equal type "d")
                 (unless (eq (car was) 'dir) (puthash path 'changed changes)))
                ((not (and (eq (car was) (if (equal type "l") 'symlink 'file))
                           (or (equal type "l") (= size (nth 1 was)))
                           (< (abs (- mtime (nth 2 was))) 1e-5)))
                 (puthash path 'changed changes))))))
    (maphash (lambda (path _)
               (when (and (not (gethash path seen))
                          (seq-some (lambda (root)
                                      (or (equal path root)
                                          (string-prefix-p (file-name-as-directory root) path)))
                                    roots)
                          (not (my/docsync--excluded-by path)))
                 (puthash path 'deleted changes)))
             manifest)
    (maphash (lambda (path _)
               (let ((dir path))
                 (while (not (equal dir "/"))
                   (setq dir (directory-file-name (file-name-directory dir)))
                   (if (gethash dir dirs) (setq dir "/") (puthash dir t dirs)))))
             changes)
    (setq my/docsync--changes changes
          my/docsync--changed-dirs dirs)
    (my/docsync--redraw)))

(defun my/docsync-file-status (file)
  "Return FILE's backup status, the key for its marker.
`saved' when it's backed up and the same as in the latest snapshot,
`changed' when it differs (for a directory, when anything inside does),
`new' when the latest snapshot doesn't have it yet, `partial-saved' or
`partial-changed' for a directory with backed-up paths inside it,
`excluded' when an exclude pattern leaves it out, and nil when backups
don't touch it.  `unknown' until the first comparison is done."
  (let* ((file (directory-file-name (expand-file-name file)))
         (state (my/docsync-state file)))
    (cond ((memq state '(nil excluded)) state)
          ((null my/docsync--changes) 'unknown)
          ((eq state 'partial)
           (if (gethash file my/docsync--changed-dirs) 'partial-changed 'partial-saved))
          ((eq (gethash file my/docsync--changes) 'new) 'new)
          ((or (gethash file my/docsync--changes)
               (gethash file my/docsync--changed-dirs))
           'changed)
          (t 'saved))))

(defun my/docsync-list-changes ()
  "Show what the next backup will pick up, in one Dired buffer.
A new directory is listed instead of everything in it.  Deletions can't
be listed, so they're only counted."
  (interactive)
  (unless my/docsync--changes
    (user-error "docsync: still comparing with the latest snapshot"))
  (let (paths (deleted 0))
    (maphash (lambda (path kind)
               (cond ((eq kind 'deleted) (setq deleted (1+ deleted)))
                     ((not (eq (gethash (directory-file-name (file-name-directory path))
                                        my/docsync--changes)
                               'new))
                      (push path paths))))
             my/docsync--changes)
    (if (null paths)
        (message "docsync: nothing changed since the latest snapshot%s"
                 (if (> deleted 0) (format " but %d deletion(s)" deleted) ""))
      (my/dirvish-reusing-window
        (dired (cons "/" (sort paths #'string<))))
      (rename-buffer "*docsync changes*" t)
      (when (> deleted 0)
        (message "docsync: also %d deletion(s), not listed" deleted)))))

(defvar my/docsync--poll-timer
  (run-with-timer 30 30 (lambda ()
                          (when (seq-some (lambda (window)
                                            (with-current-buffer (window-buffer window)
                                              (derived-mode-p 'dired-mode)))
                                          (window-list-1 nil 'nomini 'visible))
                            (my/docsync-scan))))
  "Compares with the latest snapshot every 30 seconds while Dired is on screen.")

(add-hook 'after-save-hook
          (lambda ()
            (when (and buffer-file-name
                       (memq (my/docsync-state buffer-file-name) '(listed inherited)))
              (my/docsync--schedule-scan))))
;; What's changed since the last snapshot:1 ends here

;; [[file:config.org::*In Dirvish][In Dirvish:1]]
(defvar my/docsync--last-cache nil
  "(MTIME . (SUCCESS STATUS MESSAGE)) as last read from the state files.")

(defun my/docsync-last-backup ()
  "Return (SUCCESS STATUS MESSAGE) from docsync's state files, or nil.
SUCCESS is the epoch of the last saved snapshot (nil if never), STATUS
the last run's outcome as a symbol (ok, warning, offline or error), and
MESSAGE what it said about it."
  (let* ((result (my/docsync--state-file "last-result"))
         (mtime (file-attribute-modification-time (file-attributes result))))
    (unless (and mtime (equal mtime (car my/docsync--last-cache)))
      (setq my/docsync--last-cache
            (cons mtime
                  (when-let* ((line (car (my/docsync--list-lines result)))
                              (fields (split-string line " " t))
                              ((cdr fields)))
                    (let ((success (car (my/docsync--list-lines
                                         (my/docsync--state-file "last-success")))))
                      (list (and success (string-to-number success))
                            (intern (nth 1 fields))
                            (string-join (nthcdr 2 fields) " ")))))))
    (cdr my/docsync--last-cache)))

(defun my/docsync--age (seconds)
  "Return SECONDS as a short age: 5m, 3h, 2d."
  (cond ((< seconds 3600) (format "%dm" (/ seconds 60)))
        ((< seconds 172800) (format "%dh" (/ seconds 3600)))
        (t (format "%dd" (/ seconds 86400)))))

(defun my/docsync-mode-line ()
  "Return a short mode line note of when docsync last backed up.
It's plain while backups are landing, in `warning' once the last one is
over two hours old or the last run had trouble, and in `error' after a
failed run or a day without a backup.  After it comes how many files
differ from the latest snapshot, when any do."
  (pcase-let* ((`(,success ,status ,msg) (my/docsync-last-backup))
               (age (and success (- (float-time) success)))
               (changes (and my/docsync--changes
                             (hash-table-count my/docsync--changes))))
    (concat
     " "
     (propertize (if age (concat "backup " (my/docsync--age (truncate age))) "no backup")
                 'face (cond ((or (not age) (eq status 'error) (> age 86400)) 'error)
                             ((or (memq status '(warning offline)) (> age 7200)) 'warning))
                 'help-echo (format "docsync: last run %s%s" status
                                    (if (string-empty-p (or msg "")) "" (concat ": " msg))))
     (if (and changes (> changes 0))
         (propertize (format " · %d changed" changes) 'face 'my/docsync-changed
                     'help-echo "Files that differ from the latest snapshot")
       "")
     " ")))
;; In Dirvish:1 ends here

;; [[file:config.org::*In Dirvish][In Dirvish:2]]
(defface my/docsync-saved '((t :inherit success))
  "Face for a backed-up path that hasn't changed since the latest snapshot.")

(defface my/docsync-changed '((t :inherit warning))
  "Face for a backed-up path that differs from the latest snapshot.")

(defface my/docsync-excluded '((t :inherit shadow))
  "Face for a path an exclude pattern leaves out.")

(defvar my/docsync-markers
  '((saved "✓" . my/docsync-saved)
    (changed "●" . my/docsync-changed)
    (new "+" . my/docsync-changed)
    (partial-saved "◐" . my/docsync-saved)
    (partial-changed "◐" . my/docsync-changed)
    (excluded "✕" . my/docsync-excluded)
    (unknown "·" . my/docsync-excluded))
  "Marker and face for each `my/docsync-file-status'.")

(after! dirvish
  (dirvish-define-attribute docsync
    "Whether this file is backed up and changed since; see `my/docsync-markers'."
    :right 2
    :when (not (dirvish-prop :remote))
    :setup (progn (my/docsync--lists) (my/docsync--check-manifest))
    (let* ((marker (alist-get (my/docsync-file-status f-name) my/docsync-markers))
           (str (concat " " (or (car marker) " "))))
      (add-face-text-property 0 (length str) (or hl-face (cdr marker) 'default) t str)
      `(right . ,str)))

  (dirvish-define-mode-line docsync
    "When docsync last backed up."
    (my/docsync-mode-line))

  (add-to-list 'dirvish-attributes 'docsync t)
  (unless (memq 'docsync (plist-get dirvish-mode-line-format :right))
    (setq dirvish-mode-line-format
          (plist-put dirvish-mode-line-format :right
                     (cons 'docsync (plist-get dirvish-mode-line-format :right))))))
;; In Dirvish:2 ends here

;; [[file:config.org::*Running it][Running it:1]]
(defun my/docsync--show (&rest args)
  "Run docsync with ARGS in the *docsync* buffer, shown at the bottom."
  (let ((buffer (get-buffer-create "*docsync*")))
    (when (get-buffer-process buffer)
      (user-error "docsync is already running in *docsync*"))
    (with-current-buffer buffer
      (special-mode)
      (let ((inhibit-read-only t)) (erase-buffer)))
    (make-process
     :name "docsync" :buffer buffer :connection-type 'pipe
     :command (cons (my/program "docsync") args)
     :filter (lambda (process string)
               (when (buffer-live-p (process-buffer process))
                 (with-current-buffer (process-buffer process)
                   (let ((inhibit-read-only t))
                     (save-excursion (goto-char (point-max)) (insert string))))))
     :sentinel (lambda (process event)
                 (unless (process-live-p process)
                   (message "docsync %s: %s" (car args) (string-trim event))
                   (my/docsync--check-manifest))))
    (display-buffer buffer '((display-buffer-reuse-window display-buffer-at-bottom)
                             (window-height . 12)))))

(defun my/docsync-backup-now ()
  "Take a backup now instead of waiting for the hourly timer."
  (interactive)
  (my/docsync--show "backup"))

(defun my/docsync-status ()
  "Show when docsync last backed up, and its latest snapshots."
  (interactive)
  (my/docsync--show "status"))
;; Running it:1 ends here

;; [[file:config.org::*Going back in time][Going back in time:1]]
(defvar my/docsync--mount-process nil
  "The `docsync restic mount' process serving snapshots, while it runs.")

(defvar my/docsync--mount-ready nil
  "Non-nil once `my/docsync--mount-process' has said it's serving.")

(defun my/docsync--mount-directory ()
  "Return where snapshots get mounted."
  (expand-file-name "docsync" (or (getenv "XDG_RUNTIME_DIR") temporary-file-directory)))

(defun my/docsync--with-mount (callback)
  "Call CALLBACK with the snapshot mount's directory, mounting it if needed."
  (let ((dir (my/docsync--mount-directory)))
    (cond
     ((and (process-live-p my/docsync--mount-process) my/docsync--mount-ready)
      (funcall callback dir))
     ((process-live-p my/docsync--mount-process)
      (user-error "docsync: still mounting snapshots, try again in a moment"))
     (t
      (make-directory dir t)
      ;; Clear a mount a crashed Emacs left behind, which would otherwise
      ;; make the directory unusable ("Transport endpoint is not connected").
      (call-process "fusermount3" nil nil nil "-uqz" dir)
      (message "docsync: mounting snapshots...")
      (setq my/docsync--mount-ready nil)
      (let ((buffer (generate-new-buffer " *docsync-mount*")))
        (setq my/docsync--mount-process
              (make-process
               :name "docsync-mount" :buffer buffer :connection-type 'pipe
               :command (list (my/program "docsync") "restic" "mount" "--no-lock" dir)
               :filter (lambda (process string)
                         (with-current-buffer (process-buffer process)
                           (goto-char (point-max))
                           (insert string)
                           (when (and (not my/docsync--mount-ready)
                                      (save-excursion
                                        (goto-char (point-min))
                                        (search-forward "Now serving" nil t)))
                             (setq my/docsync--mount-ready t)
                             (message "docsync: snapshots mounted at %s" dir)
                             (run-at-time 0 nil callback dir))))
               :sentinel (lambda (process _event)
                           (unless (process-live-p process)
                             (unless my/docsync--mount-ready
                               (message "docsync: mounting failed: %s"
                                        (with-current-buffer (process-buffer process)
                                          (car (last (split-string (string-trim (buffer-string))
                                                                   "\n"))))))
                             (setq my/docsync--mount-ready nil)
                             (kill-buffer (process-buffer process)))))))))))

(defun my/docsync-unmount ()
  "Unmount the snapshots."
  (interactive)
  (if (process-live-p my/docsync--mount-process)
      (progn (interrupt-process my/docsync--mount-process)
             (message "docsync: snapshots unmounted"))
    (message "docsync: snapshots aren't mounted")))

(add-hook 'kill-emacs-hook
          (lambda () (when (process-live-p my/docsync--mount-process)
                       (interrupt-process my/docsync--mount-process))))

(defun my/docsync--snapshots (mount)
  "Return the snapshot directory names under MOUNT, newest first."
  (sort (directory-files (expand-file-name "snapshots" mount) nil "\\`[0-9]")
        #'string>))

(defun my/docsync--read (prompt candidates)
  "Read one of CANDIDATES, (LABEL . VALUE) conses, keeping their order.
Return the chosen VALUE."
  (let ((choice (completing-read
                 prompt
                 (lambda (string pred action)
                   (if (eq action 'metadata)
                       '(metadata (display-sort-function . identity))
                     (complete-with-action action candidates string pred)))
                 nil t)))
    (cdr (assoc choice candidates))))

(defun my/docsync--snapshot-label (name)
  "Return snapshot directory NAME as a date and time."
  (if (string-match "\\`\\([0-9-]+\\)T\\([0-9]+:[0-9]+\\)" name)
      (concat (match-string 1 name) " " (match-string 2 name))
    name))

(defun my/docsync--versions (mount file)
  "Return FILE's distinct versions in the snapshots under MOUNT, newest first.
Each is (LABEL . PATH), PATH being that version inside the mount, labelled
with the first snapshot that has it.  Versions differ by size or
modification time, which restic keeps as they were."
  (let ((current (file-attributes file)) (seen nil) (versions nil))
    (dolist (name (reverse (my/docsync--snapshots mount)))
      (let* ((path (concat (expand-file-name name (expand-file-name "snapshots" mount)) file))
             (attrs (file-attributes path)))
        (when attrs
          (let ((key (cons (file-attribute-size attrs)
                           (file-attribute-modification-time attrs))))
            (unless (member key seen)
              (push key seen)
              (push (cons (format "%s  %s, modified %s%s"
                                  (my/docsync--snapshot-label name)
                                  (file-size-human-readable (file-attribute-size attrs))
                                  (format-time-string "%F %R" (cdr key))
                                  (if (and current
                                           (equal key (cons (file-attribute-size current)
                                                            (file-attribute-modification-time current))))
                                      "  (same as now)" ""))
                          path)
                    versions))))))
    versions))

(defun my/docsync-versions (file)
  "Pick an earlier version of FILE from the backups and compare or copy it.
For a directory, open the chosen version of it in Dired instead."
  (interactive (list (or (dired-get-filename nil t) (user-error "No file on this line")))
               dired-mode)
  (let ((file (directory-file-name (expand-file-name file))))
    (unless (memq (my/docsync-state file) '(listed inherited))
      (user-error "%s isn't backed up" (abbreviate-file-name file)))
    (my/docsync--with-mount
     (lambda (mount)
       (let* ((versions (or (my/docsync--versions mount file)
                            (user-error "No backed-up versions of %s yet"
                                        (abbreviate-file-name file))))
              (path (my/docsync--read (format "Version of %s: " (file-name-nondirectory file))
                                      versions)))
         (if (file-directory-p path)
             (my/dirvish-reusing-window (dired path))
           (pcase (read-char-choice
                   (format "%s: [e]diff with now, [o]pen, [c]opy beside it as %s.~DATE~ "
                           (file-name-nondirectory file) (file-name-nondirectory file))
                   '(?e ?o ?c))
             (?e (ediff-files path file))
             (?o (my/dirvish-reusing-window (find-file-read-only path)))
             (?c (let ((copy (format "%s.~%s~" file
                                     (format-time-string
                                      "%Y-%m-%dT%H%M"
                                      (file-attribute-modification-time (file-attributes path))))))
                   (copy-file path copy nil t)
                   (dolist (buffer (dired-buffers-for-dir (file-name-directory file)))
                     (with-current-buffer buffer (revert-buffer)))
                   (message "docsync: copied to %s" (abbreviate-file-name copy)))))))))))

(defun my/docsync-browse ()
  "Open this directory as it was in a chosen snapshot.
Deleted files can be copied back out with the usual Dired commands.  If
the directory didn't exist yet in that snapshot, open the nearest parent
that did."
  (interactive)
  (let ((dir (directory-file-name (expand-file-name default-directory))))
    (my/docsync--with-mount
     (lambda (mount)
       (let* ((snapshots (or (my/docsync--snapshots mount)
                             (user-error "docsync: no snapshots yet")))
              (name (my/docsync--read "Snapshot: "
                                      (mapcar (lambda (name)
                                                (cons (my/docsync--snapshot-label name) name))
                                              snapshots)))
              (root (expand-file-name name (expand-file-name "snapshots" mount)))
              (target dir))
         (while (and (not (file-directory-p (concat root target)))
                     (not (equal target "/")))
           (setq target (directory-file-name (file-name-directory target))))
         (my/dirvish-reusing-window (dired (concat root target))))))))

(after! vc
  ;; Don't have VC look for Git repositories inside the read-only mount.
  (setq vc-ignore-dir-regexp
        (format "%s\\|\\`%s" vc-ignore-dir-regexp
                (regexp-quote (file-name-as-directory (my/docsync--mount-directory))))))
;; Going back in time:1 ends here

;; [[file:config.org::*Keys][Keys:1]]
(map! :map dired-mode-map :localleader
      (:prefix ("b" . "backups")
       :desc "Toggle backing up"   "b" #'my/docsync-toggle
       :desc "Toggle excluding"    "x" #'my/docsync-toggle-exclude
       :desc "Back up now"         "s" #'my/docsync-backup-now
       :desc "Changed since backup" "c" #'my/docsync-list-changes
       :desc "Recheck changes"     "r" #'my/docsync-scan
       :desc "Status"              "i" #'my/docsync-status
       :desc "Versions of this"    "v" #'my/docsync-versions
       :desc "Browse a snapshot"   "t" #'my/docsync-browse
       :desc "Unmount snapshots"   "u" #'my/docsync-unmount
       :desc "List backed-up paths" "l" #'my/docsync-list
       :desc "Edit include list"   "e" #'my/docsync-edit-include
       :desc "Edit exclude list"   "E" #'my/docsync-edit-exclude))
;; Keys:1 ends here

;; [[file:config.org::*Media thumbnails][Media thumbnails:1]]
(defcustom my/media-video-extensions
  '("mp4" "mkv" "webm" "avi" "mov" "m4v" "wmv" "flv" "mpg" "mpeg" "ogv")
  "Video file extensions shown alongside images by `my/media-thumbnails'."
  :type '(repeat string))

(defcustom my/media-video-player (or (executable-find "mpv") "xdg-open")
  "Program used to open video files from the `my/media-thumbnails' grid."
  :type 'string)

(defun my/media--video-p (file)
  "Return non-nil if FILE's extension is one of `my/media-video-extensions'."
  (member (downcase (or (file-name-extension file) "")) my/media-video-extensions))

(defun my/media--file-regexp ()
  "Regexp matching both image and video files."
  (concat (image-dired--file-name-regexp)
          "\\|\\.\\(?:" (mapconcat #'regexp-quote my/media-video-extensions "\\|") "\\)\\'"))

(defun my/media--video-thumbnail-file (file)
  "Return a cached thumbnail image for video FILE, creating it if stale."
  (let* ((cache (expand-file-name "video-thumbs" (image-dired-dir)))
         (thumb (expand-file-name (concat (sha1 (expand-file-name file)) ".jpg") cache))
         (attr (file-attributes thumb)))
    (make-directory cache t)
    (when (or (not attr)
              (time-less-p (file-attribute-modification-time attr)
                           (file-attribute-modification-time (file-attributes file))))
      (unless (zerop (call-process "ffmpegthumbnailer" nil nil nil
                                    "-i" file "-o" thumb "-s"
                                    (number-to-string image-dired-thumb-size)))
        (message "ffmpegthumbnailer failed for %s" file)))
    thumb))

(defun my/media--thumbnail-file (file)
  "Return a thumbnail image for FILE, whether it is an image or a video."
  (if (my/media--video-p file)
      (my/media--video-thumbnail-file file)
    (image-dired--get-create-thumbnail-file file)))

(defun my/media-thumbnails (dir)
  "Show a grid of thumbnails for every image and video in DIR.
Uses `image-dired-thumbnail-mode', so the normal image-dired keys select,
mark, and open thumbnails; opening a video plays it with
`my/media-video-player' instead of displaying it as an image."
  (interactive (list (if (derived-mode-p 'dired-mode)
                         default-directory
                       (read-directory-name "Show thumbnails for directory: "))))
  (require 'image-dired)
  (unless (executable-find "ffmpegthumbnailer")
    (user-error "ffmpegthumbnailer is not installed"))
  (let* ((dir (expand-file-name dir))
         (default-directory dir)
         (files (let ((case-fold-search t))
                  (sort (directory-files dir t (my/media--file-regexp)) #'string-lessp)))
         (dired-buf (dired-noselect dir))
         (buf (image-dired-create-thumbnail-buffer)))
    (unless files
      (user-error "No image or video files in %s" dir))
    (with-current-buffer buf
      (let ((inhibit-read-only t))
        (erase-buffer)
        (setq-local image-dired--number-of-thumbnails (length files))
        (dolist (file files)
          (image-dired-insert-thumbnail (my/media--thumbnail-file file) file dired-buf))))
    ;; Line-up must happen after the buffer is displayed: the dynamic method
    ;; measures the window it is showing in to decide thumbnails per row.
    (pop-to-buffer buf)
    (image-dired--line-up-with-method)
    (image-dired--update-header-line)))

;; RET (`image-dired-display-this') and C-RET
;; (`image-dired-thumbnail-display-external') both hand the *original* file
;; to code that only understands images; send videos to an external player
;; instead.
(defun my/media--play-video-a (orig-fn &rest args)
  "Play FILE with `my/media-video-player' if it looks like a video.
Otherwise call ORIG-FN with ARGS. FILE is either the first of ARGS, as
passed to `image-dired-display-image', or, when ARGS is empty, the file
at point, as used by `image-dired-thumbnail-display-external'."
  (let ((file (or (car args) (image-dired-original-file-name))))
    (if (and file (my/media--video-p file))
        (start-process "my/media-video-player" nil my/media-video-player file)
      (apply orig-fn args))))

;; The thumbnail grid and the single-image display buffer are both popups
;; matched by the same "^\*image-dired" rule in the dired module, so they
;; share a slot: opening an image reuses that window instead of splitting,
;; and the grid isn't shown anywhere any more. `quit-window' is supposed to
;; restore whatever the popup replaced, but that's easy to miss when nothing
;; visibly explains how to get back. Make "q" always and explicitly return
;; to the grid, landing on the same thumbnail, instead of relying on that.
(defun my/media-close-image-display ()
  "Close the image display popup and return to the media thumbnail grid."
  (interactive)
  ;; Plain `quit-window' is what Doom's own `+popup/quit-window' works around:
  ;; on a popup it falls back to `switch-to-prev-buffer', which doesn't know
  ;; about the thumbnail grid buried underneath and lands on Dired instead.
  ;; `+popup/close' with FORCE-P bypasses this popup's `:quit nil' and just
  ;; deletes the window, leaving the grid buffer intact to pop back into.
  (+popup/close nil t)
  (when-let* ((buf (get-buffer image-dired-thumbnail-buffer)))
    (pop-to-buffer buf)))

;; Plain Dired (not just the thumbnail grid above) hands RET on a video file
;; to `dired-find-file', which opens it in a buffer as if it were text.
;; Play it with `my/media-video-player' instead.
(defun my/media--dired-find-file-a (orig-fn &rest args)
  "Play the file at point with `my/media-video-player' if it's a video.
Otherwise call ORIG-FN with ARGS."
  (let ((file (dired-get-filename nil t)))
    (if (and file (my/media--video-p file))
        (start-process "my/media-video-player" nil my/media-video-player file)
      (apply orig-fn args))))

(after! dired
  (advice-add #'dired-find-file :around #'my/media--dired-find-file-a))

(after! image-dired
  (advice-add #'image-dired-display-image :around #'my/media--play-video-a)
  (advice-add #'image-dired-thumbnail-display-external :around #'my/media--play-video-a)
  ;; The dired module tries to put this mode in emacs state via
  ;; `set-evil-initial-state!', so that a plain "q" binding below (rather
  ;; than an evil-state-qualified one) is what fires. But it does so under
  ;; the mode's pre-29.1 name, `image-dired-display-image-mode', which is now
  ;; only an obsolete function alias, not the major mode - the real mode is
  ;; `image-dired-image-mode'. Since that's never registered, Evil falls
  ;; back to its parent `image-mode', which evil-collection registers as
  ;; `normal' state, where its own "q" -> `quit-window' binding on
  ;; `image-mode-map' shadows anything bound below. Re-register under the
  ;; current name to actually get emacs state.
  (set-evil-initial-state! 'image-dired-image-mode 'emacs)
  (map! :map image-dired-image-mode-map "q" #'my/media-close-image-display)
  ;; `image-dired-thumbnail-mode' (the grid itself, not the single-image
  ;; popup above) has no explicit initial state, so it falls back to
  ;; `evil-default-state', which happens to be `normal' - the state
  ;; evil-collection's image-dired bindings need, since those are what
  ;; make motion skip the separator between thumbnails instead of
  ;; stopping on it. That fallback is easy to end up not in, e.g. by
  ;; entering the grid buffer with a visual selection already active
  ;; elsewhere, so pin it explicitly rather than relying on the default
  ;; staying `normal' or every entry path leaving the buffer in it.
  (set-evil-initial-state! 'image-dired-thumbnail-mode 'normal))

(map! :map dired-mode-map :localleader "m" #'my/media-thumbnails)
;; Media thumbnails:1 ends here

;; [[file:config.org::*Slideshow][Slideshow:1]]
(defcustom my/media-slideshow-image-duration 5
  "Seconds each image is shown for during `my/media-slideshow'."
  :type 'number)

(defun my/media--dired-buffer-files ()
  "Return every file listed in the current Dired buffer, marked or not."
  (save-excursion
    (goto-char (point-min))
    (let (files)
      (while (not (eobp))
        (when-let* ((file (dired-get-filename nil t)))
          (push file files))
        (forward-line 1))
      (nreverse files))))

(defun my/media-slideshow (&optional shuffle)
  "Play every image/video file in the current Dired buffer with mpv.
Uses the marked files if any are marked, otherwise every media file listed
in the buffer. With a prefix argument SHUFFLE, play them in random order."
  (interactive "P" dired-mode)
  (unless (executable-find "mpv")
    (user-error "mpv not found"))
  (require 'image-dired)
  (let* ((marked (dired-get-marked-files nil 'marked))
         ;; Built once: `my/media--file-regexp' runs `regexp-opt' every
         ;; time, which across a few thousand files of a big TMSU query
         ;; added up to most of a second.
         (regexp (my/media--file-regexp))
         (case-fold-search t)
         (files (seq-filter (lambda (file) (string-match-p regexp file))
                            (or marked (my/media--dired-buffer-files)))))
    (unless files
      (user-error "No image or video files %s" (if marked "marked" "in buffer")))
    (apply #'start-process "my/media-slideshow" nil "mpv"
           "--fullscreen"
           ;; Overrides this user's `loop-file=inf' in mpv.conf, which
           ;; otherwise loops the first file forever and never advances.
           "--loop-file=no"
           (format "--image-display-duration=%s" my/media-slideshow-image-duration)
           "--loop-playlist"
           (append (when shuffle '("--shuffle"))
                   files))))

(defun my/media-slideshow-shuffle ()
  "Like `my/media-slideshow', but play files in random order."
  (interactive nil dired-mode)
  (my/media-slideshow t))

(map! :map dired-mode-map :localleader
      "s" #'my/media-slideshow
      "S" #'my/media-slideshow-shuffle)
;; Slideshow:1 ends here

;; [[file:config.org::*Collage][Collage:1]]
(defun my/media-collage (output)
  "Build a masonry collage from the current Dired buffer's files with imgcollage.
Uses the marked files if any are marked, otherwise every file listed in the
buffer. Prompts for OUTPUT, defaulting to a throwaway name under
`temporary-file-directory' since most collages are just for a quick look,
not a keeper -- edit the prompt to save somewhere permanent instead. Writes
the result to OUTPUT, then takes over the frame to show it: the window
layout Dired had (Dirvish's preview pane included) is saved
before switching away, and restored, along with killing the image buffer,
when `q' is pressed -- bound buffer-locally, as `my/tmsu-dired-query-quit'
binds its own `q', since image-mode is shared with every other image Emacs
displays and a mode-wide rebind would affect all of them."
  (interactive
   (list (read-file-name
          "Collage output: " temporary-file-directory nil nil
          (concat (make-temp-name (expand-file-name "collage-" temporary-file-directory))
                  ".jpg")))
   dired-mode)
  (let* ((program (my/program "imgcollage"))
         (marked (dired-get-marked-files nil 'marked))
         (files (or marked (my/media--dired-buffer-files)))
         (config (current-window-configuration)))
    (unless files
      (user-error "No files %s" (if marked "marked" "in buffer")))
    (let ((buf (get-buffer-create "*imgcollage*")))
      (with-current-buffer buf (erase-buffer))
      (make-process
       :name "imgcollage" :buffer buf
       :command (append (list program) files (list "-o" (expand-file-name output)))
       :sentinel
       (lambda (proc _event)
         (when (memq (process-status proc) '(exit signal))
           (if (zerop (process-exit-status proc))
               (progn
                 (message "imgcollage: wrote %s" output)
                 (my/dirvish-reusing-window
                   (delete-other-windows)
                   (find-file output))
                 (let ((ibuf (current-buffer)))
                   (evil-local-set-key
                    'normal "q"
                    (lambda ()
                      (interactive)
                      (kill-buffer ibuf)
                      (set-window-configuration config)))))
             (progn (message "imgcollage failed, see %s" (buffer-name buf))
                    (my/dirvish-reusing-window (pop-to-buffer buf)))))))
      (message "imgcollage: building collage from %d file(s)..." (length files)))))

(map! :map dired-mode-map :localleader "c" #'my/media-collage)
;; Collage:1 ends here

;; [[file:config.org::*Movie grid][Movie grid:1]]
(load! "movie-grid")

(map! :leader :desc "Movie grid" "o M" #'my/movie-grid)
;; Movie grid:1 ends here

;; [[file:config.org::*Synth][Synth:1]]
(defcustom my/synth-soundfont
  (seq-find #'file-exists-p '("/usr/share/soundfonts/FluidR3_GM.sf2"
                               "/usr/share/sounds/sf2/FluidR3_GM.sf2"))
  "SoundFont file fluidsynth loads."
  :type '(choice file (const nil)))

(defcustom my/synth-audio-driver "pulseaudio"
  "Audio driver fluidsynth is started with; see `fluidsynth -a help'."
  :type 'string)

(defcustom my/synth-gain 0.6
  "Master gain fluidsynth is started with, 0 < gain < 10."
  :type 'number)

(defcustom my/synth-program 0
  "General MIDI program number (0-127) notes are played on."
  :type 'integer)

(defcustom my/synth-note-duration 0.32
  "Seconds each note in `my/synth-play-notes' occupies, attack to attack."
  :type 'number)

(defvar my/synth--process nil
  "The persistent fluidsynth process notes are sent to.")

(defvar my/synth--timers nil
  "Pending `run-at-time' timers for in-flight `my/synth-play-notes' playback.")

(defun my/synth--send (process command)
  "Send COMMAND, a fluidsynth shell command, to PROCESS if it's still alive."
  (when (process-live-p process)
    (process-send-string process command)))

(defun my/synth--ensure-process ()
  "Return a live fluidsynth process fed via its stdin shell, starting one if needed."
  (unless (process-live-p my/synth--process)
    (unless (executable-find "fluidsynth")
      (user-error "fluidsynth is not installed"))
    (unless (and my/synth-soundfont (file-exists-p my/synth-soundfont))
      (user-error "my/synth-soundfont is unset or missing: %s" my/synth-soundfont))
    (setq my/synth--process
          (make-process
           :name "synth" :buffer "*synth*" :connection-type 'pipe :noquery t
           :command (list "fluidsynth" "-a" my/synth-audio-driver "-n" "-q"
                          "-g" (number-to-string my/synth-gain)
                          my/synth-soundfont))))
  my/synth--process)

(defun my/synth-stop ()
  "Cancel any pending `my/synth-play-notes' playback and silence the synth."
  (interactive)
  (mapc #'cancel-timer my/synth--timers)
  (setq my/synth--timers nil)
  (my/synth--send my/synth--process "cc 0 123 0\n"))

(defun my/synth-play-notes (notes &optional duration)
  "Play NOTES in sequence, one every DURATION seconds (`my/synth-note-duration'
by default). Each element is a MIDI note number 0-127, or nil for a rest.
Cancels any playback already in flight."
  (my/synth-stop)
  (let ((process (my/synth--ensure-process))
        (duration (or duration my/synth-note-duration))
        (i 0))
    (my/synth--send process (format "prog 0 %d\n" my/synth-program))
    (dolist (note notes)
      (when note
        (let ((start (* i duration)))
          (push (run-at-time start nil
                              (lambda ()
                                (my/synth--send process (format "noteon 0 %d 100\n" note))))
                my/synth--timers)
          (push (run-at-time (+ start (* duration 0.9)) nil
                              (lambda ()
                                (my/synth--send process (format "noteoff 0 %d\n" note))))
                my/synth--timers)))
      (setq i (1+ i)))))

(map! :leader :desc "Stop synth" "o S" #'my/synth-stop)
;; Synth:1 ends here

;; [[file:config.org::*Music theory][Music theory:1]]
(defun my/mtheory--mod12 (n)
  "Reduce N to a pitch class in 0-11."
  (mod n 12))

(defun my/mtheory--pitch-class-to-note (pc)
  "Convert pitch class PC to a note name, counting from A = 0."
  (nth pc '("A" "Bb" "B" "C" "Db" "D" "Eb" "E" "F" "Gb" "G" "Ab")))

(defun my/mtheory--note-to-pitch-class (note)
  "Convert NOTE name to a pitch class, counting from A = 0."
  (cdr (assoc note
              '(("A" . 0) ("Bb" . 1) ("B" . 2) ("C" . 3)
                ("Db" . 4) ("D" . 5) ("Eb" . 6) ("E" . 7)
                ("F" . 8) ("Gb" . 9) ("G" . 10) ("Ab" . 11)))))

(defun my/mtheory--intervals-to-pitch-classes (intervals root)
  "Generate pitch classes by stacking INTERVALS on ROOT."
  (let ((result (list root))
        (current root))
    (dolist (interval intervals)
      (setq current (+ current interval))
      (push (my/mtheory--mod12 current) result))
    (nreverse result)))

(defcustom my/mtheory-play-octave 4
  "Octave (scientific pitch notation, where C4 = middle C) matrix buttons
and `my/mtheory-play-pitch-classes' play in."
  :type 'integer)

(defun my/mtheory--pitch-class-to-midi (pc)
  "Convert pitch class PC (0-11, counting from A = 0) to a MIDI note number
in `my/mtheory-play-octave'."
  (+ (my/mtheory--mod12 (- pc 3)) (* 12 (1+ my/mtheory-play-octave))))

(defun my/mtheory-play-pitch-classes (pcs)
  "Play PCS, a list of pitch classes (0-11, counting from A = 0), through
`my/synth-play-notes'."
  (my/synth-play-notes (mapcar #'my/mtheory--pitch-class-to-midi pcs)))

;; A dedicated link type rather than a plain `elisp:' link so clicking a
;; matrix button doesn't trigger `org-confirm-elisp-link-function' on every
;; click -- that confirmation gate only guards the built-in "elisp" type.
;; Deferred until org loads: at Doom startup config.el runs before Org is
;; necessarily loaded, and `org-link-set-parameters' is void until then.
(after! org
  (org-link-set-parameters
   "synth"
   :follow (lambda (path &optional _arg) (my/mtheory-play-pitch-classes (read path)))))

(defun my/mtheory-12-tone-matrix (row)
  "Insert the 12-tone matrix of ROW at point as an Org table, with play
buttons on all four sides. ROW is read as a Lisp list of the pitch classes
0-11 in any order.

Each data row is a transposition of ROW read left to right (P); the button
to its left plays it forward, the button to its right plays it backward, the
retrograde (R). Each data column is an inversion (I) read top to bottom; the
button above it plays top-to-bottom, the button below plays bottom-to-top,
the retrograde inversion (RI). Buttons play the matrix as generated -- a
hand-edited cell doesn't change what its row/column buttons play."
  (interactive (list (read (read-string "Row: "))))
  (unless (equal (sort (copy-sequence row) #'<) (number-sequence 0 11))
    (user-error "Row must contain each pitch class 0-11 exactly once"))
  (let* ((p0 (mapcar (lambda (x) (my/mtheory--mod12 (- x (car row)))) row))
         (i0 (mapcar (lambda (x) (my/mtheory--mod12 (- x))) p0))
         (matrix (mapcar (lambda (transposition)
                            (mapcar (lambda (p) (my/mtheory--mod12 (+ p transposition))) p0))
                          i0))
         (columns (mapcar (lambda (j) (mapcar (lambda (r) (nth j r)) matrix))
                           (number-sequence 0 11)))
         (button (lambda (glyph pcs) (format "[[synth:%S][%s]]" pcs glyph)))
         (table-start (point)))
    (insert "|   | "
            (mapconcat (lambda (col) (funcall button "▼" col)) columns " | ")
            " |   |\n")
    (insert "|-\n")
    (dolist (r matrix)
      (insert "| " (funcall button "▶" r) " | "
              (mapconcat #'number-to-string r " | ")
              " | " (funcall button "◀" (reverse r)) " |\n"))
    (insert "|-\n")
    (insert "|   | "
            (mapconcat (lambda (col) (funcall button "▲" (reverse col))) columns " | ")
            " |   |\n")
    (save-excursion (goto-char table-start) (org-table-align))))

(defun my/mtheory-table-to-notes ()
  "Convert the Org table at point from pitch classes to note names. Skips
over any [[synth:...][...]] play buttons, whose link path also holds
digits, so it doesn't rewrite the data those buttons play."
  (interactive)
  (let ((end (copy-marker (org-table-end))))
    (save-excursion
      (goto-char (org-table-begin))
      (while (re-search-forward
              "\\[\\[[^]]*\\]\\[[^]]*\\]\\]\\|\\b\\([0-9]+\\)\\b" end t)
        (when-let* ((group (match-string 1)))
          (let ((pc (string-to-number group)))
            (when (< pc 12)
              (replace-match (my/mtheory--pitch-class-to-note pc) t t nil 1))))))
    (set-marker end nil)
    (org-table-align)))

(defun my/mtheory-table-to-pitch-classes ()
  "Convert the Org table at point from note names to pitch classes. Skips
over any [[synth:...][...]] play buttons the same way
`my/mtheory-table-to-notes' does."
  (interactive)
  (let ((end (copy-marker (org-table-end))))
    (save-excursion
      (goto-char (org-table-begin))
      (while (re-search-forward
              "\\[\\[[^]]*\\]\\[[^]]*\\]\\]\\|\\b\\(A\\|Bb\\|B\\|C\\|Db\\|D\\|Eb\\|E\\|F\\|Gb\\|G\\|Ab\\)\\b"
              end t)
        (when-let* ((group (match-string 1)))
          (replace-match (number-to-string
                          (my/mtheory--note-to-pitch-class group))
                         t t nil 1))))
    (set-marker end nil)
    (org-table-align)))

(defun my/mtheory-intervals-to-notes (intervals)
  "Insert an Org table of the INTERVALS pattern in all 12 keys."
  (interactive (list (read (read-string "Intervals: "))))
  (insert (format "#+TITLE: Intervals %S\n\n" intervals))
  (insert "| Notes |\n")
  (insert "|-------|\n")
  (let ((table-start (point)))
    (dotimes (root 12)
      (insert (format "| %s |\n"
                      (mapconcat #'my/mtheory--pitch-class-to-note
                                 (my/mtheory--intervals-to-pitch-classes intervals root)
                                 " "))))
    (save-excursion
      (goto-char table-start)
      (org-table-align))))

(defun my/mtheory-respell-scale ()
  "Respell a scale so each note uses the next letter name; insert it at point.

Examples:
  G A B C D E Gb   -> G A B C D E F#
  A B Db D E Gb Ab -> A B C# D E F# G#"
  (interactive)
  (let* ((input (read-string "Scale: "))
         (notes (split-string input "[ \t]+" t))
         ;; Pitch class for each accepted spelling.
         (pitch-table
          '(("C" . 0)  ("B#" . 0)
            ("C#" . 1) ("Db" . 1)
            ("D" . 2)
            ("D#" . 3) ("Eb" . 3)
            ("E" . 4)  ("Fb" . 4)
            ("F" . 5)  ("E#" . 5)
            ("F#" . 6) ("Gb" . 6)
            ("G" . 7)
            ("G#" . 8) ("Ab" . 8)
            ("A" . 9)
            ("A#" . 10) ("Bb" . 10)
            ("B" . 11) ("Cb" . 11)))
         ;; Given an expected letter and a pitch class, how should it be spelled?
         (spell-table
          '(("C" . ((0 . "C") (1 . "C#")))
            ("D" . ((2 . "D") (3 . "D#")))
            ("E" . ((4 . "E")))
            ("F" . ((5 . "F") (6 . "F#")))
            ("G" . ((7 . "G") (8 . "G#")))
            ("A" . ((9 . "A") (10 . "A#")))
            ("B" . ((11 . "B")))))
         (next-letter
          '(("A" . "B")
            ("B" . "C")
            ("C" . "D")
            ("D" . "E")
            ("E" . "F")
            ("F" . "G")
            ("G" . "A")))
         (result nil)
         (prev-letter nil))
    (dolist (note notes)
      (let* ((letter (substring note 0 1))
             (pitch (cdr (assoc note pitch-table))))
        (unless pitch
          (user-error "Don't know how to parse note %s" note))
        (if (null prev-letter)
            ;; Keep first note exactly as entered.
            (progn
              (push note result)
              (setq prev-letter letter))
          (let* ((expected (cdr (assoc prev-letter next-letter)))
                 (spelling
                  (or (cdr (assoc pitch (cdr (assoc expected spell-table))))
                      note)))
            (push spelling result)
            (setq prev-letter expected)))))
    (insert (mapconcat #'identity (nreverse result) " "))))
;; Music theory:1 ends here

;; [[file:config.org::*Notation][Notation:1]]
(autoload 'lilypond-mode "lilypond-mode" "Major mode for editing LilyPond files." t)
(add-to-list 'auto-mode-alist '("\\.i?ly\\'" . lilypond-mode))

(when-let* ((mode-file (locate-library "lilypond-mode")))
  (dolist (file (directory-files (file-name-directory mode-file) t
                                 "\\`lilypond-.*\\.el\\'"))
    (add-to-list 'warning-suppress-types
                 `(files missing-lexbind-cookie ,(abbreviate-file-name file)))))

(setq org-babel-default-header-args:lilypond
      '((:results . "file") (:exports . "results")))

(defcustom my/lilypond-staff-size 20
  "Staff height, in points, lilypond blocks are engraved at; LilyPond's own
default is 20. A block can override it with #(set-global-staff-size N)."
  :type 'number)

(defcustom my/lilypond-png-resolution 200
  "Resolution, in DPI, lilypond blocks with a .png :file render at."
  :type 'integer)

(defun my/lilypond--preamble ()
  "LilyPond source prepended to every lilypond block: English note names, the
staff size, and no indent, titles, headers or footers."
  (format "\\language \"english\"
#(set-global-staff-size %s)
\\paper {
  indent = 0\\mm
  tagline = ##f
  oddHeaderMarkup = ##f
  evenHeaderMarkup = ##f
  oddFooterMarkup = ##f
  evenFooterMarkup = ##f
  bookTitleMarkup = ##f
  scoreTitleMarkup = ##f
}
" my/lilypond-staff-size))

(defun my/lilypond--process-basic (body params)
  "Render lilypond block BODY to its :file, cropped to the music.
Overrides `org-babel-lilypond-process-basic'. The :file extension picks the
format: svg, png, pdf or eps."
  (let* ((out-file (or (cdr (assq :file params))
                       (user-error "lilypond blocks need a :file header argument")))
         (type (downcase (or (file-name-extension out-file) "")))
         (in-file (org-babel-temp-file "lilypond-" ".ly")))
    (with-temp-file in-file
      (insert (my/lilypond--preamble)
              (org-babel-expand-body:lilypond body params)))
    (org-babel-eval
     (string-join
      (list org-babel-lilypond-ly-command
            "--loglevel=ERROR"
            "-dno-use-paper-size-for-page"
            (concat "-dtall-page-formats=" type)
            (pcase type
              ("svg" "-dbackend=svg")
              ("png" (format "--png -dresolution=%d" my/lilypond-png-resolution))
              ("pdf" "--pdf")
              ("eps" "--eps")
              (_ (user-error "Can't render lilypond to .%s; use svg, png, pdf or eps"
                             type)))
            (concat "--output="
                    (shell-quote-argument (file-name-sans-extension out-file)))
            (or (cdr (assq :cmdline params)) "")
            (shell-quote-argument in-file))
      " ")
     "")
    nil))

(after! ob-lilypond
  (setf (alist-get "lilypond" org-src-lang-modes nil nil #'equal) 'lilypond)
  (advice-add 'org-babel-lilypond-process-basic :override
              #'my/lilypond--process-basic))
;; Notation:1 ends here

;; [[file:config.org::*Jabber][Jabber:1]]
(defvar my/jabber-accounts nil
  "XMPP accounts to connect at startup, as (JID . PASS-ENTRY) pairs.
PASS-ENTRY names the password-store entry holding JID's password.")

(defun my/jabber-connect-h ()
  "Connect every account in `my/jabber-accounts', if there are any."
  (when my/jabber-accounts
    (condition-case err
        (jabber-connect-all)
      (error (warn "Jabber: not connecting: %s" (error-message-string err))))))

(use-package! jabber
  :bind-keymap ("C-x C-j" . jabber-global-keymap)
  :init
  (add-hook 'doom-after-init-hook #'my/jabber-connect-h)
  :config
  (setq jabber-account-list
        (mapcar (lambda (account)
                  `(,(car account) (:password . ,(+pass-get-secret (cdr account)))))
                my/jabber-accounts))
  (jabber-modeline-mode 1)
  (add-hook 'kill-emacs-hook #'jabber-disconnect))
;; Jabber:1 ends here

;; [[file:config.org::*IRC][IRC:2]]
(map! :leader :desc "IRC" "o i" #'=irc)
;; IRC:2 ends here

;; [[file:config.org::*Spelling][Spelling:1]]
(after! ispell
  (setq ispell-dictionary "en_US,de_DE")
  (ispell-set-spellchecker-params)
  (condition-case err
      (ispell-hunspell-add-multi-dic ispell-dictionary)
    (error (warn "Hunspell multi-dictionary setup failed: %s"
                 (error-message-string err)))))

(map! :leader :desc "Spell check buffer" "o s" #'ispell)
;; Spelling:1 ends here

;; [[file:config.org::*Wiktionary][Wiktionary:1]]
(defun my/wiktionary-lookup ()
  "Look up the word at point on Wiktionary in eww."
  (interactive)
  (if-let* ((word (thing-at-point 'word t)))
      (eww-browse-url (format "https://en.wiktionary.org/wiki/%s"
                              (url-hexify-string word)))
    (message "No word at point")))

(map! :leader
      :desc "Wiktionary lookup" "s w" #'my/wiktionary-lookup)
;; Wiktionary:1 ends here

;; [[file:config.org::*Translate][Translate:1]]
(defun my/translate (language pair)
  "Translate the region or a prompted LANGUAGE phrase with translate-shell PAIR."
  (unless (executable-find "trans")
    (user-error "translate-shell (trans) is not installed"))
  (let ((text (if (use-region-p)
                  (buffer-substring-no-properties (region-beginning) (region-end))
                (read-string (format "%s: " language)))))
    (with-help-window (format "*%s Translation*" language)
      (with-current-buffer standard-output
        (call-process "trans" nil standard-output nil
                      "-show-original" "n" pair text)))))

(defun my/translate-latin ()
  "Translate the region or a prompted Latin phrase to English."
  (interactive)
  (my/translate "Latin" "la:en"))

(defun my/translate-german ()
  "Translate the region or a prompted German phrase to English."
  (interactive)
  (my/translate "German" "de:en"))

(map! :leader
      :desc "Translate Latin"  "o l" #'my/translate-latin
      :desc "Translate German" "o g" #'my/translate-german)
;; Translate:1 ends here

;; [[file:config.org::*Password store][Password store:1]]
(map! :leader :desc "Password store" "o p" #'pass)

(after! pass
  (set-popup-rule! "^\\*Password-Store" :ignore t))
;; Password store:1 ends here

;; [[file:config.org::*Email][Email:1]]
(setq sendmail-program (executable-find "msmtp")
      send-mail-function #'sendmail-send-it
      message-send-mail-function #'message-send-mail-with-sendmail
      message-sendmail-f-is-evil t
      message-sendmail-extra-arguments '("--read-envelope-from"))
;; Email:1 ends here

;; [[file:config.org::*Email][Email:2]]
(after! mu4e
  (setq mu4e-maildir (expand-file-name user-mail-address "~/.local/share/mail/")
        message-send-mail-function #'message-send-mail-with-sendmail

        mu4e-drafts-folder "/Drafts"
        mu4e-sent-folder   "/Sent"
        mu4e-trash-folder  "/Trash"
        mu4e-refile-folder "/Archive"))
;; Email:2 ends here

;; [[file:config.org::*Contacts][Contacts:1]]
(use-package! bbdb
  :after mu4e
  :config
  (setq bbdb-file "~/.local/share/bbdb")
  (bbdb-initialize 'mu4e 'message))

(map! :leader :desc "Contacts" "o b" #'bbdb)
(map! :leader :desc "New contact" "o B" #'bbdb-create)
;; Contacts:1 ends here

;; [[file:config.org::*Calling][Calling:1]]
(defun my/tel-string-to-cheogram-jid (tel-string)
  "Normalize TEL-STRING, tel: prefix optional, to a Cheogram gateway JID."
  (let* ((digits (replace-regexp-in-string "[^0-9]" "" tel-string))
         (digits (if (= (length digits) 10) (concat "1" digits) digits)))
    (format "+%s@cheogram.com" digits)))

(defun my/browse-tel-with-dino (url &rest _args)
  "Open a tel: URL as an xmpp: chat with its Cheogram gateway JID in Dino."
  (browse-url-xdg-open
   (concat "xmpp:" (my/tel-string-to-cheogram-jid url))))

(require 'browse-url)
(add-to-list 'browse-url-handlers (cons "\\`tel:" #'my/browse-tel-with-dino))

(after! (bbdb jabber)
  (defun my/bbdb-jabber-chat (phone)
    "Open PHONE's Cheogram gateway JID as a chat in jabber.el, instead of dialing."
    (interactive (list (bbdb-current-field)))
    (when (eq (car-safe phone) 'name)
      (setq phone (car (bbdb-record-phone (bbdb-current-record)))))
    (when (eq (car-safe phone) 'phone)
      (setq phone (car (cdr phone))))
    (or (bbdb-phone-p phone) (user-error "Not on a phone field"))
    (jabber-handle-uri
     (concat "xmpp:" (my/tel-string-to-cheogram-jid (bbdb-phone-string phone)))))

  (define-key bbdb-mode-map (kbd "M-c") #'my/bbdb-jabber-chat))
;; Calling:1 ends here

;; [[file:config.org::*osm.el][osm.el:1]]
(use-package! osm
  :defer t
  :init
  (map! :leader :desc "Map" "o G" #'osm-prefix-map)
  :config
  (set-evil-initial-state! 'osm-mode 'emacs)
  (map! :map osm-mode-map "p" #'my/osm-send-to-phone))

(defun my/osm-send-to-phone ()
  "Send the selected pin, or else the map's center, to the phone."
  (interactive nil osm-mode)
  (pcase-let ((`(,lat ,lon ,name) (osm--fetch-location-data "Sent to phone")))
    (my/localsend-send-text
     (my/geo-uri lat lon (and name (my/geo-short-label name))))))
;; osm.el:1 ends here

;; [[file:config.org::*Sending to the phone][Sending to the phone:1]]
(defvar my/localsend-phone-alias nil
  "The phone's device name in LocalSend, or nil for any phone that answers.")

(defvar my/localsend-pin nil
  "PIN the phone's LocalSend asks senders for, or nil if it asks for none.")

(defvar my/localsend-port 53317
  "Port LocalSend listens on, 53317 unless changed in the app.")

(defvar my/localsend--phone nil
  "IP address where the phone answered the last scan.")

(defun my/localsend--lan-prefix ()
  "Return the first three octets of the Wi-Fi or Ethernet IPv4 address."
  (pcase (seq-find (lambda (iface) (string-match-p "\\`\\(wl\\|en\\|eth\\)" (car iface)))
                   (network-interface-list nil 'ipv4))
    (`(,_ . [,a ,b ,c ,_ ,_]) (format "%d.%d.%d" a b c))
    (_ (user-error "LocalSend: not on a local network"))))

(defun my/localsend--find-phone (prefix dir)
  "Return the phone's IP address among the /info answers saved in DIR.
Each file there is named for the last octet of the PREFIX address that
answered."
  (seq-some
   (lambda (octet)
     (let ((info (ignore-errors
                   (with-temp-buffer
                     (insert-file-contents (expand-file-name octet dir))
                     (json-parse-buffer :object-type 'plist)))))
       (and info
            (if my/localsend-phone-alias
                (equal (plist-get info :alias) my/localsend-phone-alias)
              (equal (plist-get info :deviceType) "mobile"))
            (format "%s.%s" prefix octet))))
   (directory-files dir nil "\\`[0-9]+\\'")))

(defun my/localsend--scan (callback)
  "Look for the phone on the LAN, and call CALLBACK with its IP address."
  (let ((prefix (my/localsend--lan-prefix))
        (dir (make-temp-file "localsend-" t)))
    (message "LocalSend: looking for the phone on %s.0/24..." prefix)
    (make-process
     :name "localsend-scan" :noquery t :connection-type 'pipe
     :command (list "curl" "--silent" "--insecure"
                    "--parallel" "--parallel-max" "254"
                    "--connect-timeout" "1" "--max-time" "3"
                    "--output" (expand-file-name "#1" dir)
                    (format "https://%s.[1-254]:%d/api/localsend/v2/info"
                            prefix my/localsend-port))
     :sentinel
     (lambda (proc _event)
       (unless (process-live-p proc)
         (let ((ip (my/localsend--find-phone prefix dir)))
           (delete-directory dir t)
           (if (not ip)
               (message "LocalSend: no phone answered; is the app open on it?")
             (setq my/localsend--phone ip)
             (funcall callback ip))))))))

(defun my/localsend--send (ip text &optional if-unreachable)
  "Send TEXT as a LocalSend message to the phone at IP.
When nothing answers at IP, call IF-UNREACHABLE instead of reporting it."
  (let* ((size (length (encode-coding-string text 'utf-8)))
         (body (json-serialize
                `(:info (:alias ,(format "Emacs on %s" (system-name))
                         :version "2.1" :deviceModel "Emacs" :deviceType "desktop"
                         :fingerprint ,(md5 (system-name)) :port ,my/localsend-port
                         :protocol "https" :download :false)
                  :files (:message (:id "message" :fileName "message.txt"
                                    :size ,size :fileType "text/plain"
                                    :preview ,text)))))
         (proc
          (make-process
           :name "localsend-send" :noquery t
           :connection-type 'pipe :coding 'binary
           :buffer (generate-new-buffer " *localsend-send*")
           :command (list "curl" "--silent" "--insecure" "--connect-timeout" "2"
                          "--output" "/dev/null"
                          "--write-out" "%{http_code} %{num_connects}"
                          "--header" "Content-Type: application/json"
                          "--data-binary" "@-"
                          (format "https://%s:%d/api/localsend/v2/prepare-upload%s"
                                  ip my/localsend-port
                                  (if my/localsend-pin
                                      (format "?pin=%s" my/localsend-pin)
                                    "")))
           :sentinel
           (lambda (proc _event)
             (unless (process-live-p proc)
               (pcase-let ((`(,code ,connects)
                            (with-current-buffer (process-buffer proc)
                              (split-string (buffer-string)))))
                 (kill-buffer (process-buffer proc))
                 (cond
                  ((and (equal connects "0") if-unreachable)
                   (funcall if-unreachable))
                  ((equal connects "0")
                   (message "LocalSend: nothing answered at %s" ip))
                  (t
                   (message "LocalSend: %s"
                            (pcase code
                              ((or "200" "204") "the phone has it")
                              ("401" "the phone wants a PIN; set `my/localsend-pin'")
                              ("403" "declined on the phone")
                              ("409" "the phone is busy with another transfer")
                              ("000" "lost the connection to the phone")
                              (_ (format "the phone answered HTTP %s" code))))))))))))
    (message "LocalSend: sending to %s..." ip)
    (process-send-string proc body)
    (process-send-eof proc)))

(defun my/localsend-send-text (text)
  "Send TEXT to the phone as a LocalSend message.
Interactively, send the region, or else prompt with the geo: link or
URL at point as the default."
  (interactive
   (list (if (use-region-p)
             (buffer-substring-no-properties (region-beginning) (region-end))
           (let ((default (or (cadr (my/geo-at-point)) (thing-at-point 'url t))))
             (read-string (format-prompt "Send to phone" default) nil nil default)))))
  (when (string-blank-p text)
    (user-error "Nothing to send"))
  (let ((send (lambda (ip) (my/localsend--send ip text))))
    (if my/localsend--phone
        (my/localsend--send my/localsend--phone text
                            (lambda () (my/localsend--scan send)))
      (my/localsend--scan send))))

(map! :leader :desc "Send to phone" "o y" #'my/localsend-send-text)
;; Sending to the phone:1 ends here

;; [[file:config.org::*geo: links][geo: links:1]]
(defun my/geo-parse (uri)
  "Return (LAT LON LABEL) from geo URI, or nil if it isn't one.
LABEL is the place's name from a `?q=LAT,LON(LABEL)' query, or nil."
  (when (string-match "\\`geo:\\(-?[0-9.]+\\),\\(-?[0-9.]+\\)" uri)
    (list (string-to-number (match-string 1 uri))
          (string-to-number (match-string 2 uri))
          (and (string-match "[?&]q=[^&]*(\\([^)]+\\))" uri)
               (decode-coding-string (url-unhex-string (match-string 1 uri))
                                     'utf-8)))))

(defun my/geo-uri (lat lon &optional label)
  "Return a geo URI for LAT/LON, naming the place LABEL if non-nil."
  (if label
      (format "geo:%.6f,%.6f?q=%.6f,%.6f(%s)"
              lat lon lat lon (url-hexify-string label))
    (format "geo:%.6f,%.6f" lat lon)))

(defun my/geo-short-label (name)
  "Cut NAME, a place's description, down to the place's name.
For a building without one, keep the house number and street. Return
nil when NAME starts with coordinates, osm.el's description of a place
the lookup found nothing for."
  (let ((parts (split-string name ", *" t "[ \t\n]+")))
    (cond ((or (null parts) (string-search "°" (car parts))) nil)
          ((and (cdr parts) (string-match-p "\\`[0-9]+[A-Za-z]?\\'" (car parts)))
           (concat (car parts) " " (cadr parts)))
          (t (car parts)))))

(defun my/geo-normalize (uri &optional label)
  "Rewrite geo URI in the form `my/geo-uri' makes, naming it LABEL if given."
  (pcase-let ((`(,lat ,lon ,query-label) (my/geo-parse uri)))
    (unless lat
      (user-error "Not a geo: URI: %s" uri))
    (my/geo-uri lat lon (let ((name (or label query-label)))
                          (and name (my/geo-short-label name))))))

(defun my/geo-at-point ()
  "Return the geo: URI at point as an Embark target, (geo URI BEG . END).
An Org link's description becomes the place's label."
  (require 'thingatpt)
  (when (or (thing-at-point-looking-at
             "\\[\\[\\(geo:[^]]+\\)]\\(?:\\[\\([^]]+\\)]\\)?]" 500)
            (thing-at-point-looking-at
             "\\(geo:-?[0-9.]+,-?[0-9.]+[^][ \t\n\"<>]*\\)" 200))
    (let ((beg (match-beginning 0))
          (end (match-end 0))
          (uri (match-string-no-properties 1))
          (label (match-string-no-properties 2)))
      `(geo ,(my/geo-normalize uri label) ,beg . ,end))))

(defun my/geo-read-uri (prompt)
  "Read a geo URI with PROMPT, defaulting to the one at point."
  (let ((default (cadr (my/geo-at-point))))
    (read-string (format-prompt prompt default) nil nil default)))

(defun my/geo-send-to-phone (uri)
  "Send the place in geo URI to the phone."
  (interactive (list (my/geo-read-uri "Send place to phone")))
  (my/localsend-send-text (my/geo-normalize uri)))

(defun my/geo-show-on-map (uri)
  "Show the place in geo URI on an osm.el map."
  (interactive (list (my/geo-read-uri "Show place")))
  (pcase-let ((`(,lat ,lon) (or (my/geo-parse uri)
                                (user-error "Not a geo: URI: %s" uri))))
    (osm-url (format "geo:%s,%s;z=17" lat lon))))

(after! embark
  (defvar-keymap my/embark-geo-map
    :doc "Embark actions for geo: links."
    :parent embark-general-map
    "RET" #'my/geo-send-to-phone
    "p" #'my/geo-send-to-phone
    "m" #'my/geo-show-on-map)
  (add-to-list 'embark-keymap-alist '(geo . my/embark-geo-map))
  (add-to-list 'embark-target-finders #'my/geo-at-point))
;; geo: links:1 ends here

;; [[file:config.org::*RSS][RSS:1]]
(setq rmh-elfeed-org-files '("feeds.org"))

(after! elfeed
  (setq elfeed-search-title-max-width 70)
  ;; `elfeed-search-filter' is `:local t' (auto-buffer-local), so a plain
  ;; `setq' here only sets it in whatever buffer is current when elfeed
  ;; loads -- not the *elfeed-search* buffer. Needs `setq-default'.
  (setq-default elfeed-search-filter "@2-week-ago +unread -forums -firehose")
  (map! :map elfeed-search-mode-map "z" #'elfeed-tree))

(map! :leader :desc "Elfeed" "o n" #'elfeed)
;; RSS:1 ends here

;; [[file:config.org::*RSS][RSS:2]]
(after! elfeed
  (defvar-local +elfeed-show-linked-view nil
    "Non-nil while the show buffer displays fetched link content instead of
the entry itself.")

  (defun +elfeed-show--link-candidates ()
    "Collect (LABEL . URL) for every link elfeed rendered in this buffer."
    (let ((links nil) (pos (point-min)))
      (save-excursion
        (while (< pos (point-max))
          (if-let* ((url (get-text-property pos 'shr-url)))
              (let* ((end (or (next-single-property-change pos 'shr-url nil (point-max))
                               (point-max)))
                     (text (string-trim (buffer-substring-no-properties pos end))))
                (unless (or (string-empty-p text) (rassoc url links))
                  (push (cons text url) links))
                (setq pos end))
            (setq pos (or (next-single-property-change pos 'shr-url nil (point-max))
                          (point-max))))))
      (nreverse links)))

  (defun +elfeed-show-browse-link (&optional arg)
    "Prompt for one of this entry's links and replace the buffer with its
fetched content, run through eww's readability filter to strip nav/header/
sitemap boilerplate. Press `q' to return to the normal entry.

A prefix argument toggles two independent options, stacked by how many
times \\[universal-argument] is pressed:
  C-u          show the fetched page as-is, skipping the readability filter
               (useful when readability guts a non-article page, e.g. a
               comment thread, rather than cleaning it up)
  C-u C-u      fetch through `mullvad-exclude curl', bypassing the VPN --
               useful for sites that block Mullvad exit nodes
  C-u C-u C-u  both of the above"
    (interactive "P" elfeed-show-mode)
    (when +elfeed-show-linked-view
      (elfeed-show-refresh)
      (setq +elfeed-show-linked-view nil))
    (let* ((level (if arg (round (log (prefix-numeric-value arg) 4)) 0))
           (raw (/= 0 (logand level 1)))
           (bypass-vpn (/= 0 (logand level 2)))
           (links (+elfeed-show--link-candidates))
           (candidates (mapcar (lambda (l) (cons (format "%s  —  %s" (car l) (cdr l)) (cdr l)))
                                links))
           (choice (completing-read "Open link: " candidates nil t))
           (url (cdr (assoc choice candidates))))
      (message "Fetching %s%s..." url (if bypass-vpn " (via mullvad-exclude)" ""))
      (cl-letf* ((real-start-process (symbol-function 'start-process))
                 ((symbol-function 'start-process)
                  (if bypass-vpn
                      (lambda (name buffer program &rest args)
                        (apply real-start-process name buffer "mullvad-exclude" program args))
                    real-start-process)))
        (elfeed-show--fetch
         (lambda (fetched-url content)
           (let ((inhibit-read-only t)
                 (elfeed-transform-html-functions (unless raw (list #'elfeed-show--readable))))
             (erase-buffer)
             (pcase content
               (:error (insert (propertize (format "Failed to fetch %s\n" fetched-url) 'face 'error)))
               (:fetching (insert (propertize "Fetching...\n" 'face 'italic)))
               ((pred stringp) (elfeed-insert-html content (elfeed-compute-base fetched-url))))
             (goto-char (point-min))
             (setq +elfeed-show-linked-view t)))
         :url url :force t))))

  (defun +elfeed-show-quit ()
    "Return to the normal entry view if a fetched link is showing, otherwise
quit the entry buffer as usual."
    (interactive nil elfeed-show-mode)
    (if +elfeed-show-linked-view
        (progn (elfeed-show-refresh) (setq +elfeed-show-linked-view nil))
      (quit-window)))

  ;; Bound with the `:n' (normal-state) qualifier: elfeed-show-mode runs in
  ;; evil normal state, which falls back to `evil-motion-state-map' for any
  ;; key it doesn't bind itself -- and motion state already claims plain "L"
  ;; for `evil-window-bottom'. A state-qualified `map!' installs into the
  ;; mode's own normal-state override keymap, which evil consults first.
  (map! :map elfeed-show-mode-map
        :n "L" #'+elfeed-show-browse-link
        :n "q" #'+elfeed-show-quit))
;; RSS:2 ends here

;; [[file:config.org::*Solar times][Solar times:1]]
(require 'solar)

(if-let* ((lat (getenv "ASTRO_LAT"))
          (long (getenv "ASTRO_LONG")))
    (setq calendar-latitude (string-to-number lat)
          calendar-longitude (string-to-number long))
  (warn "ASTRO_LAT/ASTRO_LONG are unset: no solar times, weather, or planet positions"))

(defun my/solar-assert-coordinates ()
  "Signal a `user-error' unless `calendar-latitude'/`calendar-longitude' are set."
  (unless (and calendar-latitude calendar-longitude)
    (user-error "No location: ASTRO_LAT/ASTRO_LONG were unset when Emacs started")))
;; Solar times:1 ends here

;; [[file:config.org::*Solar times][Solar times:2]]
(setq lunar-phase-names '("🌑 New Moon" "🌓 First Quarter Moon"
                           "🌕 Full Moon" "🌗 Last Quarter Moon"))
;; Solar times:2 ends here

;; [[file:config.org::*Solar times][Solar times:3]]
(defun my/solar-times (&optional date)
  "List (SUNRISE SOLAR-NOON SUNSET SOLAR-MIDNIGHT ZONE) for DATE.
Each time is a decimal hour; ZONE is the value `solar-time-string' wants
alongside it. DATE defaults to today. nil if the sun neither rises nor
sets on DATE, as happens near the poles, or if there are no coordinates."
  (when (and calendar-latitude calendar-longitude)
    (pcase-let ((`(,rise ,set ,_) (solar-sunrise-sunset (or date (calendar-current-date)))))
      (when (and rise set)
        (let* ((rise-time (car rise))
               (set-time (car set))
               (zone (cadr rise))
               (noon (/ (+ rise-time set-time) 2)))
          (list rise-time noon set-time (mod (+ noon 12) 24) zone))))))

(defun my/diary-solar-times ()
  "Diary sexp: today's sunrise, solar noon, sunset, and solar midnight."
  (with-no-warnings (defvar date))
  (when (calendar-date-equal date (calendar-current-date))
    (pcase (my/solar-times date)
      (`(,rise ,noon ,set ,midnight ,zone)
       (format "Sunrise %s | Noon %s | Sunset %s | Midnight %s"
               (solar-time-string rise zone)
               (solar-time-string noon zone)
               (solar-time-string set zone)
               (solar-time-string midnight zone))))))
;; Solar times:3 ends here

;; [[file:config.org::*Planetary hours][Planetary hours:1]]
(defconst my/planetary-hours-order
  '(("Saturn" . "♄") ("Jupiter" . "♃") ("Mars" . "♂") ("Sun" . "☉")
    ("Venus" . "♀") ("Mercury" . "☿") ("Moon" . "☽"))
  "The seven classical planets and their glyphs, slowest to fastest, in
the order they take successive turns ruling a planetary hour.")

(defconst my/planetary-hours-day-rulers
  ["Sun" "Moon" "Mars" "Mercury" "Jupiter" "Venus" "Saturn"]
  "Planet ruling a day's first hour, indexed like `calendar-day-of-week'
(Sunday first) -- also that day's own namesake.")
;; Planetary hours:1 ends here

;; [[file:config.org::*Planetary hours][Planetary hours:2]]
(defun my/planetary-hours--moment (date hour)
  "The moment decimal HOUR on DATE's clock comes round, HOUR read the
way `my/solar-times' gives it: local time, DST included."
  (pcase-let ((`(,month ,day ,year) date)
              (seconds (round (* hour 3600))))
    (encode-time (list (% seconds 60) (% (/ seconds 60) 60) (/ seconds 3600)
                       day month year nil -1 nil))))

(defun my/planetary-hours--hours (date)
  "Compute the planetary hours ruling DATE.
Returns a list (SUNRISE SUNSET HOURS), SUNRISE and SUNSET as Lisp
timestamps. HOURS has 24 entries of (FROM TO NAME GLYPH), FROM/TO Lisp
timestamps too. The first twelve entries divide sunrise to sunset
evenly, the last twelve divide that sunset to the following sunrise
evenly, by the time that actually passes rather than what the clock
says, and together they cycle through `my/planetary-hours-order'
starting from the planet that rules DATE's weekday. Signals a
`user-error' if the sun neither rises nor sets on DATE or the day
after, as happens near the poles."
  (my/solar-assert-coordinates)
  (pcase-let*
      ((`(,rise ,_ ,set ,_ ,_)
        (or (my/solar-times date)
            (user-error "The sun neither rises nor sets on %s"
                        (calendar-date-string date t))))
       (next-date (calendar-gregorian-from-absolute
                   (1+ (calendar-absolute-from-gregorian date))))
       (next-rise (or (car (my/solar-times next-date))
                      (user-error "The sun neither rises nor sets on %s"
                                  (calendar-date-string next-date t))))
       (sunrise (my/planetary-hours--moment date rise))
       (sunset (my/planetary-hours--moment date set))
       (next-sunrise (my/planetary-hours--moment next-date next-rise))
       (day-hour (/ (float-time (time-subtract sunset sunrise)) 12))
       (night-hour (/ (float-time (time-subtract next-sunrise sunset)) 12))
       (ruler (aref my/planetary-hours-day-rulers (calendar-day-of-week date)))
       (start (seq-position my/planetary-hours-order ruler
                            (lambda (pair name) (equal (car pair) name))))
       (hours nil))
    (dotimes (i 24)
      (let* ((night (>= i 12))
             (length (if night night-hour day-hour))
             (from (time-add (if night sunset sunrise) (* (mod i 12) length)))
             (planet (nth (mod (+ start i) 7) my/planetary-hours-order)))
        (push (list from (time-add from length) (car planet) (cdr planet)) hours)))
    (list sunrise sunset (nreverse hours))))
;; Planetary hours:2 ends here

;; [[file:config.org::*Planetary hours][Planetary hours:3]]
(defun my/planetary-hours--format-time (date time)
  "Format TIME as a clock time the way `solar-time-string' writes a
sunrise, tagged with its date once it has rolled past midnight into the
day after DATE."
  ;; Rounded to the minute before decoding, not by `solar-time-string',
  ;; which would print 11:59:45pm as 12:00pm, and on the wrong date.
  (let* ((decoded (decode-time (time-add time 30)))
         (clock (solar-time-string (+ (decoded-time-hour decoded)
                                      (/ (decoded-time-minute decoded) 60.0))
                                   (format-time-string "%Z" time)))
         (day (list (decoded-time-month decoded) (decoded-time-day decoded)
                    (decoded-time-year decoded))))
    (if (calendar-date-equal day date)
        clock
      (format "%s (%s)" clock (calendar-date-string day t t)))))

(defun my/planetary-hours (date)
  "Show which planet rules each hour of DATE in a `*Planetary Hours*' buffer.
Twelve day hours divide sunrise to sunset evenly, then twelve night
hours divide that sunset to the next sunrise evenly; both halves cycle
through the seven classical planets in Chaldean order, starting from
the planet ruling DATE's weekday. See `my/planetary-hours--hours'."
  (interactive
   (list (let ((decoded (decode-time
                         (org-read-date nil t nil "Planetary hours for date: "))))
           (list (decoded-time-month decoded) (decoded-time-day decoded)
                 (decoded-time-year decoded)))))
  (pcase-let ((`(,sunrise ,sunset ,hours) (my/planetary-hours--hours date)))
    (with-help-window "*Planetary Hours*"
      (princ (format "Planetary hours for %s\n" (calendar-date-string date)))
      (princ (format "Sunrise %s, sunset %s\n"
                     (my/planetary-hours--format-time date sunrise)
                     (my/planetary-hours--format-time date sunset)))
      (dotimes (i 24)
        (cond ((= i 0) (princ "\nDay hours\n"))
              ((= i 12) (princ "\nNight hours\n")))
        (pcase-let ((`(,from ,to ,name ,glyph) (nth i hours)))
          (princ (format "%2d. %s %-8s%s – %s\n"
                        (1+ (mod i 12)) glyph name
                        (my/planetary-hours--format-time date from)
                        (my/planetary-hours--format-time date to))))))))

(map! :leader :desc "Planetary hours" "o h" #'my/planetary-hours)
;; Planetary hours:3 ends here

;; [[file:config.org::*Planetary hours][Planetary hours:4]]
(defun my/planetary-hours-at (time)
  "Return the planetary hour ruling TIME, as (DAY-RULER HOUR-RULER NUMBER NIGHT).
DAY-RULER and HOUR-RULER are (NAME . GLYPH) pairs from
`my/planetary-hours-order'; NUMBER counts 1-12 through the day or night
hours, and NIGHT is non-nil for a night hour. The planetary day begins
at sunrise, so before sunrise TIME falls in the previous date's night.
See `my/planetary-hours--hours'."
  (pcase-let* ((`(,_ ,_ ,_ ,day ,month ,year . ,_) (decode-time time))
               (date (list month day year))
               (`(,sunrise ,_ ,hours) (my/planetary-hours--hours date)))
    (when (time-less-p time sunrise)
      (setq date (calendar-gregorian-from-absolute
                  (1- (calendar-absolute-from-gregorian date)))
            hours (nth 2 (my/planetary-hours--hours date))))
    (let* ((index (or (seq-position hours time
                                    (lambda (entry at) (time-less-p at (nth 1 entry))))
                      23))
           (planet (lambda (entry) (cons (nth 2 entry) (nth 3 entry)))))
      (list (funcall planet (car hours))
            (funcall planet (nth index hours))
            (1+ (mod index 12))
            (>= index 12)))))
;; Planetary hours:4 ends here

;; [[file:config.org::*Planet positions][Planet positions:1]]
(defconst my/planet-positions-abbrevs
  '(("Sun" . "Sun") ("Moon" . "Moon") ("Merc" . "Mercury") ("Venu" . "Venus")
    ("Mars" . "Mars") ("Jupi" . "Jupiter") ("Satu" . "Saturn"))
  "Astrolog's 4-column body abbreviations from its -Z chart, to the
full names `my/planetary-hours-order' uses for the same seven
classical planets.")

(defconst my/planet-positions-line-re
  (rx bol (group (= 4 anything)) ": "
      (group (= 7 anything)) " "
      (group (= 7 anything)) " (")
  "Matches one body's line in astrolog's -Z local-horizon chart -- a
4-column abbreviation, then fixed 7-column altitude and azimuth
fields in astrolog's signed, space-padded DD:MM' format.")

(defun my/planet-positions--program ()
  "Return the astrolog executable."
  (or (executable-find "astrolog")
      (user-error "astrolog is not on PATH")))

(defun my/planet-positions--angle (string)
  "Parse an astrolog DD:MM' angle STRING -- optionally signed, and
space-padded in place of a leading zero -- into decimal degrees."
  (let* ((clean (string-replace " " "" string))
         (negative (string-prefix-p "-" clean))
         (digits (string-remove-suffix
                  "'" (replace-regexp-in-string "\\`[+-]" "" clean)))
         (parts (split-string digits ":")))
    (* (if negative -1 1)
       (+ (string-to-number (nth 0 parts))
          (/ (string-to-number (nth 1 parts)) 60.0)))))

(defun my/planet-positions--dms (value positive negative)
  "Format signed decimal-degree VALUE as astrolog's DD:MMH string,
using the POSITIVE/NEGATIVE hemisphere letter for a non-negative/
negative VALUE -- the same layout astro-transits
derives from $ASTRO_LAT/$ASTRO_LONG (see [[*Astrology]]), computed
here directly from `calendar-latitude'/`calendar-longitude' instead."
  (let* ((hemi (if (< value 0) negative positive))
         (abs-value (abs value))
         (d (floor abs-value))
         (m (round (* 60 (- abs-value d)))))
    (when (= m 60) (setq m 0 d (1+ d)))
    (format "%d:%02d%s" d m hemi)))

(defun my/planet-positions--azimuth (raw)
  "Convert astrolog's RAW -Z azimuth (degrees counterclockwise from
due east) to a compass bearing in whole degrees, 0-359 clockwise
from north."
  (mod (round (- 90 raw)) 360))

(defun my/planet-positions--data (&optional time lat long)
  "Run astrolog for TIME (default now) and LAT/LONG decimal degrees
\(default `calendar-latitude'/`calendar-longitude'), returning an
alist of (NAME ALTITUDE AZIMUTH) for the seven classical planets --
ALTITUDE decimal degrees above (positive) or below (negative) the
horizon, AZIMUTH an integer compass bearing 0-359. See
`my/planet-positions-line-re' for the chart astrolog is asked for."
  (unless (and lat long)
    (my/solar-assert-coordinates))
  (let* ((program (my/planet-positions--program))
         ;; `current-time-zone' already resolves the UTC offset that held
         ;; at TIME, DST included, which is exactly what astrolog's -q
         ;; wants as a plain civil time with no further -z0 adjustment --
         ;; see the note above about logging a past observation.
         (west-hours (/ (- (car (current-time-zone time))) 3600))
         (lat-dms (my/planet-positions--dms (or lat calendar-latitude) "N" "S"))
         (long-dms (my/planet-positions--dms (or long calendar-longitude) "E" "W"))
         (date-args
          (if time
              (pcase-let ((`(,_ ,minute ,hour ,day ,month ,year . ,_) (decode-time time)))
                (let* ((period (if (< hour 12) "am" "pm"))
                       (hour12 (let ((h (mod hour 12))) (if (zerop h) 12 h))))
                  (list "-q" (number-to-string month) (number-to-string day)
                        (number-to-string year)
                        (format "%d:%02d%s" hour12 minute period))))
            (list "-n")))
        positions)
    (with-temp-buffer
      (unless (zerop (apply #'call-process program nil t nil
                             (append (list "-zl" long-dms lat-dms
                                           "-z" (number-to-string west-hours) "-z0" "0")
                                     date-args
                                     (list "-Z" "-R" "11" "12" "13" "14" "15"))))
        (user-error "astrolog failed: %s" (buffer-string)))
      (goto-char (point-min))
      (while (re-search-forward my/planet-positions-line-re nil t)
        ;; Collect every group before parsing any of them: the angle
        ;; and label parsing below call `string-match' themselves,
        ;; which would clobber this loop's own match data (see
        ;; `my/astro--transit-row' above for the same gotcha).
        (let ((label (match-string 1))
              (alt-str (match-string 2))
              (az-str (match-string 3)))
          (let ((name (cdr (assoc (string-trim label) my/planet-positions-abbrevs)))
                (altitude (my/planet-positions--angle alt-str))
                (azimuth (my/planet-positions--azimuth
                          (my/planet-positions--angle az-str))))
            (when name (push (list name altitude azimuth) positions))))))
    (nreverse positions)))
;; Planet positions:1 ends here

;; [[file:config.org::*Planet positions][Planet positions:2]]
(defun my/planet-positions--format-altitude (deg)
  "Format non-negative decimal degrees DEG as DD°MM'."
  (let* ((d (floor deg)) (m (round (* 60 (- deg d)))))
    (when (= m 60) (setq m 0 d (1+ d)))
    (format "%d°%02d'" d m)))

(defconst my/planet-positions-compass-points
  ["N" "NE" "E" "SE" "S" "SW" "W" "NW"]
  "8-point compass abbreviations, indexed by azimuth / 45, rounded.")

(defun my/planet-positions--lines (positions)
  "Format POSITIONS (see `my/planet-positions--data') as a list of
lines, one per classical planet in the same order and with the same
glyphs as [[*Planetary hours][=my/planetary-hours=]]
\(`my/planetary-hours-order', Chaldean, slowest to fastest), each
showing its altitude above/below the horizon and compass-bearing
azimuth."
  (mapcar
   (lambda (planet)
     (pcase-let* ((`(,name . ,glyph) planet)
                  (`(,_ ,altitude ,azimuth) (assoc name positions)))
       (if altitude
           (format "%s %-8s%s %s horizon, azimuth %3d° %-2s"
                   glyph name
                   (my/planet-positions--format-altitude (abs altitude))
                   (if (>= altitude 0) "above" "below")
                   azimuth
                   (aref my/planet-positions-compass-points
                         (mod (round (/ azimuth 45.0)) 8)))
         (format "%s %-8s(no data)" glyph name))))
   my/planetary-hours-order))

(defun my/planet-positions ()
  "Show each classical planet's current altitude and azimuth in a
`*Planet Positions*' buffer: how far above or below the horizon it
is, and its compass bearing (0-359, 0 north through 90 east, 180
south, 270 west). See `my/planet-positions--data'."
  (interactive)
  (with-help-window "*Planet Positions*"
    (princ (format "Planet positions for %s\n\n"
                   (format-time-string "%Y-%m-%d %H:%M %Z")))
    (dolist (line (my/planet-positions--lines (my/planet-positions--data)))
      (princ line) (princ "\n"))))

(map! :leader :desc "Planet positions" "o P" #'my/planet-positions)
;; Planet positions:2 ends here

;; [[file:config.org::*Planet positions][Planet positions:3]]
(defun my/astro-log-time ()
  "Return the Emacs time value of the Astronomy journal entry at point:
its UTC property if it has one, as the capture template sets it,
otherwise the first timestamp on its heading, read as local time the
way `%U' left it in entries from before that property existed."
  (let ((utc (org-entry-get nil "UTC")))
    (if utc
        (let ((decoded (org-parse-time-string utc)))
          (setf (nth 7 decoded) nil   ; DST is meaningless for UTC
                (nth 8 decoded) 0)
          (encode-time decoded))
      (save-excursion
        (org-back-to-heading t)
        (let ((eol (line-end-position)))
          (if (re-search-forward org-ts-regexp-both eol t)
              (org-time-string-to-time (match-string 0))
            (user-error "No timestamp on this heading")))))))

(defun my/astro-log-coordinates ()
  "Return (LAT . LONG) decimal degrees parsed from the COORDINATES
property of the entry at point, as the Astronomy capture template
sets it."
  (let ((value (or (org-entry-get nil "COORDINATES")
                    (user-error "No COORDINATES property on this entry"))))
    (pcase (split-string value "," t "[ \t]+")
      (`(,lat ,long) (cons (string-to-number lat) (string-to-number long)))
      (_ (user-error "COORDINATES property %S is not \"LAT, LONG\"" value)))))

(defun my/planet-positions--rows (positions)
  "Format POSITIONS (see `my/planet-positions--data') as Org table
rows, one list of cell strings per classical planet, in the same
order and with the same fields as `my/planet-positions--lines'."
  (mapcar
   (lambda (planet)
     (pcase-let* ((`(,name . ,glyph) planet)
                  (`(,_ ,altitude ,azimuth) (assoc name positions))
                  (label (format "%s %s" glyph name)))
       (if altitude
           (list label
                 (my/planet-positions--format-altitude (abs altitude))
                 (if (>= altitude 0) "above" "below")
                 (format "%d°" azimuth)
                 (aref my/planet-positions-compass-points
                       (mod (round (/ azimuth 45.0)) 8)))
         (list label "" "" "" ""))))
   my/planetary-hours-order))

(defun my/astro-insert-planet-positions ()
  "Insert the classical planets' altitude/azimuth under the Org entry at
point as an Org table, computed for its own timestamp and COORDINATES
property rather than right now. See `my/astro-log-time' and
`my/astro-log-coordinates'."
  (interactive)
  (let* ((time (my/astro-log-time))
         (coords (my/astro-log-coordinates))
         (rows (my/planet-positions--rows
                (my/planet-positions--data time (car coords) (cdr coords)))))
    (org-back-to-heading t)
    (org-end-of-meta-data t)
    ;; An entry with nothing after its drawer, narrowed the way a
    ;; capture buffer is, ends at :END: with no newline of its own.
    (unless (bolp) (insert "\n"))
    (insert (format "Planet positions for %s\n\n"
                    (format-time-string "%Y-%m-%d %H:%M %Z" time)))
    (let ((start (point)))
      (insert "| Planet | Altitude | Horizon | Azimuth | Direction |\n|-\n")
      (dolist (row rows)
        (insert "| " (string-join row " | ") " |\n"))
      (save-excursion (goto-char start) (org-table-align)))
    (insert "\n")))

(map! :map org-mode-map :localleader :desc "Planet positions" "a h" #'my/astro-insert-planet-positions)
;; Planet positions:3 ends here

;; [[file:config.org::*Planet positions][Planet positions:4]]
(defconst my/planet-longitudes-signs
  '("Ari" "Tau" "Gem" "Can" "Leo" "Vir" "Lib" "Sco" "Sag" "Cap" "Aqu" "Pis")
  "Astrolog's three-letter sign abbreviations, in zodiacal order from Aries.")

(defconst my/planet-longitudes-line-re
  (rx bol (group (= 4 anything)) ": "
      (group (= 2 (any " " digit))) (group (= 3 alpha)) (group (= 2 digit))
      " " (group (any " R")))
  "Matches one body's line in astrolog's default chart listing -- the
4-column abbreviation, the position as space-padded degree, sign and
minute, then the retrograde flag.")

(defun my/planet-positions--longitudes (time)
  "Run astrolog for TIME, returning an alist of (NAME LONGITUDE RETROGRADE)
for the seven classical planets -- LONGITUDE tropical ecliptic longitude
in decimal degrees from 0° Aries, RETROGRADE non-nil if the planet is."
  (pcase-let ((`(,_ ,minute ,hour ,day ,month ,year . ,_) (decode-time time t))
              (longitudes nil))
    (with-temp-buffer
      (unless (zerop (call-process (my/planet-positions--program) nil t nil
                                   "-z" "0" "-z0" "0"
                                   "-q" (number-to-string month) (number-to-string day)
                                   (number-to-string year) (format "%d:%02d" hour minute)
                                   "-R0" "1" "2" "3" "4" "5" "6" "7"))
        (user-error "astrolog failed: %s" (buffer-string)))
      (goto-char (point-min))
      (while (re-search-forward my/planet-longitudes-line-re nil t)
        ;; Collected up front, as in `my/planet-positions--data', before
        ;; anything below can clobber the match data.
        (let ((label (match-string 1))
              (degree (string-to-number (match-string 2)))
              (sign (seq-position my/planet-longitudes-signs (match-string 3)))
              (minute (string-to-number (match-string 4)))
              (retrograde (equal (match-string 5) "R")))
          (when-let* ((name (cdr (assoc (string-trim label) my/planet-positions-abbrevs))))
            (push (list name (+ (* 30 sign) degree (/ minute 60.0)) retrograde)
                  longitudes)))))
    (nreverse longitudes)))
;; Planet positions:4 ends here

;; [[file:config.org::*Equinoxes and solstices][Equinoxes and solstices:1]]
(defun my/diary-equinox-solstice (month label)
  "Diary sexp: LABEL on whichever equinox/solstice falls nearest MONTH
(3, 6, 9, or 12) in DATE's year, local to `calendar-latitude'/
`calendar-longitude'."
  (with-no-warnings (defvar date))
  (pcase-let* ((`((,event-date ,description))
                (solar-equinoxes-solstices-1 month (calendar-extract-year date))))
    (when (calendar-date-equal date event-date)
      (format "%s (%s)" label description))))
;; Equinoxes and solstices:1 ends here

;; [[file:config.org::*The Easter cycle][The Easter cycle:1]]
(require 'holidays)

(defun my/diary-paschal-offset (easter-fn offset label)
  "Diary sexp: LABEL on the day OFFSET days from the Easter/Pascha date
EASTER-FN (`holiday-easter-etc-abs' or `holiday-greek-orthodox-easter-abs')
computes for DATE's year."
  (with-no-warnings (defvar date))
  (when (= (calendar-absolute-from-gregorian date)
           (+ (funcall easter-fn (calendar-extract-year date)) offset))
    label))
;; The Easter cycle:1 ends here

;; [[file:config.org::*Hebrew calendar][Hebrew calendar:1]]
(require 'cal-hebrew)

(defun my/diary-hebrew-holiday (month day label)
  "Diary sexp: LABEL when DATE's Hebrew-calendar equivalent is MONTH/DAY."
  (with-no-warnings (defvar date))
  (let ((hebrew (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian date))))
    (when (and (= (calendar-extract-month hebrew) month)
               (= (calendar-extract-day hebrew) day))
      label)))
;; Hebrew calendar:1 ends here

;; [[file:config.org::*Islamic calendar][Islamic calendar:1]]
(require 'cal-islam)

(defun my/diary-islamic-holiday (month day label)
  "Diary sexp: LABEL when DATE's Islamic-calendar equivalent is MONTH/DAY."
  (with-no-warnings (defvar date))
  (let ((islamic (calendar-islamic-from-absolute (calendar-absolute-from-gregorian date))))
    (when (and (= (calendar-extract-month islamic) month)
               (= (calendar-extract-day islamic) day))
      label)))
;; Islamic calendar:1 ends here

;; [[file:config.org::*Weather][Weather:1]]
(require 'url)

(defconst my/weather-url
  (and calendar-latitude calendar-longitude
       (format "https://wttr.in/%s,%s?format=j1"
               (getenv "ASTRO_LAT") (getenv "ASTRO_LONG")))
  "wttr.in's JSON forecast for the coordinates in `ASTRO_LAT'/`ASTRO_LONG',
or nil if those were unset.")

(defvar my/weather-data nil
  "Parsed j1 response from the last successful `my/weather-refresh', or nil
before the first fetch completes.")
;; Weather:1 ends here

;; [[file:config.org::*Weather][Weather:2]]
(defun my/weather-refresh (&optional callback)
  "Fetch the current forecast asynchronously into `my/weather-data'.
Runs CALLBACK with no arguments once the fetch completes, whether or not
it succeeded."
  (interactive)
  (unless my/weather-url
    (my/solar-assert-coordinates))
  (url-retrieve
   my/weather-url
   (lambda (status)
     (unwind-protect
         (unless (plist-get status :error)
           (goto-char url-http-end-of-headers)
           (setq my/weather-data
                 (json-parse-buffer :object-type 'alist :array-type 'list)))
       (kill-buffer (current-buffer))
       (when callback (funcall callback))))
   nil t t))
;; Weather:2 ends here

;; [[file:config.org::*Weather][Weather:3]]
(defun my/weather--desc (condition)
  "The description string inside a wttr.in CONDITION alist."
  (when-let* ((desc (alist-get 'value (car (alist-get 'weatherDesc condition)))))
    (string-trim desc)))

(defun my/weather--emoji (description)
  "Emoji for wttr.in's DESCRIPTION string, by keyword; ☁️ if nothing matches."
  (let ((d (downcase description)))
    (cond ((string-match-p "thunder" d) "⛈️")
          ((string-match-p "snow\\|sleet\\|blizzard\\|ice" d) "❄️")
          ((string-match-p "rain\\|drizzle\\|shower" d) "🌧️")
          ((string-match-p "fog\\|mist\\|haze" d) "🌫️")
          ((string-match-p "overcast" d) "☁️")
          ((string-match-p "cloud" d) "⛅")
          ((string-match-p "clear\\|sunny" d) "☀️")
          (t "☁️"))))

(defun my/weather-current ()
  "Current-conditions alist from `my/weather-data', or nil."
  (car (alist-get 'current_condition my/weather-data)))

(defun my/weather-days ()
  "This and the next two days' forecast alists from `my/weather-data'."
  (alist-get 'weather my/weather-data))
;; Weather:3 ends here

;; [[file:config.org::*Weather][Weather:4]]
(defun my/weather--hour-label (time)
  "12-hour clock label for wttr.in's hourly TIME encoding (\"0\", \"300\",
..., \"2100\", each a 3-hour step from midnight)."
  (let* ((hour (/ (string-to-number time) 100))
         (h12 (let ((h (mod hour 12))) (if (zerop h) 12 h))))
    (format "%d %s" h12 (if (< hour 12) "AM" "PM"))))

(defun my/weather--block-start (date time)
  "Encoded start time of the 3-hour block on DATE (\"YYYY-MM-DD\") named
by wttr.in's hourly TIME encoding (see `my/weather--hour-label')."
  (pcase-let ((`(,y ,m ,d) (mapcar #'string-to-number (split-string date "-"))))
    (encode-time 0 0 (/ (string-to-number time) 100) d m y)))

(defun my/weather--timeline ()
  "Every hourly entry across `my/weather-days', each as a (START DATE
HOUR) list, in chronological order -- START is when that 3-hour block
begins and DATE is the \"YYYY-MM-DD\" it belongs to."
  (seq-mapcat (lambda (day)
                (let ((date (alist-get 'date day)))
                  (mapcar (lambda (hour)
                            (list (my/weather--block-start date (alist-get 'time hour))
                                  date hour))
                          (alist-get 'hourly day))))
              (my/weather-days)))

(defun my/weather--upcoming-hours ()
  "The next eight 3-hour blocks (~24 hours) from `my/weather-data', as
\(DATE HOUR) pairs starting with whichever block covers right now --
rolling into tomorrow once today's remaining blocks run out, rather than
stopping dead at midnight."
  (let ((now (current-time)))
    (mapcar #'cdr
            (seq-take
             (seq-filter (lambda (entry) (time-less-p now (time-add (nth 0 entry) (* 3 3600))))
                         (my/weather--timeline))
             8))))

(defun my/weather--precip-chance (day)
  "Highest chance of rain or snow, as a percentage, across DAY's hourly
entries."
  (seq-max (mapcar (lambda (hour)
                      (max (string-to-number (alist-get 'chanceofrain hour))
                           (string-to-number (alist-get 'chanceofsnow hour))))
                    (alist-get 'hourly day))))
;; Weather:4 ends here

;; [[file:config.org::*Weather][Weather:5]]
(defun my/weather-forecast ()
  "Show current conditions, the next 24 hours, and the next two days'
forecast in a `*Weather*' buffer. Always fetches fresh data -- see
`my/weather-refresh'."
  (interactive)
  (my/weather-refresh
   (lambda ()
     (unless (my/weather-current)
       (user-error "Weather fetch failed"))
     (with-help-window "*Weather*"
       (let* ((current (my/weather-current))
              (desc (my/weather--desc current))
              (days (my/weather-days))
              (today (format-time-string "%Y-%m-%d"))
              (last-date nil))
         (princ (format "%s %s, %s°F (feels like %s°F)\n"
                        (my/weather--emoji desc) desc
                        (alist-get 'temp_F current) (alist-get 'FeelsLikeF current)))
         (princ (format "Humidity %s%%, cloud cover %s%%, wind %s mph %s\n"
                        (alist-get 'humidity current)
                        (alist-get 'cloudcover current)
                        (alist-get 'windspeedMiles current)
                        (alist-get 'winddir16Point current)))
         (princ (format "UV index %s, pressure %s inHg, visibility %s mi\n\n"
                        (alist-get 'uvIndex current)
                        (alist-get 'pressureInches current)
                        (alist-get 'visibilityMiles current)))
         (princ "Next 24 hours\n")
         (pcase-dolist (`(,date ,hour) (my/weather--upcoming-hours))
           (unless (equal date last-date)
             (princ (format "  %s\n" (if (equal date today) "Today" "Tomorrow")))
             (setq last-date date))
           (let ((desc (my/weather--desc hour)))
             (princ (format "    %-5s  %s %-22s %3s°F  rain %s%%\n"
                            (my/weather--hour-label (alist-get 'time hour))
                            (my/weather--emoji desc) desc
                            (alist-get 'tempF hour) (alist-get 'chanceofrain hour)))))
         (princ "\nComing days\n")
         (dolist (day days)
           (let* ((desc (my/weather--desc (nth 4 (alist-get 'hourly day))))
                  (astronomy (car (alist-get 'astronomy day))))
             (princ (format "%s  %s %-22s %s–%s°F  rain %s%%  ↑%s ↓%s\n"
                            (alist-get 'date day) (my/weather--emoji desc) desc
                            (alist-get 'mintempF day) (alist-get 'maxtempF day)
                            (my/weather--precip-chance day)
                            (alist-get 'sunrise astronomy) (alist-get 'sunset astronomy))))))))))

(map! :leader :desc "Weather forecast" "o w" #'my/weather-forecast)
;; Weather:5 ends here

;; [[file:config.org::*Modeline][Modeline:1]]
(defvar my/modeline-segments
  '(my/lunar-current-phase-emoji
    my/modeline-solar-times-string
    my/modeline-weather-string)
  "Functions whose strings make up `my/modeline-astro-string', in order.
Each is called with no arguments and returns a string, or nil to be left
out of the bar.")
;; Modeline:1 ends here

;; [[file:config.org::*Current lunar phase][Current lunar phase:1]]
(require 'lunar)

(defconst my/lunar-phases
  [("🌑" . "New Moon") ("🌒" . "Waxing Crescent") ("🌓" . "First Quarter")
   ("🌔" . "Waxing Gibbous") ("🌕" . "Full Moon") ("🌖" . "Waning Gibbous")
   ("🌗" . "Last Quarter") ("🌘" . "Waning Crescent")]
  "The moon's phase, at eighths of the way through its cycle, as (EMOJI . NAME).")
;; Current lunar phase:1 ends here

;; [[file:config.org::*Current lunar phase][Current lunar phase:2]]
(defun my/lunar-next-phase (phase-index)
  "The next `lunar-phase' event for PHASE-INDEX (0 new, 2 full) on or after today."
  (let* ((today (calendar-current-date))
         (index (lunar-index today))
         (event (lunar-phase index)))
    (while (or (/= (nth 2 event) phase-index)
               (calendar-date-compare event (list today)))
      (setq index (1+ index)
            event (lunar-phase index)))
    event))

(defun my/lunar-next-events-string ()
  "Next new and full moon dates, soonest first, for the lunar tooltip.
Emoji rather than names, from `my/lunar-phases', and no year -- both are
redundant in a tooltip about the next few weeks."
  (let ((events (list (cons (car (aref my/lunar-phases 0)) (my/lunar-next-phase 0))
                       (cons (car (aref my/lunar-phases 4)) (my/lunar-next-phase 2))))
        (calendar-date-display-form '((if dayname (concat dayname ", ")) monthname " " day)))
    (mapconcat (lambda (e) (format "%s %s" (car e) (calendar-date-string (cadr e))))
               (sort events (lambda (a b) (calendar-date-compare (cdr a) (cdr b))))
               "\n")))
;; Current lunar phase:2 ends here

;; [[file:config.org::*Current lunar phase][Current lunar phase:3]]
(defun my/lunar-current-phase-emoji ()
  "Emoji for the moon's current phase; its name and the next new/full moon
as a hover tooltip."
  (let* ((synodic-month 29.530588853)
         (reference-new-moon (encode-time 0 14 18 6 1 2000 t))
         (days-elapsed (/ (float-time (time-subtract (current-time) reference-new-moon))
                          86400.0))
         (fraction (mod (/ days-elapsed synodic-month) 1.0))
         (phase (aref my/lunar-phases (min 7 (floor (* fraction 8))))))
    (propertize (car phase)
                'help-echo (concat (cdr phase) "\n" (my/lunar-next-events-string))
                'mouse-face 'mode-line-highlight)))
;; Current lunar phase:3 ends here

;; [[file:config.org::*Current solar times][Current solar times:1]]
(defun my/modeline-solar-times-string ()
  "Sun emoji for the modeline, the day's solar times as a hover tooltip."
  (when-let* ((times (my/solar-times)))
    (pcase-let ((`(,rise ,noon ,set ,midnight ,zone) times))
      (propertize
       "☀️"
       'help-echo (format "🌅 Sunrise %s\n☀️ Solar noon %s\n🌇 Sunset %s\n🌃 Solar midnight %s"
                           (solar-time-string rise zone)
                           (solar-time-string noon zone)
                           (solar-time-string set zone)
                           (solar-time-string midnight zone))
       'mouse-face 'mode-line-highlight))))
;; Current solar times:1 ends here

;; [[file:config.org::*Current weather][Current weather:1]]
(defun my/modeline-weather-string ()
  "Weather emoji for the modeline; current conditions and the next two
days' highs/lows as a hover tooltip. Nil until the first `my/weather-refresh'
completes."
  (when-let* ((current (my/weather-current))
              (desc (my/weather--desc current)))
    (propertize
     (my/weather--emoji desc)
     'help-echo (mapconcat
                 #'identity
                 (cons (format "%s, %s°F (feels like %s°F)"
                               desc (alist-get 'temp_F current) (alist-get 'FeelsLikeF current))
                       (mapcar (lambda (day)
                                 (format "%s: %s–%s°F" (alist-get 'date day)
                                         (alist-get 'mintempF day) (alist-get 'maxtempF day)))
                               (my/weather-days)))
                 "\n")
     'mouse-face 'mode-line-highlight)))
;; Current weather:1 ends here

;; [[file:config.org::*Wiring][Wiring:1]]
(defvar my/modeline-astro-string ""
  "Modeline string built from `my/modeline-segments'.")
(put 'my/modeline-astro-string 'risky-local-variable t)

(defun my/modeline-astro-update ()
  "Recompute `my/modeline-astro-string' and redraw the modeline."
  (setq my/modeline-astro-string
        (concat " " (mapconcat #'identity
                               (delq nil (mapcar #'funcall my/modeline-segments))
                               " | ")))
  (force-mode-line-update 'all))

(or global-mode-string (setq global-mode-string '("")))
(add-to-list 'global-mode-string 'my/modeline-astro-string 'append)
(my/modeline-astro-update)

(defvar my/modeline-astro-timer
  (run-at-time t 60 #'my/modeline-astro-update)
  "Timer that keeps `my/modeline-astro-string' refreshed every minute.")

(defvar my/weather-refresh-timer
  (when my/weather-url
    (my/weather-refresh #'my/modeline-astro-update)
    (run-at-time 1800 1800 (lambda () (my/weather-refresh #'my/modeline-astro-update))))
  "Timer that refetches `my/weather-data' every 30 minutes, redrawing the
modeline as soon as each fetch completes rather than waiting for the
minute-interval timer above to notice. nil when there is no location to
fetch weather for.")
;; Wiring:1 ends here

;; [[file:config.org::*Daemon][Daemon:1]]
(defun my/restart-emacs-daemon ()
  "Restart the Emacs daemon via `systemctl --user restart' and reopen a frame."
  (interactive)
  (call-process "systemd-run" nil 0 nil
                "--user" "--collect" "--"
                "sh" "-c" "systemctl --user restart emacs.service && emacsclient -c"))

(map! :leader :desc "Restart daemon (systemctl)" "q r" #'my/restart-emacs-daemon)
;; Daemon:1 ends here

;; [[file:config.org::*Claude Code][Claude Code:1]]
(use-package! claude-code
  :bind-keymap ("C-c c" . claude-code-command-map)
  :init
  (setq claude-code-terminal-backend 'vterm)
  :config
  (claude-code-mode))
;; Claude Code:1 ends here

;; [[file:config.org::*TMSU][TMSU:1]]
(defcustom my/tmsu-mount-directory "~/tmsu"
  "Default parent directory offered when prompting for a TMSU mount point."
  :type 'directory)

(defun my/tmsu-mounts ()
  "Return an alist of (MOUNTPOINT . DATABASE) for mounted TMSU filesystems."
  (with-temp-buffer
    (process-file "tmsu" nil t nil "mount")
    (mapcar (lambda (line)
              (let ((fields (split-string line "\t")))
                (cons (car (last fields)) (car fields))))
            (split-string (string-trim (buffer-string)) "\n" t))))

(defun my/tmsu-mount (mountpoint &optional database)
  "Mount a TMSU virtual filesystem at MOUNTPOINT and open it in dired.

With a prefix arg, prompt for a specific DATABASE file; otherwise TMSU's
usual discovery (TMSU_DB, then the nearest .tmsu, then the default
database) applies."
  (interactive
   (list (read-directory-name "Mount point: " my/tmsu-mount-directory)
         (when current-prefix-arg
           (read-file-name "Database: "))))
  (make-directory mountpoint t)
  (let ((args (append (when database (list (file-local-name database)))
                       (list (file-local-name mountpoint)))))
    (unless (zerop (apply #'process-file "tmsu" nil nil nil "mount" args))
      (error "tmsu mount failed")))
  (dired mountpoint))

(defun my/tmsu-mount-dired (mountpoint)
  "Open dired on an already-mounted TMSU virtual filesystem."
  (interactive
   (let ((mounts (my/tmsu-mounts)))
     (unless mounts (user-error "No TMSU filesystems mounted"))
     (list (completing-read "TMSU mount: " mounts nil t))))
  (dired mountpoint))

(defun my/tmsu-unmount (mountpoint)
  "Unmount the TMSU virtual filesystem at MOUNTPOINT."
  (interactive
   (let ((mounts (my/tmsu-mounts)))
     (unless mounts (user-error "No TMSU filesystems mounted"))
     (list (if (cdr mounts)
               (completing-read "Unmount: " mounts nil t)
             (caar mounts)))))
  (unless (zerop (process-file "tmsu" nil nil nil "unmount" (file-local-name mountpoint)))
    (error "tmsu unmount failed"))
  (when-let* ((buf (dired-find-buffer-nocreate (file-name-as-directory mountpoint))))
    (kill-buffer buf))
  (message "Unmounted %s" mountpoint))

(defun my/tmsu-dired-edit-marked ()
  "Edit TMSU tags of each marked file in turn, or the file at point."
  (interactive)
  (dolist (file (dired-get-marked-files))
    (tmsu-edit file)))

(defun my/tmsu-init (dir)
  "Initialize a new TMSU database in DIR.

Safe to run again on a directory that already has one; TMSU leaves
the existing database untouched."
  (interactive (list (if (eq major-mode 'dired-mode)
                         (dired-current-directory)
                       default-directory)))
  (unless (zerop (process-file "tmsu" nil nil nil "init" (file-local-name dir)))
    (error "tmsu init failed"))
  (message "Initialized TMSU database in %s" dir))

(defun my/tmsu-dired-overlay-all ()
  "Show TMSU tag overlays for every tag, without prompting."
  (interactive nil dired-mode)
  (require 'tmsu-dired-overlay)
  (unless (tmsu-database-p)
    (error "No TMSU database"))
  (tmsu-dired-overlay-delete-overlays)
  (tmsu-dired-overlay-create-overlays))

(defun my/tmsu-imply--candidates ()
  "Return the current TMSU tag implications as \"TAG -> IMPL\" strings."
  (with-temp-buffer
    (process-file "tmsu" nil t nil "imply")
    (split-string (string-trim (buffer-string)) "\n" t)))

(defun my/tmsu-imply-list ()
  "Show the current TMSU tag implications in a buffer."
  (interactive)
  (unless (tmsu-database-p)
    (error "No TMSU database"))
  (with-current-buffer (get-buffer-create "*TMSU implications*")
    (erase-buffer)
    (insert (string-join (or (my/tmsu-imply--candidates)
                              (list "No implications defined."))
                          "\n")
            "\n")
    (goto-char (point-min))
    (view-mode 1)
    (pop-to-buffer (current-buffer))))

(defun my/tmsu-imply-create (tag implication)
  "Make TAG imply IMPLICATION for all future TMSU queries."
  (interactive
   (list (completing-read "Tag: " (tmsu-get-tags) nil nil nil 'tmsu-query-history)
         (completing-read "Implies: " (tmsu-get-tags) nil nil nil 'tmsu-query-history)))
  (unless (zerop (process-file "tmsu" nil nil nil "imply" tag implication))
    (error "tmsu imply failed"))
  (message "%s -> %s" tag implication))

(defun my/tmsu-imply-delete (implication)
  "Delete an existing TMSU tag IMPLICATION (a \"TAG -> IMPL\" string)."
  (interactive
   (list (completing-read "Delete implication: " (my/tmsu-imply--candidates) nil t)))
  (let* ((parts (split-string implication "\\s-*->\\s-*"))
         (tag (string-trim (car parts)))
         (impl (string-trim (cadr parts))))
    (unless (zerop (process-file "tmsu" nil nil nil "imply" "--delete" tag impl))
      (error "tmsu imply --delete failed"))
    (message "Deleted: %s -> %s" tag impl)))

(defun my/tmsu-imply ()
  "Create, list, or delete a TMSU tag implication."
  (interactive)
  (unless (tmsu-database-p)
    (error "No TMSU database"))
  (pcase (completing-read "Implication: " '("create" "list" "delete") nil t)
    ("create" (call-interactively #'my/tmsu-imply-create))
    ("list"   (my/tmsu-imply-list))
    ("delete" (call-interactively #'my/tmsu-imply-delete))))

(defun my/tmsu-repair ()
  "Drop TMSU tags left behind by files that no longer exist.

Runs `tmsu repair --pretend' and shows what it found; with nothing to
fix, just reports the database clean. Otherwise asks for confirmation
before re-running with `--remove' to actually drop those files' tags."
  (interactive)
  (unless (tmsu-database-p)
    (error "No TMSU database"))
  (with-current-buffer (get-buffer-create "*TMSU repair*")
    (let ((inhibit-read-only t))
      (erase-buffer)
      (process-file "tmsu" nil t nil "repair" "--pretend")
      (goto-char (point-min)))
    (if (= (point-min) (point-max))
        (progn (message "TMSU database is clean.")
               (kill-buffer))
      (view-mode 1)
      (pop-to-buffer (current-buffer))
      (if (y-or-n-p "Remove tags for the missing files above? ")
          (let ((inhibit-read-only t))
            (erase-buffer)
            (process-file "tmsu" nil t nil "repair" "--remove")
            (goto-char (point-min))
            (message "TMSU database repaired."))
        (quit-window)))))

(use-package! tmsu
  :after dired
  :config
  (tmsu-dired-rename-repair-mode 1))

(use-package! ol-tmsu
  :when (executable-find "tmsu")
  :after org)

(after! (tmsu-dired dirvish)
  (defvar my/tmsu-dired-query-returns (make-hash-table :test 'eq)
    "Buffer -> (DV . OLD-DV-INDEX), keyed by buffer object rather than a
buffer-local variable because `tmsu-dired-query' calls
`kill-all-local-variables' on every refresh, including when reverting its
own results buffer, which would otherwise wipe the saved return state.")

  (defun my/dirvish-set-index (dv index)
    "Set DV's `dv-index' slot to INDEX.

Uses `aset' with `cl-struct-slot-offset' instead of `(setf (dv-index dv)
...)'. Dirvish's `dirvish' struct only exists once Dirvish has loaded,
but this file gets compiled before that happens; a `setf' place expanded
that early bakes in a call to a nonexistent `(setf dv-index)' function
that keeps failing even after Dirvish loads and the struct exists. `aset'
and `cl-struct-slot-offset' are plain functions resolved by name at call
time, so they aren't affected by what was or wasn't loaded at compile
time."
    (aset dv (cl-struct-slot-offset 'dirvish 'index) index))

  (defun my/tmsu-dired-query-quit ()
    "Leave a TMSU query view, restoring the Dirvish directory it came from."
    (interactive)
    (if-let* ((state (gethash (current-buffer) my/tmsu-dired-query-returns))
              (dv (car state))
              (old-index (cdr state))
              (old-buf (cdr old-index))
              ((buffer-live-p old-buf)))
        (let ((qbuf (current-buffer)))
          (my/dirvish-set-index dv old-index)
          (my/dirvish-reusing-window (switch-to-buffer old-buf))
          (kill-buffer qbuf))
      (quit-window)))

  (defun my/tmsu-dired-query-dirvish-a (orig-fn &rest args)
    "Make `tmsu-dired-query' replace the current Dirvish directory in place.

Reuses Dirvish's window and preview layout instead of popping a separate
window, and rebinds `q' in the results buffer to return to the directory
the query was run from. A no-op outside of an active Dirvish session."
    (let* ((dv (dirvish-curr))
           (old-index (and dv (dv-index dv))))
      (if (not dv)
          (apply orig-fn args)
        (my/dirvish-reusing-window (apply orig-fn args))
        (let ((qbuf (current-buffer)))
          (with-current-buffer qbuf
            (dirvish-prop :dv (dv-id dv))
            (dirvish-prop :attrs (dv-attributes dv))
            (dirvish-prop :preview-dps (dv-preview-dispatchers dv))
            (dirvish-prop :gui (display-graphic-p))
            (dirvish-prop :root default-directory)
            (dirvish--setup-dired)
            (add-hook 'kill-buffer-hook
                      (let ((buf qbuf))
                        (lambda () (remhash buf my/tmsu-dired-query-returns)))
                      nil t)
            (unless (gethash qbuf my/tmsu-dired-query-returns)
              (puthash qbuf (cons dv old-index) my/tmsu-dired-query-returns))
            (evil-local-set-key 'normal "q" #'my/tmsu-dired-query-quit))
          (my/dirvish-set-index
           dv (cons (file-name-as-directory (expand-file-name default-directory))
                    qbuf))
          (dirvish--setup-mode-line dv)))))

  (advice-add #'tmsu-dired-query :around #'my/tmsu-dired-query-dirvish-a)

  (map! :map dirvish-mode-map
        (:prefix ("t" . "tmsu")
         :n "m" #'my/tmsu-mount
         :n "u" #'my/tmsu-unmount
         :n "j" #'my/tmsu-mount-dired
         :n "i" #'my/tmsu-init
         :n "a" #'tmsu-dired-tags-add
         :n "r" #'tmsu-dired-tags-remove
         :n "e" #'my/tmsu-dired-edit-marked
         :n "d" #'tmsu-dired-edit-directory
         :n "o" #'tmsu-dired-overlay
         :n "O" #'my/tmsu-dired-overlay-all
         :n "q" #'tmsu-dired-query
         :n "I" #'my/tmsu-imply
         :n "R" #'my/tmsu-repair)))
;; TMSU:1 ends here

;; [[file:config.org::*Private overlay][Private overlay:1]]
(load! "private/config" doom-user-dir t)
;; Private overlay:1 ends here