diff options
Diffstat (limited to 'archive')
| -rw-r--r-- | archive/README.org | 71 | ||||
| -rw-r--r-- | archive/custom/edit-indirect.el | 440 | ||||
| -rw-r--r-- | archive/custom/eplot.el | 3495 | ||||
| -rw-r--r-- | archive/custom/profile-dotemacs.el | 161 | ||||
| -rw-r--r-- | archive/custom/titlecase-data.el | 643 | ||||
| -rw-r--r-- | archive/custom/titlecase.el | 389 | ||||
| -rw-r--r-- | archive/modules/duet-config.el | 19 | ||||
| -rw-r--r-- | archive/modules/mu4e-org-contacts-setup.el | 31 | ||||
| -rw-r--r-- | archive/modules/show-kill-ring.el | 122 | ||||
| -rw-r--r-- | archive/modules/signal-config.el | 380 | ||||
| -rw-r--r-- | archive/tests/test-show-kill-ring--insert-item.el | 73 | ||||
| -rw-r--r-- | archive/tests/test-signal-config--contact-cache.el | 61 | ||||
| -rw-r--r-- | archive/tests/test-signal-config-notify.el | 150 | ||||
| -rw-r--r-- | archive/tests/test-signal-config.el | 410 | ||||
| -rw-r--r-- | archive/tests/test-signel-cancel-input.el | 74 | ||||
| -rw-r--r-- | archive/tests/test-signel-input-preservation.el | 68 | ||||
| -rw-r--r-- | archive/tests/test-signel-notify-function.el | 89 | ||||
| -rw-r--r-- | archive/tests/test-signel-rpc-dispatch.el | 94 |
18 files changed, 6770 insertions, 0 deletions
diff --git a/archive/README.org b/archive/README.org new file mode 100644 index 00000000..e292065a --- /dev/null +++ b/archive/README.org @@ -0,0 +1,71 @@ +#+TITLE: Archive — Retired Modules +#+AUTHOR: Craig Jennings + +* What this is + +The pasture upstate. Modules that were once part of the config but are no +longer loaded, kept here instead of deleted so they can be read, mined for +ideas, or brought back later. + +Nothing in this directory is on the Emacs =load-path=, and nothing in the +active config requires anything here. Retiring a file means moving it here and +removing whatever orphaned reference kept pointing at it. Restoring one means +moving it back to =modules/= or =custom/= and re-adding its =require= (or +=use-package=) in =init.el=. + +The directory is tracked in git, so every retired file stays retrievable from +history even after it moves again. + +* The rule this directory enforces + +Every =.el= file *outside* this directory should be of active use — required, +loaded, or otherwise reached by the running config. If a file is never touched, +loaded, or referenced, it belongs here. The candidate list is generated by a +reachability sweep from =init.el= (transitive =require= closure), then checked +by hand for the cases pure requires miss: =use-package= with =:load-path=, +autoloads, and vendored copies shadowed by a package-manager install. + +* Layout + +Retired files keep their origin directory so a restore is a straight move back: + +- =archive/modules/= — retired first-party modules +- =archive/custom/= — retired vendored third-party files +- =archive/tests/= — tests belonging to retired modules +- =archive/gptel/= — the gptel feature subtree, retired as a unit + +* Inventory + +** archive/modules/ + +- =show-kill-ring.el= — kill-ring viewer bound to M-S-k. Its =require= was + dropped in b785a19d and consult-yank-pop covers the same need. Retiring it + also removed the orphaned M-K -> M-S-k translation in =keyboard-compat.el=, + which had been leaving M-K a dead key. +- =duet-config.el= — no reference anywhere in the config. +- =mu4e-org-contacts-setup.el= — nothing requires it; its featurep gate would + be nil at init in any case. The live mu4e contacts wiring lives in + =mu4e-org-contacts-integration.el=. +- =signal-config.el= — the in-Emacs Signal client (forked signel at + =~/code/signel= + signal-cli), retired whole on Craig's call 2026-07-14: + agents drive Signal via signal-cli / signal-mcp, so the interactive Emacs + client earns no keep. The fork repo itself is untouched. Its seven test + files moved to =archive/tests/= with it (=test-signal-config*.el=, + =test-signel-*.el=). The spec record is + =docs/specs/signal-client-spec.org= (IMPLEMENTED, then retired). + +** archive/custom/ + +- =eplot.el= — vendored plotting package, unreferenced. +- =profile-dotemacs.el= — startup-profiling tool, unreferenced. +- =titlecase.el= + =titlecase-data.el= — the duckwork/titlecase.el package, + superseded by =custom-case.el='s own =cj/title-case-region=. +- =edit-indirect.el= — a vendored copy of the MELPA package that + =text-config.el= installs (its =use-package= carries no =:ensure nil=). With + this copy off the =load-path=, the MELPA copy loads, which is the intended + one. + +** archive/gptel/ + +The gptel AI-assistant feature, retired as a whole subtree (modules, tests, +tools, custom, and its spec docs) when the config moved off gptel. diff --git a/archive/custom/edit-indirect.el b/archive/custom/edit-indirect.el new file mode 100644 index 00000000..307f9695 --- /dev/null +++ b/archive/custom/edit-indirect.el @@ -0,0 +1,440 @@ +;;; edit-indirect.el --- Edit regions in separate buffers -*- lexical-binding: t -*- + +;; Author: Fanael Linithien <fanael4@gmail.com> +;; URL: https://github.com/Fanael/edit-indirect +;; Version: 0.1.10 +;; Package-Requires: ((emacs "24.3")) + +;; This file is NOT part of GNU Emacs. + +;; SPDX-License-Identifier: BSD-2-clause +;; +;; Copyright (c) 2014-2022, Fanael Linithien +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: + +;; Edit regions in separate buffers, like `org-edit-src-code' but for arbitrary +;; regions. +;; +;; See the docstring of `edit-indirect-region' for details. + +;;; Code: +(defgroup edit-indirect nil + "Editing regions in separate buffers." + :group 'editing) + +(defcustom edit-indirect-guess-mode-function #'edit-indirect-default-guess-mode + "The function used to guess the major mode of an edit-indirect buffer. +It's called with the edit-indirect buffer as the current buffer. +It's called with three arguments, the parent buffer, the beginning +and the end of the parent buffer region being editing. + +Note that the buffer-local value from the parent buffer is used." + :type 'function + :group 'edit-indirect) + +(defcustom edit-indirect-after-creation-hook nil + "Functions called after the edit-indirect buffer is created. +The functions are called with the edit-indirect buffer as the +current buffer. + +Note that the buffer-local value from the parent buffer is used." + :type 'hook + :group 'edit-indirect) + +(defcustom edit-indirect-before-commit-hook nil + "Functions called before the edit-indirect buffer is committed. +The functions are called with the edit-indirect buffer as the +current buffer. + +Note that the buffer-local value from the edit-indirect buffer is +used." + :type 'hook + :group 'edit-indirect) + +(defcustom edit-indirect-before-commit-functions nil + "Functions called before an edit-indirect buffer is committed. +The functions are called with the parent buffer as the current +buffer. +Each function is called with two arguments, the beginning and the +end of the region to be changed." + :type 'hook + :group 'edit-indirect) + +(defcustom edit-indirect-after-commit-functions nil + "Functions called after an edit-indirect buffer has been committed. +The functions are called with the parent buffer as the current +buffer. +Each function is called with two arguments, the beginning and the +end of the changed region." + :type 'hook + :group 'edit-indirect) + +(defgroup edit-indirect-faces nil + "Faces used in `edit-indirect'." + :group 'edit-indirect + :group 'faces + :prefix "edit-indirect") + +(defface edit-indirect-edited-region + '((t :inherit secondary-selection)) + "Face used to highlight an indirectly edited region." + :group 'edit-indirect-faces) + +;; Emacs <= 24.3 has no `define-error'. +(let* ((user-error-conditions (get 'user-error 'error-conditions)) + (define-user-error (lambda (name message) + (put name 'error-conditions + (cons name user-error-conditions)) + (put name 'error-message message)))) + (funcall define-user-error 'edit-indirect-overlapping + "Indirectly edited regions cannot overlap") + (funcall define-user-error 'edit-indirect-read-only + "Text is read-only, modify the edit-indirect buffer instead") + (funcall define-user-error 'edit-indirect-not-indirect + "This is not an edit-indirect buffer")) + +(defvar edit-indirect--overlay) +(defvar edit-indirect--should-quit-window nil) +(put 'edit-indirect--should-quit-window 'permanent-local t) + +;;;###autoload +(defun edit-indirect-region (beg end &optional display-buffer) + "Edit the region BEG..END in a separate buffer. +The region is copied, without text properties, to a separate +buffer, called edit-indirect buffer, and +`edit-indirect-guess-mode-function' is called to set the major +mode. +When done, exit with `edit-indirect-commit', which will remove the +original region and replace it with the edited version; or with +`edit-indirect-abort', which will drop the modifications. + +This differs from `clone-indirect-buffer' with narrowing in that +the text properties are not shared, so the parent buffer major mode +and the edit-indirect buffer major mode will not be able to tread +on each other's toes by setting up potentially conflicting text +properties, which happens surprisingly often when the font-lock +mode is used. + +Edit-indirect buffers use the `edit-indirect-mode-map' keymap. +Regions with active edit-indirect buffers use the +`edit-indirect-overlay-map' keymap. + +If there's already an edit-indirect buffer for BEG..END, use that. +If there's already an edit-indirect buffer active overlapping any +portion of BEG..END, an `edit-indirect-overlapping' error is +signaled. + +When DISPLAY-BUFFER is non-nil or when called interactively, +display the edit-indirect buffer in some window and select it. + +In any case, return the edit-indirect buffer." + (interactive + (if (or (use-region-p) (not transient-mark-mode)) + (prog1 (list (region-beginning) (region-end) t) + (deactivate-mark)) + (user-error "No region"))) + (let ((buffer (edit-indirect--get-edit-indirect-buffer beg end))) + (when display-buffer + (edit-indirect--display-buffer buffer)) + buffer)) + +(defvar edit-indirect-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap save-buffer] #'edit-indirect-save) + (define-key map (kbd "C-c '") #'edit-indirect-commit) + (define-key map (kbd "C-c C-c") #'edit-indirect-commit) + (define-key map (kbd "C-c C-k") #'edit-indirect-abort) + map) + "Keymap for edit-indirect buffers. + +\\{edit-indirect-mode-map}") + +(defvar edit-indirect-overlay-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'edit-indirect-display-active-buffer) + map) + "Keymap for regions with active edit-indirect buffers. + +\\{edit-indirect-overlay-map}") + +(defun edit-indirect-commit () + "Commit the modifications done in an edit-indirect buffer. +That is, replace the original region in the parent buffer with the +contents of the edit-indirect buffer. +The edit-indirect buffer is then killed. + +Can be called only when the current buffer is an edit-indirect +buffer." + (interactive) + (edit-indirect--barf-if-not-indirect) + (edit-indirect--commit) + (edit-indirect--clean-up)) + +(defun edit-indirect-save () + "Save the modifications done in an edit-indirect buffer. +That is, replace the original region in the parent buffer with the +contents of the edit-indirect buffer. + +Can be called only when the current buffer is an edit-indirect +buffer." + (interactive) + (edit-indirect--barf-if-not-indirect) + (edit-indirect--commit)) + +(defun edit-indirect-abort () + "Abort indirect editing in the current buffer and kill the buffer. + +Can be called only when the current buffer is an edit-indirect +buffer." + (interactive) + (edit-indirect--barf-if-not-indirect) + (edit-indirect--abort)) + +(defun edit-indirect-buffer-indirect-p (&optional buffer) + "Non-nil iff the BUFFER is an edit-indirect buffer. +BUFFER defaults to the current buffer." + (save-current-buffer + (when buffer + (set-buffer buffer)) + ;; (not (null)) so we don't leak the overlay to the outside world. + (not (null edit-indirect--overlay)))) + +(defun edit-indirect-default-guess-mode (_parent-buffer _beg _end) + "Guess the major mode for an edit-indirect buffer. +It's done by calling `normal-mode'." + (normal-mode)) + +(defun edit-indirect-display-active-buffer () + "Display the active edit-indirect buffer of the region the point is in." + (interactive) + (let ((overlay + (let ((p (point))) + (edit-indirect--search-for-edit-indirect p (1+ p))))) + (unless overlay + (signal 'edit-indirect-not-indirect '())) + (edit-indirect--display-buffer (overlay-get overlay 'edit-indirect-buffer)))) + +(defvar edit-indirect--overlay nil + "The overlay spanning the region of the parent buffer being edited. + +It's also used as the variable determining if we're in an +edit-indirect buffer at all.") +(make-variable-buffer-local 'edit-indirect--overlay) +(put 'edit-indirect--overlay 'permanent-local t) + +;; Normally this would use `define-minor-mode', but that makes the mode function +;; interactive, which we don't want, because it's just an implementation detail. +(defun edit-indirect--mode (overlay) + "Turn the `edit-indirect--mode' \"minor mode\" on. +OVERLAY is the value to set `edit-indirect--overlay' to." + (setq edit-indirect--overlay overlay) + (add-hook 'kill-buffer-hook #'edit-indirect--abort-on-kill-buffer nil t)) +(with-no-warnings + (add-minor-mode + 'edit-indirect--overlay " indirect" edit-indirect-mode-map nil #'ignore)) + +(defun edit-indirect--display-buffer (buffer) + "Display the given BUFFER in some window and select it." + (with-current-buffer buffer + (setq-local edit-indirect--should-quit-window t)) + (select-window (display-buffer buffer)) + nil) + +(defun edit-indirect--get-edit-indirect-buffer (beg end) + "Return an edit-indirect buffer for the region BEG..END. +If there's already an edit-indirect buffer active overlapping any +portion of BEG..END, an `edit-indirect-overlapping' error is +signaled." + (let ((old-overlay (edit-indirect--search-for-edit-indirect beg end))) + (cond + ((null old-overlay) + (let ((overlay (edit-indirect--create-overlay beg end))) + (edit-indirect--create-indirect-buffer beg end overlay))) + ((and (= beg (overlay-start old-overlay)) + (= end (overlay-end old-overlay))) + (overlay-get old-overlay 'edit-indirect-buffer)) + (t + (signal 'edit-indirect-overlapping '()))))) + +(defun edit-indirect--search-for-edit-indirect (beg end) + "Return an existing edit-indirect overlay for some region inside BEG..END. +If there's no indirectly edited region inside BEG..END, return +nil." + (catch 'done + (dolist (overlay (overlays-in beg end)) + (when (overlay-get overlay 'edit-indirect-buffer) + (throw 'done overlay))) + nil)) + +(defmacro edit-indirect--buffer-local-value (buffer variable) + "Get the BUFFER local value of VARIABLE. +VARIABLE shall be a symbol." + (unless (symbolp variable) + (signal 'wrong-type-argument (list #'symbolp variable))) + ;; `with-current-buffer' is used instead of `buffer-local-value' because + ;; the latter doesn't give warnings about free variables when + ;; byte-compiled. + `(with-current-buffer ,buffer ,variable)) + +(defun edit-indirect--create-indirect-buffer (beg end overlay) + "Create an edit-indirect buffer and return it. + +BEG..END is the parent buffer region to insert. +OVERLAY is the overlay, see `edit-indirect--overlay'." + (add-hook 'after-change-major-mode-hook #'edit-indirect--rebind-save-hooks) + (let ((buffer (generate-new-buffer (format "*edit-indirect %s*" (buffer-name)))) + (parent-buffer (current-buffer))) + (overlay-put overlay 'edit-indirect-buffer buffer) + (with-current-buffer buffer + (insert-buffer-substring-no-properties parent-buffer beg end) + (set-buffer-modified-p nil) + (edit-indirect--mode overlay) + ;; Use the buffer-local values from the parent buffer. Don't retrieve the + ;; values before actual uses in case these variables are changed by some + ;; of the many possible hooks. + (funcall (edit-indirect--buffer-local-value + parent-buffer edit-indirect-guess-mode-function) + parent-buffer beg end) + (if (local-variable-p 'edit-indirect-after-creation-hook parent-buffer) + ;; Copy the parent buffer hook to the indirect buffer instead of + ;; let-binding it to avoid running it twice. + (setq-local edit-indirect-after-creation-hook + (edit-indirect--buffer-local-value + parent-buffer edit-indirect-after-creation-hook)) + ;; No need to do copy anything if the parent buffer has no local value, + ;; the global value will be used instead. Just kill the local value in + ;; the indirect buffer in case a prior hook set it, because we're not + ;; supposed to use it. + (kill-local-variable 'edit-indirect-after-creation-hook)) + (run-hooks 'edit-indirect-after-creation-hook)) + buffer)) + +(defun edit-indirect--create-overlay (beg end) + "Create the edit-indirect overlay and return it. + +BEG and END specify the region the overlay should encompass." + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face 'edit-indirect-edited-region) + (overlay-put overlay 'modification-hooks '(edit-indirect--barf-read-only)) + (overlay-put overlay 'insert-in-front-hooks '(edit-indirect--barf-read-only)) + (overlay-put overlay 'keymap edit-indirect-overlay-map) + overlay)) + +(defvar edit-indirect--inhibit-read-only nil + "Non-nil means disregard read-only status of indirectly-edited region.") + +(defun edit-indirect--barf-read-only (_ov _after _beg _end &optional _len) + "Signal an error because the text is read-only. +No error is signaled if `inhibit-read-only' or +`edit-indirect--inhibit-read-only' is non-nil." + (unless (or inhibit-read-only edit-indirect--inhibit-read-only) + (signal 'edit-indirect-read-only '()))) + +(defun edit-indirect--commit () + "Commit the modifications done in an edit-indirect buffer." + (run-hooks 'edit-indirect-before-commit-hook) + (let ((beg (overlay-start edit-indirect--overlay)) + (end (overlay-end edit-indirect--overlay)) + (buffer (current-buffer)) + (edit-indirect--inhibit-read-only t)) + (with-current-buffer (overlay-buffer edit-indirect--overlay) + (save-excursion + (let ((beg-marker (copy-marker beg)) + (end-marker (copy-marker end))) + (edit-indirect--run-hook-with-positions + 'edit-indirect-before-commit-functions beg-marker end-marker) + (save-match-data + (set-match-data (list beg-marker end-marker)) + (let ((new-data + (with-current-buffer buffer + (buffer-substring-no-properties 1 (1+ (buffer-size)))))) + (unless (string= new-data (match-string 0)) + (replace-match new-data t t)))) + (edit-indirect--run-hook-with-positions + 'edit-indirect-after-commit-functions beg-marker (point)) + (set-marker beg-marker nil) + (set-marker end-marker nil)))) + (set-buffer-modified-p nil))) + +(defun edit-indirect--run-hook-with-positions (hook beg end) + "Run HOOK with the specified positions BEG and END. +HOOK should be a symbol, a hook variable. +The functions are passed integer positions. +If a function changes the buffer contents, the next function will be +called with updated positions." + (let ((beg-marker (unless (markerp beg) (copy-marker beg))) + (end-marker (unless (markerp end) (copy-marker end)))) + (run-hook-wrapped hook + (lambda (f beg end) + (funcall f (marker-position beg) (marker-position end)) + nil) + (or beg-marker beg) (or end-marker end)) + (when beg-marker (set-marker beg-marker nil)) + (when end-marker (set-marker end-marker nil)))) + +(defun edit-indirect--abort () + "Abort indirect edit." + (edit-indirect--clean-up)) + +(defun edit-indirect--clean-up () + "Clean up an edit-indirect buffer." + (delete-overlay edit-indirect--overlay) + ;; Kill the overlay reference so that `edit-indirect--abort-on-kill-buffer' + ;; won't try to call us again. + (setq edit-indirect--overlay nil) + ;; If we created a window, get rid of it. Kill the buffer we created. + (if edit-indirect--should-quit-window + (quit-window t) + (kill-buffer))) + +(defun edit-indirect--rebind-save-hooks () + "Bind our `save-buffer' hooks in the current buffer. +Does nothing if the current buffer is not an edit-indirect buffer." + (when (edit-indirect-buffer-indirect-p) + (setq buffer-offer-save t) + (add-hook 'write-contents-functions #'edit-indirect--commit-on-save nil t))) + +(defun edit-indirect--commit-on-save () + "Commit the indirect edit. +Should only be called from `write-contents-functions'." + (edit-indirect--commit) + t) + +(defun edit-indirect--abort-on-kill-buffer () + "Abort indirect edit. +Should be called only from `kill-buffer-hook'." + (when edit-indirect--overlay + (edit-indirect--abort))) + +(defun edit-indirect--barf-if-not-indirect () + "Signal an error if the current buffer is not an edit-indirect buffer. +The error signaled is `edit-indirect-not-indirect'." + (unless edit-indirect--overlay + (signal 'edit-indirect-not-indirect '()))) + +(provide 'edit-indirect) +;;; edit-indirect.el ends here diff --git a/archive/custom/eplot.el b/archive/custom/eplot.el new file mode 100644 index 00000000..c00a3e31 --- /dev/null +++ b/archive/custom/eplot.el @@ -0,0 +1,3495 @@ +;;; eplot.el --- Manage and Edit Wordpress Posts -*- lexical-binding: t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: charts +;; Package: eplot +;; Version: 1.0 +;; Package-Requires: ((emacs "29.0.59") (pcsv "0.0")) + +;; eplot is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;;; Commentary: + +;; The main entry point is `M-x eplot' in a buffer with time series +;; data. +;; +;; If installing manually, put something like the following in your +;; Emacs init file (but adjust the path to where you've put eplot): +;; +;; (push "~/src/eplot/" load-path) +;; (autoload 'eplot "eplot" nil t) +;; (autoload 'eplot-mode "eplot" nil t) +;; (unless (assoc "\\.plt" auto-mode-alist) +;; (setq auto-mode-alist (cons '("\\.plt" . eplot-mode) auto-mode-alist))) + +;; This requires the pcsv package to parse CSV files. + +;;; Code: + +(require 'svg) +(require 'cl-lib) +(require 'face-remap) +(require 'eieio) +(require 'iso8601) +(require 'transient) + +(defvar eplot--user-defaults nil) +(defvar eplot--chart-headers nil) +(defvar eplot--plot-headers nil) +(defvar eplot--transient-settings nil) + + +(defvar eplot--colors + '("aliceblue" "antiquewhite" "aqua" "aquamarine" "azure" "beige" "bisque" + "black" "blanchedalmond" "blue" "blueviolet" "brown" "burlywood" + "cadetblue" "chartreuse" "chocolate" "coral" "cornflowerblue" "cornsilk" + "crimson" "cyan" "darkblue" "darkcyan" "darkgoldenrod" "darkgray" + "darkgreen" "darkgrey" "darkkhaki" "darkmagenta" "darkolivegreen" + "darkorange" "darkorchid" "darkred" "darksalmon" "darkseagreen" + "darkslateblue" "darkslategray" "darkslategrey" "darkturquoise" + "darkviolet" "deeppink" "deepskyblue" "dimgray" "dimgrey" "dodgerblue" + "firebrick" "floralwhite" "forestgreen" "fuchsia" "gainsboro" "ghostwhite" + "gold" "goldenrod" "gray" "green" "greenyellow" "grey" "honeydew" "hotpink" + "indianred" "indigo" "ivory" "khaki" "lavender" "lavenderblush" "lawngreen" + "lemonchiffon" "lightblue" "lightcoral" "lightcyan" "lightgoldenrodyellow" + "lightgray" "lightgreen" "lightgrey" "lightpink" "lightsalmon" + "lightseagreen" "lightskyblue" "lightslategray" "lightslategrey" + "lightsteelblue" "lightyellow" "lime" "limegreen" "linen" "magenta" + "maroon" "mediumaquamarine" "mediumblue" "mediumorchid" "mediumpurple" + "mediumseagreen" "mediumslateblue" "mediumspringgreen" "mediumturquoise" + "mediumvioletred" "midnightblue" "mintcream" "mistyrose" "moccasin" + "navajowhite" "navy" "oldlace" "olive" "olivedrab" "orange" "orangered" + "orchid" "palegoldenrod" "palegreen" "paleturquoise" "palevioletred" + "papayawhip" "peachpuff" "peru" "pink" "plum" "powderblue" "purple" "red" + "rosybrown" "royalblue" "saddlebrown" "salmon" "sandybrown" "seagreen" + "seashell" "sienna" "silver" "skyblue" "slateblue" "slategray" "slategrey" + "snow" "springgreen" "steelblue" "tan" "teal" "thistle" "tomato" + "turquoise" "violet" "wheat" "white" "whitesmoke" "yellow" "yellowgreen")) + +(defun eplot-set (header value) + "Set the default value of HEADER to VALUE. +To get a list of all possible HEADERs, use the `M-x +eplot-list-chart-headers' command. + +Also see `eplot-reset'." + (let ((elem (or (assq header eplot--chart-headers) + (assq header eplot--plot-headers)))) + (unless elem + (error "No such header type: %s" header)) + (eplot--add-default header value))) + +(defun eplot--add-default (header value) + ;; We want to preserve the order defaults have been added, so that + ;; we can apply them in the same order. This makes a difference + ;; when we're dealing with specs that have inheritence. + (setq eplot--user-defaults (delq (assq header eplot--user-defaults) + eplot--user-defaults)) + (setq eplot--user-defaults (list (cons header value)))) + +(defun eplot-reset (&optional header) + "Reset HEADER to defaults. +If HEADER is nil or not present, reset everything to defaults." + (if header + (setq eplot--user-defaults (delq (assq header eplot--user-defaults) + eplot--user-defaults)) + (setq eplot--user-defaults nil))) + +(unless (assoc "\\.plt" auto-mode-alist) + (setq auto-mode-alist (cons '("\\.plt" . eplot-mode) auto-mode-alist))) + +;;; eplot modes. + +(defvar-keymap eplot-mode-map + "C-c C-c" #'eplot-update-view-buffer + "C-c C-p" #'eplot-switch-view-buffer + "C-c C-e" #'eplot-list-chart-headers + "C-c C-v" #'eplot-customize + "C-c C-l" #'eplot-create-controls + "TAB" #'eplot-complete) + +;; # is working overtime in the syntax here: +;; It can be a color like Color: #e0e0e0, and +;; it can be a setting like 33 # Label: Apples, +;; when it starts a line it's a comment. +(defvar eplot-font-lock-keywords + `(("^[ \t\n]*#.*" . font-lock-comment-face) + ("^[^ :\n]+:" . font-lock-keyword-face) + ("#[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]\\([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]\\)?" . font-lock-variable-name-face) + ("#.*" . font-lock-builtin-face))) + +(define-derived-mode eplot-mode text-mode "eplot" + "Major mode for editing charts. +Use the \\[eplot-list-chart-headers] command to get a list of all +possible chart headers." + (setq-local completion-at-point-functions + (cons 'eplot--complete-header completion-at-point-functions)) + (setq-local font-lock-defaults + '(eplot-font-lock-keywords nil nil nil))) + +(defun eplot-complete () + "Complete headers." + (interactive) + (cond + ((let ((completion-fail-discreetly t)) + (completion-at-point)) + ;; Completion was performed; nothing else to do. + nil) + (t (indent-relative)))) + +(defun eplot--complete-header () + (or + ;; Complete headers names. + (and (or (looking-at ".*:") + (and (looking-at "[ \t]*$") + (save-excursion + (beginning-of-line) + (not (looking-at "\\(.+\\):"))))) + (lambda () + (let ((headers (mapcar + (lambda (h) + (if (looking-at ".*:") + (capitalize (symbol-name (car h))) + (concat (capitalize (symbol-name (car h))) ": "))) + (save-excursion + ;; If we're after the headers, then we want + ;; to complete over the plot headers. Otherwise, + ;; complete over the chart headers. + (if (and (not (bobp)) + (progn + (forward-line -1) + (re-search-backward "^[ \t]*$" nil t))) + eplot--plot-headers + eplot--chart-headers)))) + (completion-ignore-case t)) + (completion-in-region (pos-bol) (line-end-position) headers) + 'completion-attempted))) + ;; Complete header values. + (let ((hname nil)) + (and (save-excursion + (and (looking-at "[ \t]*$") + (progn + (beginning-of-line) + (and (looking-at "\\(.+\\):") + (setq hname (intern (downcase (match-string 1))))))) + (lambda () + (let ((valid (plist-get + (cdr (assq hname (append eplot--plot-headers + eplot--chart-headers))) + :valid)) + (completion-ignore-case t)) + (completion-in-region + (save-excursion + (search-backward ":" (pos-bol) t) + (skip-chars-forward ": \t") + (point)) + (line-end-position) + (mapcar #'symbol-name valid)) + 'completion-attempted))))))) + +(define-minor-mode eplot-minor-mode + "Minor mode to issue commands from an eplot data buffer." + :lighter " eplot") + +(defvar-keymap eplot-minor-mode-map + "H-l" #'eplot-eval-and-update) + +(defvar-keymap eplot-view-mode-map + "s" #'eplot-view-write-file + "w" #'eplot-view-write-scaled-file + "c" #'eplot-view-customize + "l" #'eplot-create-controls) + +(define-derived-mode eplot-view-mode special-mode "eplot view" + "Major mode for displaying eplots." + (setq-local revert-buffer-function #'eplot-update + cursor-type nil)) + +(defun eplot-view-write-file (file &optional width) + "Write the current chart to a file. +If you type in a file name that ends with something else than \"svg\", +ImageMagick \"convert\" will be used to convert the image first. + +If writing to a PNG file, \"rsvg-conver\" will be used instead if +it exists as this usually gives better results." + (interactive "FWrite to file name: ") + (when (and (file-exists-p file) + (not (yes-or-no-p "File exists, overwrite? "))) + (error "Not overwriting the file")) + (save-excursion + (goto-char (point-min)) + (let ((match + (text-property-search-forward 'display nil + (lambda (_ e) + (and (consp e) + (eq (car e) 'image)))))) + (unless match + (error "Can't find an image in the current buffer")) + (let ((svg (plist-get (cdr (prop-match-value match)) :data)) + (tmp " *eplot convert*") + (executable (if width "rsvg-convert" "convert")) + sfile ofile) + (unless svg + (error "Invalid image in the current buffer")) + (with-temp-buffer + (set-buffer-multibyte nil) + (svg-print svg) + (if (string-match-p "\\.svg\\'" file) + (write-region (point-min) (point-max) file) + (if (and (string-match-p "\\.png\\'" file) + (executable-find "rsvg-convert")) + (setq executable "rsvg-convert") + (unless (executable-find executable) + (error "%s isn't installed; can only save svg files" + executable))) + (when (and (equal executable "rsvg-convert") + (not (string-match-p "\\.png\\'" file)) + (not (executable-find "convert"))) + (error "Can only write PNG files when scaling because \"convert\" isn't installed")) + (unwind-protect + (progn + (setq sfile (make-temp-file "eplot" nil ".svg") + ofile (make-temp-file "eplot" nil ".png")) + (write-region (point-min) (point-max) sfile nil 'silent) + ;; We don't use `call-process-region', because + ;; convert doesn't seem to like that? + (let ((code (if (equal executable "rsvg-convert") + (apply + #'call-process + executable nil (get-buffer-create tmp) nil + `(,(format "--output=%s" + (expand-file-name ofile)) + ,@(and width + `(,(format "--width=%d" width) + "--keep-aspect-ratio")) + ,sfile)) + (call-process + executable nil (get-buffer-create tmp) nil + sfile file)))) + (eplot--view-error code tmp) + (when (file-exists-p ofile) + (if (string-match-p "\\.png\\'" file) + (rename-file ofile file) + (let ((code (call-process "convert" nil tmp nil + ofile file))) + (eplot--view-error code tmp)))) + (message "Wrote %s" file))) + ;; Clean-up. + (when (get-buffer tmp) + (kill-buffer tmp)) + (when (file-exists-p sfile) + (delete-file sfile)) + (when (file-exists-p ofile) + (delete-file sfile))))))))) + +(defun eplot--view-error (code tmp) + (unless (zerop code) + (error "Error code %d: %s" + code + (with-current-buffer tmp + (while (search-forward "[ \t\n]+" nil t) + (replace-match " ")) + (string-trim (buffer-string)))))) + +(defun eplot-view-write-scaled-file (width file) + "Write the current chart to a rescaled to a file. +The rescaling is done by \"rsvg-convert\", which has to be +installed. Rescaling is done when rendering, so this should give +you a clear, non-blurry version of the chart at any size." + (interactive "nWidth: \nFWrite to file: ") + (eplot-view-write-file file width)) + +(defun eplot-view-customize () + "Customize the settings for the chart in the current buffer." + (interactive) + (with-suppressed-warnings ((interactive-only eplot-customize)) + (eplot-customize))) + +(defvar eplot--data-buffer nil) +(defvar eplot--current-chart nil) + +(defun eplot () + "Plot the data in the current buffer." + (interactive) + (eplot-update-view-buffer)) + +(defun eplot-with-headers (header-file) + "Plot the data in the current buffer using headers from a file." + (interactive "fHeader file: ") + (eplot-update-view-buffer + (with-temp-buffer + (insert-file-contents header-file) + (eplot--parse-headers)))) + +(defun eplot-make-plot (headers &rest datas) + "Return an SVG based on DATA. +DATA should be pairs of headers, then followed by the plot data." + (with-temp-buffer + ;; Insert the headers. + (dolist (line headers) + (insert (format "%s:" (pop line))) + (dolist (elem line) + (insert (format " %s" elem))) + (insert "\n")) + ;; Then insert all the plot data sets. + (dolist (data datas) + (insert "\n") + (dolist (line data) + (dolist (elem line) + (insert (format "%s" elem) " ")) + (insert "\n"))) + ;;(setq a (buffer-string)) (debug) + (eplot--render (eplot--parse-buffer) t))) + +(defun eplot-switch-view-buffer () + "Switch to the eplot view buffer and render the chart." + (interactive) + (eplot-update-view-buffer nil t)) + +(defun eplot-update-view-buffer (&optional headers switch) + "Update the eplot view buffer based on the current data buffer." + (interactive) + ;; This is mainly useful during implementation. + (if (and (eq major-mode 'emacs-lisp-mode) + (get-buffer-window "*eplot*" t)) + (with-current-buffer "*eplot*" + (eplot-update) + (when-let ((win (get-buffer-window "*eplot*" t))) + (set-window-point win (point-min)))) + ;; Normal case. + (let* ((eplot--user-defaults (eplot--settings-table)) + (data (eplot--parse-buffer)) + (data-buffer (current-buffer)) + (window (selected-window))) + (unless data + (user-error "No data in the current buffer")) + (setq data (eplot--inject-headers data headers)) + (if (get-buffer-window "*eplot*" t) + (set-buffer "*eplot*") + (if switch + (pop-to-buffer-same-window "*eplot*") + (pop-to-buffer "*eplot*"))) + (let ((inhibit-read-only t)) + (erase-buffer) + (unless (eq major-mode 'eplot-view-mode) + (eplot-view-mode)) + (setq-local eplot--data-buffer data-buffer) + (let ((chart (eplot--render data))) + (with-current-buffer data-buffer + (setq-local eplot--current-chart chart))) + (insert "\n") + (when-let ((win (get-buffer-window "*eplot*" t))) + (set-window-point win (point-min)))) + (select-window window)))) + +(defun eplot--settings-table () + (if (not eplot--transient-settings) + eplot--user-defaults + (append eplot--user-defaults eplot--transient-settings))) + +(defun eplot--inject-headers (data headers) + ;; It's OK not to separate the plot headers from the chart + ;; headers. Collect them here, if any. + (when-let ((plot-headers + (cl-loop for elem in (mapcar #'car eplot--plot-headers) + for value = (eplot--vs elem headers) + when value + collect (progn + ;; Remove these headers from the data + ;; headers so that we don't get errors + ;; on undefined headers. + (setq headers (delq (assq elem headers) + headers)) + (cons elem value))))) + (dolist (plot (cdr (assq :plots data))) + (let ((headers (assq :headers plot))) + (if headers + (nconc headers plot-headers) + (nconc plot (list (list :headers plot-headers))))))) + (append data headers)) + +(defun eplot-eval-and-update () + "Helper command when developing." + (interactive nil emacs-lisp-mode) + (save-some-buffers t) + (elisp-eval-buffer) + (eval-defun nil) + (eplot-update-view-buffer)) + +;;; Parsing buffers. + +(defun eplot-update (&rest _ignore) + "Update the plot in the current buffer." + (interactive) + (unless eplot--data-buffer + (user-error "No data buffer associated with this eplot view buffer")) + (let ((data (with-current-buffer eplot--data-buffer + (eplot--parse-buffer))) + (eplot--user-defaults (with-current-buffer eplot--data-buffer + (eplot--settings-table))) + (inhibit-read-only t)) + (erase-buffer) + (let ((chart (eplot--render data))) + (with-current-buffer eplot--data-buffer + (setq-local eplot--current-chart chart))) + (insert "\n\n"))) + +(defun eplot--parse-buffer () + (if (eq major-mode 'org-mode) + (eplot--parse-org-buffer) + (eplot--parse-eplot-buffer))) + +(defun eplot--parse-eplot-buffer () + (if (eplot--csv-buffer-p) + (eplot--parse-csv-buffer) + (let ((buf (current-buffer))) + (with-temp-buffer + (insert-buffer-substring buf) + ;; Remove comments first. + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*#" nil t) + (delete-line)) + (goto-char (point-min)) + ;; First headers. + (let* ((data (eplot--parse-headers)) + (plot-headers + ;; It's OK not to separate the plot headers from the chart + ;; headers. Collect them here, if any. + (cl-loop for elem in (mapcar #'car eplot--plot-headers) + for value = (eplot--vs elem data) + when value + collect (progn + ;; Remove these headers from the data + ;; headers so that we don't get errors + ;; on undefined headers. + (setq data (delq (assq elem data) data)) + (cons elem value)))) + plots) + ;; Then the values. + (while-let ((plot (eplot--parse-values nil plot-headers))) + (setq plot-headers nil) + (push plot plots)) + (when plots + (push (cons :plots (nreverse plots)) data)) + data))))) + +(defun eplot--parse-headers () + (let ((data nil) + type value) + (while (looking-at "\\([^\n\t :]+\\):\\(.*\\)") + (setq type (intern (downcase (match-string 1))) + value (substring-no-properties (string-trim (match-string 2)))) + (forward-line 1) + ;; Get continuation lines. + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value " " (string-trim (match-string 1)))) + (forward-line 1)) + (if (eq type 'header-file) + (setq data (nconc data + (with-temp-buffer + (insert-file-contents value) + (eplot--parse-headers)))) + ;; We don't use `push' here because we want to preserve order + ;; also when inserting headers from other files. + (setq data (nconc data (list (cons type value)))))) + data)) + +(defun eplot--parse-values (&optional in-headers data-headers) + ;; Skip past separator lines. + (while (looking-at "[ \t]*\n") + (forward-line 1)) + (let* ((values nil) + ;; We may have plot-specific headers. + (headers (nconc (eplot--parse-headers) data-headers)) + (data-format (or (eplot--vyl 'data-format headers) + (eplot--vyl 'data-format in-headers))) + (two-values (memq 'two-values data-format)) + (xy (or (memq 'year data-format) + (memq 'date data-format) + (memq 'time data-format) + (memq 'xy data-format))) + (data-column (or (eplot--vn 'data-column headers) + (eplot--vn 'data-column in-headers)))) + (if-let ((data-file (eplot--vs 'data-file headers))) + (with-temp-buffer + (insert-file-contents data-file) + (setq values (cdr (assq :values (eplot--parse-values headers))) + headers (delq (assq 'data headers) headers))) + ;; Now we come to the data. The data is typically either just a + ;; number, or two numbers (in which case the first number is a + ;; date or a time). Labels ans settings can be introduced with + ;; a # char. + (while (looking-at "\\([-0-9. \t]+\\)\\([ \t]*#\\(.*\\)\\)?") + (let ((numbers (match-string 1)) + (settings (eplot--parse-settings (match-string 3))) + this) + (setq numbers (mapcar #'string-to-number + (split-string (string-trim numbers)))) + ;; If we're reading two dimensionalish data, the first + ;; number is the date/time/x. + (when xy + (setq this (list :x (pop numbers)))) + ;; Chop off all the numbers until we read the column(s) + ;; we're using. + (when data-column + (setq numbers (nthcdr (1- data-column) numbers))) + (when numbers + (setq this (nconc this (list :value (pop numbers))))) + (when two-values + (setq this (nconc this (list :extra-value (pop numbers))))) + (when settings + (setq this (nconc this (list :settings settings)))) + (when (plist-get this :value) + (push this values))) + (forward-line 1)) + (setq values (nreverse values))) + (and values + `((:headers . ,headers) (:values . ,values))))) + +(defun eplot--parse-settings (string) + (when string + (with-temp-buffer + (insert (string-trim string) "\n") + (goto-char (point-min)) + (while (re-search-forward "\\(.\\)," nil t) + (if (equal (match-string 1) "\\") + (replace-match "," t t) + (delete-char -1) + (insert "\n") + (when (looking-at "[ \t]+") + (replace-match "")))) + (goto-char (point-min)) + (eplot--parse-headers)))) + +;;; Accessing data. + +(defun eplot--vn (type data &optional default) + (if-let ((value (cdr (assq type data)))) + (string-to-number value) + default)) + +(defun eplot--vs (type data &optional default) + (or (cdr (assq type data)) default)) + +(defun eplot--vy (type data &optional default) + (if-let ((value (cdr (assq type data)))) + (intern (downcase value)) + default)) + +(defun eplot--vyl (type data &optional default) + (if-let ((value (cdr (assq type data)))) + (mapcar #'intern (split-string (downcase value))) + default)) + +(defmacro eplot-def (args doc-string) + (declare (indent defun)) + `(eplot--def ',(nth 0 args) ',(nth 1 args) ',(nth 2 args) ',(nth 3 args) + ,doc-string)) + +(defun eplot--def (name type default valid doc) + (setq eplot--chart-headers (delq (assq name eplot--chart-headers) + eplot--chart-headers)) + (push (list name + :type type + :default default + :doc doc + :valid valid) + eplot--chart-headers)) + +(eplot-def (width number) + "The width of the entire chart.") + +(eplot-def (height number) + "The height of the entire chart.") + +(eplot-def (format symbol normal (normal bar-chart horizontal-bar-chart)) + "The overall format of the chart.") + +(eplot-def (layout symbol nil (normal compact)) + "The general layout of the chart.") + +(eplot-def (mode symbol light (dark light)) + "Dark/light mode.") + +(eplot-def (margin-left number 70) + "The left margin.") + +(eplot-def (margin-right number 20) + "The right margin.") + +(eplot-def (margin-top number 40) + "The top margin.") + +(eplot-def (margin-bottom number 60) + "The bottom margin.") + +(eplot-def (x-axis-title-space number 5) + "The space between the X axis and the label.") + +(eplot-def (font string "sans-serif") + "The font to use in titles, labels and legends.") + +(eplot-def (font-size number 12) + "The font size.") + +(eplot-def (font-weight symbol bold (bold normal)) + "The font weight.") + +(eplot-def (label-font string (spec font)) + "The font to use for axes labels.") + +(eplot-def (label-font-size number (spec font-size)) + "The font size to use for axes labels.") + +(eplot-def (horizontal-label-font-size number (spec label-font-size)) + "The font size to use for horizontal labels.") + +(eplot-def (bar-font string (spec font)) + "The font to use for bar chart labels.") + +(eplot-def (bar-font-size number (spec font-size)) + "The font size to use for bar chart labels.") + +(eplot-def (bar-font-weight symbol (spec font-weight) (bold normal)) + "The font weight to use for bar chart labels.") + +(eplot-def (chart-color string "black") + "The foreground color to use in plots, axes, legends, etc. +This is used as the default, but can be overridden per thing.") + +(eplot-def (background-color string "white") + "The background color. +If you want a chart with a transparent background, use the color +\"none\".") + +(eplot-def (background-gradient string) + "Use this to get a gradient color in the background.") + +(eplot-def (axes-color string (spec chart-color)) + "The color of the axes.") + +(eplot-def (grid-color string "#e0e0e0") + "The color of the grid.") + +(eplot-def (grid symbol xy (xy x y off)) + "What grid axes to do.") + +(eplot-def (grid-opacity number) + "The opacity of the grid. +This should either be nil or a value between 0 and 1, where 0 is +fully transparent.") + +(eplot-def (grid-position symbol bottom (bottom top)) + "Whether to put the grid on top or under the plot.") + +(eplot-def (legend symbol nil (true nil)) + "Whether to do a legend.") + +(eplot-def (legend-color string (spec chart-color)) + "The color of legends (if any).") + +(eplot-def (legend-border-color string (spec chart-color)) + "The border color of legends (if any).") + +(eplot-def (legend-background-color string (spec background-color)) + "The background color of legends (if any).") + +(eplot-def (label-color string (spec axes-color)) + "The color of labels on the axes.") + +(eplot-def (surround-color string) + "The color between the plot area and the edges of the chart.") + +(eplot-def (border-color string) + "The color of the border of the chart, if any.") + +(eplot-def (border-width number) + "The width of the border of the chart, if any.") + +(eplot-def (frame-color string) + "The color of the frame of the plot, if any.") + +(eplot-def (frame-width number) + "The width of the frame of the plot, if any.") + +(eplot-def (min number) + "The minimum value in the chart. +This is normally computed automatically, but can be overridden + with this spec.") + +(eplot-def (max number) + "The maximum value in the chart. +This is normally computed automatically, but can be overridden + with this spec.") + +(eplot-def (title string) + "The title of the chart, if any.") + +(eplot-def (title-color string (spec chart-color)) + "The color of the title.") + +(eplot-def (x-title string) + "The title of the X axis, if any.") + +(eplot-def (y-title string) + "The title of the X axis, if any.") + +(eplot-def (x-label-format string) + "Format string for the X labels. +This is a `format' string.") + +(eplot-def (y-label-format string) + "Format string for the Y labels. +This is a `format' string.") + +(eplot-def (horizontal-label-left number) + "Position of the horizontal labels.") + +(eplot-def (x-label-orientation symbol horizontal (horizontal vertical)) + "Orientation of the X labels.") + +(eplot-def (background-image-file string) + "Use an image as the background.") + +(eplot-def (background-image-opacity number 1) + "The opacity of the background image.") + +(eplot-def (background-image-cover symbol all (all plot frame)) + "Position of the background image. +Valid values are `all' (the entire image), `plot' (the plot area) +and `frame' (the surrounding area).") + +(eplot-def (header-file string) + "File where the headers are.") + +(defvar eplot-compact-defaults + '((margin-left 30) + (margin-right 10) + (margin-top 20) + (margin-bottom 21) + (font-size 12) + (x-axis-title-space 3))) + +(defvar eplot-dark-defaults + '((chart-color "#c0c0c0") + (axes-color "#c0c0c0") + (grid-color "#404040") + (background-color "#101010") + (label-color "#c0c0c0") + (legend-color "#c0c0c0") + (legend-background-color "#000000") + (title-color "#c0c0c0"))) + +(defvar eplot-bar-chart-defaults + '((grid-position top) + (grid y) + (grid-opacity 0.2) + (min 0))) + +(defvar eplot-horizontal-bar-chart-defaults + '((grid-position top) + (grid-opacity 0.2) + (min 0))) + +(defclass eplot-chart () + ( + (plots :initarg :plots) + (data :initarg :data) + (xs) + (ys) + (x-values :initform nil) + (x-type :initform nil) + (x-min) + (x-max) + (x-ticks) + (y-ticks) + (y-labels) + (x-labels) + (print-format) + (x-tick-step) + (x-label-step) + (x-step-map :initform nil) + (y-tick-step) + (y-label-step) + (inhibit-compute-x-step :initform nil) + ;; ---- CUT HERE ---- + (axes-color :initarg :axes-color :initform nil) + (background-color :initarg :background-color :initform nil) + (background-gradient :initarg :background-gradient :initform nil) + (background-image-cover :initarg :background-image-cover :initform nil) + (background-image-file :initarg :background-image-file :initform nil) + (background-image-opacity :initarg :background-image-opacity :initform nil) + (bar-font :initarg :bar-font :initform nil) + (bar-font-size :initarg :bar-font-size :initform nil) + (bar-font-weight :initarg :bar-font-weight :initform nil) + (border-color :initarg :border-color :initform nil) + (border-width :initarg :border-width :initform nil) + (chart-color :initarg :chart-color :initform nil) + (font :initarg :font :initform nil) + (font-size :initarg :font-size :initform nil) + (font-weight :initarg :font-weight :initform nil) + (format :initarg :format :initform nil) + (frame-color :initarg :frame-color :initform nil) + (frame-width :initarg :frame-width :initform nil) + (grid :initarg :grid :initform nil) + (grid-color :initarg :grid-color :initform nil) + (grid-opacity :initarg :grid-opacity :initform nil) + (grid-position :initarg :grid-position :initform nil) + (header-file :initarg :header-file :initform nil) + (height :initarg :height :initform nil) + (horizontal-label-font-size :initarg :horizontal-label-font-size :initform nil) + (label-color :initarg :label-color :initform nil) + (label-font :initarg :label-font :initform nil) + (label-font-size :initarg :label-font-size :initform nil) + (layout :initarg :layout :initform nil) + (legend :initarg :legend :initform nil) + (legend-background-color :initarg :legend-background-color :initform nil) + (legend-border-color :initarg :legend-border-color :initform nil) + (legend-color :initarg :legend-color :initform nil) + (margin-bottom :initarg :margin-bottom :initform nil) + (margin-left :initarg :margin-left :initform nil) + (margin-right :initarg :margin-right :initform nil) + (margin-top :initarg :margin-top :initform nil) + (max :initarg :max :initform nil) + (min :initarg :min :initform nil) + (mode :initarg :mode :initform nil) + (surround-color :initarg :surround-color :initform nil) + (title :initarg :title :initform nil) + (title-color :initarg :title-color :initform nil) + (width :initarg :width :initform nil) + (x-axis-title-space :initarg :x-axis-title-space :initform nil) + (x-title :initarg :x-title :initform nil) + (y-title :initarg :y-title :initform nil) + (x-label-format :initarg :x-label-format :initform nil) + (x-label-orientation :initarg :x-label-orientation :initform nil) + (y-label-format :initarg :y-label-format :initform nil) + (horizontal-label-left :initarg :horizontal-label-left :initform nil) + ;; ---- CUT HERE ---- + )) + +;;; Parameters that are plot specific. + +(defmacro eplot-pdef (args doc-string) + (declare (indent defun)) + `(eplot--pdef ',(nth 0 args) ',(nth 1 args) ',(nth 2 args) ',(nth 3 args) + ,doc-string)) + +(defun eplot--pdef (name type default valid doc) + (setq eplot--plot-headers (delq (assq name eplot--plot-headers) + eplot--plot-headers)) + (push (list name + :type type + :default default + :valid valid + :doc doc) + eplot--plot-headers)) + +(eplot-pdef (smoothing symbol nil (moving-average nil)) + "Smoothing algorithm to apply to the data, if any. +Valid values are `moving-average' and, er, probably more to come.") + +(eplot-pdef (gradient string) + "Gradient to apply to the plot. +The syntax is: + + from-color to-color direction position + +The last two parameters are optional. + +direction is either `top-down' (the default), `bottom-up', +`left-right' or `right-left'). + +position is either `below' or `above'. + +to-color can be either a color name, or a string that defines +stops and colors: + + Gradient: black 25-purple-50-white-75-purple-black + +In that case, the second element specifies the percentage points +of where each color ends, so the above starts with black, then at +25% it's purple, then at 50% it's white, then it's back to purple +again at 75%, before ending up at black at a 100% (but you don't +have to include the 100% here -- it's understood).") + +(eplot-pdef (style symbol line ( line impulse point square circle cross + triangle rectangle curve)) + "Style the plot should be drawn in. +Valid values are listed below. Some styles take additional +optional parameters. + +line + Straight lines between values. + +curve + Curved lines between values. + +impulse + size: width of the impulse + +point + +square + +circle + size: diameter of the circle + fill-color: color to fill the center + +cross + size: length of the lines in the cross + +triangle + size: length of the sides of the triangle + fill-color: color to fill the center + +rectangle + size: length of the sides of the rectangle + fill-color: color to fill the center") + +(eplot-pdef (fill-color string) + "Color to use to fill the plot styles that are closed shapes. +I.e., circle, triangle and rectangle.") + +(eplot-pdef (color string (spec chart-color)) + "Color to draw the plot.") + +(eplot-pdef (data-format symbol single (single date time xy)) + "Format of the data. +By default, eplot assumes that each line has a single data point. +This can also be `date', `time' and `xy'. + +date: The first column is a date on ISO8601 format (i.e., YYYYMMDD). + +time: The first column is a clock (i.e., HHMMSS). + +xy: The first column is the X position.") + +(eplot-pdef (data-column number 1) + "Column where the data is.") + +(eplot-pdef (fill-border-color string) + "Border around the fill area when using a fill/gradient style.") + +(eplot-pdef (size number) + "Size of elements in styles that have meaningful sizes.") + +(eplot-pdef (size-factor number) + "Multiply the size of the elements by the value.") + +(eplot-pdef (data-file string) + "File where the data is.") + +(eplot-pdef (data-format symbol-list nil (nil two-values date time)) + "List of symbols to describe the data format. +Elements allowed are `two-values', `date' and `time'.") + +(eplot-pdef (name string) + "Name of the plot, which will be displayed if legends are switched on.") + +(eplot-pdef (legend-color string (spec chart-color)) + "Color for the name to be displayed in the legend.") + +(eplot-pdef (bezier-factor number 0.1) + "The Bezier factor to apply to curve plots.") + +(eplot-pdef (bar-max-width number) + "Max width of bars in bar plots.") + +(defclass eplot-plot () + ( + (values :initarg :values) + ;; ---- CUT HERE ---- + (bar-max-width :initarg :bar-max-width :initform nil) + (bezier-factor :initarg :bezier-factor :initform nil) + (color :initarg :color :initform nil) + (data-column :initarg :data-column :initform nil) + (data-file :initarg :data-file :initform nil) + (data-format :initarg :data-format :initform nil) + (fill-border-color :initarg :fill-border-color :initform nil) + (fill-color :initarg :fill-color :initform nil) + (gradient :initarg :gradient :initform nil) + (legend-color :initarg :legend-color :initform nil) + (name :initarg :name :initform nil) + (size :initarg :size :initform nil) + (size-factor :initarg :size-factor :initform nil) + (smoothing :initarg :smoothing :initform nil) + (style :initarg :style :initform nil) + ;; ---- CUT HERE ---- + )) + +(defun eplot--make-plot (data) + "Make an `eplot-plot' object and initialize based on DATA." + (let ((plot (make-instance 'eplot-plot + :values (cdr (assq :values data))))) + ;; Get the program-defined defaults. + (eplot--object-defaults plot eplot--plot-headers) + ;; One special case. I don't think this hack is quite right... + (when (or (eq (eplot--vs 'mode data) 'dark) + (eq (cdr (assq 'mode eplot--user-defaults)) 'dark)) + (setf (slot-value plot 'color) "#c0c0c0")) + ;; Use the headers. + (eplot--object-values plot (cdr (assq :headers data)) eplot--plot-headers) + plot)) + +(defun eplot--make-chart (data) + "Make an `eplot-chart' object and initialize based on DATA." + (let ((chart (make-instance 'eplot-chart + :plots (mapcar #'eplot--make-plot + (eplot--vs :plots data)) + :data data))) + ;; First get the program-defined defaults. + (eplot--object-defaults chart eplot--chart-headers) + ;; Then do the "meta" variables. + (eplot--meta chart data 'mode 'dark eplot-dark-defaults) + (eplot--meta chart data 'layout 'compact eplot-compact-defaults) + (eplot--meta chart data 'format 'bar-chart eplot-bar-chart-defaults) + (eplot--meta chart data 'format 'horizontal-bar-chart + eplot-horizontal-bar-chart-defaults) + ;; Set defaults from user settings/transients. + (cl-loop for (name . value) in eplot--user-defaults + when (assq name eplot--chart-headers) + do + (setf (slot-value chart name) value) + (eplot--set-dependent-values chart name value)) + ;; Finally, use the data from the chart. + (eplot--object-values chart data eplot--chart-headers) + ;; If not set, recompute the margins based on the font sizes (if + ;; the font size has been changed from defaults). + (when (or (assq 'font-size eplot--user-defaults) + (assq 'font-size data)) + (with-slots ( title x-title y-title + margin-top margin-bottom margin-left + font-size font font-weight) + chart + (when (or title x-title y-title) + (let ((text-height + (eplot--text-height (concat title x-title y-title) + font font-size font-weight))) + (when (and title + (and (not (assq 'margin-top eplot--user-defaults)) + (not (assq 'margin-top data)))) + (cl-incf margin-top (* text-height 1.4))) + (when (and x-title + (and (not (assq 'margin-bottom eplot--user-defaults)) + (not (assq 'margin-bottom data)))) + (cl-incf margin-bottom (* text-height 1.4))) + (when (and y-title + (and (not (assq 'margin-left eplot--user-defaults)) + (not (assq 'margin-left data)))) + (cl-incf margin-left (* text-height 1.4))))))) + chart)) + +(defun eplot--meta (chart data slot value defaults) + (when (or (eq (cdr (assq slot eplot--user-defaults)) value) + (eq (eplot--vy slot data) value)) + (eplot--set-theme chart defaults))) + +(defun eplot--object-defaults (object headers) + (dolist (header headers) + (when-let ((default (plist-get (cdr header) :default))) + (setf (slot-value object (car header)) + ;; Allow overrides via `eplot-set'. + (or (cdr (assq (car header) eplot--user-defaults)) + (if (and (consp default) + (eq (car default) 'spec)) + ;; Chase dependencies. + (eplot--default (cadr default)) + default)))))) + +(defun eplot--object-values (object data headers) + (cl-loop for (name . value) in data + do (unless (eq name :plots) + (let ((spec (cdr (assq name headers)))) + (if (not spec) + (error "%s is not a valid spec" name) + (let ((value + (cl-case (plist-get spec :type) + (number + (string-to-number value)) + (symbol + (intern (downcase value))) + (symbol-list + (mapcar #'intern (split-string (downcase value)))) + (t + value)))) + (setf (slot-value object name) value) + (eplot--set-dependent-values object name value))))))) + +(defun eplot--set-dependent-values (object name value) + (dolist (slot (gethash name (eplot--dependecy-graph))) + (setf (slot-value object slot) value) + (eplot--set-dependent-values object slot value))) + +(defun eplot--set-theme (chart map) + (cl-loop for (slot value) in map + do (setf (slot-value chart slot) value))) + +(defun eplot--default (slot) + "Find the default value for SLOT, chasing dependencies." + (let ((spec (cdr (assq slot eplot--chart-headers)))) + (unless spec + (error "Invalid slot %s" slot)) + (let ((default (plist-get spec :default))) + (if (and (consp default) + (eq (car default) 'spec)) + (eplot--default (cadr default)) + (or (cdr (assq slot eplot--user-defaults)) default))))) + +(defun eplot--dependecy-graph () + (let ((table (make-hash-table))) + (dolist (elem eplot--chart-headers) + (let ((default (plist-get (cdr elem) :default))) + (when (and (consp default) + (eq (car default) 'spec)) + (push (car elem) (gethash (cadr default) table))))) + table)) + +(defun eplot--render (data &optional return-image) + "Create the chart and display it. +If RETURN-IMAGE is non-nil, return it instead of displaying it." + (let* ((chart (eplot--make-chart data)) + svg) + (with-slots ( width height xs ys + margin-left margin-right margin-top margin-bottom + grid-position plots x-min format + x-label-orientation) + chart + ;; Set the size of the chart based on the window it's going to + ;; be displayed in. It uses the *eplot* window by default, or + ;; the current one if that isn't displayed. + (let ((factor (image-compute-scaling-factor image-scaling-factor))) + (unless width + (setq width (truncate + (/ (* (window-pixel-width + (get-buffer-window "*eplot*" t)) + 0.9) + factor)))) + (unless height + (setq height (truncate + (/ (* (window-pixel-height + (get-buffer-window "*eplot*" t)) + 0.9) + factor))))) + (setq svg (svg-create width height) + xs (- width margin-left margin-right) + ys (- height margin-top margin-bottom)) + ;; Protect against being called in an empty buffer. + (if (not (and plots + ;; Sanity check against the user choosing dimensions + ;; that leave no space for the plot. + (> ys 0) (> xs 0))) + ;; Just draw the basics. + (eplot--draw-basics svg chart) + + ;; Horizontal bar charts are special. + (when (eq format 'horizontal-bar-chart) + (eplot--adjust-horizontal-bar-chart chart data)) + ;; Compute min/max based on all plots, and also compute x-ticks + ;; etc. + (eplot--compute-chart-dimensions chart) + (when (and (eq x-label-orientation 'vertical) + (eplot--default-p 'margin-bottom (slot-value chart 'data))) + (eplot--adjust-vertical-x-labels chart)) + ;; Analyze values and adjust values accordingly. + (eplot--adjust-chart chart) + ;; Compute the Y labels -- this may adjust `margin-left'. + (eplot--compute-y-labels chart) + ;; Compute the X labels -- this may adjust `margin-bottom'. + (eplot--compute-x-labels chart) + ;; Draw background/borders/titles/etc. + (eplot--draw-basics svg chart) + + (when (eq grid-position 'top) + (eplot--draw-plots svg chart)) + + (eplot--draw-x-ticks svg chart) + (unless (eq format 'horizontal-bar-chart) + (eplot--draw-y-ticks svg chart)) + + ;; Draw axes. + (with-slots ( margin-left margin-right margin-margin-top + margin-bottom axes-color) + chart + (svg-line svg margin-left margin-top margin-left + (+ (- height margin-bottom) 5) + :stroke axes-color) + (svg-line svg (- margin-left 5) (- height margin-bottom) + (- width margin-right) (- height margin-bottom) + :stroke axes-color)) + + (when (eq grid-position 'bottom) + (eplot--draw-plots svg chart))) + + (with-slots (frame-color frame-width) chart + (when (or frame-color frame-width) + (svg-rectangle svg margin-left margin-top xs ys + :stroke-width frame-width + :fill "none" + :stroke-color frame-color))) + (eplot--draw-legend svg chart)) + + (if return-image + svg + (svg-insert-image svg) + chart))) + +(defun eplot--adjust-horizontal-bar-chart (chart data) + (with-slots ( plots bar-font bar-font-size bar-font-weight margin-left + width margin-right xs) + chart + (dolist (plot plots) + (with-slots ( data-format values) plot + (push 'xy data-format) + ;; Flip the values -- we want the values to be on the X + ;; axis instead. + (setf values + (cl-loop for value in values + for i from 1 + collect (list :value i + :x (plist-get value :value) + :settings + (plist-get value :settings)))) + (when (eplot--default-p 'margin-left data) + (setf margin-left + (+ (cl-loop for value in values + maximize + (eplot--text-width + (eplot--vs 'label (plist-get value :settings)) + bar-font bar-font-size bar-font-weight)) + 20) + xs (- width margin-left margin-right))))))) + +(defun eplot--draw-basics (svg chart) + (with-slots ( width height + chart-color font font-size font-weight + margin-left margin-right margin-top margin-bottom + background-color label-color + xs ys) + chart + ;; Add background. + (eplot--draw-background chart svg 0 0 width height) + (with-slots ( background-image-file background-image-opacity + background-image-cover) + chart + (when (and background-image-file + ;; Sanity checks to avoid erroring out later. + (file-exists-p background-image-file) + (file-regular-p background-image-file)) + (apply #'svg-embed svg background-image-file "image/jpeg" nil + :opacity background-image-opacity + :preserveAspectRatio "xMidYMid slice" + (if (memq background-image-cover '(all frame)) + `(:x 0 :y 0 :width ,width :height ,height) + `(:x ,margin-left :y ,margin-top :width ,xs :height ,ys))) + (when (eq background-image-cover 'frame) + (eplot--draw-background chart svg margin-left margin-right xs ys)))) + ;; Area between plot and edges. + (with-slots (surround-color) chart + (when surround-color + (svg-rectangle svg 0 0 width height + :fill surround-color) + (svg-rectangle svg margin-left margin-top + xs ys + :fill background-color))) + ;; Border around the entire chart. + (with-slots (border-width border-color) chart + (when (or border-width border-color) + (svg-rectangle svg 0 0 width height + :stroke-width (or border-width 1) + :fill "none" + :stroke-color (or border-color chart-color)))) + ;; Frame around the plot. + (with-slots (frame-width frame-color) chart + (when (or frame-width frame-color) + (svg-rectangle svg margin-left margin-top xs ys + :stroke-width (or frame-width 1) + :fill "none" + :stroke-color (or frame-color chart-color)))) + ;; Title and legends. + (with-slots (title title-color) chart + (when title + (svg-text svg title + :font-family font + :text-anchor "middle" + :font-weight font-weight + :font-size font-size + :fill title-color + :x (+ margin-left (/ (- width margin-left margin-right) 2)) + :y (+ 3 (/ margin-top 2))))) + (with-slots (x-title) chart + (when x-title + (svg-text svg x-title + :font-family font + :text-anchor "middle" + :font-weight font-weight + :font-size font-size + :fill label-color + :x (+ margin-left (/ (- width margin-left margin-right) 2)) + :y (- height (/ margin-bottom 4))))) + (with-slots (y-title) chart + (when y-title + (let ((text-height + (eplot--text-height y-title font font-size font-weight))) + (svg-text svg y-title + :font-family font + :text-anchor "middle" + :font-weight font-weight + :font-size font-size + :fill label-color + :transform + (format "translate(%s,%s) rotate(-90)" + (- (/ margin-left 2) (/ text-height 2) 4) + (+ margin-top + (/ (- height margin-bottom margin-top) 2))))))))) + +(defun eplot--draw-background (chart svg left top width height) + (with-slots (background-gradient background-color) chart + (let ((gradient (eplot--parse-gradient background-gradient)) + id) + (when gradient + (setq id (format "gradient-%s" (make-temp-name "grad"))) + (eplot--gradient svg id 'linear + (eplot--stops (eplot--vs 'from gradient) + (eplot--vs 'to gradient)) + (eplot--vs 'direction gradient))) + (apply #'svg-rectangle svg left top width height + (if gradient + `(:gradient ,id) + `(:fill ,background-color)))))) + +(defun eplot--compute-chart-dimensions (chart) + (with-slots ( min max plots x-values x-min x-max x-ticks + print-format font-size + xs + inhibit-compute-x-step x-type x-step-map format + x-tick-step x-label-step + label-font label-font-size x-label-format) + chart + (let ((set-min min) + (set-max max)) + (dolist (plot plots) + (with-slots (values data-format) plot + (let* ((vals (nconc (seq-map (lambda (v) (plist-get v :value)) values) + (and (memq 'two-values data-format) + (seq-map + (lambda (v) (plist-get v :extra-value)) + values))))) + ;; Set the x-values based on the first plot. + (unless x-values + (setq print-format (cond + ((memq 'year data-format) 'year) + ((memq 'date data-format) 'date) + ((memq 'time data-format) 'time) + (t 'number))) + (cond + ((or (memq 'xy data-format) + (memq 'year data-format)) + (setq x-values (cl-loop for val in values + collect (plist-get val :x)) + x-min (if (eq format 'horizontal-bar-chart) + 0 + (seq-min x-values)) + x-max (seq-max x-values) + x-ticks (eplot--get-ticks x-min x-max xs)) + (when (memq 'year data-format) + (setq print-format 'literal-year))) + ((memq 'date data-format) + (setq x-values + (cl-loop for val in values + collect + (time-to-days + (encode-time + (decoded-time-set-defaults + (iso8601-parse-date + (format "%d" (plist-get val :x))))))) + x-min (seq-min x-values) + x-max (seq-max x-values) + inhibit-compute-x-step t) + (let ((xs (eplot--get-date-ticks + x-min x-max xs + label-font label-font-size x-label-format))) + (setq x-ticks (car xs) + print-format (cadr xs) + x-tick-step 1 + x-label-step 1 + x-step-map (nth 2 xs)))) + ((memq 'time data-format) + (setq x-values + (cl-loop for val in values + collect + (time-convert + (encode-time + (decoded-time-set-defaults + (iso8601-parse-time + (format "%06d" (plist-get val :x))))) + 'integer)) + x-min (car x-values) + x-max (car (last x-values)) + inhibit-compute-x-step t) + (let ((xs (eplot--get-time-ticks + x-min x-max xs label-font label-font-size + x-label-format))) + (setq x-ticks (car xs) + print-format (cadr xs) + x-tick-step 1 + x-label-step 1 + x-step-map (nth 2 xs)))) + (t + ;; This is a one-dimensional plot -- we don't have X + ;; values, really, so we just do zero to (1- (length + ;; values)). + (setq x-type 'one-dimensional + x-values (cl-loop for i from 0 + repeat (length values) + collect i) + x-min (car x-values) + x-max (car (last x-values)) + x-ticks x-values)))) + (unless set-min + (setq min (min (or min 1.0e+INF) (seq-min vals)))) + (unless set-max + (setq max (max (or max -1.0e+INF) (seq-max vals)))))))))) + +(defun eplot--adjust-chart (chart) + (with-slots ( x-tick-step x-label-step y-tick-step y-label-step + min max ys format inhibit-compute-x-step + y-ticks xs x-values print-format + x-label-format label-font label-font-size data + x-ticks) + chart + (setq y-ticks (and max + (eplot--get-ticks + min + ;; We get 5% more ticks to check whether we + ;; should extend max. + (if (eplot--default-p 'max data) + (* max 1.05) + max) + ys))) + (when (eplot--default-p 'max data) + (setq max (max max (car (last y-ticks))))) + (if (eq format 'bar-chart) + (setq x-tick-step 1 + x-label-step 1) + (unless inhibit-compute-x-step + (let ((xt (eplot--compute-x-ticks + xs x-ticks print-format + x-label-format label-font label-font-size))) + (setq x-tick-step (car xt) + x-label-step (cadr xt))))) + (when max + (let ((yt (eplot--compute-y-ticks + ys y-ticks + (eplot--text-height "100" label-font label-font-size)))) + (setq y-tick-step (car yt) + y-label-step (cadr yt)))) + ;; If max is less than 2% off from a pleasant number, then + ;; increase max. + (when (eplot--default-p 'max data) + (cl-loop for tick in (reverse y-ticks) + when (and (< max tick) + (< (e/ (- tick max) (- max min)) 0.02)) + return (progn + (setq max tick) + ;; Chop off any further ticks. + (setcdr (member tick y-ticks) nil)))) + + (when y-ticks + (if (and (eplot--default-p 'min data) + (< (car y-ticks) min)) + (setq min (car y-ticks)) + ;; We may be extending the bottom of the chart to get pleasing + ;; numbers. We don't want to be drawing the chart on top of the + ;; X axis, because the chart won't be visible there. + (when (and nil + (<= min (car y-ticks)) + ;; But not if we start at origo, because that just + ;; looks confusing. + (not (zerop min))) + (setq min (- (car y-ticks) + ;; 2% of the value range. + (* 0.02 (- (car (last y-ticks)) (car y-ticks)))))))))) + +(defun eplot--adjust-vertical-x-labels (chart) + (with-slots ( x-step-map x-ticks format plots + print-format x-label-format label-font + label-font-size margin-bottom + bar-font bar-font-size bar-font-weight) + chart + ;; Make X ticks. + (let ((width + (cl-loop + for xv in (or x-step-map x-ticks) + for x = (if (consp xv) (car xv) xv) + for i from 0 + for value = (and (equal format 'bar-chart) + (elt (slot-value (car plots) 'values) i)) + for label = (if (equal format 'bar-chart) + (eplot--vs 'label + (plist-get value :settings) + ;; When we're doing bar charts, we + ;; want default labeling to start with + ;; 1 and not zero. + (format "%s" (1+ x))) + (eplot--format-value x print-format x-label-format)) + maximize (if (equal format 'bar-chart) + (eplot--text-width + label bar-font bar-font-size bar-font-weight) + (eplot--text-width + label label-font label-font-size))))) + ;; Ensure that we have enough room to display the X labels + ;; (unless overridden). + (with-slots ( height margin-top ys + y-ticks y-tick-step y-label-step min max) + chart + (setq margin-bottom (max margin-bottom (+ width 40)) + ys (- height margin-top margin-bottom)))))) + +(defun eplot--compute-x-labels (chart) + (with-slots ( x-step-map x-ticks + format plots print-format x-label-format x-labels + x-tick-step x-label-step + x-label-orientation margin-bottom) + chart + ;; Make X ticks. + (setf x-labels + (cl-loop + for xv in (or x-step-map x-ticks) + for x = (if (consp xv) (car xv) xv) + for do-tick = (if (consp xv) + (nth 1 xv) + (zerop (e% x x-tick-step))) + for do-label = (if (consp xv) + (nth 2 xv) + (zerop (e% x x-label-step))) + for i from 0 + for value = (and (equal format 'bar-chart) + (elt (slot-value (car plots) 'values) i)) + collect (list + (if (equal format 'bar-chart) + (eplot--vs 'label + (plist-get value :settings) + ;; When we're doing bar charts, we + ;; want default labeling to start with + ;; 1 and not zero. + (format "%s" (1+ x))) + (eplot--format-value x print-format x-label-format)) + do-tick + do-label))))) + +(defun eplot--draw-x-ticks (svg chart) + (with-slots ( x-step-map x-ticks format layout print-format + margin-left margin-right margin-top margin-bottom + x-min x-max xs + width height + axes-color label-color + grid grid-opacity grid-color + font x-tick-step x-label-step x-label-format x-label-orientation + label-font label-font-size + plots x-labels + x-values + bar-font bar-font-size bar-font-weight + plots) + chart + (let ((font label-font) + (font-size label-font-size) + (font-weight 'normal) + (label-settings nil)) + (when (equal format 'bar-chart) + (setq font bar-font + font-size bar-font-size + font-weight bar-font-weight + label-settings (mapcar (lambda (e) + (plist-get e :settings)) + (slot-value (car plots) 'values)))) + ;; Make X ticks. + (cl-loop with label-height + for xv in (or x-step-map x-ticks) + for x = (if (consp xv) (car xv) xv) + for i from 0 + for (label do-tick do-label) in x-labels + for px = (if (equal format 'bar-chart) + (+ margin-left + (/ (/ xs (length x-values)) 2) + (* (e/ i (length x-values)) + xs)) + (+ margin-left + (* (/ (- (* 1.0 x) x-min) (- x-max x-min)) + xs))) + for this-font-weight = + (if (equal format 'bar-chart) + (or (cdr (assq 'label-font-weight (nth i label-settings))) + font-weight) + font-weight) + ;; We might have one extra stride outside the area -- don't + ;; draw it. + when (<= px (- width margin-right)) + do + (when do-tick + ;; Draw little tick. + (unless (equal format 'bar-chart) + (svg-line svg + px (- height margin-bottom) + px (+ (- height margin-bottom) + (if do-label + 4 + 2)) + :stroke axes-color)) + (when (or (eq grid 'xy) (eq grid 'x)) + (svg-line svg px margin-top + px (- height margin-bottom) + :opacity grid-opacity + :stroke grid-color))) + (when (and do-label + ;; We want to skip marking the first X value + ;; unless we're a bar chart or we're a one + ;; dimensional chart. + (or (equal format 'bar-chart) + t + (not (= x-min (car x-values))) + (eq x-type 'one-dimensional) + (and (not (zerop x)) (not (zerop i))))) + (if (eq x-label-orientation 'vertical) + (progn + (unless label-height + ;; The X position we're putting the label at is + ;; based on the bottom of the lower-case + ;; characters. So we want to ignore descenders + ;; etc, so we use "xx" to determine the height + ;; to be able to center the text. + (setq label-height + (eplot--text-height + ;; If the labels are numerical, we need + ;; to center them using the height of + ;; numbers. + (if (string-match "^[0-9]+$" label) + "10" + ;; Otherwise center them on the baseline. + "xx") + font font-size this-font-weight))) + (svg-text svg label + :font-family font + :text-anchor "end" + :font-size font-size + :font-weight this-font-weight + :fill label-color + :transform + (format "translate(%s,%s) rotate(-90)" + (+ px (/ label-height 2)) + (- height margin-bottom -10)))) + (svg-text svg label + :font-family font + :text-anchor "middle" + :font-size font-size + :font-weight this-font-weight + :fill label-color + :x px + :y (+ (- height margin-bottom) + font-size + (if (equal format 'bar-chart) + (if (equal layout 'compact) 3 5) + 2))))))))) + +(defun eplot--stride (chart values) + (with-slots (xs x-type format) chart + (if (eq x-type 'one-dimensional) + (e/ xs + ;; Fenceposting bar-chart vs everything else. + (if (eq format 'bar-chart) + (length values) + (1- (length values)))) + (e/ xs (length values))))) + +(defun eplot--default-p (slot data) + "Return non-nil if SLOT is at the default value." + (and (not (assq slot eplot--user-defaults)) + (not (assq slot data)))) + +(defun eplot--compute-y-labels (chart) + (with-slots ( y-ticks y-labels + width height min max xs ys + margin-top margin-bottom margin-left margin-right + y-tick-step y-label-step y-label-format) + chart + ;; First collect all the labels we're thinking about outputting. + (setq y-labels + (cl-loop for y in y-ticks + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 y) min) (- max min)) + ys)) + when (and (<= margin-top py (- height margin-bottom)) + (zerop (e% y y-tick-step)) + (zerop (e% y y-label-step))) + collect (eplot--format-y + y (- (cadr y-ticks) (car y-ticks)) nil + y-label-format))) + ;; Check the labels to see whether we have too many digits for + ;; what we're actually going to display. Man, this is a lot of + ;; back-and-forth and should be rewritten to be less insanely + ;; inefficient. + (when (= (seq-count (lambda (label) + (string-match "\\." label)) + y-labels) + (length y-labels)) + (setq y-labels + (cl-loop with max = (cl-loop for label in y-labels + maximize (eplot--decimal-digits + (string-to-number label))) + for label in y-labels + collect (format (if (zerop max) + "%d" + (format "%%.%df" max)) + (string-to-number label))))) + (setq y-labels (cl-coerce y-labels 'vector)) + ;; Ensure that we have enough room to display the Y labels + ;; (unless overridden). + (when (eplot--default-p 'margin-left (slot-value chart 'data)) + (with-slots (label-font label-font-size) chart + (setq margin-left (max margin-left + (+ (eplot--text-width + (elt y-labels (1- (length y-labels))) + label-font label-font-size) + 10)) + xs (- width margin-left margin-right)))))) + +(defun eplot--draw-y-ticks (svg chart) + (with-slots ( y-ticks y-labels y-tick-step y-label-step label-color + label-font label-font-size + width height min max ys + margin-top margin-bottom margin-left margin-right + axes-color + grid grid-opacity grid-color) + chart + ;; Make Y ticks. + (cl-loop with lnum = 0 + with text-height = (eplot--text-height + "012" label-font label-font-size) + for y in y-ticks + for i from 0 + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 y) min) (- max min)) + ys)) + do + (when (and (<= margin-top py (- height margin-bottom)) + (zerop (e% y y-tick-step))) + (svg-line svg margin-left py + (- margin-left 3) py + :stroke-color axes-color) + (when (or (eq grid 'xy) (eq grid 'y)) + (svg-line svg margin-left py + (- width margin-right) py + :opacity grid-opacity + :stroke-color grid-color)) + (when (zerop (e% y y-label-step)) + (svg-text svg (elt y-labels lnum) + :font-family label-font + :text-anchor "end" + :font-size label-font-size + :fill label-color + :x (- margin-left 6) + :y (+ py (/ text-height 2) -1)) + (cl-incf lnum)))))) + +(defun eplot--text-width (text font font-size &optional font-weight) + (string-pixel-width + (propertize text 'face + (list :font (font-spec :family font + :weight (or font-weight 'normal) + :size font-size))))) + +(defvar eplot--text-size-cache (make-hash-table :test #'equal)) + +(defun eplot--text-height (text font font-size &optional font-weight) + (cdr (eplot--text-size text font font-size font-weight))) + +(defun eplot--text-size (text font font-size font-weight) + (let ((key (list text font font-size font-weight))) + (or (gethash key eplot--text-size-cache) + (let ((size (eplot--text-size-1 text font font-size font-weight))) + (setf (gethash key eplot--text-size-cache) size) + size)))) + +(defun eplot--text-size-1 (text font font-size font-weight) + (if (not (executable-find "convert")) + ;; This "default" text size is kinda bogus. + (cons (* (length text) font-size) font-size) + (let* ((size (* font-size 10)) + (svg (svg-create size size)) + text-size) + (svg-rectangle svg 0 0 size size :fill "black") + (svg-text svg text + :font-family font + :text-anchor "middle" + :font-size font-size + :font-weight (or font-weight 'normal) + :fill "white" + :x (/ size 2) + :y (/ size 2)) + (with-temp-buffer + (set-buffer-multibyte nil) + (svg-print svg) + (let* ((file (make-temp-file "eplot" nil ".svg")) + (png (file-name-with-extension file ".png"))) + (unwind-protect + (progn + (write-region (point-min) (point-max) file nil 'silent) + ;; rsvg-convert is 5x faster than convert when doing SVG, so + ;; if we have it, we use it. + (when (executable-find "rsvg-convert") + (unwind-protect + (call-process "rsvg-convert" nil nil nil + (format "--output=%s" png) file) + (when (file-exists-p png) + (delete-file file) + (setq file png)))) + (erase-buffer) + (when (zerop (call-process "convert" nil t nil + "-trim" "+repage" file "info:-")) + (goto-char (point-min)) + (when (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\)" nil t) + (setq text-size + (cons (string-to-number (match-string 1)) + (string-to-number (match-string 2))))))) + (when (file-exists-p file) + (delete-file file))))) + (or text-size + ;; This "default" text size is kinda bogus. + (cons (* (length text) font-size) font-size))))) + +(defun eplot--draw-legend (svg chart) + (with-slots ( legend plots + margin-left margin-top + font font-size font-weight + background-color axes-color + legend-color legend-background-color legend-border-color) + chart + (when (eq legend 'true) + (when-let ((names + (cl-loop for plot in plots + for name = (slot-value plot 'name) + when name + collect + (cons name (slot-value plot 'color))))) + (svg-rectangle svg (+ margin-left 20) (+ margin-top 20) + (format "%dpx" + (+ 10 + (seq-max + (mapcar (lambda (name) + (eplot--text-width (car name) + font font-size)) + names)))) + (* font-size (+ (length names) 2)) + :font-size font-size + :fill-color legend-background-color + :stroke-color legend-border-color) + (cl-loop for name in names + for i from 0 + do (svg-text svg (car name) + :font-family font + :text-anchor "front" + :font-size font-size + :font-weight font-weight + :fill (or (cdr name) legend-color) + :x (+ margin-left 25) + :y (+ margin-top 40 (* i font-size)))))))) + +(defun eplot--format-y (y spacing whole format-string) + (format (or format-string "%s") + (cond + ((or (= (round (* spacing 100)) 10) (= (round (* spacing 100)) 20)) + (format "%.1f" y)) + ((< spacing 0.01) + (format "%.3f" y)) + ((< spacing 1) + (format "%.2f" y)) + ((and (< spacing 1) (not (zerop (mod (* spacing 10) 1)))) + (format "%.1f" y)) + ((zerop (% spacing 1000000000)) + (format "%dG" (/ y 1000000000))) + ((zerop (% spacing 1000000)) + (format "%dM" (/ y 1000000))) + ((zerop (% spacing 1000)) + (format "%dk" (/ y 1000))) + ((>= spacing 1) + (format "%s" y)) + ((not whole) + (format "%.1f" y)) + (t + (format "%s" y))))) + +(defun eplot--format-value (value print-format label-format) + (replace-regexp-in-string + ;; Texts in SVG collapse multiple spaces into one. So do it here, + ;; too, so that width calculations are correct. + " +" " " + (cond + ((eq print-format 'date) + (format-time-string + (or label-format "%Y-%m-%d") (eplot--days-to-time value))) + ((eq print-format 'year) + (format-time-string (or label-format "%Y") (eplot--days-to-time value))) + ((eq print-format 'time) + (format-time-string (or label-format "%H:%M:%S") value)) + ((eq print-format 'minute) + (format-time-string (or label-format "%H:%M") value)) + ((eq print-format 'hour) + (format-time-string (or label-format "%H") value)) + (t + (format (or label-format "%s") value))))) + +(defun eplot--compute-x-ticks (xs x-values print-format x-label-format + label-font label-font-size) + (let* ((min (seq-min x-values)) + (max (seq-max x-values)) + (count (length x-values)) + (max-print (eplot--format-value max print-format x-label-format)) + ;; We want each label to be spaced at least as long apart as + ;; the length of the longest label, with room for two blanks + ;; in between. + (min-spacing (* 1.2 (eplot--text-width max-print label-font + label-font-size))) + (digits (eplot--decimal-digits (- (cadr x-values) (car x-values)))) + (every (e/ 1 (expt 10 digits)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) xs) + (list every every)) + ;; We have to prune X labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ((< (* count 10) xs) + (list every + (let ((label-step every)) + (while (> (/ (- max min) label-step) (/ xs min-spacing)) + (setq label-step (eplot--next-weed label-step))) + label-step))) + ;; We have to reduce both grid lines and labels. + (t + (let ((tick-step every)) + (while (> (/ (- max min) tick-step) (/ xs 10)) + (setq tick-step (eplot--next-weed tick-step))) + (list tick-step + (let ((label-step tick-step)) + (while (> (/ (- max min) label-step) (/ xs min-spacing)) + (setq label-step (eplot--next-weed label-step)) + (while (not (zerop (% label-step tick-step))) + (setq label-step (eplot--next-weed label-step)))) + label-step))))))) + +(defun eplot--compute-y-ticks (ys y-values text-height) + (let* ((min (car y-values)) + (max (car (last y-values))) + (count (length y-values)) + ;; We want each label to be spaced at least as long apart as + ;; the height of the label. + (min-spacing (+ text-height 10)) + (digits (eplot--decimal-digits (- (cadr y-values) (car y-values)))) + (every (e/ 1 (expt 10 digits)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) ys) + (list every every)) + ;; We have to prune Y labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ((< (* count 10) ys) + (list every + (let ((label-step every)) + (while (> (/ (- max min) label-step) (/ ys min-spacing)) + (setq label-step (eplot--next-weed label-step))) + label-step))) + ;; We have to reduce both grid lines and labels. + (t + (let ((tick-step 1)) + (while (> (/ count tick-step) (/ ys 10)) + (setq tick-step (eplot--next-weed tick-step))) + (list tick-step + (let ((label-step tick-step)) + (while (> (/ (- max min) label-step) (/ ys min-spacing)) + (setq label-step (eplot--next-weed label-step))) + label-step))))))) + +(defvar eplot--pleasing-numbers '(1 2 5 10)) + +(defun eplot--next-weed (weed) + (let (digits series) + (if (>= weed 1) + (setq digits (truncate (log weed 10)) + series (/ weed (expt 10 digits))) + (setq digits (eplot--decimal-digits weed) + series (truncate (* weed (expt 10 digits))))) + (let ((next (cadr (memq series eplot--pleasing-numbers)))) + (unless next + (error "Invalid weed: %s" weed)) + (if (>= weed 1) + (* next (expt 10 digits)) + (e/ next (expt 10 digits)))))) + +(defun eplot--parse-gradient (string) + (when string + (let ((bits (split-string string))) + (list + (cons 'from (nth 0 bits)) + (cons 'to (nth 1 bits)) + (cons 'direction (intern (or (nth 2 bits) "top-down"))) + (cons 'position (intern (or (nth 3 bits) "below"))))))) + +(defun eplot--smooth (values algo xs) + (if (not algo) + values + (let* ((vals (cl-coerce values 'vector)) + (max (1- (length vals))) + (period (* 4 (ceiling (/ max xs))))) + (cl-case algo + (moving-average + (cl-loop for i from 0 upto max + collect (e/ (cl-loop for ii from 0 upto (1- period) + sum (elt vals (min (+ i ii) max))) + period))))))) + +(defun eplot--vary-color (color n) + (let ((colors ["#e6194b" "#3cb44b" "#ffe119" "#4363d8" "#f58231" "#911eb4" + "#46f0f0" "#f032e6" "#bcf60c" "#fabebe" "#008080" "#e6beff" + "#9a6324" "#fffac8" "#800000" "#aaffc3" "#808000" "#ffd8b1" + "#000075" "#808080" "#ffffff" "#000000"])) + (unless (equal color "vary") + (setq colors + (if (string-search " " color) + (split-string color) + (list color)))) + (elt colors (mod n (length colors))))) + +(defun eplot--pv (plot slot &optional default) + (let ((user (cdr (assq slot eplot--user-defaults)))) + (when (and (stringp user) (zerop (length user))) + (setq user nil)) + (or user (slot-value plot slot) default))) + +(defun eplot--draw-plots (svg chart) + (if (eq (slot-value chart 'format) 'horizontal-bar-chart) + (eplot--draw-horizontal-bar-chart svg chart) + (eplot--draw-normal-plots svg chart))) + +(defun eplot--draw-normal-plots (svg chart) + (with-slots ( plots chart-color height format + margin-bottom margin-left + min max xs ys + margin-top + x-values x-min x-max + label-font label-font-size) + chart + ;; Draw all the plots. + (cl-loop for plot in (reverse plots) + for plot-number from 0 + for values = (slot-value plot 'values) + for vals = (eplot--smooth + (seq-map (lambda (v) (plist-get v :value)) values) + (slot-value plot 'smoothing) + xs) + for polygon = nil + for gradient = (eplot--parse-gradient (eplot--pv plot 'gradient)) + for lpy = nil + for lpx = nil + for style = (if (eq format 'bar-chart) + 'bar + (slot-value plot 'style)) + for bar-max-width = (eplot--pv plot 'bar-max-width) + for bar-width = (and (eq style 'bar) + (min (or bar-max-width most-positive-fixnum) + (/ xs (length x-values)))) + for bar-gap = (and (eq style 'bar) + (if (< bar-width + (or bar-max-width most-positive-fixnum)) + (* bar-width 0.1) + 0)) + for clip-id = (format "url(#clip-%d)" plot-number) + do + (svg--append + svg + (dom-node 'clipPath + `((id . ,(format "clip-%d" plot-number))) + (dom-node 'rect + `((x . ,margin-left) + (y . , margin-top) + (width . ,xs) + (height . ,ys))))) + (unless gradient + (when-let ((fill (slot-value plot 'fill-color))) + (setq gradient `((from . ,fill) (to . ,fill) + (direction . top-down) (position . below))))) + (when gradient + (if (eq (eplot--vs 'position gradient) 'above) + (push (cons margin-left margin-top) polygon) + (push (cons margin-left (- height margin-bottom)) polygon))) + (cl-loop + for val in vals + for value in values + for x in x-values + for i from 0 + for settings = (plist-get value :settings) + for color = (eplot--vary-color + (eplot--vs 'color settings (slot-value plot 'color)) + i) + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 val) min) (- max min)) + ys)) + for px = (if (eq style 'bar) + (+ margin-left + (/ (/ xs (length x-values)) 2) + (* (e/ i (length x-values)) + xs)) + (+ margin-left + (* (e/ (- x x-min) (- x-max x-min)) + xs))) + do + ;; Some data points may have texts. + (when-let ((text (eplot--vs 'text settings))) + (svg-text svg text + :font-family label-font + :text-anchor "middle" + :font-size label-font-size + :font-weight 'normal + :fill color + :x px + :y (- py (eplot--text-height + text label-font label-font-size) + -5))) + ;; You may mark certain points. + (when-let ((mark (eplot--vy 'mark settings))) + (cl-case mark + (cross + (let ((s (eplot--element-size val plot settings 3))) + (svg-line svg (- px s) (- py s) + (+ px s) (+ py s) + :clip-path clip-id + :stroke color) + (svg-line svg (+ px s) (- py s) + (- px s) (+ py s) + :clip-path clip-id + :stroke color))) + (otherwise + (svg-circle svg px py 3 + :fill color)))) + (cl-case style + (bar + (if (not gradient) + (svg-rectangle + svg + (+ (- px (e/ bar-width 2)) (e/ bar-gap 2)) + py + (- bar-width bar-gap) + (- height margin-bottom py) + :clip-path clip-id + :fill color) + (let ((id (format "gradient-%s" (make-temp-name "grad")))) + (eplot--gradient svg id 'linear + (eplot--stops (eplot--vs 'from gradient) + (eplot--vs 'to gradient)) + (eplot--vs 'direction gradient)) + (svg-rectangle + svg + (+ (- px (e/ bar-width 2)) (e/ bar-gap 2)) + py + (- bar-width bar-gap) + (- height margin-bottom py) + :clip-path clip-id + :gradient id)))) + (impulse + (let ((width (eplot--element-size val plot settings 1))) + (if (= width 1) + (svg-line svg + px py + px (- height margin-bottom) + :clip-path clip-id + :stroke color) + (svg-rectangle svg + (- px (e/ width 2)) py + width (- height py margin-bottom) + :clip-path clip-id + :fill color)))) + (point + (svg-line svg px py (1+ px) (1+ py) + :clip-path clip-id + :stroke color)) + (line + ;; If we're doing a gradient, we're just collecting + ;; points and will draw the polygon later. + (if gradient + (push (cons px py) polygon) + (when lpx + (svg-line svg lpx lpy px py + :stroke-width (eplot--pv plot 'size 1) + :clip-path clip-id + :stroke color)))) + (curve + (push (cons px py) polygon)) + (square + (if gradient + (progn + (when lpx + (push (cons lpx py) polygon)) + (push (cons px py) polygon)) + (when lpx + (svg-line svg lpx lpy px lpy + :clip-path clip-id + :stroke color) + (svg-line svg px lpy px py + :clip-path clip-id + :stroke color)))) + (circle + (svg-circle svg px py + (eplot--element-size val plot settings 3) + :clip-path clip-id + :stroke color + :fill (eplot--vary-color + (eplot--vs + 'fill-color settings + (or (slot-value plot 'fill-color) "none")) + i))) + (cross + (let ((s (eplot--element-size val plot settings 3))) + (svg-line svg (- px s) (- py s) + (+ px s) (+ py s) + :clip-path clip-id + :stroke color) + (svg-line svg (+ px s) (- py s) + (- px s) (+ py s) + :clip-path clip-id + :stroke color))) + (triangle + (let ((s (eplot--element-size val plot settings 5))) + (svg-polygon svg + (list + (cons (- px (e/ s 2)) (+ py (e/ s 2))) + (cons px (- py (e/ s 2))) + (cons (+ px (e/ s 2)) (+ py (e/ s 2)))) + :clip-path clip-id + :stroke color + :fill-color + (or (slot-value plot 'fill-color) "none")))) + (rectangle + (let ((s (eplot--element-size val plot settings 3))) + (svg-rectangle svg (- px (e/ s 2)) (- py (e/ s 2)) + s s + :clip-path clip-id + :stroke color + :fill-color + (or (slot-value plot 'fill-color) "none"))))) + (setq lpy py + lpx px)) + + ;; We're doing a gradient of some kind (or a curve), so + ;; draw it now when we've collected the polygon. + (when polygon + ;; We have a "between" chart, so collect the data points + ;; from the "extra" values, too. + (when (memq 'two-values (slot-value plot 'data-format)) + (cl-loop + for val in (nreverse + (seq-map (lambda (v) (plist-get v :extra-value)) + values)) + for x from (1- (length vals)) downto 0 + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 val) min) (- max min)) + ys)) + for px = (+ margin-left + (* (e/ (- x x-min) (- x-max x-min)) + xs)) + do + (cl-case style + (line + (push (cons px py) polygon)) + (square + (when lpx + (push (cons lpx py) polygon)) + (push (cons px py) polygon))) + (setq lpx px lpy py))) + (when gradient + (if (eq (eplot--vs 'position gradient) 'above) + (push (cons lpx margin-top) polygon) + (push (cons lpx (- height margin-bottom)) polygon))) + (let ((id (format "gradient-%d" plot-number))) + (when gradient + (eplot--gradient svg id 'linear + (eplot--stops (eplot--vs 'from gradient) + (eplot--vs 'to gradient)) + (eplot--vs 'direction gradient))) + (if (eq style 'curve) + (apply #'svg-path svg + (nconc + (cl-loop + with points = (cl-coerce + (nreverse polygon) 'vector) + for i from 0 upto (1- (length points)) + collect + (cond + ((zerop i) + `(moveto ((,(car (elt points 0)) . + ,(cdr (elt points 0)))))) + (t + `(curveto + (,(eplot--bezier + (eplot--pv plot 'bezier-factor) + i points)))))) + (and gradient '((closepath)))) + `( :clip-path ,clip-id + :stroke-width ,(eplot--pv plot 'size 1) + :stroke ,(slot-value plot 'color) + ,@(if gradient + `(:gradient ,id) + `(:fill "none")))) + (svg-polygon + svg (nreverse polygon) + :clip-path clip-id + :gradient id + :stroke (slot-value plot 'fill-border-color)))))))) + +(defun eplot--element-size (value plot settings default) + (eplot--vn 'size settings + (if (slot-value plot 'size-factor) + (* value (slot-value plot 'size-factor)) + (or (slot-value plot 'size) default)))) + +(defun eplot--draw-horizontal-bar-chart (svg chart) + (with-slots ( plots chart-color height format + margin-bottom margin-left + min max xs ys + margin-top + x-values x-min x-max + label-font label-font-size label-color + horizontal-label-left horizontal-label-font-size) + chart + (dolist (plot plots) + (cl-loop with values = (slot-value plot 'values) + with stride = (e/ ys (length values)) + with label-height = (eplot--text-height "xx" label-font + label-font-size) + with bar-gap = (* stride 0.1) + for i from 0 + for value in values + for settings = (plist-get value :settings) + for bar-max-width = (eplot--pv plot 'bar-max-width) + for py = (+ margin-top (* i stride)) + for px = (* (e/ (plist-get value :x) x-max) xs) + for color = (eplot--vary-color + (eplot--vs 'color settings (slot-value plot 'color)) + i) + do + (svg-rectangle svg + margin-left + (+ py (e/ bar-gap 2) + (if (and bar-max-width + (< bar-max-width (- stride bar-gap))) + (- (/ stride 2) (/ bar-max-width 2)) + 0)) + px + (if bar-max-width + (min bar-max-width (- stride bar-gap)) + (- stride bar-gap)) + :fill color) + (svg-text svg (eplot--vs 'label settings) + :font-family label-font + :text-anchor "left" + :font-size horizontal-label-font-size + :font-weight 'normal + :fill label-color + :x (or horizontal-label-left 5) + :y (+ py label-height + (/ stride 2))))))) + +(defun eplot--stops (from to) + (append `((0 . ,from)) + (cl-loop for (pct col) on (split-string to "-") by #'cddr + collect (if col + (cons (string-to-number pct) col) + (cons 100 pct))))) + +(defun eplot--gradient (svg id type stops &optional direction) + "Add a gradient with ID to SVG. +TYPE is `linear' or `radial'. + +STOPS is a list of percentage/color pairs. + +DIRECTION is one of `top-down', `bottom-up', `left-right' or `right-left'. +nil means `top-down'." + (svg--def + svg + (apply + #'dom-node + (if (eq type 'linear) + 'linearGradient + 'radialGradient) + `((id . ,id) + (x1 . ,(if (eq direction 'left-right) 1 0)) + (x2 . ,(if (eq direction 'right-left) 1 0)) + (y1 . ,(if (eq direction 'bottom-up) 1 0)) + (y2 . ,(if (eq direction 'top-down) 1 0))) + (mapcar + (lambda (stop) + (dom-node 'stop `((offset . ,(format "%s%%" (car stop))) + (stop-color . ,(cdr stop))))) + stops)))) + +(defun e% (num1 num2) + (let ((factor (max (expt 10 (eplot--decimal-digits num1)) + (expt 10 (eplot--decimal-digits num2))))) + (% (truncate (* num1 factor)) (truncate (* num2 factor))))) + +(defun eplot--decimal-digits (number) + (- (length (replace-regexp-in-string + "0+\\'" "" + (format "%.10f" (- number (truncate number))))) + 2)) + +(defun e/ (&rest numbers) + (if (cl-every #'integerp numbers) + (let ((int (apply #'/ numbers)) + (float (apply #'/ (* 1.0 (car numbers)) (cdr numbers)))) + (if (= int float) + int + float)) + (apply #'/ numbers))) + +(defun eplot--get-ticks (min max height &optional whole) + (let* ((diff (abs (- min max))) + (even (eplot--pleasing-numbers (* (e/ diff height) 10))) + (factor (max (expt 10 (eplot--decimal-digits even)) + (expt 10 (eplot--decimal-digits diff)))) + (fmin (truncate (* min factor))) + (feven (truncate (* factor even))) + start) + (when whole + (setq even 1 + feven factor)) + + (setq start + (cond + ((< min 0) + (+ (floor fmin) + feven + (- (% (floor fmin) feven)) + (- feven))) + (t + (- fmin (% fmin feven))))) + (cl-loop for x from start upto (* max factor) by feven + collect (e/ x factor)))) + +(defun eplot--days-to-time (days) + (days-to-time (- days (time-to-days 0)))) + +(defun eplot--get-date-ticks (start end xs label-font label-font-size + x-label-format &optional skip-until) + (let* ((duration (- end start)) + (limits + (list + (list (/ 368 16) 'date + (lambda (_d) t)) + (list (/ 368 4) 'date + ;; Collect Mondays. + (lambda (decoded) + (= (decoded-time-weekday decoded) 1))) + (list (/ 368 2) 'date + ;; Collect 1st and 15th. + (lambda (decoded) + (or (= (decoded-time-day decoded) 1) + (= (decoded-time-day decoded) 15)))) + (list (* 368 2) 'date + ;; Collect 1st of every month. + (lambda (decoded) + (= (decoded-time-day decoded) 1))) + (list (* 368 4) 'date + ;; Collect every quarter. + (lambda (decoded) + (and (= (decoded-time-day decoded) 1) + (memq (decoded-time-month decoded) '(1 4 7 10))))) + (list (* 368 8) 'date + ;; Collect every half year. + (lambda (decoded) + (and (= (decoded-time-day decoded) 1) + (memq (decoded-time-month decoded) '(1 7))))) + (list 1.0e+INF 'year + ;; Collect every Jan 1st. + (lambda (decoded) + (and (= (decoded-time-day decoded) 1) + (= (decoded-time-month decoded) 1))))))) + ;; First we collect the potential ticks. + (while (or (>= duration (caar limits)) + (and skip-until (>= skip-until (caar limits)))) + (pop limits)) + (let* ((x-ticks (cl-loop for day from start upto end + for time = (eplot--days-to-time day) + for decoded = (decode-time time) + when (funcall (nth 2 (car limits)) decoded) + collect day)) + (count (length x-ticks)) + (print-format (nth 1 (car limits))) + (max-print (eplot--format-value (car x-ticks) print-format + x-label-format)) + (min-spacing (* 1.2 (eplot--text-width max-print label-font + label-font-size)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) xs) + (list x-ticks print-format)) + ;; We have to prune X labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ((< (* count 10) xs) + (cond + ((not (cdr limits)) + (eplot--year-ticks + x-ticks xs label-font label-font-size x-label-format)) + ;; The Mondays grid is special, because it doesn't resolve + ;; into any of the bigger limits evenly. + ((= (caar limits) (/ 368 4)) + (let* ((max-print (eplot--format-value + (car x-ticks) print-format x-label-format)) + (min-spacing (* 1.2 (eplot--text-width + max-print label-font label-font-size))) + (weed-factor 2)) + (while (> (* (/ (length x-ticks) weed-factor) min-spacing) xs) + (setq weed-factor (* weed-factor 2))) + (list x-ticks 'date + (cl-loop for val in x-ticks + for i from 0 + collect (list val t (zerop (% i weed-factor))))))) + (t + (pop limits) + (catch 'found + (while limits + (let ((candidate + (cl-loop for day in x-ticks + for time = (eplot--days-to-time day) + for decoded = (decode-time time) + collect (list day t + (not (not + (funcall (nth 2 (car limits)) + decoded))))))) + (setq print-format (nth 1 (car limits))) + (let* ((max-print (eplot--format-value + (car x-ticks) print-format x-label-format)) + (min-spacing (* 1.2 (eplot--text-width + max-print label-font + label-font-size))) + (num-labels (seq-count (lambda (v) (nth 2 v)) + candidate))) + (when (and (not (zerop num-labels)) + (< (* num-labels min-spacing) xs)) + (throw 'found (list x-ticks print-format candidate))))) + (pop limits)) + (eplot--year-ticks + x-ticks xs label-font label-font-size x-label-format))))) + ;; We have to reduce both grid lines and labels. + (t + (eplot--get-date-ticks start end xs label-font label-font-size + x-label-format (caar limits))))))) + +(defun eplot--year-ticks (x-ticks xs label-font label-font-size x-label-format) + (let* ((year-ticks (mapcar (lambda (day) + (decoded-time-year + (decode-time (eplot--days-to-time day)))) + x-ticks)) + (xv (eplot--compute-x-ticks + xs year-ticks 'year x-label-format label-font label-font-size))) + (let ((tick-step (car xv)) + (label-step (cadr xv))) + (list x-ticks 'year + (cl-loop for year in year-ticks + for val in x-ticks + collect (list val + (zerop (% year tick-step)) + (zerop (% year label-step)))))))) + +(defun eplot--get-time-ticks (start end xs label-font label-font-size + x-label-format + &optional skip-until) + (let* ((duration (- end start)) + (limits + (list + (list (* 2 60) 'time + (lambda (_d) t)) + (list (* 2 60 60) 'time + ;; Collect whole minutes. + (lambda (decoded) + (zerop (decoded-time-second decoded)))) + (list (* 3 60 60) 'minute + ;; Collect five minutes. + (lambda (decoded) + (zerop (% (decoded-time-minute decoded) 5)))) + (list (* 4 60 60) 'minute + ;; Collect fifteen minutes. + (lambda (decoded) + (and (zerop (decoded-time-second decoded)) + (memq (decoded-time-minute decoded) '(0 15 30 45))))) + (list (* 8 60 60) 'minute + ;; Collect half hours. + (lambda (decoded) + (and (zerop (decoded-time-second decoded)) + (memq (decoded-time-minute decoded) '(0 30))))) + (list 1.0e+INF 'hour + ;; Collect whole hours. + (lambda (decoded) + (and (zerop (decoded-time-second decoded)) + (zerop (decoded-time-minute decoded)))))))) + ;; First we collect the potential ticks. + (while (or (>= duration (caar limits)) + (and skip-until (>= skip-until (caar limits)))) + (pop limits)) + (let* ((x-ticks (cl-loop for time from start upto end + for decoded = (decode-time time) + when (funcall (nth 2 (car limits)) decoded) + collect time)) + (count (length x-ticks)) + (print-format (nth 1 (car limits))) + (max-print (eplot--format-value (car x-ticks) print-format + x-label-format)) + (min-spacing (* (+ (length max-print) 2) (e/ label-font-size 2)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) xs) + (list x-ticks print-format)) + ;; We have to prune X labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ;; If we're plotting just seconds, then just weed out some seconds. + ((and (< (* count 10) xs) + (= (caar limits) (* 2 60))) + (let ((xv (eplot--compute-x-ticks + xs x-ticks 'time x-label-format label-font label-font-size))) + (let ((tick-step (car xv)) + (label-step (cadr xv))) + (list x-ticks 'time + (cl-loop for val in x-ticks + collect (list val + (zerop (% val tick-step)) + (zerop (% val label-step)))))))) + ;; Normal case for pruning labels, but not grid lines. + ((< (* count 10) xs) + (if (not (cdr limits)) + (eplot--hour-ticks x-ticks xs label-font label-font-size + x-label-format) + (pop limits) + (catch 'found + (while limits + (let ((candidate + (cl-loop for val in x-ticks + for decoded = (decode-time val) + collect (list val t + (not (not + (funcall (nth 2 (car limits)) + decoded))))))) + (setq print-format (nth 1 (car limits))) + (let ((min-spacing (* (+ (length max-print) 2) + (e/ label-font-size 2)))) + (when (< (* (seq-count (lambda (v) (nth 2 v)) candidate) + min-spacing) + xs) + (throw 'found (list x-ticks print-format candidate))))) + (pop limits)) + (eplot--hour-ticks x-ticks xs label-font label-font-size + x-label-format)))) + ;; We have to reduce both grid lines and labels. + (t + (eplot--get-time-ticks start end xs label-font label-font-size + x-label-format (caar limits))))))) + +(defun eplot--hour-ticks (x-ticks xs label-font label-font-size + x-label-format) + (let* ((eplot--pleasing-numbers '(1 3 6 12)) + (hour-ticks (mapcar (lambda (time) + (decoded-time-hour (decode-time time))) + x-ticks)) + (xv (eplot--compute-x-ticks + xs hour-ticks 'year x-label-format label-font label-font-size))) + (let ((tick-step (car xv)) + (label-step (cadr xv))) + (list x-ticks 'hour + (cl-loop for hour in hour-ticks + for val in x-ticks + collect (list val + (zerop (% hour tick-step)) + (zerop (% hour label-step)))))))) + +(defun eplot--int (number) + (cond + ((integerp number) + number) + ((= number (truncate number)) + (truncate number)) + (t + number))) + +(defun eplot--pleasing-numbers (number) + (let* ((digits (eplot--decimal-digits number)) + (one (e/ 1 (expt 10 digits))) + (two (e/ 2 (expt 10 digits))) + (five (e/ 5 (expt 10 digits)))) + (catch 'found + (while t + (when (< number one) + (throw 'found one)) + (setq one (* one 10)) + (when (< number two) + (throw 'found two)) + (setq two (* two 10)) + (when (< number five) + (throw 'found five)) + (setq five (* five 10)))))) + +(defun eplot-parse-and-insert (file) + "Parse and insert a file in the current buffer." + (interactive "fEplot file: ") + (let ((default-directory (file-name-directory file))) + (setq-local eplot--current-chart + (eplot--render (with-temp-buffer + (insert-file-contents file) + (eplot--parse-buffer)))))) + +(defun eplot-list-chart-headers () + "Pop to a buffer showing all chart parameters." + (interactive) + (pop-to-buffer "*eplot help*") + (let ((inhibit-read-only t)) + (special-mode) + (erase-buffer) + (insert "The following headers influence the overall\nlook of the chart:\n\n") + (eplot--list-headers eplot--chart-headers) + (ensure-empty-lines 2) + (insert "The following headers are per plot:\n\n") + (eplot--list-headers eplot--plot-headers) + (goto-char (point-min)))) + +(defun eplot--list-headers (headers) + (dolist (header (sort (copy-sequence headers) + (lambda (e1 e2) + (string< (car e1) (car e2))))) + (insert (propertize (capitalize (symbol-name (car header))) 'face 'bold) + "\n") + (let ((start (point))) + (insert (plist-get (cdr header) :doc) "\n") + (when-let ((valid (plist-get (cdr header) :valid))) + (insert "Possible values are: " + (mapconcat (lambda (v) (format "`%s'" v)) valid ", ") + ".\n")) + (indent-rigidly start (point) 2)) + (ensure-empty-lines 1))) + +(defvar eplot--transients + '((("Size" + ("sw" "Width") + ("sh" "Height") + ("sl" "Margin-Left") + ("st" "Margin-Top") + ("sr" "Margin-Right") + ("sb" "Margin-Bottom")) + ("Colors" + ("ca" "Axes-Color") + ("cb" "Border-Color") + ("cc" "Chart-Color") + ("cf" "Frame-Color") + ("cs" "Surround-Color") + ("ct" "Title-Color")) + ("Background" + ("bc" "Background-Color") + ("bg" "Background-Gradient") + ("bi" "Background-Image-File") + ("bv" "Background-Image-Cover") + ("bo" "Background-Image-Opacity"))) + (("General" + ("gt" "Title") + ("gf" "Font") + ("gs" "Font-Size") + ("ge" "Font-Weight") + ("go" "Format") + ("gw" "Frame-Width") + ("gh" "Header-File") + ("gi" "Min") + ("ga" "Max") + ("gm" "Mode") + ("gr" "Reset" eplot--reset-transient) + ("gv" "Save" eplot--save-transient)) + ("Axes, Grid & Legend" + ("xx" "X-Title") + ("xy" "Y-Title") + ("xf" "Label-Font") + ("xz" "Label-Font-Size") + ("xs" "X-Axis-Title-Space") + ("xl" "X-Label-Format") + ("xa" "Y-Label-Format") + ("il" "Grid-Color") + ("io" "Grid-Opacity") + ("ip" "Grid-Position") + ("ll" "Legend") + ("lb" "Legend-Background-Color") + ("lo" "Legend-Border-Color") + ("lc" "Legend-Color")) + ("Plot" + ("ps" "Style") + ("pc" "Color") + ("po" "Data-Column") + ("pr" "Data-format") + ("pn" "Fill-Border-Color") + ("pi" "Fill-Color") + ("pg" "Gradient") + ("pz" "Size") + ("pm" "Smoothing") + ("pb" "Bezier-Factor"))))) + +(defun eplot--define-transients () + (cl-loop for row in eplot--transients + collect (cl-coerce + (cl-loop for column in row + collect + (cl-coerce + (cons (pop column) + (mapcar #'eplot--define-transient column)) + 'vector)) + 'vector))) + +(defun eplot--define-transient (action) + (list (nth 0 action) + (nth 1 action) + ;; Allow explicit commands. + (or (nth 2 action) + ;; Make a command for altering a setting. + (lambda () + (interactive) + (eplot--execute-transient (nth 1 action)))))) + +(defun eplot--execute-transient (action) + (with-current-buffer (or eplot--data-buffer (current-buffer)) + (unless eplot--transient-settings + (setq-local eplot--transient-settings nil)) + (let* ((name (intern (downcase action))) + (spec (assq name (append eplot--chart-headers eplot--plot-headers))) + (type (plist-get (cdr spec) :type))) + ;; Sanity check. + (unless spec + (error "No such header type: %s" name)) + (setq eplot--transient-settings + (append + eplot--transient-settings + (list + (cons + name + (cond + ((eq type 'number) + (read-number (format "Value for %s (%s): " action type))) + ((string-match "color" (downcase action)) + (eplot--read-color (format "Value for %s (color): " action))) + ((string-match "font" (downcase action)) + (eplot--read-font-family + (format "Value for %s (font family): " action))) + ((string-match "gradient" (downcase action)) + (eplot--read-gradient action)) + ((string-match "file" (downcase action)) + (read-file-name (format "File for %s: " action))) + ((eq type 'symbol) + (intern + (completing-read (format "Value for %s: " action) + (plist-get (cdr spec) :valid) + nil t))) + (t + (read-string (format "Value for %s (string): " action)))))))) + (eplot-update-view-buffer)))) + +(defun eplot--read-gradient (action) + (format "%s %s %s %s" + (eplot--read-color (format "%s from color: " action)) + (eplot--read-color (format "%s to color: " action)) + (completing-read (format "%s direction: " action) + '(top-down bottom-up left-right right-left) + nil t) + (completing-read (format "%s position: " action) + '(below above) + nil t))) + +(defun eplot--reset-transient () + (interactive) + (with-current-buffer (or eplot--data-buffer (current-buffer)) + (setq-local eplot--transient-settings nil) + (eplot-update-view-buffer))) + +(defun eplot--save-transient (file) + (interactive "FSave parameters to file: ") + (when (and (file-exists-p file) + (not (yes-or-no-p "File exists; overwrite? "))) + (user-error "Exiting")) + (let ((settings (with-current-buffer (or eplot--data-buffer (current-buffer)) + eplot--transient-settings))) + (with-temp-buffer + (cl-loop for (name . value) in settings + do (insert (capitalize (symbol-name name)) ": " + (format "%s" value) "\n")) + (write-region (point-min) (point-max) file)))) + +(defvar-keymap eplot-control-mode-map + "RET" #'eplot-control-update + "TAB" #'eplot-control-next-field + "C-<tab>" #'eplot-control-next-field + "<backtab>" #'eplot-control-prev-field) + +(define-derived-mode eplot-control-mode special-mode "eplot control" + (setq-local completion-at-point-functions + (cons 'eplot--complete-control completion-at-point-functions)) + (add-hook 'before-change-functions #'eplot--process-text-input-before nil t) + (add-hook 'after-change-functions #'eplot--process-text-value nil t) + (add-hook 'after-change-functions #'eplot--process-text-input nil t) + (setq-local nobreak-char-display nil) + (setq truncate-lines t)) + +(defun eplot--complete-control () + ;; Complete headers names. + (when-let* ((input (get-text-property (point) 'input)) + (name (plist-get input :name)) + (spec (cdr (assq name (append eplot--plot-headers + eplot--chart-headers)))) + (start (plist-get input :start)) + (end (- (plist-get input :end) 2)) + (completion-ignore-case t)) + (skip-chars-backward " " start) + (or + (and (eq (plist-get spec :type) 'symbol) + (lambda () + (let ((valid (plist-get spec :valid))) + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end + (mapcar #'symbol-name valid)) + 'completion-attempted))) + (and (string-match "color" (symbol-name name)) + (lambda () + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end eplot--colors) + 'completion-attempted)) + (and (string-match "\\bfile\\b" (symbol-name name)) + (lambda () + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end (directory-files ".")) + 'completion-attempted)) + (and (string-match "\\bfont\\b" (symbol-name name)) + (lambda () + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end + (eplot--font-families)) + 'completion-attempted))))) + +(defun eplot--read-font-family (prompt) + "Prompt for a font family, possibly offering autocomplete." + (let ((families (eplot--font-families))) + (if families + (completing-read prompt families) + (read-string prompt)))) + +(defun eplot--font-families () + (when (executable-find "fc-list") + (let ((fonts nil)) + (with-temp-buffer + (call-process "fc-list" nil t nil ":" "family") + (goto-char (point-min)) + (while (re-search-forward "^\\([^,\n]+\\)" nil t) + (push (downcase (match-string 1)) fonts))) + (seq-uniq (sort fonts #'string<))))) + +(defun eplot-control-next-input () + "Go to the next input field." + (interactive) + (when-let ((match (text-property-search-forward 'input))) + (goto-char (prop-match-beginning match)))) + +(defun eplot-control-update () + "Update the chart based on the current settings." + (interactive) + (let ((settings nil)) + (save-excursion + (goto-char (point-min)) + (while-let ((match (text-property-search-forward 'input))) + (when (equal (get-text-property (prop-match-beginning match) 'face) + 'eplot--input-changed) + (let* ((name (plist-get (prop-match-value match) :name)) + (spec (cdr (assq name (append eplot--plot-headers + eplot--chart-headers)))) + (value + (or (plist-get (prop-match-value match) :value) + (plist-get (prop-match-value match) :original-value)))) + (setq value (string-trim (string-replace "\u00A0" " " value))) + (push (cons name + (cl-case (plist-get spec :type) + (number + (string-to-number value)) + (symbol + (intern (downcase value))) + (symbol-list + (mapcar #'intern (split-string (downcase value)))) + (t + value))) + settings))))) + (with-current-buffer eplot--data-buffer + (setq-local eplot--transient-settings (nreverse settings)) + (eplot-update-view-buffer)))) + +(defvar eplot--column-width nil) + +(defun eplot-create-controls () + "Pop to a buffer that lists all parameters and allows editing." + (interactive) + (with-current-buffer (or eplot--data-buffer (current-buffer)) + (let ((settings eplot--transient-settings) + (data-buffer (current-buffer)) + (chart eplot--current-chart) + ;; Find the max width of all the different names. + (width (seq-max + (mapcar (lambda (e) + (length (cadr e))) + (apply #'append + (mapcar #'cdr + (apply #'append eplot--transients)))))) + (transients (mapcar #'copy-sequence + (copy-sequence eplot--transients)))) + (unless chart + (user-error "Must be called from an eplot buffer that has rendered a chart")) + ;; Rearrange the transients a bit for better display. + (let ((size (caar transients))) + (setcar (car transients) (caadr transients)) + (setcar (cadr transients) size)) + (pop-to-buffer "*eplot controls*") + (unless (eq major-mode 'eplot-control-mode) + (eplot-control-mode)) + (setq-local eplot--data-buffer data-buffer + eplot--column-width (+ width 12 2)) + (let ((inhibit-read-only t) + (before-change-functions nil) + (after-change-functions nil)) + (erase-buffer) + (cl-loop for column in transients + for cn from 0 + do + (goto-char (point-min)) + (end-of-line) + (cl-loop + for row in column + do + (if (zerop cn) + (when (not (bobp)) + (insert (format (format "%%-%ds" (+ width 14)) "") + "\n")) + (unless (= (count-lines (point-min) (point)) 1) + (if (eobp) + (progn + (insert (format (format "%%-%ds" (+ width 14)) "") + "\n") + (insert (format (format "%%-%ds" (+ width 14)) "") + "\n") + (forward-line -1) + (end-of-line)) + (forward-line 1) + (end-of-line)))) + ;; If we have a too-long input in the first column, + ;; then go to the next line. + (when (and (> cn 0) + (> (- (point) (pos-bol)) + (+ width 12 2))) + (forward-line 1) + (end-of-line)) + (insert (format (format "%%-%ds" (+ width 14)) + (propertize (pop row) 'face 'bold))) + (if (looking-at "\n") + (forward-line 1) + (insert "\n")) + (cl-loop + for elem in row + for name = (cadr elem) + for slot = (intern (downcase name)) + when (null (nth 2 elem)) + do + (let* ((object (if (assq slot eplot--chart-headers) + chart + (car (slot-value chart 'plots)))) + (value (format "%s" + (or (cdr (assq slot settings)) + (if (not (slot-boundp object slot)) + "" + (or (slot-value object slot) + "")))))) + (end-of-line) + ;; If we have a too-long input in the first column, + ;; then go to the next line. + (when (and (> cn 0) + (> (- (point) (pos-bol)) + (+ width 12 2))) + (forward-line 1) + (end-of-line)) + (when (and (> cn 0) + (bolp)) + (insert (format (format "%%-%ds" (+ width 14)) "") "\n") + (forward-line -1) + (end-of-line)) + (insert (format (format "%%-%ds" (1+ width)) name)) + (eplot--input slot value + (if (cdr (assq slot settings)) + 'eplot--input-changed + 'eplot--input-default)) + (if (looking-at "\n") + (forward-line 1) + (insert "\n"))))))) + (goto-char (point-min))))) + +(defface eplot--input-default + '((t :background "#505050" + :foreground "#a0a0a0" + :box (:line-width 1))) + "Face for eplot default inputs.") + +(defface eplot--input-changed + '((t :background "#505050" + :foreground "white" + :box (:line-width 1))) + "Face for eplot changed inputs.") + +(defvar-keymap eplot--input-map + :full t :parent text-mode-map + "RET" #'eplot-control-update + "TAB" #'eplot-input-complete + "C-a" #'eplot-move-beginning-of-input + "C-e" #'eplot-move-end-of-input + "C-k" #'eplot-kill-input + "C-<tab>" #'eplot-control-next-field + "<backtab>" #'eplot-control-prev-field) + +(defun eplot-input-complete () + "Complete values in inputs." + (interactive) + (cond + ((let ((completion-fail-discreetly t)) + (completion-at-point)) + ;; Completion was performed; nothing else to do. + nil) + ((not (get-text-property (point) 'input)) + (eplot-control-next-input)) + (t + (user-error "No completion in this field")))) + +(defun eplot-move-beginning-of-input () + "Move to the start of the current input field." + (interactive) + (if (= (point) (eplot--beginning-of-field)) + (goto-char (pos-bol)) + (goto-char (eplot--beginning-of-field)))) + +(defun eplot-move-end-of-input () + "Move to the end of the current input field." + (interactive) + (let ((input (get-text-property (point) 'input))) + (if (or (not input) + (= (point) (1- (plist-get input :end)))) + (goto-char (pos-eol)) + (goto-char (1+ (eplot--end-of-field)))))) + +(defun eplot-control-next-field () + "Move to the beginning of the next field." + (interactive) + (let ((input (get-text-property (point) 'input)) + (start (point))) + (when input + (goto-char (plist-get input :end))) + (let ((match (text-property-search-forward 'input))) + (if match + (goto-char (prop-match-beginning match)) + (goto-char start) + (user-error "No next field"))))) + +(defun eplot-control-prev-field () + "Move to the beginning of the previous field." + (interactive) + (let ((input (get-text-property (point) 'input)) + (start (point))) + (when input + (goto-char (plist-get input :start)) + (unless (bobp) + (forward-char -1))) + (let ((match (text-property-search-backward 'input))) + (unless match + (goto-char start) + (user-error "No previous field"))))) + +(defun eplot-kill-input () + "Remove the part of the input after point." + (interactive) + (let ((end (1+ (eplot--end-of-field)))) + (kill-new (string-trim (buffer-substring (point) end))) + (delete-region (point) end))) + +(defun eplot--input (name value face) + (let ((start (point)) + input) + (insert value) + (when (< (length value) 11) + (insert (make-string (- 11 (length value)) ?\u00A0))) + (put-text-property start (point) 'face face) + (put-text-property start (point) 'inhibit-read-only t) + (put-text-property start (point) 'input + (setq input + (list :name name + :size 11 + :is-default (eq face 'eplot--input-default) + :original-value value + :original-face face + :start (set-marker (make-marker) start) + :value value))) + (put-text-property start (point) 'local-map eplot--input-map) + ;; This seems like a NOOP, but redoing the properties like this + ;; somehow makes `delete-region' work better. + (set-text-properties start (point) (text-properties-at start)) + (insert (propertize " " 'face face + 'input input + 'inhibit-read-only t + 'local-map eplot--input-map)) + (plist-put input :end (point-marker)) + (insert " "))) + +(defun eplot--end-of-field () + (- (plist-get (get-text-property (point) 'input) :end) 2)) + +(defun eplot--beginning-of-field () + (plist-get (get-text-property (point) 'input) :start)) + +(defvar eplot--prev-deletion nil) + +(defun eplot--process-text-input-before (beg end) + (message "Before: %s %s" beg end) + (cond + ((= beg end) + (setq eplot--prev-deletion nil)) + ((> end beg) + (setq eplot--prev-deletion (buffer-substring beg end))))) + +(defun eplot--process-text-input (beg end _replace-length) + ;;(message "After: %s %s %s %s" beg end replace-length eplot--prev-deletion) + (when-let ((props (if eplot--prev-deletion + (text-properties-at 0 eplot--prev-deletion) + (if (get-text-property end 'input) + (text-properties-at end) + (text-properties-at beg)))) + (input (plist-get props 'input))) + ;; The action concerns something in the input field. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (size (plist-get input :size))) + (save-excursion + (set-text-properties beg (- (plist-get input :end) 2) props) + (goto-char (1- (plist-get input :end))) + (let* ((remains (- (point) (plist-get input :start) 1)) + (trim (- size remains 1))) + (if (< remains size) + ;; We need to add some padding. + (insert (apply #'propertize (make-string trim ?\u00A0) + props)) + ;; We need to delete some padding, but only delete + ;; spaces at the end. + (setq trim (abs trim)) + (while (and (> trim 0) + (eql (char-after (1- (point))) ?\u00A0)) + (delete-region (1- (point)) (point)) + (cl-decf trim)) + (when (> trim 0) + (eplot--possibly-open-column))))) + ;; We re-set the properties so that they are continguous. This + ;; somehow makes the machinery that decides whether we can kill + ;; a word work better. + (set-text-properties (plist-get input :start) + (1- (plist-get input :end)) props) + ;; Compute what the value is now. + (let ((value (buffer-substring-no-properties + (plist-get input :start) + (plist-get input :end)))) + (when (string-match "\u00A0+\\'" value) + (setq value (substring value 0 (match-beginning 0)))) + (plist-put input :value value))))) + +(defun eplot--possibly-open-column () + (save-excursion + (when-let ((input (get-text-property (point) 'input))) + (goto-char (plist-get input :end))) + (unless (looking-at " *\n") + (skip-chars-forward " ") + (while (not (eobp)) + (let ((text (buffer-substring (point) (pos-eol)))) + (delete-region (point) (pos-eol)) + (forward-line 1) + (if (eobp) + (insert (make-string eplot--column-width ?\s) text "\n") + (forward-char eplot--column-width) + (if (get-text-property (point) 'input) + (forward-line 1) + (insert text) + ;; We have to fix up the markers. + (save-excursion + (let* ((match (text-property-search-backward 'input)) + (input (prop-match-value match))) + (plist-put input :start + (set-marker (plist-get input :start) + (prop-match-beginning match))) + (plist-put input :end + (set-marker (plist-get input :end) + (+ (prop-match-end match) 1)))))))))))) + +(defun eplot--process-text-value (beg _end _replace-length) + (when-let* ((input (get-text-property beg 'input))) + (let ((inhibit-read-only t)) + (when (plist-get input :is-default) + (put-text-property (plist-get input :start) + (plist-get input :end) + 'face + (if (equal (plist-get input :original-value) + (plist-get input :value)) + 'eplot--input-default + 'eplot--input-changed)))))) + +(defun eplot--read-color (prompt) + "Read an SVG color." + (completing-read prompt eplot--colors)) + +(eval `(transient-define-prefix eplot-customize () + "Customize Chart" + ,@(eplot--define-transients))) + +(defun eplot--bezier (factor i points) + (cl-labels ((padd (p1 p2) + (cons (+ (car p1) (car p2)) (+ (cdr p1) (cdr p2)))) + (psub (p1 p2) + (cons (- (car p1) (car p2)) (- (cdr p1) (cdr p2)))) + (pscale (factor point) + (cons (* factor (car point)) (* factor (cdr point))))) + (let* ((start (elt points (1- i))) + (end (elt points i)) + (prev (if (< (- i 2) 0) + start + (elt points (- i 2)))) + (next (if (> (1+ i) (1- (length points))) + end + (elt points (1+ i)))) + (start-control-point + (padd start (pscale factor (psub end prev)))) + (end-control-point + (padd end (pscale factor (psub start next))))) + (list (car start-control-point) + (cdr start-control-point) + (car end-control-point) + (cdr end-control-point) + (car end) + (cdr end))))) + +;;; CSV Parsing Stuff. + +(defun eplot--csv-buffer-p () + (save-excursion + (goto-char (point-min)) + (let ((min 1.0e+INF) + (max -1.0e+INF) + (total 0) + (lines 0)) + (while (not (eobp)) + (let ((this 0)) + (while (search-forward "," (pos-eol) t) + (cl-incf total) + (cl-incf this)) + (forward-line 1) + (cl-incf lines) + (setq min (min min this) + max (max max this)))) + (let ((mid (e/ total lines))) + ;; If we have a comma on each line, and it's fairly evenly + ;; distributed, it's a CSV buffer. + (and (>= min 1) + (< (* mid 0.9) min) + (> (* mid 1.1) max)))))) + +(defun eplot--numericalp (value) + (string-match-p "\\`[-.0-9]*\\'" value)) + +(defun eplot--numberish (value) + (if (or (zerop (length value)) + (not (eplot--numericalp value))) + value + (string-to-number value))) + +(defun eplot--parse-csv-buffer () + (unless (fboundp 'pcsv-parse-buffer) + (user-error "You need to install the pcsv package to parse CSV files")) + (let ((csv (and (fboundp 'pcsv-parse-buffer) + ;; This repeated check is just to silence the byte + ;; compiler. + (pcsv-parse-buffer))) + names) + ;; Check whether the first line looks like a header. + (when (and (length> csv 1) + ;; The second line is all numbers... + (cl-every #'eplot--numericalp (nth 1 csv)) + ;; .. and the first line isn't. + (not (cl-every #'eplot--numericalp (nth 0 csv)))) + (setq names (pop csv))) + (list + (cons 'legend (and names "true")) + (cons :plots + (cl-loop + for column from 1 upto (1- (length (car csv))) + collect + (list (cons :headers + (list + (cons 'name (elt names column)) + (cons 'data-format + (cond + ((cl-every (lambda (e) (<= (length e) 4)) + (mapcar #'car csv)) + "year") + ((cl-every (lambda (e) (= (length e) 8)) + (mapcar #'car csv)) + "date") + (t + "number"))) + (cons 'color (eplot--vary-color "vary" (1- column))))) + (cons + :values + (cl-loop for line in csv + collect (list :x (eplot--numberish (car line)) + :value (eplot--numberish + (elt line column))))))))))) + +(declare-function org-element-parse-buffer "org-element") + +(defun eplot--parse-org-buffer () + (require 'org-element) + (let* ((table (nth 2 (nth 2 (org-element-parse-buffer)))) + (columns (cl-loop for cell in (nthcdr 2 (nth 2 table)) + collect (substring-no-properties (nth 2 cell)))) + (value-column (or (seq-position columns "value") 0)) + (date-column (seq-position columns "date"))) + `((:plots + ((:headers + ,@(and date-column '((data-format . "date")))) + (:values + ,@(cl-loop for row in (nthcdr 4 table) + collect + (let ((cells (cl-loop for cell in (nthcdr 2 row) + collect (substring-no-properties + (nth 2 cell))))) + (list :value (string-to-number (elt cells value-column)) + :x (string-to-number + (replace-regexp-in-string + "[^0-9]" "" (elt cells date-column))) + ))))))))) + +(provide 'eplot) + +;;; eplot.el ends here diff --git a/archive/custom/profile-dotemacs.el b/archive/custom/profile-dotemacs.el new file mode 100644 index 00000000..8baee47b --- /dev/null +++ b/archive/custom/profile-dotemacs.el @@ -0,0 +1,161 @@ +;;; profile-dotemacs.el --- Profile your Emacs init file + +;; Copyright (C) 2010, 2012 David Engster + +;; Author: David Engster <dengste@eml.cc> + +;; This file is NOT part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Profiles profile-dotemacs-file by evaluating top-level sexps with +;; benchmark-run, then overlays the source buffer so expensive forms stand out +;; by percentage of total runtime. +;; +;; Run with: +;; emacs -Q -l /path/to/profile-dotemacs.el -f profile-dotemacs +;; +;; Full sexps are the unit of measurement; split large conditional blocks before +;; profiling if finer detail is needed. + +;;; Code: + +(require 'thingatpt) +(require 'benchmark) + +;; User variables + +(defvar profile-dotemacs-file "~/.emacs.d/init.el" + "File to be profiled.") + +(defvar profile-dotemacs-low-percentage 3 + "Percentage which should be considered low. +All sexp's with a running time below this percentage will be +grayed out.") + +(defface profile-dotemacs-time-face + '((((background dark)) (:background "OrangeRed1")) + (t (:background "red3"))) + "Background color to indicate percentage of total time.") + +(defface profile-dotemacs-low-percentage-face + '((((background dark)) (:foreground "gray25")) + (t (:foreground "gray75"))) + "Face for sexps below `profile-dotemacs-low-percentage'.") + +(defface profile-dotemacs-highlight-face + '((((background dark)) (:background "blue")) + (t (:background "yellow"))) + "Highlight face for benchmark results.") + +;; Main function + +(defun profile-dotemacs () + "Load `profile-dotemacs-file' and benchmark its sexps." + (interactive) + (with-current-buffer (find-file-noselect profile-dotemacs-file t) + (setq buffer-read-only t) ;; just to be sure + (goto-char (point-min)) + (let (start end results) + (while + (< (point) + (setq end (progn + (forward-sexp 1) + (point)))) + (forward-sexp -1) + (setq start (point)) + (add-to-list + 'results + `(,start ,end + ,(benchmark-run + (eval (sexp-at-point))))) + (goto-char end)) + (profile-dotemacs-show-results results) + (switch-to-buffer (current-buffer))))) + +;; Helper functions + +(defun profile-dotemacs-show-results (results) + "Show timings from RESULTS in current buffer." + (let ((totaltime (profile-dotemacs-totaltime results)) + current percentage ov) + (while results + (let* ((current (pop results)) + (ov (make-overlay (car current) (cadr current))) + (current (car (last current))) + (percentage (/ (+ (car current) (nth 2 current)) + totaltime)) + col benchstr lowface) + (setq col + (profile-dotemacs-percentage-color + percentage + (face-background 'default) + (face-background 'profile-dotemacs-time-face))) + (setq percentage (round (* 100 percentage))) + (setq benchstr (profile-dotemacs-make-benchstr current)) + (overlay-put ov 'help-echo benchstr) + (if (and (numberp profile-dotemacs-low-percentage) + (< percentage profile-dotemacs-low-percentage)) + (overlay-put ov 'face 'profile-dotemacs-low-percentage-face) + (overlay-put ov 'before-string + (propertize benchstr + 'face 'profile-dotemacs-highlight-face)) + (overlay-put ov 'face + `(:background ,col))))) + (setq ov (make-overlay (1- (point-max)) (point-max))) + (overlay-put ov 'after-string + (propertize + (format "\n-----------------\nTotal time: %.2fs\n" + totaltime) + 'face 'profile-dotemacs-highlight-face)))) + +(defun profile-dotemacs-totaltime (results) + "Calculate total time of RESULTS." + (let ((totaltime 0)) + (mapc (lambda (x) + (let ((cur (car (last x)))) + (setq totaltime (+ totaltime (car cur) (nth 2 cur))))) + results) + totaltime)) + +(defun profile-dotemacs-percentage-color (percent col-begin col-end) + "Calculate color according to PERCENT between COL-BEGIN and COL-END." + (let* ((col1 (color-values col-begin)) + (col2 (color-values col-end)) + (col + (mapcar (lambda (c) + (round + (+ (* (- 1 percent) (nth c col1)) + (* percent (nth c col2))))) + '(0 1 2)))) + (format "RGB:%04x/%04x/%04x" + (car col) + (nth 1 col) + (nth 2 col)))) + +(defun profile-dotemacs-make-benchstr (timings) + "Create descriptive benchmark string from TIMINGS." + (format + (concat + "<Percentage: %d ; " + "Time: %.2f ; " + "Number of GC: %d ; " + "Time for GC: %.2f>\n") + percentage + (car timings) (nth 1 timings) (nth 2 timings))) + + +;; profile-dotemacs.el ends here diff --git a/archive/custom/titlecase-data.el b/archive/custom/titlecase-data.el new file mode 100644 index 00000000..7415a210 --- /dev/null +++ b/archive/custom/titlecase-data.el @@ -0,0 +1,643 @@ +;;; titlecase-data.el --- Data for titlecase.el -*- lexical-binding: t; -*- + +;; Author: Case Duckworth <acdw@acdw.net> +;; Maintainer: Case Duckworth <acdw@acdw.net> +;; URL: https://github.com/duckwork/titlecase.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Data tables for titlecase.el: style-specific lowercase word lists, phrasal +;; verbs, and exceptions used by the title-casing engine. +;; +;; Title casing is best-effort because English style guides disagree and some +;; cases require grammatical knowledge this package does not model. Proofread +;; output before publication. + +;;; Code: + +(require 'seq) + +(defvar titlecase-prepositions + ;; This was pulled from Wikipedia, and so is somewhat weird. + ;; https://en.wikipedia.org/wiki/List_of_English_prepositions + '("'thout" "'tween" "aboard" "about" "above" + "abreast" "absent" "abt." "across" "after" "against" "ago" "aloft" "along" + "alongside" "amid" "amidst" "among" "amongst" "anti" "apart" "apropos" + "around" "as" "aside" "aslant" "astride" "at" "atop" "away" "before" + "behind" "below" "beneath" "beside" "besides" "between" "beyond" "but" "by" + "c." "ca." "circa" "come" "concerning" "contra" "counting" "cum" "despite" + "down" "during" "effective" "ere" "except" "excepting" "excluding" "failing" + "following" "for" "from" "hence" "in" "including" "inside" "into" "less" + "like" "mid" "midst" "minus" "mod" "modulo" "near" "nearer" "nearest" + "neath" "next" "notwithstanding" "o'" "o'er" "of" "off" "on" + "onto" "ontop" "opposite" "out" "outside" "over" "pace" "past" "pending" + "per" "plus" "post" "pre" "pro" "qua" "re" "regarding" "respecting" "round" + "sans" "save" "saving" "short" "since" "sub" "t'" "than" "through" + "throughout" "thru" "thruout" "till" "times" "to" "toward" "towards" "under" + "underneath" "unlike" "until" "unto" "up" "upon" "v." "versus" "via" + "vis-à-vis" "vs." "w." "w/" "w/i" "w/o" "wanting" "with" "within" + "without") + "List of prepositions in English. +This list is, by necessity, incomplete, even though prepositions +are a closed lexical group in the English language. This list +was pulled and culled from +https://en.wikipedia.org/wiki/List_of_English_prepositions.") + +(defvar titlecase-phrasal-verbs + (let (verbs) + (dolist + (phrase + '(("account" "for") ("ache" "for") ("act" "on") + ("act" "out") ("act" "up") ("add" "on") ("add" "up") + ("add" "up" "to") ("aim" "at") ("allow" "for") ("angle" "for") + ("answer" "back") ("answer" "for") ("argue" "out") ("ask" "after") + ("ask" "around") ("ask" "for") ("ask" "in") ("ask" "out") + ("ask" "over") ("ask" "round") ("auction" "off") ("back" "away") + ("back" "down") ("back" "off") ("back" "out") ("back" "out" "of") + ("back" "up") ("bag" "out") ("bail" "out") ("bail" "out" "on") + ("bail" "up") ("ball" "up") ("balls" "up") ("bang" "about") + ("bang" "around") ("bang" "on" "about") ("bang" "out") ("bang" "up") + ("bank" "on") ("barge" "in") ("barge" "into") ("bash" "about") + ("bash" "in") ("bash" "out") ("bash" "up") ("bawl" "out") + ("be" "after") ("be" "along") ("be" "away") ("be" "cut" "out" "for") + ("be" "cut" "up") ("be" "down") ("be" "down" "with") + ("be" "fed" "up") ("be" "in") ("be" "in" "on") ("be" "not" "on") + ("be" "off") ("be" "on") ("be" "on" "about") ("be" "onto") + ("be" "out") ("be" "out" "of") ("be" "out" "to") + ("be" "snowed" "under") ("be" "taken" "aback") ("be" "taken" "with") + ("be" "up") ("be" "up" "to") ("bear" "down" "on") ("bear" "on") + ("bear" "out") ("bear" "up") ("bear" "up" "under") ("bear" "with") + ("beat" "down") ("beat" "up") ("beaver" "away") + ("beaver" "away" "at") ("bed" "down") ("bed" "out") ("beef" "up") + ("belt" "out") ("belt" "up") ("bend" "down") ("bend" "over") + ("bend" "over" "backwards") ("black" "out") ("blank" "out") + ("blare" "out") ("blast" "off") ("blaze" "away") ("bliss" "out") + ("block" "in") ("block" "off") ("block" "out") ("block" "up") + ("blow" "away") ("blow" "down") ("blow" "off") ("blow" "out") + ("blow" "over") ("blow" "up") ("blurt" "out") ("bog" "down") + ("bog" "in") ("bog" "into") ("bog" "off") ("boil" "down") + ("boil" "down" "to") ("boil" "over") ("boil" "up") + ("bone" "up" "on") ("book" "in") ("book" "into") ("book" "up") + ("boot" "up") ("border" "on") ("boss" "about") ("boss" "around") + ("botch" "up") ("bottle" "away") ("bottle" "out") ("bottle" "up") + ("bottom" "out") ("bounce" "into") ("bounce" "off") ("bowl" "over") + ("box" "in") ("box" "up") ("branch" "out") ("break" "away") + ("break" "down") ("break" "in") ("break" "off") ("break" "out" "of") + ("break" "through") ("break" "up") ("breeze" "along") + ("breeze" "in") ("breeze" "into") ("breeze" "through") + ("brighten" "up") ("bring" "about") ("bring" "along") + ("bring" "around") ("bring" "back") ("bring" "down") + ("bring" "forth") ("bring" "forward") ("bring" "in") ("bring" "on") + ("bring" "out") ("bring" "out" "in") ("bring" "round") + ("bring" "up") ("brush" "off") ("brush" "up") ("bubble" "over") + ("bucket" "down") ("budge" "up") ("buff" "up") ("buff" "up" "on") + ("bug" "off") ("bug" "out") ("build" "up") ("bulk" "out") + ("bump" "into") ("bump" "off") ("bump" "up") ("bundle" "off") + ("bundle" "out") ("bundle" "up") ("bunk" "off") ("buoy" "up") + ("burn" "down") ("burn" "off") ("burn" "out") ("burst" "into") + ("butt" "in") ("butt" "out") ("butter" "up") ("buy" "in") + ("buy" "into") ("buy" "off") ("buy" "out") ("buy" "up") + ("buzz" "around") ("buzz" "off") ("buzz" "off") ("call" "after") + ("call" "around") ("call" "back") ("call" "for") ("call" "forth") + ("call" "in") ("call" "off") ("call" "on") ("call" "round") + ("call" "up") ("calm" "down") ("cancel" "out") ("care" "for") + ("carried" "away") ("carry" "forward") ("carry" "off") + ("carry" "on") ("carry" "on" "with") ("carry" "out") + ("carry" "over") ("carry" "through") ("cart" "off") ("cash" "in") + ("cash" "in" "on") ("cash" "out") ("cash" "up") ("catch" "at") + ("catch" "on") ("catch" "out") ("catch" "up") ("catch" "up" "on") + ("catch" "up" "with") ("cater" "for") ("cater" "to") ("cave" "in") + ("chalk" "out") ("chalk" "up") ("chalk" "up" "to") ("chance" "upon") + ("change" "over") ("charge" "up") ("charge" "with") ("chase" "down") + ("chase" "off") ("chase" "up") ("chat" "up") ("cheat" "on") + ("cheat" "out" "of") ("check" "by") ("check" "in") ("check" "into") + ("check" "off") ("check" "out") ("check" "out" "of") + ("check" "over") ("cheer" "on") ("cheer" "up") ("chew" "on") + ("chew" "out") ("chew" "over") ("chew" "up") ("chicken" "out") + ("chill" "out") ("chime" "in") ("chip" "away" "at") ("chip" "in") + ("choose" "up") ("chop" "down") ("chop" "up") ("chuck" "away") + ("chuck" "in") ("chuck" "out") ("chuck" "up") ("churn" "out") + ("clag" "up") ("clam" "up") ("clamp" "down" "on") ("claw" "back") + ("clean" "out") ("clean" "up") ("clear" "away") ("clear" "off") + ("clear" "out") ("clear" "up") ("click" "through") ("climb" "down") + ("clog" "up") ("close" "down") ("close" "in") ("close" "in" "on") + ("close" "in" "upon") ("close" "off") ("close" "on") ("close" "out") + ("close" "up") ("cloud" "over") ("clown" "about") ("clown" "around") + ("cock" "up") ("color" "up") ("colour" "up") ("come" "about") + ("come" "across") ("come" "apart") ("come" "before") ("come" "by") + ("come" "down") ("come" "down" "on") ("come" "down" "with") + ("come" "forth") ("come" "forth" "with") ("come" "from") + ("come" "in") ("come" "into") ("come" "into" "use") ("come" "off") + ("come" "off" "it") ("come" "on") ("come" "out") ("come" "out" "in") + ("come" "out" "with") ("come" "over") ("come" "round") + ("come" "through") ("come" "through" "with") ("come" "to") + ("come" "up") ("come" "up" "against") ("come" "up" "with") + ("come" "upon") ("conjure" "up") ("conk" "out") ("contract" "in") + ("contract" "out") ("contract" "out" "of") ("cool" "down") + ("coop" "up") ("cop" "it") ("cop" "off") ("cop" "out") + ("cotton" "on") ("could" "do" "with") ("count" "in") ("count" "on") + ("count" "out") ("count" "up") ("cozy" "up") ("cozy" "up" "to") + ("crack" "down" "on") ("crack" "on") ("crack" "up") ("crank" "out") + ("crank" "up") ("crash" "out") ("creep" "in") ("creep" "into") + ("creep" "out") ("creep" "out" "on") ("creep" "over") + ("creep" "up" "on") ("crop" "up") ("cross" "off") ("cross" "out") + ("crumb" "down") ("cry" "off") ("cry" "out") ("cut" "across") + ("cut" "back") ("cut" "back" "on") ("cut" "down") + ("cut" "down" "on") ("cut" "in") ("cut" "it" "out") ("cut" "off") + ("cut" "out") ("cut" "out" "on") ("cut" "up") ("dash" "off") + ("dawn" "on") ("die" "away") ("die" "down") ("die" "for") + ("die" "off") ("die" "out") ("dig" "in") ("dig" "into") ("dig" "up") + ("dine" "out") ("dine" "out" "on") ("dip" "in") ("dip" "into") + ("dip" "out") ("disagree" "with") ("dish" "out") ("dish" "up") + ("dive" "in") ("dive" "into") ("divvy" "out") ("divvy" "up") + ("do" "away" "with") ("do" "out" "of") ("do" "up") ("do" "without") + ("doss" "about") ("doss" "around") ("doss" "down") ("doze" "off") + ("drag" "on") ("draw" "back") ("draw" "down") ("draw" "in") + ("draw" "into") ("draw" "on") ("draw" "out") ("draw" "up") + ("dream" "of") ("dream" "up") ("dredge" "up") ("dress" "down") + ("dress" "up") ("drift" "apart") ("drift" "off") ("drill" "down") + ("drill" "down" "through") ("drill" "into") ("drink" "up") + ("drive" "away") ("drive" "back") ("drive" "by") ("drive" "off") + ("drive" "out") ("drive" "up") ("drone" "on") ("drop" "around") + ("drop" "away") ("drop" "back") ("drop" "by") ("drop" "in") + ("drop" "off") ("drop" "out") ("drop" "over") ("drop" "round") + ("drop" "someone" "in" "it") ("drop" "through") ("drown" "in") + ("drown" "out") ("drum" "into") ("drum" "out") ("drum" "up") + ("duck" "out" "of") ("duff" "up") ("dumb" "down") ("dwell" "on") + ("dwell" "upon") ("ease" "off") ("ease" "up") ("eat" "away") + ("eat" "in") ("eat" "into") ("eat" "out") ("eat" "up") + ("ebb" "away") ("edge" "out") ("edge" "up") ("egg" "on") + ("eke" "out") ("embark" "on") ("embark" "upon") ("empty" "out") + ("end" "in") ("end" "up") ("end" "up" "with") ("enter" "for") + ("enter" "into") ("eye" "up") ("face" "off") ("face" "up" "to") + ("faff" "about") ("faff" "around") ("fall" "about") ("fall" "apart") + ("fall" "back") ("fall" "back" "on") ("fall" "behind") + ("fall" "down") ("fall" "for") ("fall" "in") ("fall" "into") + ("fall" "off") ("fall" "out") ("fall" "over") ("fall" "through") + ("fall" "under") ("farm" "out") ("fart" "about") ("fart" "around") + ("fasten" "down") ("fasten" "on") ("fasten" "onto") ("fasten" "up") + ("fathom" "out") ("fatten" "up") ("fawn" "on") ("fawn" "over") + ("feed" "off") ("feed" "on") ("feed" "up") ("feel" "up") + ("feel" "up" "to") ("fend" "for") ("fend" "off") ("ferret" "out") + ("fess" "up") ("fess" "up" "to") ("fiddle" "about") + ("fiddle" "around") ("fiddle" "away") ("fight" "back") + ("fight" "it" "out") ("fight" "off") ("figure" "on") + ("figure" "out") ("file" "away") ("fill" "in") ("fill" "in" "for") + ("fill" "in" "on") ("fill" "out") ("fill" "up") ("filter" "in") + ("filter" "out") ("find" "out") ("finish" "off") ("fink" "on") + ("fink" "out") ("fire" "away") ("fire" "off") ("fire" "up") + ("firm" "up") ("fish" "for") ("fish" "out") ("fit" "in") + ("fit" "into") ("fit" "up") ("fix" "up") ("fizzle" "out") + ("flag" "down") ("flag" "up") ("flake" "out") ("flame" "out") + ("flame" "up") ("flare" "out") ("flare" "up") ("flesh" "out") + ("flick" "over") ("flick" "through") ("flip" "off") ("flip" "out") + ("flip" "through") ("flog" "off") ("floor" "it") ("flounce" "off") + ("flounce" "out") ("fly" "about") ("fly" "around") ("fly" "at") + ("fly" "by") ("fly" "into") ("fob" "off") ("fob" "off" "on") + ("fob" "off" "onto") ("fob" "off" "with") ("focus" "on") + ("fold" "up") ("fool" "around") ("forge" "ahead") ("freak" "out") + ("freeze" "out") ("freeze" "over") ("freeze" "up") ("freshen" "up") + ("front" "for") ("front" "off") ("front" "onto") ("front" "out") + ("front" "up") ("frown" "on") ("gad" "about") ("gad" "around") + ("gag" "for") ("gang" "up") ("gang" "up" "on") ("gear" "up") + ("geek" "out") ("get" "about") ("get" "above") ("get" "across") + ("get" "across" "to") ("get" "after") ("get" "ahead") + ("get" "ahead" "of") ("get" "along") ("get" "along" "in") + ("get" "along" "with") ("get" "around") ("get" "around") + ("get" "around" "to") ("get" "around" "to") ("get" "at") + ("get" "away") ("get" "away" "from") ("get" "away" "with") + ("get" "back") ("get" "back" "at") ("get" "back" "into") + ("get" "back" "to") ("get" "back" "together") ("get" "behind") + ("get" "behind" "with") ("get" "by") ("get" "by" "on") + ("get" "by" "with") ("get" "down") ("get" "down" "on") + ("get" "down" "to") ("get" "in") ("get" "in" "on") + ("get" "in" "with") ("get" "into") ("get" "it") ("get" "it" "off") + ("get" "it" "off" "with") ("get" "it" "on") ("get" "it" "on" "with") + ("get" "it" "together") ("get" "it" "up") ("get" "off") + ("get" "off" "it") ("get" "off" "on") ("get" "off" "with") + ("get" "on") ("get" "on" "at") ("get" "on" "for") ("get" "on" "to") + ("get" "on" "with") ("get" "onto") ("get" "out") ("get" "out" "of") + ("get" "over") ("get" "over" "with") ("get" "round") ("get" "round") + ("get" "round" "to") ("get" "through") ("get" "through" "to") + ("get" "to") ("get" "together") ("get" "up") ("get" "up" "to") + ("give") ("give" "away") ("give" "back") ("give" "in") + ("give" "in" "to") ("give" "it" "to") ("give" "it" "up" "for") + ("give" "it" "up" "to") ("give" "of") ("give" "off") ("give" "onto") + ("give" "out") ("give" "over") ("give" "over" "to") ("give" "up") + ("give" "up") ("give" "up" "on") ("give" "up" "to") ("give" "way") + ("give" "way" "to") ("give" "yourself" "up") + ("give" "yourself" "up" "to") ("gloss" "over") ("gnaw" "at") + ("gnaw" "away" "at") ("go" "about") ("go" "across") ("go" "after") + ("go" "against") ("go" "ahead") ("go" "ahead" "with") + ("go" "along" "with") ("go" "around") ("go" "at") ("go" "away") + ("go" "back") ("go" "back" "on") ("go" "before") ("go" "below") + ("go" "by") ("go" "down") ("go" "down" "on") ("go" "down" "to") + ("go" "down" "with") ("go" "for") ("go" "forth") ("go" "forward") + ("go" "in") ("go" "in" "for") ("go" "in" "with") ("go" "into") + ("go" "it") ("go" "it" "alone") ("go" "off") ("go" "off" "with") + ("go" "on") ("go" "on" "about") ("go" "on" "at") ("go" "on" "to") + ("go" "on" "with") ("go" "out") ("go" "out" "for") ("go" "out" "to") + ("go" "out" "with") ("go" "over") ("go" "over" "to") ("go" "past") + ("go" "round") ("go" "through") ("go" "through" "with") + ("go" "together") ("go" "towards") ("go" "under") ("go" "up") + ("go" "up") ("go" "up" "to") ("go" "with") ("go" "without") + ("goof" "around") ("goof" "off") ("goof" "up") ("grass" "on") + ("grass" "up") ("grey" "out") ("grind" "away") ("grind" "down") + ("grind" "into") ("grind" "on") ("grind" "out") ("grind" "up") + ("grow" "apart") ("grow" "away" "from") ("grow" "back") + ("grow" "from") ("grow" "into") ("grow" "on") ("grow" "out") + ("grow" "out" "of") ("grow" "to") ("grow" "together") ("grow" "up") + ("grow" "up" "on") ("grow" "upon") ("gun" "for") ("hack" "around") + ("hack" "into") ("hack" "off") ("ham" "up") ("hammer" "away" "at") + ("hammer" "into") ("hammer" "out") ("hand" "back") ("hand" "down") + ("hand" "in") ("hand" "on") ("hand" "out") ("hand" "over") + ("hang" "about") ("hang" "about") ("hang" "around") ("hang" "back") + ("hang" "back" "from") ("hang" "in" "there") ("hang" "on") + ("hang" "onto") ("hang" "out") ("hang" "out" "for") ("hang" "over") + ("hang" "together") ("hang" "up") ("hang" "up" "on") ("hang" "with") + ("hanker" "after") ("hanker" "for") ("harp" "on") ("have" "against") + ("have" "around") ("have" "down" "as") ("have" "in") + ("have" "it" "away") ("have" "it" "in" "for") ("have" "it" "off") + ("have" "it" "out" "with") ("have" "off") ("have" "on") + ("have" "over") ("have" "round") ("have" "up") ("head" "for") + ("head" "off") ("head" "out") ("head" "up") ("heat" "up") + ("help" "out") ("hit" "back") ("hit" "for") ("hit" "it" "off") + ("hit" "it" "off" "with") ("hit" "on") ("hit" "out" "at") + ("hit" "up") ("hit" "up" "on") ("hit" "upon") ("hit" "with") + ("hold" "against") ("hold" "back") ("hold" "back" "from") + ("hold" "down") ("hold" "forth") ("hold" "off") ("hold" "on") + ("hold" "on" "to") ("hold" "onto") ("hold" "out") + ("hold" "out" "against") ("hold" "out" "for") ("hold" "out" "on") + ("hold" "over") ("hold" "together") ("hold" "up") ("hold" "with") + ("home" "in" "on") ("hone" "in" "on") ("hook" "up") + ("hook" "up" "to") ("hoon" "around") ("horse" "around") + ("hound" "out") ("hunker" "down") ("hunt" "down") ("hunt" "out") + ("hunt" "up") ("hush" "up") ("iron" "out") ("issue" "forth") + ("jack" "around") ("jack" "in") ("jack" "up") ("jam" "on") + ("jaw" "away") ("jazz" "up") ("joke" "around") ("jot" "down") + ("juice" "up") ("jump" "at") ("jump" "in") ("jump" "on") + ("keel" "over") ("keep" "around") ("keep" "at") ("keep" "away") + ("keep" "back") ("keep" "down") ("keep" "from") ("keep" "in") + ("keep" "off") ("keep" "on") ("keep" "out") ("keep" "to") + ("keep" "up") ("keep" "up" "at") ("keep" "up" "with") ("key" "in") + ("kick" "about") ("kick" "around") ("kick" "around" "with") + ("kick" "back") ("kick" "down") ("kick" "in") ("kick" "off") + ("kick" "out") ("kick" "up") ("kiss" "off") ("kiss" "up" "to") + ("knock" "about") ("knock" "around") ("knock" "back") + ("knock" "down") ("knock" "it" "off") ("knock" "off") + ("knock" "out") ("knock" "together") ("knock" "up") + ("knuckle" "down") ("knuckle" "under") ("lap" "up") + ("large" "it" "up") ("lark" "about") ("lark" "around") + ("lark" "it" "up") ("lash" "down") ("lash" "into") ("lash" "out") + ("lash" "out" "against") ("lash" "out" "at") ("lash" "out" "on") + ("latch" "on") ("latch" "on" "to") ("latch" "onto") ("lay" "down") + ("lay" "into") ("lay" "off") ("lay" "on") ("lay" "out") + ("lead" "to") ("leak" "out") ("lean" "on") ("leave" "on") + ("leave" "out") ("let" "down") ("let" "in") ("let" "off") + ("let" "on") ("let" "out") ("lie" "down") ("lie" "with") + ("lift" "off") ("light" "up") ("lighten" "up") ("limber" "up") + ("limber" "up" "for") ("line" "up") ("link" "up") + ("link" "up" "with") ("listen" "out" "for") ("live" "by") + ("live" "down") ("live" "for") ("live" "in") ("live" "it" "up") + ("live" "off") ("live" "out") ("live" "through") ("live" "together") + ("live" "up" "to") ("live" "with") ("load" "down") ("load" "up") + ("load" "up" "on") ("lock" "away") ("lock" "down") ("lock" "in") + ("lock" "onto") ("lock" "out") ("lock" "up") + ("lock" "yourself" "away") ("log" "in") ("log" "into") ("log" "off") + ("log" "on") ("log" "out") ("look" "after") ("look" "back") + ("look" "down" "on") ("look" "for") ("look" "forward" "to") + ("look" "in") ("look" "in" "on") ("look" "into") ("look" "like") + ("look" "on") ("look" "on" "as") ("look" "out") ("look" "over") + ("look" "round") ("look" "to") ("look" "up") ("look" "up" "to") + ("look" "upon" "as") ("lord" "it" "over") ("lose" "out") + ("lose" "out" "on") ("lose" "out" "to") ("luck" "out") + ("magic" "away") ("make" "do" "with") ("make" "for") ("make" "into") + ("make" "it") ("make" "it" "up" "to") ("make" "off" "with") + ("make" "out") ("make" "over") ("make" "up") ("make" "up" "for") + ("make" "up" "to") ("make" "with") ("mark" "down") + ("mark" "down" "as") ("mark" "off") ("mark" "out") + ("mark" "out" "for") ("mark" "out" "from") ("mark" "up") + ("marry" "in") ("marry" "out") ("mash" "up") ("max" "out") + ("measure" "against") ("measure" "off") ("measure" "out") + ("measure" "up") ("meet" "with") ("mess" "about") + ("mess" "about" "with") ("mess" "around") ("mess" "around" "with") + ("mess" "over") ("mess" "up") ("mess" "with") ("mill" "around") + ("miss" "out") ("miss" "out" "on") ("mix" "up") ("monkey" "around") + ("mooch" "about") ("mooch" "around") ("mop" "up") ("mope" "about") + ("mope" "around") ("mount" "up") ("mouth" "off") ("move" "on") + ("mug" "up") ("mug" "up" "on") ("mull" "over") ("muscle" "in") + ("muscle" "in" "on") ("muscle" "into") ("muscle" "out") + ("naff" "off") ("nag" "at") ("nail" "down") ("name" "after") + ("nip" "off") ("nip" "out") ("nod" "off") ("nose" "about") + ("nose" "around") ("note" "down") ("nut" "out") ("occur" "to") + ("open" "up") ("opt" "for") ("opt" "out") ("owe" "to") ("own" "up") + ("pack" "away") ("pack" "in") ("pack" "it" "in") ("pack" "off") + ("pack" "out") ("pack" "up") ("pad" "down") ("pad" "out") + ("pair" "off") ("pair" "off" "with") ("pair" "up") ("palm" "off") + ("pan" "out") ("paper" "over") ("pare" "back") ("pare" "down") + ("pass" "around") ("pass" "as") ("pass" "away") ("pass" "by") + ("pass" "for") ("pass" "off") ("pass" "on") ("pass" "out") + ("pass" "over") ("pass" "through") ("pass" "to") ("pass" "up") + ("patch" "up") ("pay" "back") ("pay" "for") ("pay" "into") + ("pay" "off") ("peck" "at") ("peg" "away") ("peg" "down") + ("peg" "it") ("peg" "out") ("pencil" "in") ("perk" "up") + ("peter" "out") ("phase" "in") ("phase" "out") ("phrasal" "verb") + ("phrasal" "verbs") ("pick" "at") ("pick" "off") ("pick" "on") + ("pick" "out") ("pick" "through") ("pick" "up") + ("pick" "up" "after") ("pick" "up" "on") ("pick" "yourself" "up") + ("pig" "off") ("pig" "out") ("pile" "up") ("pin" "down") + ("pin" "on") ("pin" "up") ("pine" "away") ("pipe" "down") + ("pipe" "up") ("pit" "against") ("pit" "out") ("pitch" "for") + ("pitch" "in") ("pitch" "into") ("play" "along") ("play" "around") + ("play" "at") ("play" "away") ("play" "back") ("play" "down") + ("play" "off") ("play" "on") ("play" "out") ("play" "up") + ("play" "up" "to") ("play" "upon") ("play" "with") ("plead" "out") + ("plough" "back") ("plough" "into") ("plough" "on") + ("plough" "through") ("plough" "up") ("plow" "back") ("plow" "into") + ("plow" "on") ("plow" "through") ("plow" "up") ("plug" "in") + ("plump" "for") ("point" "out") ("polish" "off") ("polish" "up") + ("pony" "up") ("poop" "out") ("poop" "out" "on") ("pop" "in") + ("pop" "off") ("pop" "out") ("pop" "up") ("potter" "about") + ("potter" "around") ("pour" "down") ("pour" "forth") + ("prattle" "on") ("press" "ahead") ("press" "on") ("price" "up") + ("print" "out") ("prop" "up") ("psych" "out") ("psych" "up") + ("pull" "ahead") ("pull" "apart") ("pull" "away") ("pull" "back") + ("pull" "down") ("pull" "for") ("pull" "in") ("pull" "off") + ("pull" "on") ("pull" "out") ("pull" "over") ("pull" "through") + ("pull" "to") ("pull" "together") ("pull" "up") + ("pull" "yourself" "together") ("push" "in") ("put" "across") + ("put" "away") ("put" "back") ("put" "by") ("put" "down") + ("put" "down" "for") ("put" "down" "to") ("put" "in") + ("put" "in" "for") ("put" "off") ("put" "on") ("put" "out") + ("put" "through") ("put" "towards") ("put" "up") ("put" "up" "with") + ("quieten" "down") ("rack" "up") ("rain" "down" "on") + ("rake" "it" "in") ("rake" "up") ("ramp" "up") ("rat" "on") + ("rat" "out") ("rat" "through") ("ratchet" "up") ("rattle" "off") + ("reach" "out") ("reach" "out" "for") ("reach" "out" "to") + ("read" "off") ("read" "out") ("read" "up" "on") ("reckon" "on") + ("reel" "in") ("reel" "off") ("reel" "out") ("rein" "in") + ("ride" "off") ("ride" "on") ("ride" "out") ("ride" "up") + ("ring" "back") ("ring" "off") ("ring" "up") ("rip" "off") + ("rode" "off") ("roll" "back") ("roll" "in") ("roll" "on") + ("roll" "out") ("roll" "up") ("romp" "in") ("romp" "through") + ("room" "in") ("root" "about") ("root" "around") ("root" "for") + ("root" "out") ("root" "up") ("rope" "in") ("rough" "up") + ("round" "off") ("row" "back") ("rub" "along") ("rub" "down") + ("rub" "in") ("rub" "it" "in") ("rub" "off" "on") ("rub" "out") + ("rub" "up" "against") ("rub" "up" "on") ("rule" "out") + ("run" "across") ("run" "away") ("run" "down") ("run" "for") + ("run" "in") ("run" "into") ("run" "off") ("run" "on") + ("run" "out" "of") ("run" "over") ("run" "through") ("run" "to") + ("run" "up") ("run" "up" "against") ("run" "up" "on") ("run" "with") + ("rush" "into") ("sag" "off") ("sail" "into") ("sail" "through") + ("sally" "forth") ("sally" "out") ("salt" "away") ("save" "on") + ("save" "up") ("scare" "away") ("scare" "off") ("scout" "about") + ("scout" "around") ("scout" "out") ("scout" "round") ("scout" "up") + ("scrape" "along") ("scrape" "by") ("scrape" "in") ("scrape" "into") + ("scrape" "through") ("scrape" "together") ("scrape" "up") + ("screen" "off") ("screen" "out") ("screw" "around") ("screw" "up") + ("see" "about") ("see" "into") ("see" "off") ("see" "out") + ("see" "through") ("see" "to") ("sell" "off") ("sell" "on") + ("sell" "out") ("sell" "up") ("send" "back") ("send" "for") + ("send" "in") ("send" "off") ("send" "off" "for") ("send" "out") + ("send" "out" "for") ("send" "up") ("set" "about") ("set" "aside") + ("set" "back") ("set" "forth") ("set" "in") ("set" "off") + ("set" "out") ("set" "up") ("settle" "down") ("settle" "for") + ("settle" "in") ("settle" "on") ("settle" "up") ("sex" "up") + ("shack" "up") ("shake" "down") ("shake" "off") ("shape" "up") + ("shave" "off") ("shell" "out") ("ship" "off") ("ship" "out") + ("shoot" "away") ("shoot" "back") ("shoot" "off") ("shoot" "out") + ("shoot" "up") ("shop" "around") ("show" "around") ("show" "in") + ("show" "off") ("show" "out") ("show" "over") ("show" "round") + ("show" "through") ("show" "up") ("shrug" "off") ("shut" "away") + ("shut" "down") ("shut" "in") ("shut" "off") ("shut" "out") + ("shut" "out" "of") ("shut" "up") ("shut" "yourself" "away") + ("shy" "away" "from") ("side" "with") ("sift" "through") + ("sign" "away") ("sign" "for") ("sign" "in") ("sign" "into") + ("sign" "off") ("sign" "on") ("sign" "on" "with") ("sign" "out") + ("sign" "out" "of") ("sign" "up") ("sign" "with") ("simmer" "down") + ("sink" "in") ("sit" "about") ("sit" "around") ("sit" "back") + ("sit" "by") ("sit" "down") ("sit" "for") ("sit" "in") + ("sit" "in" "for") ("sit" "in" "on") ("sit" "on") ("sit" "out") + ("sit" "over") ("sit" "through") ("sit" "with") ("size" "up") + ("skive" "off") ("slack" "off") ("slag" "off") ("sleep" "off") + ("sleep" "on") ("sleep" "over") ("sleep" "through") ("slip" "out") + ("slip" "up") ("slob" "about") ("slob" "around") ("slope" "off") + ("slow" "down") ("slow" "up") ("smack" "of") ("smash" "down") + ("smash" "in") ("smash" "up") ("snap" "off") ("snap" "out" "of") + ("snap" "to" "it") ("snap" "up") ("sniff" "around") ("sniff" "at") + ("sniff" "out") ("sober" "up") ("soldier" "on") ("sort" "out") + ("sound" "off") ("sound" "out") ("spark" "off") ("spark" "up") + ("speak" "out") ("speak" "up") ("spell" "out") ("spit" "it" "out") + ("spit" "out") ("split" "up") ("spoil" "for") ("spur" "on") + ("square" "away") ("square" "off") ("square" "off" "against") + ("square" "up") ("square" "up" "to") ("square" "with") + ("squeeze" "up") ("stack" "up") ("stack" "up" "against") + ("staff" "up") ("stamp" "out") ("stand" "about") ("stand" "around") + ("stand" "aside") ("stand" "back") ("stand" "by") ("stand" "down") + ("stand" "for") ("stand" "in" "for") ("stand" "out") ("stand" "up") + ("stand" "up" "for") ("stand" "up" "to") ("start" "off") + ("start" "off" "on") ("start" "on") ("start" "on" "at") + ("start" "out") ("start" "out" "as") ("start" "out" "to") + ("start" "over") ("start" "up") ("stash" "away") ("stay" "away") + ("stay" "away" "from") ("stay" "in") ("stay" "on") ("stay" "out") + ("stay" "over") ("stay" "up") ("steer" "clear" "of") ("stem" "from") + ("step" "aside") ("step" "back") ("step" "down") ("step" "forward") + ("step" "in") ("step" "on" "it") ("step" "out") ("step" "to") + ("step" "up") ("stick" "around") ("stick" "at") ("stick" "by") + ("stick" "down") ("stick" "it" "to") ("stick" "out") + ("stick" "out" "for") ("stick" "to") ("stick" "together") + ("stick" "up") ("stick" "up" "for") ("stick" "with") ("stir" "up") + ("stitch" "up") ("stop" "around") ("stop" "back") ("stop" "behind") + ("stop" "by") ("stop" "doing") ("stop" "in") ("stop" "off") + ("stop" "out") ("stop" "over") ("stop" "round") ("stop" "up") + ("storm" "off") ("storm" "out") ("stow" "away") ("straighten" "out") + ("straighten" "up") ("strike" "back") ("strike" "down") + ("strike" "off") ("strike" "on") ("strike" "out") ("strike" "up") + ("strike" "upon") ("string" "along") ("string" "out") + ("string" "together") ("string" "up") ("stub" "out") + ("stumble" "across") ("stumble" "upon") ("stump" "up") ("suck" "in") + ("suck" "into") ("suck" "up" "to") ("sum" "up") ("summon" "up") + ("suss" "out") ("swan" "about") ("swan" "around") ("swan" "in") + ("swan" "off") ("swear" "by") ("swear" "down") ("sweep" "through") + ("swing" "around") ("swing" "at") ("swing" "by") ("swing" "round") + ("syphon" "off") ("tack" "on") ("tack" "onto") ("tag" "along") + ("tag" "on") ("tag" "onto") ("tag" "with") ("tail" "away") + ("tail" "back") ("tail" "off") ("take" "after") ("take" "apart") + ("take" "aside") ("take" "away") ("take" "back") ("take" "down") + ("take" "in") ("take" "it") ("take" "it" "out" "on") + ("take" "it" "upon" "yourself") ("take" "off") ("take" "on") + ("take" "out") ("take" "over") ("take" "to") ("take" "up") + ("talk" "back") ("talk" "down") ("talk" "down" "to") ("talk" "into") + ("talk" "out" "of") ("talk" "over") ("talk" "through") ("talk" "up") + ("tap" "for") ("tap" "into") ("tap" "off" "with") ("tap" "out") + ("tap" "up") ("team" "up") ("tear" "apart") ("tear" "at") + ("tear" "away") ("tear" "down") ("tear" "into") ("tear" "off") + ("tear" "up") ("tee" "off") ("tee" "off" "on") ("tee" "up") + ("tell" "apart") ("tell" "off") ("tell" "on") ("think" "over") + ("think" "through") ("think" "up") ("throw" "away") ("throw" "out") + ("throw" "up") ("tick" "away") ("tick" "by") ("tick" "off") + ("tick" "over") ("tide" "over") ("tidy" "up") ("tie" "back") + ("tie" "down") ("tie" "in") ("tie" "in" "with") ("tie" "up") + ("tighten" "up") ("tip" "off") ("tip" "over") ("tire" "of") + ("tire" "out") ("toddle" "off") ("tone" "down") ("tool" "up") + ("top" "off") ("top" "out") ("top" "up") ("touch" "down") + ("touch" "for") ("touch" "off") ("touch" "on") ("touch" "up") + ("touch" "upon") ("toy" "at") ("toy" "over") ("toy" "with") + ("track" "down") ("trade" "down") ("trade" "in") ("trade" "off") + ("trade" "on") ("trade" "up") ("trade" "upon") ("trickle" "down") + ("trip" "over") ("trip" "up") ("trot" "out") ("trump" "up") + ("try" "back") ("try" "for") ("try" "it" "on") ("try" "on") + ("try" "out") ("try" "out" "for") ("tuck" "away") ("tuck" "in") + ("tuck" "into") ("tuck" "up") ("tune" "in") ("tune" "in" "to") + ("tune" "out") ("tune" "up") ("turn" "against") ("turn" "away") + ("turn" "down") ("turn" "in") ("turn" "into") ("turn" "off") + ("turn" "on") ("turn" "out") ("turn" "over") ("turn" "to") + ("turn" "up") ("type" "up") ("use" "up") ("veg" "out") + ("venture" "forth") ("wade" "in") ("wade" "into") ("wade" "through") + ("wait" "about") ("wait" "around") ("wait" "behind") ("wait" "in") + ("wait" "on") ("wait" "out") ("wait" "up") ("wait" "upon") + ("wake" "up") ("walk" "away" "from") ("walk" "away" "with") + ("walk" "in" "on") ("walk" "into") ("walk" "off") + ("walk" "off" "with") ("walk" "on") ("walk" "out") + ("walk" "out" "on") ("walk" "up") ("want" "out") ("warm" "up") + ("wash" "away") ("wash" "down") ("wash" "out") ("wash" "over") + ("wash" "up") ("watch" "out") ("watch" "out" "for") ("watch" "over") + ("water" "down") ("wean" "off") ("wear" "away") ("wear" "down") + ("wear" "off") ("wear" "out") ("weed" "out") ("weigh" "in") + ("weigh" "up") ("went" "up") ("while" "away") ("whip" "out") + ("whip" "through") ("whip" "up") ("whisk" "away") ("white" "out") + ("wig" "out") ("wimp" "out") ("wind" "down") ("wind" "on") + ("wind" "up") ("winkle" "out") ("wipe" "out") ("wire" "up") + ("wise" "up") ("word" "up") ("work" "off") ("work" "on") + ("work" "out") ("wrap" "up") ("wriggle" "out" "of") ("write" "down") + ("write" "in") ("write" "off") ("write" "out") ("write" "up") + ("yack" "on") ("yammer" "on") ("yield" "to") ("zero" "in" "on") + ("zero" "out") ("zip" "around") ("zip" "by") ("zip" "up") + ("zone" "in") ("zone" "in" "on") ("zone" "out") ("zonk" "out") + ("zoom" "in") ("zoom" "in" "on") ("zoom" "off") ("zoom" "out"))) + (setf (alist-get (car phrase) verbs nil nil 'string-equal) + (cons (cdr phrase) + (alist-get (car phrase) verbs nil nil 'string-equal)))) + verbs) + "List of phrasal verbs in English. +This list is (a) very long and (b) probably incomplete. It's +been pulled from +https://capitalizemytitle.com/what-is-a-phrasal-verb/.") + +(defvar titlecase-articles '("a" "an" "the") + "List of articles in English.") + +(defvar titlecase-coordinating-conjunctions '("for" "and" "nor" "but" "or" + "yet" "so") + "List of coordinating conjunctions in English.") + + +(defvar titlecase-styles-capitalize-phrasal-verbs + '(chicago apa mla ap bluebook ama nyt wikipedia) + "Styles in which to capitalize phrasal verbs.") + +(defvar titlecase-styles-capitalize-last-word + '(chicago ap bluebook ama nyt wikipedia) + "Styles in which to capitalize the last word of a title.") + +(defvar titlecase-styles-capitalize-non-short-words + '(ap) + "Styles in which to capitalize all non-short words. +See `titlecase-short-word-length'.") + +(defvar titlecase-short-word-length 3 + "Maximum length of a short word. +See `titlecase-styles-capitalize-non-short-words'.") + +(defvar titlecase-lowercase-chicago (append titlecase-articles + titlecase-prepositions + '("as" "and" "but" "for" "nor" + "or")) + "Words to lowercase in Chicago Style. +Include: articles, and, but, for, nor, or, prepositions, and +\"to\" in an infinitive (though that's caught as a preposition).") + +(defvar titlecase-lowercase-apa (append titlecase-articles + (seq-filter (lambda (p) + (< (length p) 4)) + titlecase-prepositions) + '("as" "if")) + "Words to lowercase in APA Style.") + +(defvar titlecase-lowercase-mla (append titlecase-articles + titlecase-prepositions + titlecase-coordinating-conjunctions) + "Words to lowercase in MLA Style.") + +(defvar titlecase-lowercase-ap (append titlecase-articles + (seq-filter (lambda (p) + (< (length p) 4)) + titlecase-prepositions) + (seq-filter + (lambda (p) + (< (length p) 4)) + titlecase-coordinating-conjunctions) + '("as" "if")) + "Words to lowercase in AP Style.") + +(defvar titlecase-lowercase-bluebook (append titlecase-articles + titlecase-coordinating-conjunctions + (seq-filter + (lambda (p) + (< (length p) 4)) + titlecase-prepositions)) + "Words to lowercase in Bluebook Style.") + +(defvar titlecase-lowercase-ama (append titlecase-articles + titlecase-coordinating-conjunctions + (seq-filter (lambda (p) + (< (length p) 4)) + titlecase-prepositions)) + "Words to lowercase in AMA Style.") + +(defvar titlecase-lowercase-nyt '("as" "and" "as" "at" "but" "by" "en" "for" + "in" "if" "of" "on" "or" "the" "to" "v." "vs." + "via") + "Words to lowercase in New York Times Style. +NYT is unique in explicitly listing all words to lowercase. +Thanks, NYT! Of course, these should be capitalized when used as +adverbs, and \"for\" should be capitalized \"if it takes the +place of a verb meaning 'support' or 'advocate.'\" In addition, +\"in\" and \"on\" are generally capitalized when used as +adjectives in actual NYT headlines.") + +(defvar titlecase-lowercase-imdb '("a" "an" "and" "as" "at" "by" "for" + "from" "in" "of" "on" "or" "the" "to" + "with") + "Words to lowercase in IMDB style. +IMDB is another style guide that's explicit in which words to +lowercase. Shout-out to IMDB!") + +(defvar titlecase-lowercase-wikipedia + (append titlecase-articles + (seq-filter (lambda (p) (< (length p) 5)) titlecase-prepositions) + titlecase-coordinating-conjunctions) + "Words to lowercase in Wikipedia Style.") + +(defvar titlecase-lowercase-sentence nil + "Words to titlecase in Sentence style. +This is nil, since `titlecase--region-with-style-impl' deals with +the logic here (and besides, this list would be /quite/ long when +enumerated!)") + +(provide 'titlecase-data) +;;; titlecase-data.el ends here diff --git a/archive/custom/titlecase.el b/archive/custom/titlecase.el new file mode 100644 index 00000000..319befef --- /dev/null +++ b/archive/custom/titlecase.el @@ -0,0 +1,389 @@ +;;; titlecase.el --- Title-case phrases -*- lexical-binding: t; -*- + +;; Author: Case Duckworth <acdw@acdw.net> +;; Maintainer: Case Duckworth <acdw@acdw.net> +;; Version: 0.3.0 +;; URL: https://codeberg.org/acdw/titlecase.el +;; Package-Requires: ((emacs "25.1")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library strives to be the most accurate possible with title-casing +;; sentences, lines, and regions of text in English prose according to a number +;; of styles guides' capitalization rules. It is necessarily a best-effort; due +;; to the vaguaries of written English it's impossible to completely correctly +;; capitalize aribtrary titles. So be sure to proofread and copy-edit your +;; titles before sending them off to be published, and never trust a computer. + +;; INSTALLATION and USE: + +;; Make sure both titlecase.el and titlecase-data.el are in your `load-path', +;; and `require' titlecase. You should then be able to call the interactive +;; functions defined in this file. + +;;; CUSTOMIZATION: + +;; Only two customization options are probably going to be of any interest: +;; `titlecase-style' (the style to use for capitalizing titles), and +;; `titlecase-dwim-non-region-function', which determines what to do when +;; `titlecase-dwim' isn't acting on a region. + +;; If you want to use your own title-casing code, or a third party, you can +;; customize `titlecase-command' to something other than its default. One +;; possibility is titlecase.pl, written John Gruber and Aristotle Pagaltzis: +;; https://github.com/ap/titlecase. + +;;; Code: + +(require 'browse-url) ; `browse-url-button-regexp' +(require 'cl-lib) ; `cl-loop' +(require 'seq) ; `seq-some' +(require 'thingatpt) ; `bounds-of-thing-at-point' +(require 'titlecase-data) + +(defgroup titlecase nil + "Customization for title-casing phrases." + :prefix "titlecase-" + :group 'text) + +(defvar titlecase-styles '((chicago . "Chicago Style") + (apa . "APA Style") + (mla . "MLA Style") + (ap . "AP Style") + (bluebook . "Bluebook Style") + (ama . "AMA Style") + (nyt . "New York Times Style") + (wikipedia . "Wikipedia Style") + (imdb . "IMDB Style") + (sentence . "Sentence style")) + "Available styles for title-casing.") + +(defvar titlecase-default-case-function #'capitalize-word + "What to do to a word when a style doesn't specify what to do.") + +(defcustom titlecase-normalize-functions '(titlecase--lowercase-all-caps) + "List of functions for normalizing input before title-casing. +Each function will be passed 3 arguments: the beginning and +ending points of the region to operate on, as well as the +title-casing style. They are called one after another in order +in a `save-excursion' block." + :type '(repeat function)) + +(defcustom titlecase-skip-words-regexps (list "\\b[[:upper:]]+\\b" + browse-url-button-regexp) + "Regexps of words to skip when titlecasing. +Each regexp in this list will be tested on each word considered +for title-casing, and if the regexp matches the entire word, the +word will be skipped. + +NOTE: These regexps will be matched against the title-cased +region /after/ normalizing it, which means that, by default, if +the region is in all-caps before calling `titlecase-region', it +will be downcased before title-casing. Thus, some of these +regexps might not match when expected. This behavior is a +trade-off between possible user expectations. To change this +behavior, customize `titlecase-normalize-functions'." + :type '(repeat regexp)) + +(defcustom titlecase-style 'wikipedia + "Which style to use when title-casing." + :type (cons 'choice (cl-loop + for style in titlecase-styles + collect (list 'const :tag (cdr style) (car style)) + into choices + finally return choices))) + +(defcustom titlecase-force-cap-after-punc "[.?!\\/;:\n\r]" + "Regexp to force the next word capitalized." + :type 'regexp) + +(defcustom titlecase-dwim-non-region-function #'titlecase-line + "What to do with `titlecase-dwim' when region isn't active. +Recommended: `titlecase-line' or `titlecase-sentence'." + :type 'function) + +(defcustom titlecase-command #'titlecase--region-with-style + "Command to use for titlecasing titles. +This option can be one of two things: + +A string value, or a list of string values, is interpreted as a +system command to run using `call-process-region' on a temp +buffer containing the text to titlecase. Just a string is +interpreted as the command to run, with no arguments. A list of +strings will pass those strings as aruguments to the command-line +program. In that list, the symbol `style' will be replaced with +the the string of the title-casing style that's passed. + +A function value is interpreted as the function to call on the +region. The function will be called with three arguments: the +beginning and end of the region, and the style (see +`titlecase-style') to capitalize it in.") + +(defcustom titlecase-downcase-sentences nil + "Whether to downcase words after the first in \"sentence\" style. +If nil, titlecasing using the \"sentence\" style will leave all +words as-is. If t, \"sentence\"-style titlecasing will downcase +words that don't begin a sentence." + :type 'boolean) + +(defun titlecase--region-with-style-impl (begin end style) + "Title-case implementation. +`titlecase-force-cap-after-punc' must be handled by the caller. +This is expected to have run in a block that uses `save-excursion' and +`save-match-data'. See documentation for `titlecase--region-with-style' +for docs on BEGIN, END and STYLE." + (let ( ;; Constants during this function's runtime. + (case-fold-search nil) + (downcase-word-list (symbol-value + (intern (format "titlecase-lowercase-%s" + style))))) + + ;; Normalize the text in region by calling `titlecase-normalize-functions' + ;; in order. + (dolist (fn titlecase-normalize-functions) + (save-excursion + (funcall fn begin end style))) + + ;; Skip blank lines & white-space (where `current-word' would return nil). + ;; It's important this uses the same logic that `current-word' uses to scan + ;; for words, or this may be nil when it's not expected. See #11. + (goto-char begin) + (skip-syntax-forward "^w" end) + (setq begin (point)) + + ;; And loop over the rest. + (catch :done + (while (< (point) end) + (let ((this-word (current-word))) + (cond + ;; Skip words matching `titlecase-skip-words-regexps'. + ((looking-at (format "%s" + (mapconcat #'identity + titlecase-skip-words-regexps + "\\|"))) + (goto-char (match-end 0)) + ;; If the skip regexp consumed the final word, exit before the main loop tries + ;; to advance past END. + (when (>= (point) end) + (throw :done 'skipped))) + ;; Phrasal verbs! + ((and (memq style titlecase-styles-capitalize-phrasal-verbs) + (member (downcase this-word) + (mapcar #'car titlecase-phrasal-verbs))) + ;; We need to do a little state machine thingy here. + (let ((next-words (assoc this-word titlecase-phrasal-verbs)) + (bail-pt (point))) + ;; Take care of the first word --- this is inelegant. + (capitalize-word 1) + (skip-syntax-forward "^w" end) + (setq this-word (current-word)) + ;; Loop through the rest + (while (and this-word + (member (downcase this-word) + (mapcar #'car-safe next-words))) + (capitalize-word 1) + (skip-syntax-forward "^w" end) + (setq this-word (current-word) + next-words (mapcar #'cdr-safe next-words))) + (unless (seq-some #'null next-words) + ;; If it's not a phrasal verb, bail --- but still + ;; capitalize the first word! + (downcase-region bail-pt (point)) + (goto-char bail-pt) + (capitalize-word 1)))) + ;; Force capitalization if this is the first word. + ((eq begin (point)) + (capitalize-word 1)) + ;; AP capitalizes /all/ words longer than 3 letters. + ((and (memq style titlecase-styles-capitalize-non-short-words) + (> (length this-word) titlecase-short-word-length)) + (capitalize-word 1)) + ;; Sentence style either leaves later words unchanged or downcases them, + ;; depending on titlecase-downcase-sentences. + ((eq style 'sentence) + (funcall (if titlecase-downcase-sentences + #'downcase-word + #'forward-word) + 1)) + ;; Skip the next word if: + ((or + ;; None of the styles require a capital letter after an + ;; apostrophe. + (memq (char-before (point)) '(?' ?’)) + ;; FIXME: Hyphens are a completely different story with + ;; capitalization. + (eq (char-before (point)) ?-)) + (forward-word 1)) + ;; Down-case words that should be. + ((member (downcase this-word) downcase-word-list) + (downcase-word 1)) + ;; Otherwise, do the default function on the word. + (t + (funcall titlecase-default-case-function 1)))) + + ;; Step over the loop. + (unless (= end (point)) + (skip-syntax-forward "^w" end))) + ;; Capitalize the last word, only in some styles and some conditions. + (when (and (memq style titlecase-styles-capitalize-last-word)) + (save-excursion + (backward-word 1) + (when (and (>= (point) begin) + (not (seq-some (lambda (r) (looking-at r)) + titlecase-skip-words-regexps))) + (capitalize-word 1))))))) + +(defun titlecase--region-with-style (begin end style) + "Title-case the region of English text from BEGIN to END, using STYLE." + ;; It doesn't makes sense for this function to be interactive; + ;; `titlecase-region' can now specify a style interactively. + (save-match-data + (while (< begin end) + (goto-char begin) + (let ((end-step + (if (re-search-forward titlecase-force-cap-after-punc + end :noerror) + (point) + end))) + (if (memq (titlecase--region-with-style-impl begin end-step style) + '(skipped)) + (setq begin (point)) + (setq begin end-step)))))) + +(defun titlecase--read-style () + "Read which title-case style to use from the minibuffer." + (let ((choice (completing-read + "Title-case style: " + (mapcar #'cdr titlecase-styles) + nil t nil nil + (alist-get titlecase-style titlecase-styles)))) + (cl-loop for (s . n) in titlecase-styles + if (equal n choice) return s))) + +(defun titlecase--arg (style interactivep) + "Process arguments to titlecase functions. +If STYLE is passed to a function in any way, use it; otherwise, +if INTERACTIVEP, prompt the user for a style to use. As a +fall-back, use `titlecase-style'." + (or style + (and interactivep (titlecase--read-style)) + titlecase-style)) + +(defun titlecase--string (str style) + "Run `titlecase-command' on STR with STYLE and return the result. +See the docstring for `titlecase-command' for its possible +values." + (let (;; Remember the existing newlines + (str-ending-newlines (replace-regexp-in-string + "\\`\\([^z-a]*?\\)\n*\\'" "" str nil nil 1))) + (with-temp-buffer + (insert str) + (cond + ((stringp titlecase-command) + (call-process-region (point-min) (point-max) titlecase-command t t nil)) + ((listp titlecase-command) + (apply #'call-process-region (point-min) (point-max) + (car titlecase-command) t t nil + (mapcar (lambda (s) + (format "%s" (if (or (null s) + (eq s 'style)) + titlecase-style + s))) + (cdr titlecase-command)))) + ((functionp titlecase-command) + (funcall titlecase-command (point-min) (point-max) + (or style titlecase-style)))) + ;; Ensure that the string has no extra trailing whitespace. + (goto-char (point-max)) ; Go to the end of the buffer + (newline) ; Ensure at least one newline + (delete-blank-lines) ; Delete all but the last newline + (insert str-ending-newlines) ; Replace the pre-existing newlines + ;; Delete the extra newline and return the buffer as a string + (buffer-substring (point-min) (1- (point-max)))))) + +(defun titlecase--lowercase-all-caps (begin end _style) + "If the text from BEGIN to END is all-caps, downcase it." + (goto-char begin) + (unless (re-search-forward "[[:lower:]]" end :noerror) + (downcase-region begin end))) + +;;;###autoload +(defun titlecase-region (begin end &optional style interactivep) + "Title-case the region of English text from BEGIN to END. +Uses the style provided in `titlecase-style', unless optional +STYLE is provided. + +When called interactively , or when INTERACTIVEP is non-nil, +\\[universal-argument] \\[titlecase-region] will prompt the user +for the style to use." + (interactive "*r\ni\nP") + (atomic-change-group + (save-excursion ; `replace-region-contents' + (save-restriction + (narrow-to-region begin end) + (insert (titlecase--string (delete-and-extract-region begin end) + style)))))) + +;;;###autoload +(defun titlecase-line (&optional point style interactivep) + "Title-case the line at POINT. +Uses the style provided in `titlecase-style', unless optional +STYLE is provided. + +When called interactively , or when INTERACTIVEP is non-nil, +POINT is the current point, and calling with +\\[universal-argument] \\[titlecase-line] will prompt the user +for the style to use." + (interactive "d\ni\nP") + (goto-char (or point (point))) + (let ((style (titlecase--arg style interactivep)) + (thing (bounds-of-thing-at-point 'line))) + (titlecase-region (car thing) (cdr thing) style))) + +;;;###autoload +(defun titlecase-sentence (&optional point style interactivep) + "Title-case the sentence at POINT. +Uses the style provided in `titlecase-style', unless optional +STYLE is provided. + +When called interactively , or when INTERACTIVEP is non-nil, +POINT is the current point, and calling with +\\[universal-argument] \\[titlecase-sentence] will prompt the +user for the style to use." + (interactive "d\ni\nP") + (goto-char (or point (point))) + (let ((style (titlecase--arg style interactivep)) + (thing (bounds-of-thing-at-point 'sentence))) + (titlecase-region (car thing) (cdr thing) style) + (goto-char (cdr thing)))) + +;;;###autoload +(defun titlecase-dwim (&optional style interactivep) + "Title-case either the region, if active, or the current line. +Uses the style provided in `titlecase-style', unless optional +STYLE is provided. + +When called interactively with \\[universal-argument] +\\[titlecase-dwim], or when INTERACTIVEP is non-nil, prompt the +user for the style to use." + (interactive "i\nP") + (let ((style (titlecase--arg style interactivep))) + (if (region-active-p) + (titlecase-region (region-beginning) (region-end) style) + (funcall titlecase-dwim-non-region-function (point) style)))) + +(provide 'titlecase) +;;; titlecase.el ends here diff --git a/archive/modules/duet-config.el b/archive/modules/duet-config.el new file mode 100644 index 00000000..2dc7ad2e --- /dev/null +++ b/archive/modules/duet-config.el @@ -0,0 +1,19 @@ +;;; duet-config.el --- DUET dual-pane commander configuration -*- lexical-binding: t -*- + +;;; Commentary: +;; Personal configuration glue for the DUET package, developed locally at +;; ~/code/duet. Keybindings, defcustom values, and connection storage live +;; here; the package itself stays free of personal opinions. +;; +;; Not yet required from init.el — DUET is a pre-alpha skeleton. Wire it in +;; once Stage 1 provides usable commands. + +;;; Code: + +(use-package duet + :load-path "~/code/duet" + :ensure nil + :commands (duet)) + +(provide 'duet-config) +;;; duet-config.el ends here diff --git a/archive/modules/mu4e-org-contacts-setup.el b/archive/modules/mu4e-org-contacts-setup.el new file mode 100644 index 00000000..bfb9b1f2 --- /dev/null +++ b/archive/modules/mu4e-org-contacts-setup.el @@ -0,0 +1,31 @@ +;;; mu4e-org-contacts-setup.el --- Setup mu4e with org-contacts -*- lexical-binding: t; -*- +;; author: Craig Jennings <c@cjennings.net> + +;;; Commentary: +;; +;; Thin activation wrapper for mu4e-org-contacts-integration. If mu4e is loaded, +;; enable org-contacts completion and disable mu4e's internal contact collector +;; so completion has one source of truth. + +;;; Code: + +(defvar mu4e-compose-complete-only-personal) +(defvar mu4e-compose-complete-only-after) +(declare-function cj/activate-mu4e-org-contacts-integration "mu4e-org-contacts-integration") + +;; Load the integration module. Activation only runs when the module loaded +;; cleanly AND mu4e is present; otherwise this file is a no-op so the rest +;; of the config can load without mu4e installed. +(when (require 'mu4e-org-contacts-integration nil t) + (when (featurep 'mu4e) + (cj/activate-mu4e-org-contacts-integration))) + +;; Optional: If you want to use org-contacts as the primary source, +;; you might want to disable mu4e's contact caching to save memory +(with-eval-after-load 'mu4e + ;; Disable mu4e's internal contact collection + (setq mu4e-compose-complete-only-personal nil) + (setq mu4e-compose-complete-only-after nil)) + +(provide 'mu4e-org-contacts-setup) +;;; mu4e-org-contacts-setup.el ends here
\ No newline at end of file diff --git a/archive/modules/show-kill-ring.el b/archive/modules/show-kill-ring.el new file mode 100644 index 00000000..e65d48b5 --- /dev/null +++ b/archive/modules/show-kill-ring.el @@ -0,0 +1,122 @@ +;;; show-kill-ring.el --- Displays Previous Kill Ring Entries -*- lexical-binding: t; coding: utf-8; -*- +;; Show Kill Ring +;; Stolen from Steve Yegge when he wasn't looking +;; enhancements and bugs added by Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Browse items you've previously killed. +;; Yank text using C-u, the index, then C-y. +;; +;; I've lovingly kept the nice 1970s aesthetic, complete with wood paneling. +;; Maybe I'll give it a makeover at some point. +;; +;;; Code: + +(require 'cl-lib) + +(defvar show-kill-max-item-size 1000 + "This represents the size of a \='kill ring\=' entry. +A positive number means to limit the display of \='kill-ring\=' items to +that number of characters.") + +(defun show-kill-ring-exit () + "Exit the show-kill-ring buffer." + (interactive) + (quit-window t)) + +(defun show-kill-ring () + "Show the current contents of the kill ring in a separate buffer. +This makes it easy to figure out which prefix to pass to yank." + (interactive) + ;; kill existing one, since erasing it doesn't work + (let ((buf (get-buffer "*Kill Ring*"))) + (and buf (kill-buffer buf))) + + (let* ((buf (get-buffer-create "*Kill Ring*")) + (temp kill-ring) + (count 1) + (bar (make-string 32 ?=)) + (bar2 (concat " " bar)) + (item " Item ") + (yptr nil) (ynum 1)) + (set-buffer buf) + (erase-buffer) + + (show-kill-insert-header) + + ;; show each of the items in the kill ring, in order + (while temp + ;; insert our little divider + (insert (concat "\n" bar item (prin1-to-string count) " " + (if (< count 10) bar2 bar) "\n")) + + ;; if this is the yank pointer target, grab it + (when (equal temp kill-ring-yank-pointer) + (setq yptr (car temp) ynum count)) + + ;; insert the item and loop + (show-kill-insert-item (car temp)) + (cl-incf count) + (setq temp (cdr temp))) + + ;; show info about yank item + (show-kill-insert-footer yptr ynum) + + ;; use define-key instead of local-set-key + (use-local-map (make-sparse-keymap)) + (define-key (current-local-map) "q" #'show-kill-ring-exit) + + ;; show it + (goto-char (point-min)) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + ;; display-buffer rather than pop-to-buffer + ;; easier for user to C-u (item#) C-y + ;; while the point is where they want to yank + (display-buffer buf))) + +(defun show-kill-insert-item (item) + "Insert an ITEM from the kill ring into the current buffer. +If it's too long, truncate it first." + (let ((max show-kill-max-item-size)) + (cond + ((or (not (numberp max)) + (< max 0) + (< (length item) max)) + (insert item)) + (t + ;; put ellipsis on its own line if item is longer than 1 line + (let ((preview (substring item 0 max))) + (if (< (length item) (- (frame-width) 5)) + (insert (concat preview "...")) + (insert (concat preview "\n...")))))))) + +(defun show-kill-insert-header () + "Insert the show-kill-ring header or a notice if the kill ring is empty." + (if kill-ring + (insert "Contents of the kill ring:\n") + (insert "The kill ring is empty"))) + +(defun show-kill-insert-footer (yptr ynum) + "Insert final divider and the yank-pointer (YPTR YNUM) info." + (when kill-ring + (save-excursion + (re-search-backward "^\\(=+ Item [0-9]+ =+\\)$")) + (insert "\n") + (insert (make-string (length (match-string 1)) ?=)) + ;; Use number-to-string instead of int-to-string + (insert (concat "\n\nItem " (number-to-string ynum) + " is the next to be yanked:\n\n")) + (show-kill-insert-item yptr) + (insert "\n\nThe prefix arg will yank relative to this item."))) + +(defun empty-kill-ring () + "Force garbage collection of huge kill ring entries that I don't care about." + (interactive) + (setq kill-ring nil) + (garbage-collect)) + +(keymap-global-set "M-S-k" #'show-kill-ring) ;; was M-K, overrides kill-sentence + +(provide 'show-kill-ring) +;;; show-kill-ring.el ends here diff --git a/archive/modules/signal-config.el b/archive/modules/signal-config.el new file mode 100644 index 00000000..a1ec7933 --- /dev/null +++ b/archive/modules/signal-config.el @@ -0,0 +1,380 @@ +;;; signal-config.el --- Signal client (forked signel) configuration -*- lexical-binding: t -*- + +;;; Commentary: +;; cj/-namespaced configuration and helpers layered on the forked `signel' +;; package, a Signal client that drives signal-cli over JSON-RPC. +;; +;; This file currently holds the pure, signal-cli-independent helper layer +;; that the fork edits and `use-package' wiring build on: +;; - contact-list parsing for a completing-read contact picker, and +;; - the predicate that suppresses a notification for the chat the user +;; is actively viewing. +;; Both are unit-tested without a linked account. The use-package wiring, +;; keybindings, and the signel fork edits that call these helpers land once +;; signal-cli is installed and the device is linked. + +;;; Code: + +(require 'seq) +(require 'keybindings) ;; provides cj/custom-keymap + cj/register-prefix-map +(require 'system-lib) ;; for cj/executable-find-or-warn + +(declare-function notifications-notify "notifications") + +(defun cj/signal--jstr (value) + "Return VALUE if it is a non-blank string, else nil. +Normalizes a JSON field that may arrive as nil, the empty string, or a +null sentinel symbol into a plain string-or-nil." + (and (stringp value) + (not (string-empty-p (string-trim value))) + value)) + +(defun cj/signal--combine-name (given family) + "Join GIVEN and FAMILY name parts into a trimmed full name, or nil. +Either part may be nil, the empty string, or a JSON null sentinel." + (let ((parts (delq nil (list (cj/signal--jstr given) (cj/signal--jstr family))))) + (cj/signal--jstr (mapconcat #'identity parts " ")))) + +(defun cj/signal--contact-display-name (contact) + "Return a display name for CONTACT, or nil when none is set. +CONTACT is one entry alist from signal-cli `listContacts'. Picks the +first set source in priority order: the nickname (combined nickName, or +nickGivenName+nickFamilyName), the stored contact name, the top-level +givenName+familyName, the profile givenName+familyName, then username. +signal-cli 0.14 puts givenName/familyName at the top level; the profile +sub-object's name fields are usually null, so it is the deeper fallback." + (let ((profile (alist-get 'profile contact))) + (seq-find + #'cj/signal--jstr + (list (cj/signal--jstr (alist-get 'nickName contact)) + (cj/signal--combine-name (alist-get 'nickGivenName contact) + (alist-get 'nickFamilyName contact)) + (cj/signal--jstr (alist-get 'name contact)) + (cj/signal--combine-name (alist-get 'givenName contact) + (alist-get 'familyName contact)) + (cj/signal--combine-name (alist-get 'givenName profile) + (alist-get 'familyName profile)) + (cj/signal--jstr (alist-get 'username contact)))))) + +(defun cj/signal--parse-contacts (result) + "Parse RESULT from signal-cli `listContacts' into a completing-read alist. +RESULT is the JSON-RPC result value: a sequence (list or vector) of +contact alists. Returns an alist of (LABEL . RECIPIENT) sorted by LABEL, +where RECIPIENT is the contact's phone number (falling back to its UUID) +and LABEL is \"Name (recipient)\" when a name is known, or the bare +recipient otherwise. Contacts with no usable recipient are dropped." + (let (pairs) + (dolist (contact (append result nil)) + (let ((recipient (or (cj/signal--jstr (alist-get 'number contact)) + (cj/signal--jstr (alist-get 'uuid contact)))) + (name (cj/signal--contact-display-name contact))) + (when recipient + (push (cons (if name (format "%s (%s)" name recipient) recipient) + recipient) + pairs)))) + (sort pairs (lambda (a b) (string-lessp (car a) (car b)))))) + +(defun cj/signal--chat-buffer-name (id) + "Return the chat buffer name `signel' uses for chat ID." + (format "*Signel: %s*" id)) + +(defun cj/signal--suppress-notify-p (chat-id viewing-buffer-name frame-focused) + "Return non-nil when a notification for CHAT-ID should be suppressed. +Suppress only while the user is actively viewing that chat: the chat +buffer named by `cj/signal--chat-buffer-name' is VIEWING-BUFFER-NAME and +FRAME-FOCUSED is non-nil. A nil VIEWING-BUFFER-NAME or an unfocused +frame never suppresses." + (and frame-focused + (stringp viewing-buffer-name) + (string= viewing-buffer-name (cj/signal--chat-buffer-name chat-id)))) + +(defun cj/signal--frame-focused-p () + "Return non-nil when the selected frame currently has input focus. +Treats an unknown focus state as focused." + (if (fboundp 'frame-focus-state) + (let ((state (frame-focus-state))) + (if (eq state 'unknown) t state)) + t)) + +(defun cj/signal--should-notify-p (chat-id) + "Return non-nil when an incoming message for CHAT-ID should notify. +Notify unless the user is actively viewing that chat in the selected +window of a focused frame." + (not (cj/signal--suppress-notify-p + chat-id + (buffer-name (window-buffer (selected-window))) + (cj/signal--frame-focused-p)))) + +;;; Notifications + +(defcustom cj/signel-notify-sound nil + "When non-nil, incoming-message notifications play the notify script's sound. +Nil (the default) passes --silent so the toast is visual only." + :type 'boolean + :group 'signel) + +(defconst cj/signal--notify-body-max 120 + "Maximum character length of a desktop-notification body. +Longer message text truncates to this length ending in an ellipsis; +the full text is always in the chat buffer.") + +(defun cj/signal--format-notify-body (text) + "Collapse whitespace in TEXT and truncate it for a notification body. +Whitespace runs (including newlines) become single spaces, the result +is trimmed, and anything over `cj/signal--notify-body-max' characters +truncates to that length with a trailing ellipsis." + (let ((flat (string-trim (replace-regexp-in-string "[ \t\n\r]+" " " text)))) + (if (<= (length flat) cj/signal--notify-body-max) + flat + (concat (substring flat 0 (1- cj/signal--notify-body-max)) "…")))) + +(defun cj/signel--notify (chat-id sender body) + "Raise a desktop notification for an incoming Signal message. +Suppressed via `cj/signal--should-notify-p' when the user is actively +viewing CHAT-ID. Routes through the external notify script when it is +on PATH (type info, sound gated by `cj/signel-notify-sound'), falling +back to `notifications-notify' otherwise. SENDER names the title; +BODY is formatted by `cj/signal--format-notify-body'. Installed as +`signel-notify-function' in the use-package :config below." + (when (cj/signal--should-notify-p chat-id) + (let ((title (format "Signal: %s" sender)) + (text (cj/signal--format-notify-body body)) + (script (executable-find "notify"))) + (if script + (apply #'start-process "signel-notify" nil script "info" title text + (unless cj/signel-notify-sound (list "--silent"))) + ;; notifications.el is not autoloaded; load it on the first fallback. + (unless (fboundp 'notifications-notify) + (require 'notifications)) + (notifications-notify :title title :body text))))) + +;;; signel — fork integration + +(defcustom cj/signal-private-config-file + (expand-file-name "signal-config.local.el" user-emacs-directory) + "Private signal-config file, loaded when readable. +This is the place to set `signel-account' to the linked phone number so +the number stays out of the version-controlled (and publicly mirrored) +config. A phone number is an identifier rather than a credential, so it +lives here rather than in authinfo, which avoids a GPG prompt at connect +time." + :type 'file + :group 'signel) + +(use-package signel + :load-path "~/code/signel" + :ensure nil + :commands (signel-start signel-stop signel-chat signel-dashboard) + :custom + ;; Don't let an incoming message steal a window by auto-popping its chat + ;; buffer; surface arrivals through notifications instead (see child task + ;; "Notify only for the unviewed conversation"). + (signel-auto-open-buffer nil) + :config + (when (file-readable-p cj/signal-private-config-file) + (load cj/signal-private-config-file nil t)) + ;; Route incoming-message notifications through cj/signel--notify + ;; (suppression + notify script + truncation); warn once at load when + ;; the script is missing — the runtime path still falls back to + ;; notifications-notify, so messages are never silently dropped. + (setq signel-notify-function #'cj/signel--notify) + (cj/executable-find-or-warn "notify" "Signal desktop notifications via the notify script (falling back to notifications-notify)" 'signal-config)) + +;; Chat buffers (named `*Signel: <id>*') open in the bottom 30% of the +;; frame rather than wherever display-buffer's fallback rule picks. +;; The fork's `signel-chat' uses `pop-to-buffer', so this entry applies. +(add-to-list + 'display-buffer-alist + '("\\`\\*Signel: " + (display-buffer-reuse-window display-buffer-at-bottom) + (window-height . 0.3) + (reusable-frames . nil))) + +;;; Connection guard, contact fetch, and cache + +;; Forward declarations: signel.el is loaded by the use-package above (with +;; :load-path on the fork), but the byte-compiler doesn't see those symbols +;; statically. Declaring them keeps the compile clean without changing +;; runtime behavior. +(defvar signel-account) +(defvar signel--process-name) +(declare-function signel-start "signel" ()) +(declare-function signel--send-rpc "signel" (method params &optional target-buffer success-callback)) + +(defvar cj/signel--contact-cache nil + "Contact-picker cache: nil (cold), `empty', or a `(LABEL . RECIPIENT)' alist. +Populated by `cj/signel--fetch-contacts' on first invocation (or after a +`cj/signel-refresh-contacts'). A fetched-and-empty account caches the +symbol `empty' rather than nil, so it reads as warm and the picker does +not re-run its blocking fetch on every open -- read through +`cj/signel--cached-contacts'. Cleared back to cold by +`cj/signel--clear-contact-cache', advised onto `signel-stop' so a stale +list can't survive a reconnect. In-memory only.") + +(defun cj/signel--clear-contact-cache (&rest _) + "Return the contact cache to cold (nil) so the next picker refetches. +Advised `:after' `signel-stop': a relink or reconnect may change the +contact list, so a cache from the previous connection must not survive." + (setq cj/signel--contact-cache nil)) + +(advice-add 'signel-stop :after #'cj/signel--clear-contact-cache) + +(defun cj/signel--cached-contacts () + "Return the cached contact alist, treating the `empty' sentinel as none." + (unless (eq cj/signel--contact-cache 'empty) + cj/signel--contact-cache)) + +(defcustom cj/signel-fetch-timeout 3.0 + "Seconds the picker blocks on `accept-process-output' for a cold-cache fetch. +On warm cache the picker opens instantly; on cold cache it kicks off a +fetch and waits up to this many seconds for the RPC result before +reporting a `user-error' so a dead or wedged daemon can't hang Emacs." + :type 'number + :group 'signel) + +(defun cj/signel--ensure-started () + "Ensure the signel daemon is live, starting it if needed. +Three branches: +- The process is already live -- no-op, return nil. +- `signel-account' is set but no live process exists -- call `signel-start' + and pre-warm the contact cache with a background `listContacts' fetch so + the picker is instant on first use. +- `signel-account' is nil -- `user-error' naming the remedy (set the + account in `cj/signal-private-config-file'). + +If startup launches but the RPC handshake exits before the first response, +the subsequent `signel--send-rpc' call (in the pre-warm or any later +fetch) signals through its own error path; check =*signel-log*= and +=*signel-stderr*= for detail and link the account manually. + +Loads the `signel' feature explicitly before reading any of its +private variables: the use-package above autoloads only on +`signel-start' / `signel-stop' / `signel-chat' / `signel-dashboard', +so without this require the first branch's read of `signel--process-name' +fires a void-variable error before the autoload would trigger." + (require 'signel) + (cond + ((process-live-p (get-process signel--process-name)) + nil) + ((null signel-account) + (user-error + "signel-account is unset. Set it in %s (or your private config) and link the device manually with `signal-cli link', then retry" + cj/signal-private-config-file)) + (t + (signel-start) + (cj/signel--fetch-contacts)))) + +(defun cj/signel--fetch-contacts (&optional after-callback) + "Fetch the contact list from signal-cli and populate `cj/signel--contact-cache'. +Issues a `listContacts' RPC and registers a success callback that runs +the result through `cj/signal--parse-contacts' (the verified parser) and +stores the resulting `(LABEL . RECIPIENT)' alist in the cache. An empty +result caches the `empty' sentinel -- nil would read as a cold cache and +re-run the picker's blocking fetch on every open. A failure goes +through the dispatch error path and never invokes the callback, so the +prior cache survives. + +AFTER-CALLBACK, when non-nil, is invoked with no arguments after the +cache has been populated -- the picker uses this to unblock its +bounded-wait on cold caches." + (signel--send-rpc + "listContacts" nil nil + (lambda (result) + (setq cj/signel--contact-cache + (or (cj/signal--parse-contacts result) 'empty)) + (when after-callback (funcall after-callback))))) + +(defun cj/signel-refresh-contacts () + "Clear the picker's contact cache and refetch it from signal-cli. +Use when a contact added or renamed on the phone hasn't shown up in the +picker yet; this forces a fresh `listContacts' rather than reading the +cached snapshot." + (interactive) + (setq cj/signel--contact-cache nil) + (cj/signel--fetch-contacts)) + +;;; Picker, self-message, and connect + +(declare-function signel-chat "signel" (recipient)) +(declare-function signel-dashboard "signel" ()) +(declare-function signel-stop "signel" ()) + +(defun cj/signel-connect () + "Connect to signal-cli, starting the daemon if needed. +Thin interactive wrapper around `cj/signel--ensure-started' so the +keymap has a friendly verb to bind." + (interactive) + (cj/signel--ensure-started) + (message "Signel connected.")) + +(defun cj/signel-message () + "Pick a Signal contact by name and open the chat buffer. +Ensures the daemon is connected first (auto-starts and pre-warms on +cold start, or errors with the remedy if the account isn't set). Uses +the cached contact list when warm; on a cold cache, kicks off a fetch +and waits up to `cj/signel-fetch-timeout' seconds for the result before +raising a `user-error' so a dead daemon can't hang Emacs. The picker +offers a pinned \"Note to Self\" entry plus every Signal contact, and +opens the chosen recipient in `signel-chat'." + (interactive) + (cj/signel--ensure-started) + (unless cj/signel--contact-cache + (let ((done nil) + (deadline (+ (float-time) cj/signel-fetch-timeout))) + (cj/signel--fetch-contacts (lambda () (setq done t))) + (while (and (not done) (< (float-time) deadline)) + (accept-process-output nil 0.1)) + (unless done + (user-error + "Signal contact fetch timed out after %.1fs; try again or run M-x cj/signel-refresh-contacts (see *signel-log* for detail)" + cj/signel-fetch-timeout)))) + (let* ((note-self (cons "Note to Self" signel-account)) + (candidates (cons note-self (cj/signel--cached-contacts))) + (table (lambda (string pred action) + (if (eq action 'metadata) + `(metadata + (category . signal-contact) + (annotation-function + . ,(lambda (cand) + (let ((r (cdr (assoc cand candidates)))) + (when r + (concat " " (propertize r 'face 'completions-annotations)))))) + (display-sort-function . identity) + (cycle-sort-function . identity)) + (complete-with-action action candidates string pred)))) + (label (completing-read "Signal recipient: " table nil t)) + (recipient (cdr (assoc label candidates)))) + (when recipient + (signel-chat recipient)))) + +(defun cj/signel-message-self () + "Open a Signal chat buffer addressed to Note to Self. +Resolves to `signel-account' (the linked phone number). Sending to it +lands in the Signal Note-to-Self thread on the phone; manual-verify +that on first use." + (interactive) + (cj/signel--ensure-started) + (unless signel-account + (user-error "signel-account is unset; cannot send to self")) + (signel-chat signel-account)) + +(defvar cj/signel-prefix-map + (let ((map (make-sparse-keymap))) + (keymap-set map "m" #'cj/signel-message) + (keymap-set map "s" #'cj/signel-message-self) + (keymap-set map "d" #'signel-dashboard) + (keymap-set map "q" #'signel-stop) + (keymap-set map "SPC" #'cj/signel-connect) + map) + "Signel \"Messages\" prefix keymap, bound under `C-; M'. +Leaves =l= unbound for now -- the future =cj/signel-link= command lands +in a later pass. See =docs/specs/signal-client-spec-doing.org= scope summary.") + +;; Register the messages prefix under C-; M via the documented helper. +;; keybindings.el owns cj/custom-keymap; the (require 'keybindings) above +;; guarantees it is loaded before this runs, so no load-order guard is +;; needed. This is the same pattern every other feature module uses. +(cj/register-prefix-map "M" cj/signel-prefix-map "signal messages") + +(provide 'signal-config) +;;; signal-config.el ends here diff --git a/archive/tests/test-show-kill-ring--insert-item.el b/archive/tests/test-show-kill-ring--insert-item.el new file mode 100644 index 00000000..a29ca75e --- /dev/null +++ b/archive/tests/test-show-kill-ring--insert-item.el @@ -0,0 +1,73 @@ +;;; test-show-kill-ring--insert-item.el --- Tests for show-kill-insert-item -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `show-kill-insert-item' in show-kill-ring.el — inserts a +;; kill-ring entry into the current buffer, truncating to +;; `show-kill-max-item-size' with an ellipsis when too long. The ellipsis +;; sits inline for short items and on its own line for items wider than the +;; frame. Frame width is read at runtime so the test is environment-stable. + +;;; Code: + +(require 'ert) +(require 'show-kill-ring) + +;;; Normal Cases + +(ert-deftest test-show-kill-ring-insert-item-short-verbatim () + "Normal: an item shorter than the max is inserted unchanged." + (let ((show-kill-max-item-size 1000)) + (with-temp-buffer + (show-kill-insert-item "hello") + (should (string= (buffer-string) "hello"))))) + +(ert-deftest test-show-kill-ring-insert-item-inline-ellipsis () + "Normal: an over-max item narrower than the frame gets an inline ellipsis." + (let* ((show-kill-max-item-size 5) + (len (/ (frame-width) 2)) ; > max, < (frame-width - 5) + (item (make-string len ?b))) + (with-temp-buffer + (show-kill-insert-item item) + (should (string= (buffer-string) "bbbbb..."))))) + +;;; Boundary Cases + +(ert-deftest test-show-kill-ring-insert-item-length-equals-max-truncates () + "Boundary: length exactly equal to max truncates — the guard is (< len max)." + (let ((show-kill-max-item-size 5)) + (with-temp-buffer + (show-kill-insert-item "hello") ; length 5, equals max + (should (string= (buffer-string) "hello..."))))) + +(ert-deftest test-show-kill-ring-insert-item-wide-newline-ellipsis () + "Boundary: an item wider than the frame puts the ellipsis on its own line." + (let* ((show-kill-max-item-size 5) + (item (make-string (+ (frame-width) 10) ?a))) + (with-temp-buffer + (show-kill-insert-item item) + (should (string= (buffer-string) "aaaaa\n..."))))) + +(ert-deftest test-show-kill-ring-insert-item-max-nil-verbatim () + "Boundary: a non-numeric max disables truncation." + (let ((show-kill-max-item-size nil)) + (with-temp-buffer + (show-kill-insert-item "anything long enough to exceed nothing") + (should (string= (buffer-string) + "anything long enough to exceed nothing"))))) + +(ert-deftest test-show-kill-ring-insert-item-max-negative-verbatim () + "Boundary: a negative max disables truncation." + (let ((show-kill-max-item-size -1)) + (with-temp-buffer + (show-kill-insert-item "abc") + (should (string= (buffer-string) "abc"))))) + +(ert-deftest test-show-kill-ring-insert-item-empty-string () + "Boundary: an empty item inserts nothing and does not error." + (let ((show-kill-max-item-size 1000)) + (with-temp-buffer + (show-kill-insert-item "") + (should (string= (buffer-string) ""))))) + +(provide 'test-show-kill-ring--insert-item) +;;; test-show-kill-ring--insert-item.el ends here diff --git a/archive/tests/test-signal-config--contact-cache.el b/archive/tests/test-signal-config--contact-cache.el new file mode 100644 index 00000000..720e0c3a --- /dev/null +++ b/archive/tests/test-signal-config--contact-cache.el @@ -0,0 +1,61 @@ +;;; test-signal-config--contact-cache.el --- Contact-cache lifecycle tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The picker's contact cache has two lifecycle bugs from the 2026-06 config +;; audit: (1) its docstring promised clearing on signel-stop but nothing +;; cleared it, so a stale list survived a relink/reconnect; (2) a +;; fetched-and-empty list was cached as nil, indistinguishable from a cold +;; cache, so a zero-contact account re-ran the blocking fetch (up to +;; `cj/signel-fetch-timeout') on every picker open. The fix names the empty +;; state with an `empty' sentinel and clears the cache via a named function +;; advised onto `signel-stop'. +;; +;; Boundary mocks only (the RPC send, the prompt); the cache logic runs +;; real. The ensure-started branches the audit called untested were +;; already covered in test-signal-config.el -- that claim was stale. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'signal-config) + +;;; ------------------------- clear-on-stop (F1) ------------------------------ + +(ert-deftest test-signal-config-clear-contact-cache-resets () + "Normal: the clear function empties the cache back to cold (nil)." + (let ((cj/signel--contact-cache '(("Al (+1)" . "+1")))) + (cj/signel--clear-contact-cache) + (should (null cj/signel--contact-cache)))) + +(ert-deftest test-signal-config-clear-contact-cache-advises-stop () + "Normal: `signel-stop' carries the clear advice, so the docstring's +\"cleared on stop/restart\" promise is real." + (should (advice-member-p #'cj/signel--clear-contact-cache 'signel-stop))) + +;;; ------------------------- empty sentinel (F2) ------------------------------ + +(ert-deftest test-signal-config-fetch-empty-caches-sentinel () + "Boundary: a fetched-and-empty list caches the `empty' sentinel, not nil. +nil means cold cache; without the sentinel a zero-contact account re-ran +the blocking fetch on every picker open." + (let ((cj/signel--contact-cache nil) + (captured-callback nil)) + (cl-letf (((symbol-function 'signel--send-rpc) + (lambda (_method _params _buf callback) + (setq captured-callback callback)))) + (cj/signel--fetch-contacts) + (funcall captured-callback '())) + (should (eq cj/signel--contact-cache 'empty)))) + +(ert-deftest test-signal-config-cached-contacts-unwraps-sentinel () + "Normal: the cache reader returns the alist, and nil for the sentinel." + (let ((cj/signel--contact-cache '(("Al (+1)" . "+1")))) + (should (equal (cj/signel--cached-contacts) '(("Al (+1)" . "+1"))))) + (let ((cj/signel--contact-cache 'empty)) + (should (null (cj/signel--cached-contacts))))) + +(provide 'test-signal-config--contact-cache) +;;; test-signal-config--contact-cache.el ends here diff --git a/archive/tests/test-signal-config-notify.el b/archive/tests/test-signal-config-notify.el new file mode 100644 index 00000000..1a772289 --- /dev/null +++ b/archive/tests/test-signal-config-notify.el @@ -0,0 +1,150 @@ +;;; test-signal-config-notify.el --- Tests for the signal-config notification slice -*- lexical-binding: t -*- + +;;; Commentary: +;; ERT tests for the notification slice of `signal-config': the pure +;; body formatter (whitespace collapse + truncation to +;; `cj/signal--notify-body-max') and `cj/signel--notify' routing (the +;; suppression gate, the notify-script path with the sound flag, and +;; the `notifications-notify' fallback). Spec: the "Notification +;; slice" addendum in docs/specs/signal-client-spec-doing.org. No signal-cli or +;; linked account needed. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; signel is the fork at ~/code/signel; signal-config wires it via +;; use-package but these tests need the symbols available directly. +(eval-and-compile + (add-to-list 'load-path (expand-file-name "~/code/signel"))) +(require 'signel) + +(require 'signal-config) + +;;; cj/signal--format-notify-body + +(ert-deftest test-signal-config-format-notify-body-passthrough () + "Normal: short single-line text passes through unchanged." + (should (equal (cj/signal--format-notify-body "lunch at noon?") + "lunch at noon?"))) + +(ert-deftest test-signal-config-format-notify-body-collapses-whitespace () + "Normal: newlines and whitespace runs collapse to single spaces." + (should (equal (cj/signal--format-notify-body "two\nlines\n\nhere") + "two lines here")) + (should (equal (cj/signal--format-notify-body "tabs\t\tand spaces") + "tabs and spaces"))) + +(ert-deftest test-signal-config-format-notify-body-trims () + "Boundary: leading and trailing whitespace is trimmed." + (should (equal (cj/signal--format-notify-body " hi ") "hi"))) + +(ert-deftest test-signal-config-format-notify-body-empty () + "Boundary: the empty string stays empty." + (should (equal (cj/signal--format-notify-body "") ""))) + +(ert-deftest test-signal-config-format-notify-body-exact-limit () + "Boundary: a body exactly at the limit is untouched." + (let ((s (make-string cj/signal--notify-body-max ?x))) + (should (equal (cj/signal--format-notify-body s) s)))) + +(ert-deftest test-signal-config-format-notify-body-truncates-over-limit () + "Boundary: over-limit text truncates to the limit, ending in an ellipsis." + (let* ((s (make-string (1+ cj/signal--notify-body-max) ?x)) + (out (cj/signal--format-notify-body s))) + (should (= (length out) cj/signal--notify-body-max)) + (should (string-suffix-p "…" out)))) + +(ert-deftest test-signal-config-format-notify-body-unicode () + "Boundary: multibyte text truncates by characters, not bytes." + (let* ((s (make-string (+ cj/signal--notify-body-max 10) ?é)) + (out (cj/signal--format-notify-body s))) + (should (= (length out) cj/signal--notify-body-max)) + (should (string-suffix-p "…" out)))) + +;;; cj/signel--notify routing + +(ert-deftest test-signal-config-notify-suppressed-when-viewing () + "Normal: nothing fires when the suppression predicate says no." + (let (script-calls fallback-calls) + (cl-letf (((symbol-function 'cj/signal--should-notify-p) + (lambda (_chat-id) nil)) + ((symbol-function 'start-process) + (lambda (&rest args) (push args script-calls) nil)) + ((symbol-function 'notifications-notify) + (lambda (&rest args) (push args fallback-calls) nil))) + (cj/signel--notify "+15551234567" "Alice" "hi")) + (should-not script-calls) + (should-not fallback-calls))) + +(ert-deftest test-signal-config-notify-script-silent-by-default () + "Normal: with the script present and sound off, runs notify info --silent." + (let (script-calls) + (cl-letf (((symbol-function 'cj/signal--should-notify-p) + (lambda (_chat-id) t)) + ((symbol-function 'executable-find) + (lambda (p &optional _remote) + (when (equal p "notify") "/usr/bin/notify"))) + ((symbol-function 'start-process) + (lambda (&rest args) (push args script-calls) nil)) + ((symbol-function 'notifications-notify) + (lambda (&rest _) + (error "Fallback must not fire when the script is present")))) + (let ((cj/signel-notify-sound nil)) + (cj/signel--notify "+15551234567" "Alice" "hi"))) + (should (= (length script-calls) 1)) + ;; start-process args: (NAME BUFFER PROGRAM &rest PROGRAM-ARGS); + ;; PROGRAM is the path executable-find resolved, not the bare name. + (should (equal (nthcdr 2 (car script-calls)) + '("/usr/bin/notify" "info" "Signal: Alice" "hi" "--silent"))))) + +(ert-deftest test-signal-config-notify-sound-enabled-drops-silent () + "Normal: with `cj/signel-notify-sound' non-nil, --silent is omitted." + (let (script-calls) + (cl-letf (((symbol-function 'cj/signal--should-notify-p) + (lambda (_chat-id) t)) + ((symbol-function 'executable-find) + (lambda (p &optional _remote) + (when (equal p "notify") "/usr/bin/notify"))) + ((symbol-function 'start-process) + (lambda (&rest args) (push args script-calls) nil))) + (let ((cj/signel-notify-sound t)) + (cj/signel--notify "+15551234567" "Alice" "hi"))) + (should (equal (nthcdr 2 (car script-calls)) + '("/usr/bin/notify" "info" "Signal: Alice" "hi"))))) + +(ert-deftest test-signal-config-notify-fallback-when-script-missing () + "Error: without the script on PATH, falls back to notifications-notify." + (let (script-calls fallback-calls) + (cl-letf (((symbol-function 'cj/signal--should-notify-p) + (lambda (_chat-id) t)) + ((symbol-function 'executable-find) + (lambda (_p &optional _remote) nil)) + ((symbol-function 'start-process) + (lambda (&rest args) (push args script-calls) nil)) + ((symbol-function 'notifications-notify) + (lambda (&rest args) (push args fallback-calls) nil))) + (cj/signel--notify "+15551234567" "Alice" "hi")) + (should-not script-calls) + (should (= (length fallback-calls) 1)) + (let ((args (car fallback-calls))) + (should (equal (plist-get args :title) "Signal: Alice")) + (should (equal (plist-get args :body) "hi"))))) + +(ert-deftest test-signal-config-notify-formats-body-before-send () + "Normal: the body runs through the formatter before reaching the script." + (let (script-calls) + (cl-letf (((symbol-function 'cj/signal--should-notify-p) + (lambda (_chat-id) t)) + ((symbol-function 'executable-find) + (lambda (p &optional _remote) + (when (equal p "notify") "/usr/bin/notify"))) + ((symbol-function 'start-process) + (lambda (&rest args) (push args script-calls) nil))) + (let ((cj/signel-notify-sound nil)) + (cj/signel--notify "+15551234567" "Alice" "first line\nsecond line"))) + (should (equal (nth 5 (car script-calls)) "first line second line")))) + +(provide 'test-signal-config-notify) +;;; test-signal-config-notify.el ends here diff --git a/archive/tests/test-signal-config.el b/archive/tests/test-signal-config.el new file mode 100644 index 00000000..f8bf4410 --- /dev/null +++ b/archive/tests/test-signal-config.el @@ -0,0 +1,410 @@ +;;; test-signal-config.el --- Tests for signal-config -*- lexical-binding: t -*- + +;;; Commentary: +;; ERT tests for the pure helper layer of `signal-config': contact-list +;; parsing for the contact picker, and the notify-when-not-viewing +;; predicate. These need neither signal-cli nor a linked account. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'json) + +;; signel is the fork at ~/code/signel; signal-config wires it via +;; use-package but the connection-guard/fetch tests need the symbols +;; available directly. +(eval-and-compile + (add-to-list 'load-path (expand-file-name "~/code/signel"))) +(require 'signel) + +(require 'signal-config) + +;;; cj/signal--jstr + +(ert-deftest test-signal-config-jstr-string () + "Normal: a non-blank string passes through unchanged." + (should (equal (cj/signal--jstr "hi") "hi"))) + +(ert-deftest test-signal-config-jstr-rejects-nonstrings () + "Boundary/Error: nil, empty, whitespace, and non-string sentinels become nil." + (should-not (cj/signal--jstr nil)) + (should-not (cj/signal--jstr "")) + (should-not (cj/signal--jstr " ")) + (should-not (cj/signal--jstr :null)) + (should-not (cj/signal--jstr 42))) + +;;; cj/signal--contact-display-name +;; Field priority: nickName, then nickGiven+nickFamily, then top-level name, +;; then top-level given+family, then profile given+family, then username. + +(ert-deftest test-signal-config-display-name-prefers-name () + "Normal: the top-level combined name wins over the given/family parts." + (should (equal (cj/signal--contact-display-name + '((name . "Alice Anderson") (givenName . "Ali") (familyName . "A"))) + "Alice Anderson"))) + +(ert-deftest test-signal-config-display-name-nickname-wins () + "Normal: a nickName overrides the contact name." + (should (equal (cj/signal--contact-display-name + '((nickName . "Edster") (name . "Eve Edwards") + (givenName . "Eve") (familyName . "Edwards"))) + "Edster"))) + +(ert-deftest test-signal-config-display-name-nickname-parts () + "Boundary: nickGivenName+nickFamilyName combine when nickName is unset." + (should (equal (cj/signal--contact-display-name + '((nickGivenName . "DJ") (nickFamilyName . "Cool") (name . "Daniel"))) + "DJ Cool"))) + +(ert-deftest test-signal-config-display-name-toplevel-given-family () + "Boundary: with no name, top-level givenName+familyName combine." + (should (equal (cj/signal--contact-display-name + '((name) (givenName . "Bob") (familyName . "Brown"))) + "Bob Brown"))) + +(ert-deftest test-signal-config-display-name-profile-fallback () + "Boundary: with no name or top-level parts, profile given/family is the fallback." + (should (equal (cj/signal--contact-display-name + '((name) (givenName) (familyName) + (profile . ((givenName . "Carol") (familyName))))) + "Carol"))) + +(ert-deftest test-signal-config-display-name-username-fallback () + "Boundary: username is the last name source." + (should (equal (cj/signal--contact-display-name + '((name) (username . "dave.42"))) + "dave.42"))) + +(ert-deftest test-signal-config-display-name-none () + "Error: no usable name yields nil." + (should-not (cj/signal--contact-display-name + '((name) (givenName) (familyName) + (profile . ((givenName) (familyName)))))) + (should-not (cj/signal--contact-display-name '((number . "+15551112222"))))) + +;;; cj/signal--parse-contacts + +(defconst test-signal-config--contacts-json + "[ + {\"number\":\"+15551112222\",\"uuid\":\"uuid-a\",\"name\":\"Alice Anderson\",\"givenName\":\"Alice\",\"familyName\":\"Anderson\",\"nickName\":null,\"nickGivenName\":null,\"nickFamilyName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, + {\"number\":\"+15553334444\",\"uuid\":null,\"name\":null,\"givenName\":\"Bob\",\"familyName\":\"Brown\",\"nickName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, + {\"number\":\"+15555556666\",\"uuid\":\"uuid-c\",\"name\":null,\"givenName\":null,\"familyName\":null,\"nickName\":null,\"username\":null,\"profile\":{\"givenName\":\"Carol\",\"familyName\":null}}, + {\"number\":null,\"uuid\":\"uuid-d\",\"name\":null,\"givenName\":null,\"familyName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, + {\"number\":\"+15557778888\",\"uuid\":\"uuid-e\",\"name\":\"Eve Edwards\",\"givenName\":\"Eve\",\"familyName\":\"Edwards\",\"nickName\":\"Edster\",\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}} +]" + "Synthetic fixture mirroring the signal-cli 0.14.4.1 `listContacts' shape: +top-level name/givenName/familyName and nickName fields, with a profile +sub-object whose name fields are usually null. Field layout was confirmed +against a live linked account on 2026-05-26; the values here are fake.") + +(ert-deftest test-signal-config-parse-contacts-normal () + "Normal: top-level name, top-level parts, profile fallback, uuid fallback, nickname." + (let* ((result (json-read-from-string test-signal-config--contacts-json)) + (pairs (cj/signal--parse-contacts result))) + (should (equal pairs + '(("Alice Anderson (+15551112222)" . "+15551112222") + ("Bob Brown (+15553334444)" . "+15553334444") + ("Carol (+15555556666)" . "+15555556666") + ("Edster (+15557778888)" . "+15557778888") + ("uuid-d" . "uuid-d")))))) + +(ert-deftest test-signal-config-parse-contacts-empty () + "Boundary: an empty result yields nil for both vector and nil input." + (should-not (cj/signal--parse-contacts [])) + (should-not (cj/signal--parse-contacts nil))) + +(ert-deftest test-signal-config-parse-contacts-accepts-list-and-vector () + "Boundary: vector and list result sequences parse identically." + (let ((entry '((number . "+15551112222") (name . "Al")))) + (should (equal (cj/signal--parse-contacts (vector entry)) + (cj/signal--parse-contacts (list entry)))))) + +(ert-deftest test-signal-config-parse-contacts-drops-recipientless () + "Error: a contact with neither number nor uuid is dropped." + (should-not (cj/signal--parse-contacts + (list '((name . "Ghost") (number) (uuid)))))) + +;;; cj/signal--suppress-notify-p + +(ert-deftest test-signal-config-suppress-when-viewing-focused () + "Normal: viewing the chat buffer with focus suppresses the notification." + (should (cj/signal--suppress-notify-p + "+15551112222" "*Signel: +15551112222*" t))) + +(ert-deftest test-signal-config-no-suppress-other-buffer () + "Boundary: a different selected buffer does not suppress." + (should-not (cj/signal--suppress-notify-p + "+15551112222" "*scratch*" t))) + +(ert-deftest test-signal-config-no-suppress-unfocused () + "Boundary: viewing the chat but with the frame unfocused still notifies." + (should-not (cj/signal--suppress-notify-p + "+15551112222" "*Signel: +15551112222*" nil))) + +(ert-deftest test-signal-config-no-suppress-nil-viewing () + "Error: a nil viewing-buffer name does not suppress." + (should-not (cj/signal--suppress-notify-p "+15551112222" nil t))) + +;;; cj/signel--ensure-started + +(ert-deftest test-signal-config-ensure-started-live-process-noop () + "Normal: with a live signel process, ensure-started returns without +calling `signel-start' or the pre-warm fetch." + (let ((start-called nil) + (fetch-called nil)) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'get-process) (lambda (_) 'fake-proc)) + ((symbol-function 'signel-start) + (lambda () (setq start-called t))) + ((symbol-function 'cj/signel--fetch-contacts) + (lambda (&rest _) (setq fetch-called t)))) + (cj/signel--ensure-started) + (should-not start-called) + (should-not fetch-called)))) + +(ert-deftest test-signal-config-ensure-started-starts-when-account-set () + "Normal: with `signel-account' set and no live process, ensure-started +calls `signel-start' to bring the daemon up." + (let ((start-called nil) + (signel-account "+15555550100")) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) + ((symbol-function 'get-process) (lambda (_) nil)) + ((symbol-function 'signel-start) + (lambda () (setq start-called t))) + ((symbol-function 'cj/signel--fetch-contacts) + (lambda (&rest _) nil))) + (cj/signel--ensure-started) + (should start-called)))) + +(ert-deftest test-signal-config-ensure-started-prewarms-on-start () + "Normal: when ensure-started actually starts the daemon, it triggers a +pre-warm fetch so the picker cache is warm on first invocation." + (let ((fetch-called nil) + (signel-account "+15555550100")) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) + ((symbol-function 'get-process) (lambda (_) nil)) + ((symbol-function 'signel-start) (lambda () nil)) + ((symbol-function 'cj/signel--fetch-contacts) + (lambda (&rest _) (setq fetch-called t)))) + (cj/signel--ensure-started) + (should fetch-called)))) + +(ert-deftest test-signal-config-ensure-started-errors-when-no-account () + "Error: with `signel-account' nil, ensure-started signals a user-error +naming the remedy (set the account in the private config) instead of +starting an account-less daemon." + (let ((signel-account nil)) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) + ((symbol-function 'get-process) (lambda (_) nil))) + (should-error (cj/signel--ensure-started) :type 'user-error)))) + +(ert-deftest test-signal-config-ensure-started-requires-signel-first () + "Error: ensure-started must `require' signel BEFORE reading any of +its private variables, so a `void-variable' error cannot fire when +called before signel has been autoloaded. Captures the bug where +`signel--process-name' was forward-declared in signal-config but not +yet bound at runtime because the `use-package' autoload had not fired. + +Asserts ordering, not just presence: a future refactor that moves the +`require' below the `cond' would still execute the require eventually +but the variable read in the cond would fire void-variable first. +The test fails if `require' isn't the first call inside the function." + (let ((call-order nil)) + (cl-letf (((symbol-function 'require) + (lambda (feature &optional _filename _noerror) + (push (list 'require feature) call-order) + t)) + ((symbol-function 'process-live-p) + (lambda (_) (push 'process-live-p call-order) t)) + ((symbol-function 'get-process) + (lambda (_) (push 'get-process call-order) 'fake-proc))) + (cj/signel--ensure-started) + (should (equal (car (reverse call-order)) '(require signel)))))) + +;;; cj/signel--fetch-contacts + cj/signel--contact-cache + +(ert-deftest test-signal-config-fetch-contacts-issues-list-contacts-rpc () + "Normal: fetch-contacts sends a `listContacts' RPC and registers a +success callback so the response routes back." + (let (sent-method sent-callback) + (cl-letf (((symbol-function 'signel--send-rpc) + (lambda (method _params _target callback) + (setq sent-method method + sent-callback callback) + 1))) + (cj/signel--fetch-contacts)) + (should (equal sent-method "listContacts")) + (should (functionp sent-callback)))) + +(ert-deftest test-signal-config-fetch-contacts-callback-populates-cache () + "Normal: on a successful result, the callback parses the contact list +and stores the (LABEL . RECIPIENT) alist in `cj/signel--contact-cache'." + (let (sent-callback) + (cl-letf (((symbol-function 'signel--send-rpc) + (lambda (_method _params _target callback) + (setq sent-callback callback) 1))) + (setq cj/signel--contact-cache nil) + (cj/signel--fetch-contacts) + (funcall sent-callback + [((number . "+15555550100") (givenName . "Alice"))])) + (should (equal cj/signel--contact-cache + '(("Alice (+15555550100)" . "+15555550100")))))) + +(ert-deftest test-signal-config-fetch-contacts-empty-result-caches-sentinel () + "Boundary: an empty listContacts result caches the `empty' sentinel. +nil would read as a cold cache and re-run the picker's blocking fetch on +every open; the sentinel marks warm-but-empty. Still distinct from a +failure path, which never invokes the success callback. (This test +formerly pinned the nil behavior -- the 2026-06 audit's F2 bug.)" + (let (sent-callback) + (cl-letf (((symbol-function 'signel--send-rpc) + (lambda (_method _params _target callback) + (setq sent-callback callback) 1))) + (setq cj/signel--contact-cache '(("stale" . "+10000000000"))) + (cj/signel--fetch-contacts) + (funcall sent-callback [])) + (should (eq cj/signel--contact-cache 'empty)))) + +;;; cj/signel-refresh-contacts + +(ert-deftest test-signal-config-refresh-contacts-clears-and-refetches () + "Normal: `cj/signel-refresh-contacts' clears the cache and triggers a +fresh fetch so a stale entry can't survive a user-driven refresh." + (let ((fetch-called nil)) + (setq cj/signel--contact-cache '(("stale" . "+10000000000"))) + (cl-letf (((symbol-function 'cj/signel--fetch-contacts) + (lambda (&rest _) (setq fetch-called t)))) + (cj/signel-refresh-contacts)) + (should-not cj/signel--contact-cache) + (should fetch-called))) + +;;; cj/signel-message picker + +(ert-deftest test-signal-config-message-warm-cache-picks-contact () + "Normal: with a warm cache, picking a contact label opens that +recipient's chat buffer." + (let ((chosen-recipient nil) + (signel-account "+15555550100")) + (setq cj/signel--contact-cache + '(("Alice (+15555550200)" . "+15555550200"))) + (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) + ((symbol-function 'completing-read) + (lambda (&rest _) "Alice (+15555550200)")) + ((symbol-function 'signel-chat) + (lambda (r) (setq chosen-recipient r)))) + (cj/signel-message)) + (should (equal chosen-recipient "+15555550200")))) + +(ert-deftest test-signal-config-message-warm-cache-picks-note-to-self () + "Normal: the pinned `Note to Self' entry resolves to `signel-account' +so a self-message lands in the Signal Note-to-Self thread." + (let ((chosen-recipient nil) + (signel-account "+15555550100")) + (setq cj/signel--contact-cache + '(("Alice (+15555550200)" . "+15555550200"))) + (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) + ((symbol-function 'completing-read) + (lambda (&rest _) "Note to Self")) + ((symbol-function 'signel-chat) + (lambda (r) (setq chosen-recipient r)))) + (cj/signel-message)) + (should (equal chosen-recipient "+15555550100")))) + +(ert-deftest test-signal-config-message-cold-cache-fetch-resolves-in-time () + "Normal: cold cache, fetch's after-callback fires inside the bounded +wait, picker proceeds with the now-warm cache." + (let ((chosen-recipient nil) + (signel-account "+15555550100") + (cj/signel-fetch-timeout 1.0)) + (setq cj/signel--contact-cache nil) + (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) + ((symbol-function 'cj/signel--fetch-contacts) + (lambda (&optional after-cb) + (setq cj/signel--contact-cache + '(("Bob (+15555550300)" . "+15555550300"))) + (when after-cb (funcall after-cb)))) + ((symbol-function 'completing-read) + (lambda (&rest _) "Bob (+15555550300)")) + ((symbol-function 'signel-chat) + (lambda (r) (setq chosen-recipient r)))) + (cj/signel-message)) + (should (equal chosen-recipient "+15555550300")))) + +(ert-deftest test-signal-config-message-cold-cache-timeout-errors () + "Error: cold cache, fetch never resolves, picker user-errors before +the bounded wait would let Emacs hang on a dead daemon." + (let ((signel-account "+15555550100") + (cj/signel-fetch-timeout 0.1)) + (setq cj/signel--contact-cache nil) + (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) + ((symbol-function 'cj/signel--fetch-contacts) + (lambda (&rest _) nil))) + (should-error (cj/signel-message) :type 'user-error)))) + +;;; cj/signel-message-self + +(ert-deftest test-signal-config-message-self-calls-signel-chat-with-account () + "Normal: the direct self-message command opens a chat buffer addressed +to `signel-account', skipping the picker entirely." + (let ((chosen-recipient nil) + (signel-account "+15555550100")) + (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) + ((symbol-function 'signel-chat) + (lambda (r) (setq chosen-recipient r)))) + (cj/signel-message-self)) + (should (equal chosen-recipient "+15555550100")))) + +;;; cj/signel-prefix-map (C-; M) + +(ert-deftest test-signal-config-prefix-map-has-expected-bindings () + "Normal: the signel C-; M prefix map binds m / s / d / q / SPC to the +commands the workflow spec names." + (should (eq (keymap-lookup cj/signel-prefix-map "m") + #'cj/signel-message)) + (should (eq (keymap-lookup cj/signel-prefix-map "s") + #'cj/signel-message-self)) + (should (eq (keymap-lookup cj/signel-prefix-map "d") + #'signel-dashboard)) + (should (eq (keymap-lookup cj/signel-prefix-map "q") + #'signel-stop)) + (should (eq (keymap-lookup cj/signel-prefix-map "SPC") + #'cj/signel-connect))) + +(ert-deftest test-signal-config-prefix-map-registered-under-c-semi-m () + "Normal: loading signal-config registers `cj/signel-prefix-map' under +`M' in `cj/custom-keymap', so C-; M reaches the signel prefix. Guards +the wiring contract that the load-order bug broke: signal-config must +register through `cj/register-prefix-map', not a boundp-guarded direct +mutation that silently no-ops when keybindings loaded in a different +order." + (require 'keybindings) + (should (eq (keymap-lookup cj/custom-keymap "M") cj/signel-prefix-map))) + +;;; display-buffer-alist entry for *Signel: ...* chat buffers + +(ert-deftest test-signal-config-chat-buffer-display-rule-uses-bottom-30 () + "Normal: signal-config registers a `display-buffer-alist' entry that +matches `*Signel: <id>*' buffers, routes them through +`display-buffer-at-bottom', and sets `window-height' to 0.3 so the +chat docks to the bottom 30% of the frame." + (let ((entry (seq-find (lambda (e) (equal (car e) "\\`\\*Signel: ")) + display-buffer-alist))) + (should entry) + (should (memq 'display-buffer-at-bottom (cadr entry))) + (should (equal 0.3 (cdr (assq 'window-height (cddr entry))))))) + +(ert-deftest test-signal-config-chat-buffer-display-rule-matches-buffer-name () + "Boundary: the registered regex matches a realistic chat buffer name +\(phone-number id and group-id) and does not match unrelated buffers." + (let* ((entry (seq-find (lambda (e) (equal (car e) "\\`\\*Signel: ")) + display-buffer-alist)) + (regex (car entry))) + (should regex) + (should (string-match-p regex "*Signel: +15555550100*")) + (should (string-match-p regex "*Signel: groupid-abc*")) + (should-not (string-match-p regex "*signel-log*")) + (should-not (string-match-p regex "scratch")))) + +(provide 'test-signal-config) +;;; test-signal-config.el ends here diff --git a/archive/tests/test-signel-cancel-input.el b/archive/tests/test-signel-cancel-input.el new file mode 100644 index 00000000..b2a7ef89 --- /dev/null +++ b/archive/tests/test-signel-cancel-input.el @@ -0,0 +1,74 @@ +;;; test-signel-cancel-input.el --- Cancel-input contract for the signel fork -*- lexical-binding: t; -*- + +;;; Commentary: +;; `signel--cancel-input' is the C-c C-k handler in `signel-chat-mode'. +;; Its contract: clear any in-progress input between `signel--input-marker' +;; and `point-max' (so the prompt is fresh on next visit), then dismiss +;; the window via `quit-window' (the buffer stays alive so chat history +;; survives revisits). These tests lock the contract; the binding test +;; locks the keymap entry. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(eval-and-compile + (add-to-list 'load-path (expand-file-name "~/code/signel"))) +(require 'signel) + +(defmacro test-signel-cancel--with-chat-buffer (&rest body) + "Set up a temp signel-chat-mode buffer with prompt drawn and run BODY." + (declare (indent 0)) + `(with-temp-buffer + (signel-chat-mode) + (setq signel--chat-id "+15555550100") + (signel--draw-prompt) + ,@body)) + +(ert-deftest test-signel-cancel-input-clears-pending-text () + "Normal: pending input from input-marker to point-max is cleared." + (test-signel-cancel--with-chat-buffer + (insert "abandoned-draft") + (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) + (signel--cancel-input)) + (should-not (signel--pending-input)))) + +(ert-deftest test-signel-cancel-input-empty-input-area-is-a-noop () + "Boundary: cancelling with no in-progress input is harmless." + (test-signel-cancel--with-chat-buffer + (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) + (signel--cancel-input)) + (should-not (signel--pending-input)))) + +(ert-deftest test-signel-cancel-input-calls-quit-window () + "Normal: cancel dismisses the window via `quit-window'." + (test-signel-cancel--with-chat-buffer + (insert "abandoned-draft") + (let ((called nil)) + (cl-letf (((symbol-function 'quit-window) + (lambda (&rest _) (setq called t)))) + (signel--cancel-input)) + (should called)))) + +(ert-deftest test-signel-cancel-input-preserves-buffer () + "Normal: cancel does not kill the buffer; chat history (prompt + prior +content above the input marker) survives so reopening the contact lands +in the same buffer." + (test-signel-cancel--with-chat-buffer + (insert "abandoned-draft") + (let ((buf (current-buffer))) + (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) + (signel--cancel-input)) + (should (buffer-live-p buf))))) + +(ert-deftest test-signel-chat-mode-binds-c-c-c-k-to-cancel () + "Normal: `signel-chat-mode' binds C-c C-k to `signel--cancel-input' so +the documented cancel gesture reaches the handler." + (with-temp-buffer + (signel-chat-mode) + (should (eq (lookup-key (current-local-map) (kbd "C-c C-k")) + #'signel--cancel-input)))) + +(provide 'test-signel-cancel-input) +;;; test-signel-cancel-input.el ends here diff --git a/archive/tests/test-signel-input-preservation.el b/archive/tests/test-signel-input-preservation.el new file mode 100644 index 00000000..e8ce4ddb --- /dev/null +++ b/archive/tests/test-signel-input-preservation.el @@ -0,0 +1,68 @@ +;;; test-signel-input-preservation.el --- Regression for signel #2 input clobber -*- lexical-binding: t; -*- + +;;; Commentary: +;; signel-chat-mode buffers have an editable prompt area starting at +;; `signel--input-marker'. Before this fix, both `signel--insert-msg' (the +;; receive path) and `signel--insert-system-msg' (the RPC-error path) +;; called `(delete-region (point) (point-max))' to clear the old prompt +;; before redrawing it, which destroyed any text the user was mid-typing. +;; +;; These tests lock the preservation contract: a small `signel--pending-input' +;; helper captures the in-progress input from the marker to `point-max', and +;; both inserters restore it after the freshly drawn prompt. The chat-mode +;; buffer is constructed in a temp buffer; `signel--insert-msg' is steered +;; to it via a stub on `signel--get-buffer'. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(eval-and-compile + (add-to-list 'load-path (expand-file-name "~/code/signel"))) +(require 'signel) + +(defmacro test-signel--with-chat-buffer (&rest body) + "Set up a temp signel-chat-mode buffer with prompt drawn and run BODY." + (declare (indent 0)) + `(with-temp-buffer + (signel-chat-mode) + (setq signel--chat-id "+15555550100") + (signel--draw-prompt) + ,@body)) + +(ert-deftest test-signel-input-pending-returns-typed-text () + "Normal: with text after the prompt marker, `signel--pending-input' +returns the captured text." + (test-signel--with-chat-buffer + (insert "halfwritten") + (should (equal (signel--pending-input) "halfwritten")))) + +(ert-deftest test-signel-input-pending-returns-nil-when-empty () + "Boundary: an empty input area returns nil so callers don't restore an +empty string after the prompt." + (test-signel--with-chat-buffer + (should-not (signel--pending-input)))) + +(ert-deftest test-signel-input-system-msg-preserves-pending-input () + "Regression for #2: `signel--insert-system-msg' redraws the prompt +without clobbering text the user was mid-typing." + (test-signel--with-chat-buffer + (insert "halfwritten") + (signel--insert-system-msg "An error happened" 'signel-error-face) + (should (string-match-p "An error happened" (buffer-string))) + (should (equal (signel--pending-input) "halfwritten")))) + +(ert-deftest test-signel-input-msg-preserves-pending-input () + "Regression for #2: `signel--insert-msg' (the receive path) redraws the +prompt without clobbering the user's in-progress input." + (test-signel--with-chat-buffer + (insert "halfwritten") + (cl-letf (((symbol-function 'signel--get-buffer) + (lambda (_) (current-buffer)))) + (signel--insert-msg "+15555550100" "Alice" "Hi there" nil nil nil)) + (should (string-match-p "Hi there" (buffer-string))) + (should (equal (signel--pending-input) "halfwritten")))) + +(provide 'test-signel-input-preservation) +;;; test-signel-input-preservation.el ends here diff --git a/archive/tests/test-signel-notify-function.el b/archive/tests/test-signel-notify-function.el new file mode 100644 index 00000000..e3d97af5 --- /dev/null +++ b/archive/tests/test-signel-notify-function.el @@ -0,0 +1,89 @@ +;;; test-signel-notify-function.el --- Tests for signel's notify-function dispatch -*- lexical-binding: t -*- + +;;; Commentary: +;; signel's receive handler (signel.el in the fork at ~/code/signel) +;; raised notifications through a hardwired `notifications-notify' +;; call. The notification slice (docs/specs/signal-client-spec-doing.org, +;; "Notification slice" addendum) replaces that with +;; `signel-notify-function', a customization point called with +;; CHAT-ID, SENDER, and BODY so a config layer can add suppression or +;; route through an external notifier. These tests cover the +;; dispatch: text, sticker, and attachment bodies reach the function +;; with the right arguments, and the default preserves the plain +;; `notifications-notify' behavior. +;; +;; `signel--handle-receive' is exercised directly with synthetic +;; envelope alists; buffer/dashboard side effects are stubbed. No +;; live process needed. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(eval-and-compile + (add-to-list 'load-path (expand-file-name "~/code/signel"))) +(require 'signel) + +(defun test-signel-notify--receive (envelope) + "Run `signel--handle-receive' on ENVELOPE, capturing notify calls. +Returns the list of (CHAT-ID SENDER BODY) argument lists the handler +passed to `signel-notify-function', oldest first. Buffer and +dashboard side effects are stubbed out." + (let (calls) + (cl-letf (((symbol-function 'signel--insert-msg) (lambda (&rest _) nil)) + ((symbol-function 'signel--dashboard-refresh) (lambda () nil)) + ((symbol-function 'signel--get-buffer) + (lambda (_) (current-buffer)))) + (let ((signel-notify-function + (lambda (chat-id sender body) + (push (list chat-id sender body) calls))) + (signel-auto-open-buffer nil)) + (signel--handle-receive `((envelope . ,envelope))))) + (nreverse calls))) + +(ert-deftest test-signel-notify-function-text-message () + "Normal: a text dataMessage calls the function with chat-id, sender, text." + (should (equal (test-signel-notify--receive + '((sourceNumber . "+15551234567") + (sourceName . "Alice") + (dataMessage . ((message . "hi there"))))) + '(("+15551234567" "Alice" "hi there"))))) + +(ert-deftest test-signel-notify-function-sticker-placeholder () + "Boundary: a sticker with no text gets the [Sticker] placeholder body." + (should (equal (test-signel-notify--receive + '((sourceNumber . "+15551234567") + (sourceName . "Alice") + (dataMessage . ((sticker . ((packId . "p1"))))))) + '(("+15551234567" "Alice" "[Sticker]"))))) + +(ert-deftest test-signel-notify-function-attachment-placeholder () + "Boundary: an attachment with no text gets the [Attachment] placeholder." + (should (equal (test-signel-notify--receive + '((sourceNumber . "+15551234567") + (sourceName . "Alice") + (dataMessage . ((attachments . [((id . "a1"))]))))) + '(("+15551234567" "Alice" "[Attachment]"))))) + +(ert-deftest test-signel-notify-function-no-data-no-call () + "Boundary: an envelope with no dataMessage never calls the function." + (should-not (test-signel-notify--receive + '((sourceNumber . "+15551234567") + (sourceName . "Alice") + (typingMessage . ((action . "STARTED"))))))) + +(ert-deftest test-signel-notify-function-default-preserves-behavior () + "Normal: the default value raises a plain notifications-notify toast." + (should (eq signel-notify-function #'signel--notify-default)) + (let (calls) + (cl-letf (((symbol-function 'notifications-notify) + (lambda (&rest args) (push args calls) nil))) + (signel--notify-default "+15551234567" "Alice" "hi")) + (should (= (length calls) 1)) + (let ((args (car calls))) + (should (equal (plist-get args :title) "Signel: Alice")) + (should (equal (plist-get args :body) "hi"))))) + +(provide 'test-signel-notify-function) +;;; test-signel-notify-function.el ends here diff --git a/archive/tests/test-signel-rpc-dispatch.el b/archive/tests/test-signel-rpc-dispatch.el new file mode 100644 index 00000000..5ae023d6 --- /dev/null +++ b/archive/tests/test-signel-rpc-dispatch.el @@ -0,0 +1,94 @@ +;;; test-signel-rpc-dispatch.el --- Tests for signel JSON-RPC success-result dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; signel's JSON-RPC dispatch (signel.el in the fork at ~/code/signel) routes +;; incoming `receive' notifications and errors, but successful +;; `((id . N) (result . VALUE))' responses had no path until this work added a +;; request-callback table. These tests cover the new behavior: a registered +;; callback fires with the result and is then removed; an error response +;; also removes the handler so a retry starts clean; an unregistered id is a +;; silent no-op; passing SUCCESS-CALLBACK to `signel--send-rpc' registers it +;; under the returned id. +;; +;; The dispatch tests exercise `signel--dispatch' directly with synthetic JSON +;; alists; no live process is needed. The send-rpc test stubs `get-process' +;; and `process-send-string' so it doesn't require a running signal-cli. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(eval-and-compile + (add-to-list 'load-path (expand-file-name "~/code/signel"))) +(require 'signel) + +(defun test-signel-rpc--reset () + "Reset signel dispatch state to a clean baseline before each test." + (clrhash signel--request-handler-map) + (clrhash signel--request-buffer-map) + (setq signel--rpc-id-counter 0)) + +(ert-deftest test-signel-rpc-dispatch-result-invokes-callback () + "Normal: a result response with a registered id fires the callback with the +result value and removes the handler." + (test-signel-rpc--reset) + (let ((captured nil)) + (puthash 7 (lambda (val) (setq captured val)) signel--request-handler-map) + (signel--dispatch '((jsonrpc . "2.0") (id . 7) + (result . ((contacts . [1 2 3]))))) + (should (equal captured '((contacts . [1 2 3])))) + (should-not (gethash 7 signel--request-handler-map)))) + +(ert-deftest test-signel-rpc-dispatch-unknown-id-is-noop () + "Boundary: a result response with an unregistered id is a silent no-op: +neither receive nor error handler fires, and the handler map stays empty." + (test-signel-rpc--reset) + (let ((called nil)) + (cl-letf (((symbol-function 'signel--handle-error) + (lambda (&rest _) (setq called 'error))) + ((symbol-function 'signel--handle-receive) + (lambda (&rest _) (setq called 'receive)))) + (signel--dispatch '((jsonrpc . "2.0") (id . 99) (result . "anything")))) + (should-not called) + (should (zerop (hash-table-count signel--request-handler-map))))) + +(ert-deftest test-signel-rpc-dispatch-error-cleans-up-handler () + "Error: an error response with a registered id removes the handler without +firing the callback, leaving the map clean for a retry." + (test-signel-rpc--reset) + (let ((fired nil)) + (puthash 11 (lambda (&rest _) (setq fired t)) + signel--request-handler-map) + (cl-letf (((symbol-function 'signel--handle-error) (lambda (&rest _) nil))) + (signel--dispatch '((jsonrpc . "2.0") (id . 11) + (error . ((code . -1) (message . "boom")))))) + (should-not fired) + (should-not (gethash 11 signel--request-handler-map)))) + +(ert-deftest test-signel-rpc-send-rpc-registers-success-callback () + "Normal: passing a SUCCESS-CALLBACK to `signel--send-rpc' stores it under +the returned id so the matching response can route to it." + (test-signel-rpc--reset) + (let ((cb (lambda (_) 'ok)) + (sent nil)) + (cl-letf (((symbol-function 'get-process) (lambda (&rest _) 'fake-proc)) + ((symbol-function 'process-send-string) + (lambda (_ s) (setq sent s))) + ((symbol-function 'signel--log) (lambda (&rest _) nil))) + (let ((id (signel--send-rpc "listContacts" nil nil cb))) + (should (eq cb (gethash id signel--request-handler-map))) + (should (stringp sent)))))) + +(ert-deftest test-signel-rpc-stop-clears-handler-map () + "Normal (reconnect-invalidation): `signel-stop' clears the handler map so a +restart starts with no stale callbacks waiting for responses that will never +arrive." + (test-signel-rpc--reset) + (puthash 13 (lambda (&rest _) nil) signel--request-handler-map) + (cl-letf (((symbol-function 'get-process) (lambda (&rest _) nil))) + (signel-stop)) + (should (zerop (hash-table-count signel--request-handler-map)))) + +(provide 'test-signel-rpc-dispatch) +;;; test-signel-rpc-dispatch.el ends here |