From d9897243c88b39109996e67f214ebff63d000742 Mon Sep 17 00:00:00 2001 From: Craig Jennings Date: Sat, 11 Jul 2026 13:14:56 -0500 Subject: refactor: retire unreferenced modules to an archive directory A reachability sweep from init.el found eight .el files that nothing in the config loads or references. I moved them under archive/ (off the load-path, still tracked in git) so they stay readable and restorable rather than deleted. archive/README.org records the rule (every .el outside archive/ should be actively used) and why each file was retired. I retired show-kill-ring, duet-config, and mu4e-org-contacts-setup from modules/, and eplot, profile-dotemacs, titlecase, titlecase-data, and edit-indirect from custom/. Retiring show-kill-ring also removed the orphaned M-K -> M-S-k translation in keyboard-compat, which had left M-K a dead key. Its tests now assert seventeen translations and guard M-K's absence. --- archive/README.org | 64 + archive/custom/edit-indirect.el | 440 +++ archive/custom/eplot.el | 3495 +++++++++++++++++++++ archive/custom/profile-dotemacs.el | 161 + archive/custom/titlecase-data.el | 643 ++++ archive/custom/titlecase.el | 389 +++ archive/modules/duet-config.el | 19 + archive/modules/mu4e-org-contacts-setup.el | 31 + archive/modules/show-kill-ring.el | 122 + archive/tests/test-show-kill-ring--insert-item.el | 73 + custom/edit-indirect.el | 440 --- custom/eplot.el | 3495 --------------------- custom/profile-dotemacs.el | 161 - custom/titlecase-data.el | 643 ---- custom/titlecase.el | 389 --- modules/duet-config.el | 19 - modules/keyboard-compat.el | 3 +- modules/mu4e-org-contacts-setup.el | 31 - modules/show-kill-ring.el | 122 - tests/test-keyboard-compat-setup.el | 14 +- tests/test-show-kill-ring--insert-item.el | 73 - 21 files changed, 5446 insertions(+), 5381 deletions(-) create mode 100644 archive/README.org create mode 100644 archive/custom/edit-indirect.el create mode 100644 archive/custom/eplot.el create mode 100644 archive/custom/profile-dotemacs.el create mode 100644 archive/custom/titlecase-data.el create mode 100644 archive/custom/titlecase.el create mode 100644 archive/modules/duet-config.el create mode 100644 archive/modules/mu4e-org-contacts-setup.el create mode 100644 archive/modules/show-kill-ring.el create mode 100644 archive/tests/test-show-kill-ring--insert-item.el delete mode 100644 custom/edit-indirect.el delete mode 100644 custom/eplot.el delete mode 100644 custom/profile-dotemacs.el delete mode 100644 custom/titlecase-data.el delete mode 100644 custom/titlecase.el delete mode 100644 modules/duet-config.el delete mode 100644 modules/mu4e-org-contacts-setup.el delete mode 100644 modules/show-kill-ring.el delete mode 100644 tests/test-show-kill-ring--insert-item.el diff --git a/archive/README.org b/archive/README.org new file mode 100644 index 00000000..bbc30a14 --- /dev/null +++ b/archive/README.org @@ -0,0 +1,64 @@ +#+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=. + +** 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 +;; 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 +;; 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-" #'eplot-control-next-field + "" #'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-" #'eplot-control-next-field + "" #'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 + +;; 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 . + +;;; 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 + "\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 +;; Maintainer: Case Duckworth +;; 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 . + +;;; 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 +;; Maintainer: Case Duckworth +;; 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 . + +;;; 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 + +;;; 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 +;; +;;; 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/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/custom/edit-indirect.el b/custom/edit-indirect.el deleted file mode 100644 index 307f9695..00000000 --- a/custom/edit-indirect.el +++ /dev/null @@ -1,440 +0,0 @@ -;;; edit-indirect.el --- Edit regions in separate buffers -*- lexical-binding: t -*- - -;; Author: Fanael Linithien -;; 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/custom/eplot.el b/custom/eplot.el deleted file mode 100644 index c00a3e31..00000000 --- a/custom/eplot.el +++ /dev/null @@ -1,3495 +0,0 @@ -;;; eplot.el --- Manage and Edit Wordpress Posts -*- lexical-binding: t -*- - -;; Copyright (C) 2024 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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-" #'eplot-control-next-field - "" #'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-" #'eplot-control-next-field - "" #'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/custom/profile-dotemacs.el b/custom/profile-dotemacs.el deleted file mode 100644 index 8baee47b..00000000 --- a/custom/profile-dotemacs.el +++ /dev/null @@ -1,161 +0,0 @@ -;;; profile-dotemacs.el --- Profile your Emacs init file - -;; Copyright (C) 2010, 2012 David Engster - -;; Author: David Engster - -;; 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 . - -;;; 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 - "\n") - percentage - (car timings) (nth 1 timings) (nth 2 timings))) - - -;; profile-dotemacs.el ends here diff --git a/custom/titlecase-data.el b/custom/titlecase-data.el deleted file mode 100644 index 7415a210..00000000 --- a/custom/titlecase-data.el +++ /dev/null @@ -1,643 +0,0 @@ -;;; titlecase-data.el --- Data for titlecase.el -*- lexical-binding: t; -*- - -;; Author: Case Duckworth -;; Maintainer: Case Duckworth -;; 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 . - -;;; 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/custom/titlecase.el b/custom/titlecase.el deleted file mode 100644 index 319befef..00000000 --- a/custom/titlecase.el +++ /dev/null @@ -1,389 +0,0 @@ -;;; titlecase.el --- Title-case phrases -*- lexical-binding: t; -*- - -;; Author: Case Duckworth -;; Maintainer: Case Duckworth -;; 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 . - -;;; 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/modules/duet-config.el b/modules/duet-config.el deleted file mode 100644 index 2dc7ad2e..00000000 --- a/modules/duet-config.el +++ /dev/null @@ -1,19 +0,0 @@ -;;; 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/modules/keyboard-compat.el b/modules/keyboard-compat.el index b72362e7..73138ca5 100644 --- a/modules/keyboard-compat.el +++ b/modules/keyboard-compat.el @@ -98,8 +98,7 @@ Meta+Shift+letter triggers M-S-letter keybindings." (define-key key-translation-map (kbd "M-D") (kbd "M-S-d")) (define-key key-translation-map (kbd "M-I") (kbd "M-S-i")) (define-key key-translation-map (kbd "M-C") (kbd "M-S-c")) - (define-key key-translation-map (kbd "M-B") (kbd "M-S-b")) - (define-key key-translation-map (kbd "M-K") (kbd "M-S-k")))) + (define-key key-translation-map (kbd "M-B") (kbd "M-S-b")))) ;; In daemon mode, no frame exists at startup so env-gui-p returns nil. ;; Use server-after-make-frame-hook to set up translations when the first diff --git a/modules/mu4e-org-contacts-setup.el b/modules/mu4e-org-contacts-setup.el deleted file mode 100644 index bfb9b1f2..00000000 --- a/modules/mu4e-org-contacts-setup.el +++ /dev/null @@ -1,31 +0,0 @@ -;;; mu4e-org-contacts-setup.el --- Setup mu4e with org-contacts -*- lexical-binding: t; -*- -;; author: Craig Jennings - -;;; 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/modules/show-kill-ring.el b/modules/show-kill-ring.el deleted file mode 100644 index e65d48b5..00000000 --- a/modules/show-kill-ring.el +++ /dev/null @@ -1,122 +0,0 @@ -;;; 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 -;; -;;; 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/tests/test-keyboard-compat-setup.el b/tests/test-keyboard-compat-setup.el index a3e6f441..a23e24e1 100644 --- a/tests/test-keyboard-compat-setup.el +++ b/tests/test-keyboard-compat-setup.el @@ -79,18 +79,20 @@ without the arrow-key decodings. The GUI half already frame-scopes itself." ,@body))) (defconst test-kbc--meta-shift-letters - '(?o ?m ?y ?f ?w ?e ?l ?r ?v ?h ?t ?z ?u ?d ?i ?c ?b ?k) - "The 18 letters whose M- form is translated to M-S- in GUI mode.") + '(?o ?m ?y ?f ?w ?e ?l ?r ?v ?h ?t ?z ?u ?d ?i ?c ?b) + "The 17 letters whose M- form is translated to M-S- in GUI mode.") (ert-deftest test-keyboard-compat-gui-setup-translates-spot-checks () - "Normal: in GUI mode, M-O -> M-S-o and M-K -> M-S-k (sampled)." + "Normal: in GUI mode, M-O -> M-S-o and M-B -> M-S-b (sampled). +M-K is no longer translated: show-kill-ring, its only consumer, was retired." (test-kbc--gui t (cj/keyboard-compat-gui-setup) (should (equal (lookup-key key-translation-map (kbd "M-O")) (kbd "M-S-o"))) - (should (equal (lookup-key key-translation-map (kbd "M-K")) (kbd "M-S-k"))) - (should (equal (lookup-key key-translation-map (kbd "M-D")) (kbd "M-S-d"))))) + (should (equal (lookup-key key-translation-map (kbd "M-B")) (kbd "M-S-b"))) + (should (equal (lookup-key key-translation-map (kbd "M-D")) (kbd "M-S-d"))) + (should-not (lookup-key key-translation-map (kbd "M-K"))))) -(ert-deftest test-keyboard-compat-gui-setup-translates-all-eighteen () +(ert-deftest test-keyboard-compat-gui-setup-translates-all-seventeen () "Normal: every documented M- maps to its M-S- form." (test-kbc--gui t (cj/keyboard-compat-gui-setup) diff --git a/tests/test-show-kill-ring--insert-item.el b/tests/test-show-kill-ring--insert-item.el deleted file mode 100644 index a29ca75e..00000000 --- a/tests/test-show-kill-ring--insert-item.el +++ /dev/null @@ -1,73 +0,0 @@ -;;; 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 -- cgit v1.2.3