diff options
Diffstat (limited to 'config.el')
| -rw-r--r-- | config.el | 4652 |
1 files changed, 4652 insertions, 0 deletions
diff --git a/config.el b/config.el new file mode 100644 index 0000000..94cf0df --- /dev/null +++ b/config.el @@ -0,0 +1,4652 @@ +;;; 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 |