diff options
| author | Craig Jennings <c@cjennings.net> | 2025-10-12 11:47:26 -0500 |
|---|---|---|
| committer | Craig Jennings <c@cjennings.net> | 2025-10-12 11:47:26 -0500 |
| commit | 092304d9e0ccc37cc0ddaa9b136457e56a1cac20 (patch) | |
| tree | ea81999b8442246c978b364dd90e8c752af50db5 /custom | |
changing repositories
Diffstat (limited to 'custom')
| -rw-r--r-- | custom/c-boxes.el | 407 | ||||
| -rw-r--r-- | custom/edit-indirect.el | 440 | ||||
| -rw-r--r-- | custom/elpa-mirror.el | 450 | ||||
| -rw-r--r-- | custom/eplot.el | 3495 | ||||
| -rw-r--r-- | custom/gptel-prompts.el | 418 | ||||
| -rw-r--r-- | custom/org-checklist.el | 153 | ||||
| -rw-r--r-- | custom/pdf-continuous-scroll-mode-latest.el | 1046 | ||||
| -rw-r--r-- | custom/pdf-continuous-scroll-mode.el | 434 | ||||
| -rw-r--r-- | custom/profile-dotemacs.el | 200 | ||||
| -rw-r--r-- | custom/titlecase-data.el | 721 | ||||
| -rw-r--r-- | custom/titlecase.el | 396 | ||||
| -rw-r--r-- | custom/utilities/vcf-conversion-helpers.el | 388 |
12 files changed, 8548 insertions, 0 deletions
diff --git a/custom/c-boxes.el b/custom/c-boxes.el new file mode 100644 index 00000000..273b783a --- /dev/null +++ b/custom/c-boxes.el @@ -0,0 +1,407 @@ +;;; Boxed comments for C mode. +;;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +;;; Francois Pinard <pinard@iro.umontreal.ca>, April 1991. +;;; +;;; I often refill paragraphs inside C comments, while stretching or +;;; shrinking the surrounding box as needed. This is a real pain to +;;; do by hand. Here is the code I made to ease my life on this, +;;; usable from within GNU Emacs. It would not be fair giving all +;;; sources for a product without also giving the means for nicely +;;; modifying them. +;;; +;;; The function rebox-c-comment adjust comment boxes without +;;; refilling comment paragraphs, while reindent-c-comment adjust +;;; comment boxes after refilling. Numeric prefixes are used to add, +;;; remove, or change the style of the box surrounding the comment. +;;; Since refilling paragraphs in C mode does make sense only for +;;; comments, this code redefines the M-q command in C mode. I use +;;; this hack by putting, in my .emacs file: +;;; +;;; (setq c-mode-hook +;;; '(lambda () +;;; (define-key c-mode-map "\M-q" 'reindent-c-comment))) +;;; (autoload 'rebox-c-comment "c-boxes" nil t) +;;; (autoload 'reindent-c-comment "c-boxes" nil t) +;;; +;;; The cursor should be within a comment before any of these +;;; commands, or else it should be between two comments, in which case +;;; the command applies to the next comment. When the command is +;;; given without prefix, the current comment box type is recognized +;;; and preserved. Given 0 as a prefix, the comment box disappears +;;; and the comment stays between a single opening `/*' and a single +;;; closing `*/'. Given 1 or 2 as a prefix, a single or doubled lined +;;; comment box is forced. Given 3 as a prefix, a Taarna style box is +;;; forced, but you do not even want to hear about those. When a +;;; negative prefix is given, the absolute value is used, but the +;;; default style is changed. Any other value (like C-u alone) forces +;;; the default box style. +;;; +;;; I observed rounded corners first in some code from Warren Tucker +;;; <wht@n4hgf.mt-park.ga.us>. + +(defvar c-box-default-style 'single "*Preferred style for box comments.") +(defvar c-mode-taarna-style nil "*Non-nil for Taarna team C-style.") + +;;; Set or reset the Taarna team's own way for a C style. + +(defun taarna-mode () + (interactive) + (if c-mode-taarna-style + (progn + + (setq c-mode-taarna-style nil) + (setq c-indent-level 2) + (setq c-continued-statement-offset 2) + (setq c-brace-offset 0) + (setq c-argdecl-indent 5) + (setq c-label-offset -2) + (setq c-tab-always-indent t) + (setq c-box-default-style 'single) + (message "C mode: GNU style")) + + (setq c-mode-taarna-style t) + (setq c-indent-level 4) + (setq c-continued-statement-offset 4) + (setq c-brace-offset -4) + (setq c-argdecl-indent 4) + (setq c-label-offset -4) + (setq c-tab-always-indent t) + (setq c-box-default-style 'taarna) + (message "C mode: Taarna style"))) + +;;; Return the minimum value of the left margin of all lines, or -1 if +;;; all lines are empty. + +(defun buffer-left-margin () + (let ((margin -1)) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t") + (if (not (looking-at "\n")) + (setq margin + (if (< margin 0) + (current-column) + (min margin (current-column))))) + (forward-line 1)) + margin)) + +;;; Return the maximum value of the right margin of all lines. Any +;;; sentence ending a line has a space guaranteed before the margin. + +(defun buffer-right-margin () + (let ((margin 0) period) + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (if (bobp) + (setq period 0) + (backward-char 1) + (setq period (if (looking-at "[.?!]") 1 0)) + (forward-char 1)) + (setq margin (max margin (+ (current-column) period))) + (forward-char 1)) + margin)) + +;;; Add, delete or adjust a C comment box. If FLAG is nil, the +;;; current boxing style is recognized and preserved. When 0, the box +;;; is removed; when 1, a single lined box is forced; when 2, a double +;;; lined box is forced; when 3, a Taarna style box is forced. If +;;; negative, the absolute value is used, but the default style is +;;; changed. For any other value (like C-u), the default style is +;;; forced. If REFILL is not nil, refill the comment paragraphs prior +;;; to reboxing. + +(defun rebox-c-comment-engine (flag refill) + (save-restriction + (let ((undo-list buffer-undo-list) + (marked-point (point-marker)) + (saved-point (point)) + box-style left-margin right-margin) + + ;; First, find the limits of the block of comments following or + ;; enclosing the cursor, or return an error if the cursor is not + ;; within such a block of comments, narrow the buffer, and + ;; untabify it. + + ;; - insure the point is into the following comment, if any + + (skip-chars-forward " \t\n") + (if (looking-at "/\\*") + (forward-char 2)) + + (let ((here (point)) start end temp) + + ;; - identify a minimal comment block + + (search-backward "/*") + (setq temp (point)) + (beginning-of-line) + (setq start (point)) + (skip-chars-forward " \t") + (if (< (point) temp) + (progn + (goto-char saved-point) + (error "text before comment's start"))) + (search-forward "*/") + (setq temp (point)) + (end-of-line) + (if (looking-at "\n") + (forward-char 1)) + (setq end (point)) + (skip-chars-backward " \t\n") + (if (> (point) temp) + (progn + (goto-char saved-point) + (error "text after comment's end"))) + (if (< end here) + (progn + (goto-char saved-point) + (error "outside any comment block"))) + + ;; - try to extend the comment block backwards + + (goto-char start) + (while (and (not (bobp)) + (progn (previous-line 1) + (beginning-of-line) + (looking-at "[ \t]*/\\*.*\\*/[ \t]*$"))) + (setq start (point))) + + ;; - try to extend the comment block forward + + (goto-char end) + (while (looking-at "[ \t]*/\\*.*\\*/[ \t]*$") + (forward-line 1) + (beginning-of-line) + (setq end (point))) + + ;; - narrow to the whole block of comments + + (narrow-to-region start end)) + + ;; Second, remove all the comment marks, and move all the text + ;; rigidly to the left to insure the left margin stays at the + ;; same place. At the same time, recognize and save the box + ;; style in BOX-STYLE. + + (let ((previous-margin (buffer-left-margin)) + actual-margin) + + ;; - remove all comment marks + + (goto-char (point-min)) + (replace-regexp "^\\([ \t]*\\)/\\*" "\\1 ") + (goto-char (point-min)) + (replace-regexp "^\\([ \t]*\\)|" "\\1 ") + (goto-char (point-min)) + (replace-regexp "\\(\\*/\\||\\)[ \t]*" "") + (goto-char (point-min)) + (replace-regexp "\\*/[ \t]*/\\*" " ") + + ;; - remove the first and last dashed lines + + (setq box-style 'plain) + (goto-char (point-min)) + (if (looking-at "^[ \t]*-*[.\+\\]?[ \t]*\n") + (progn + (setq box-style 'single) + (replace-match "")) + (if (looking-at "^[ \t]*=*[.\+\\]?[ \t]*\n") + (progn + (setq box-style 'double) + (replace-match "")))) + (goto-char (point-max)) + (previous-line 1) + (beginning-of-line) + (if (looking-at "^[ \t]*[`\+\\]?*[-=]+[ \t]*\n") + (progn + (if (eq box-style 'plain) + (setq box-style 'taarna)) + (replace-match ""))) + + ;; - remove all spurious whitespace + + (goto-char (point-min)) + (replace-regexp "[ \t]+$" "") + (goto-char (point-min)) + (if (looking-at "\n+") + (replace-match "")) + (goto-char (point-max)) + (skip-chars-backward "\n") + (if (looking-at "\n\n+") + (replace-match "\n")) + (goto-char (point-min)) + (replace-regexp "\n\n\n+" "\n\n") + + ;; - move the text left is adequate + + (setq actual-margin (buffer-left-margin)) + (if (not (= previous-margin actual-margin)) + (indent-rigidly (point-min) (point-max) + (- previous-margin actual-margin)))) + + ;; Third, select the new box style from the old box style and + ;; the argument, choose the margins for this style and refill + ;; each paragraph. + + ;; - modify box-style only if flag is defined + + (if flag + (setq box-style + (cond ((eq flag 0) 'plain) + ((eq flag 1) 'single) + ((eq flag 2) 'double) + ((eq flag 3) 'taarna) + ((eq flag '-) (setq c-box-default-style 'plain) 'plain) + ((eq flag -1) (setq c-box-default-style 'single) 'single) + ((eq flag -2) (setq c-box-default-style 'double) 'double) + ((eq flag -3) (setq c-box-default-style 'taarna) 'taarna) + (t c-box-default-style)))) + + ;; - compute the left margin + + (setq left-margin (buffer-left-margin)) + + ;; - temporarily set the fill prefix and column, then refill + + (untabify (point-min) (point-max)) + + (if refill + (let ((fill-prefix (make-string left-margin ? )) + (fill-column (- fill-column + (if (memq box-style '(single double)) 4 6)))) + (fill-region (point-min) (point-max)))) + + ;; - compute the right margin after refill + + (setq right-margin (buffer-right-margin)) + + ;; Fourth, put the narrowed buffer back into a comment box, + ;; according to the value of box-style. Values may be: + ;; plain: insert between a single pair of comment delimiters + ;; single: complete box, overline and underline with dashes + ;; double: complete box, overline and underline with equal signs + ;; taarna: comment delimiters on each line, underline with dashes + + ;; - move the right margin to account for left inserts + + (setq right-margin (+ right-margin + (if (memq box-style '(single double)) + 2 + 3))) + + ;; - construct the box comment, from top to bottom + + (goto-char (point-min)) + (cond ((eq box-style 'plain) + + ;; - construct a plain style comment + + (skip-chars-forward " " (+ (point) left-margin)) + (insert (make-string (- left-margin (current-column)) ? ) + "/* ") + (end-of-line) + (forward-char 1) + (while (not (eobp)) + (skip-chars-forward " " (+ (point) left-margin)) + (insert (make-string (- left-margin (current-column)) ? ) + " ") + (end-of-line) + (forward-char 1)) + (backward-char 1) + (insert " */")) + ((eq box-style 'single) + + ;; - construct a single line style comment + + (indent-to left-margin) + (insert "/*") + (insert (make-string (- right-margin (current-column)) ?-) + "-.\n") + (while (not (eobp)) + (skip-chars-forward " " (+ (point) left-margin)) + (insert (make-string (- left-margin (current-column)) ? ) + "| ") + (end-of-line) + (indent-to right-margin) + (insert " |") + (forward-char 1)) + (indent-to left-margin) + (insert "`") + (insert (make-string (- right-margin (current-column)) ?-) + "*/\n")) + ((eq box-style 'double) + + ;; - construct a double line style comment + + (indent-to left-margin) + (insert "/*") + (insert (make-string (- right-margin (current-column)) ?=) + "=\\\n") + (while (not (eobp)) + (skip-chars-forward " " (+ (point) left-margin)) + (insert (make-string (- left-margin (current-column)) ? ) + "| ") + (end-of-line) + (indent-to right-margin) + (insert " |") + (forward-char 1)) + (indent-to left-margin) + (insert "\\") + (insert (make-string (- right-margin (current-column)) ?=) + "*/\n")) + ((eq box-style 'taarna) + + ;; - construct a Taarna style comment + + (while (not (eobp)) + (skip-chars-forward " " (+ (point) left-margin)) + (insert (make-string (- left-margin (current-column)) ? ) + "/* ") + (end-of-line) + (indent-to right-margin) + (insert " */") + (forward-char 1)) + (indent-to left-margin) + (insert "/* ") + (insert (make-string (- right-margin (current-column)) ?-) + " */\n")) + (t (error "unknown box style"))) + + ;; Fifth, retabify, restore the point position, then cleanup the + ;; undo list of any boundary since we started. + + ;; - retabify before left margin only (adapted from tabify.el) + + (goto-char (point-min)) + (while (re-search-forward "^[ \t][ \t][ \t]*" nil t) + (let ((column (current-column)) + (indent-tabs-mode t)) + (delete-region (match-beginning 0) (point)) + (indent-to column))) + + ;; - restore the point position + + (goto-char (marker-position marked-point)) + + ;; - remove all intermediate boundaries from the undo list + + (if (not (eq buffer-undo-list undo-list)) + (let ((cursor buffer-undo-list)) + (while (not (eq (cdr cursor) undo-list)) + (if (car (cdr cursor)) + (setq cursor (cdr cursor)) + (rplacd cursor (cdr (cdr cursor)))))))))) + +;;; Rebox a C comment without refilling it. + +(defun rebox-c-comment (flag) + (interactive "P") + (rebox-c-comment-engine flag nil)) + +;;; Rebox a C comment after refilling. + +(defun reindent-c-comment (flag) + (interactive "P") + (rebox-c-comment-engine flag t)) + diff --git a/custom/edit-indirect.el b/custom/edit-indirect.el new file mode 100644 index 00000000..307f9695 --- /dev/null +++ b/custom/edit-indirect.el @@ -0,0 +1,440 @@ +;;; edit-indirect.el --- Edit regions in separate buffers -*- lexical-binding: t -*- + +;; Author: Fanael Linithien <fanael4@gmail.com> +;; URL: https://github.com/Fanael/edit-indirect +;; Version: 0.1.10 +;; Package-Requires: ((emacs "24.3")) + +;; This file is NOT part of GNU Emacs. + +;; SPDX-License-Identifier: BSD-2-clause +;; +;; Copyright (c) 2014-2022, Fanael Linithien +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: + +;; Edit regions in separate buffers, like `org-edit-src-code' but for arbitrary +;; regions. +;; +;; See the docstring of `edit-indirect-region' for details. + +;;; Code: +(defgroup edit-indirect nil + "Editing regions in separate buffers." + :group 'editing) + +(defcustom edit-indirect-guess-mode-function #'edit-indirect-default-guess-mode + "The function used to guess the major mode of an edit-indirect buffer. +It's called with the edit-indirect buffer as the current buffer. +It's called with three arguments, the parent buffer, the beginning +and the end of the parent buffer region being editing. + +Note that the buffer-local value from the parent buffer is used." + :type 'function + :group 'edit-indirect) + +(defcustom edit-indirect-after-creation-hook nil + "Functions called after the edit-indirect buffer is created. +The functions are called with the edit-indirect buffer as the +current buffer. + +Note that the buffer-local value from the parent buffer is used." + :type 'hook + :group 'edit-indirect) + +(defcustom edit-indirect-before-commit-hook nil + "Functions called before the edit-indirect buffer is committed. +The functions are called with the edit-indirect buffer as the +current buffer. + +Note that the buffer-local value from the edit-indirect buffer is +used." + :type 'hook + :group 'edit-indirect) + +(defcustom edit-indirect-before-commit-functions nil + "Functions called before an edit-indirect buffer is committed. +The functions are called with the parent buffer as the current +buffer. +Each function is called with two arguments, the beginning and the +end of the region to be changed." + :type 'hook + :group 'edit-indirect) + +(defcustom edit-indirect-after-commit-functions nil + "Functions called after an edit-indirect buffer has been committed. +The functions are called with the parent buffer as the current +buffer. +Each function is called with two arguments, the beginning and the +end of the changed region." + :type 'hook + :group 'edit-indirect) + +(defgroup edit-indirect-faces nil + "Faces used in `edit-indirect'." + :group 'edit-indirect + :group 'faces + :prefix "edit-indirect") + +(defface edit-indirect-edited-region + '((t :inherit secondary-selection)) + "Face used to highlight an indirectly edited region." + :group 'edit-indirect-faces) + +;; Emacs <= 24.3 has no `define-error'. +(let* ((user-error-conditions (get 'user-error 'error-conditions)) + (define-user-error (lambda (name message) + (put name 'error-conditions + (cons name user-error-conditions)) + (put name 'error-message message)))) + (funcall define-user-error 'edit-indirect-overlapping + "Indirectly edited regions cannot overlap") + (funcall define-user-error 'edit-indirect-read-only + "Text is read-only, modify the edit-indirect buffer instead") + (funcall define-user-error 'edit-indirect-not-indirect + "This is not an edit-indirect buffer")) + +(defvar edit-indirect--overlay) +(defvar edit-indirect--should-quit-window nil) +(put 'edit-indirect--should-quit-window 'permanent-local t) + +;;;###autoload +(defun edit-indirect-region (beg end &optional display-buffer) + "Edit the region BEG..END in a separate buffer. +The region is copied, without text properties, to a separate +buffer, called edit-indirect buffer, and +`edit-indirect-guess-mode-function' is called to set the major +mode. +When done, exit with `edit-indirect-commit', which will remove the +original region and replace it with the edited version; or with +`edit-indirect-abort', which will drop the modifications. + +This differs from `clone-indirect-buffer' with narrowing in that +the text properties are not shared, so the parent buffer major mode +and the edit-indirect buffer major mode will not be able to tread +on each other's toes by setting up potentially conflicting text +properties, which happens surprisingly often when the font-lock +mode is used. + +Edit-indirect buffers use the `edit-indirect-mode-map' keymap. +Regions with active edit-indirect buffers use the +`edit-indirect-overlay-map' keymap. + +If there's already an edit-indirect buffer for BEG..END, use that. +If there's already an edit-indirect buffer active overlapping any +portion of BEG..END, an `edit-indirect-overlapping' error is +signaled. + +When DISPLAY-BUFFER is non-nil or when called interactively, +display the edit-indirect buffer in some window and select it. + +In any case, return the edit-indirect buffer." + (interactive + (if (or (use-region-p) (not transient-mark-mode)) + (prog1 (list (region-beginning) (region-end) t) + (deactivate-mark)) + (user-error "No region"))) + (let ((buffer (edit-indirect--get-edit-indirect-buffer beg end))) + (when display-buffer + (edit-indirect--display-buffer buffer)) + buffer)) + +(defvar edit-indirect-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap save-buffer] #'edit-indirect-save) + (define-key map (kbd "C-c '") #'edit-indirect-commit) + (define-key map (kbd "C-c C-c") #'edit-indirect-commit) + (define-key map (kbd "C-c C-k") #'edit-indirect-abort) + map) + "Keymap for edit-indirect buffers. + +\\{edit-indirect-mode-map}") + +(defvar edit-indirect-overlay-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'edit-indirect-display-active-buffer) + map) + "Keymap for regions with active edit-indirect buffers. + +\\{edit-indirect-overlay-map}") + +(defun edit-indirect-commit () + "Commit the modifications done in an edit-indirect buffer. +That is, replace the original region in the parent buffer with the +contents of the edit-indirect buffer. +The edit-indirect buffer is then killed. + +Can be called only when the current buffer is an edit-indirect +buffer." + (interactive) + (edit-indirect--barf-if-not-indirect) + (edit-indirect--commit) + (edit-indirect--clean-up)) + +(defun edit-indirect-save () + "Save the modifications done in an edit-indirect buffer. +That is, replace the original region in the parent buffer with the +contents of the edit-indirect buffer. + +Can be called only when the current buffer is an edit-indirect +buffer." + (interactive) + (edit-indirect--barf-if-not-indirect) + (edit-indirect--commit)) + +(defun edit-indirect-abort () + "Abort indirect editing in the current buffer and kill the buffer. + +Can be called only when the current buffer is an edit-indirect +buffer." + (interactive) + (edit-indirect--barf-if-not-indirect) + (edit-indirect--abort)) + +(defun edit-indirect-buffer-indirect-p (&optional buffer) + "Non-nil iff the BUFFER is an edit-indirect buffer. +BUFFER defaults to the current buffer." + (save-current-buffer + (when buffer + (set-buffer buffer)) + ;; (not (null)) so we don't leak the overlay to the outside world. + (not (null edit-indirect--overlay)))) + +(defun edit-indirect-default-guess-mode (_parent-buffer _beg _end) + "Guess the major mode for an edit-indirect buffer. +It's done by calling `normal-mode'." + (normal-mode)) + +(defun edit-indirect-display-active-buffer () + "Display the active edit-indirect buffer of the region the point is in." + (interactive) + (let ((overlay + (let ((p (point))) + (edit-indirect--search-for-edit-indirect p (1+ p))))) + (unless overlay + (signal 'edit-indirect-not-indirect '())) + (edit-indirect--display-buffer (overlay-get overlay 'edit-indirect-buffer)))) + +(defvar edit-indirect--overlay nil + "The overlay spanning the region of the parent buffer being edited. + +It's also used as the variable determining if we're in an +edit-indirect buffer at all.") +(make-variable-buffer-local 'edit-indirect--overlay) +(put 'edit-indirect--overlay 'permanent-local t) + +;; Normally this would use `define-minor-mode', but that makes the mode function +;; interactive, which we don't want, because it's just an implementation detail. +(defun edit-indirect--mode (overlay) + "Turn the `edit-indirect--mode' \"minor mode\" on. +OVERLAY is the value to set `edit-indirect--overlay' to." + (setq edit-indirect--overlay overlay) + (add-hook 'kill-buffer-hook #'edit-indirect--abort-on-kill-buffer nil t)) +(with-no-warnings + (add-minor-mode + 'edit-indirect--overlay " indirect" edit-indirect-mode-map nil #'ignore)) + +(defun edit-indirect--display-buffer (buffer) + "Display the given BUFFER in some window and select it." + (with-current-buffer buffer + (setq-local edit-indirect--should-quit-window t)) + (select-window (display-buffer buffer)) + nil) + +(defun edit-indirect--get-edit-indirect-buffer (beg end) + "Return an edit-indirect buffer for the region BEG..END. +If there's already an edit-indirect buffer active overlapping any +portion of BEG..END, an `edit-indirect-overlapping' error is +signaled." + (let ((old-overlay (edit-indirect--search-for-edit-indirect beg end))) + (cond + ((null old-overlay) + (let ((overlay (edit-indirect--create-overlay beg end))) + (edit-indirect--create-indirect-buffer beg end overlay))) + ((and (= beg (overlay-start old-overlay)) + (= end (overlay-end old-overlay))) + (overlay-get old-overlay 'edit-indirect-buffer)) + (t + (signal 'edit-indirect-overlapping '()))))) + +(defun edit-indirect--search-for-edit-indirect (beg end) + "Return an existing edit-indirect overlay for some region inside BEG..END. +If there's no indirectly edited region inside BEG..END, return +nil." + (catch 'done + (dolist (overlay (overlays-in beg end)) + (when (overlay-get overlay 'edit-indirect-buffer) + (throw 'done overlay))) + nil)) + +(defmacro edit-indirect--buffer-local-value (buffer variable) + "Get the BUFFER local value of VARIABLE. +VARIABLE shall be a symbol." + (unless (symbolp variable) + (signal 'wrong-type-argument (list #'symbolp variable))) + ;; `with-current-buffer' is used instead of `buffer-local-value' because + ;; the latter doesn't give warnings about free variables when + ;; byte-compiled. + `(with-current-buffer ,buffer ,variable)) + +(defun edit-indirect--create-indirect-buffer (beg end overlay) + "Create an edit-indirect buffer and return it. + +BEG..END is the parent buffer region to insert. +OVERLAY is the overlay, see `edit-indirect--overlay'." + (add-hook 'after-change-major-mode-hook #'edit-indirect--rebind-save-hooks) + (let ((buffer (generate-new-buffer (format "*edit-indirect %s*" (buffer-name)))) + (parent-buffer (current-buffer))) + (overlay-put overlay 'edit-indirect-buffer buffer) + (with-current-buffer buffer + (insert-buffer-substring-no-properties parent-buffer beg end) + (set-buffer-modified-p nil) + (edit-indirect--mode overlay) + ;; Use the buffer-local values from the parent buffer. Don't retrieve the + ;; values before actual uses in case these variables are changed by some + ;; of the many possible hooks. + (funcall (edit-indirect--buffer-local-value + parent-buffer edit-indirect-guess-mode-function) + parent-buffer beg end) + (if (local-variable-p 'edit-indirect-after-creation-hook parent-buffer) + ;; Copy the parent buffer hook to the indirect buffer instead of + ;; let-binding it to avoid running it twice. + (setq-local edit-indirect-after-creation-hook + (edit-indirect--buffer-local-value + parent-buffer edit-indirect-after-creation-hook)) + ;; No need to do copy anything if the parent buffer has no local value, + ;; the global value will be used instead. Just kill the local value in + ;; the indirect buffer in case a prior hook set it, because we're not + ;; supposed to use it. + (kill-local-variable 'edit-indirect-after-creation-hook)) + (run-hooks 'edit-indirect-after-creation-hook)) + buffer)) + +(defun edit-indirect--create-overlay (beg end) + "Create the edit-indirect overlay and return it. + +BEG and END specify the region the overlay should encompass." + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face 'edit-indirect-edited-region) + (overlay-put overlay 'modification-hooks '(edit-indirect--barf-read-only)) + (overlay-put overlay 'insert-in-front-hooks '(edit-indirect--barf-read-only)) + (overlay-put overlay 'keymap edit-indirect-overlay-map) + overlay)) + +(defvar edit-indirect--inhibit-read-only nil + "Non-nil means disregard read-only status of indirectly-edited region.") + +(defun edit-indirect--barf-read-only (_ov _after _beg _end &optional _len) + "Signal an error because the text is read-only. +No error is signaled if `inhibit-read-only' or +`edit-indirect--inhibit-read-only' is non-nil." + (unless (or inhibit-read-only edit-indirect--inhibit-read-only) + (signal 'edit-indirect-read-only '()))) + +(defun edit-indirect--commit () + "Commit the modifications done in an edit-indirect buffer." + (run-hooks 'edit-indirect-before-commit-hook) + (let ((beg (overlay-start edit-indirect--overlay)) + (end (overlay-end edit-indirect--overlay)) + (buffer (current-buffer)) + (edit-indirect--inhibit-read-only t)) + (with-current-buffer (overlay-buffer edit-indirect--overlay) + (save-excursion + (let ((beg-marker (copy-marker beg)) + (end-marker (copy-marker end))) + (edit-indirect--run-hook-with-positions + 'edit-indirect-before-commit-functions beg-marker end-marker) + (save-match-data + (set-match-data (list beg-marker end-marker)) + (let ((new-data + (with-current-buffer buffer + (buffer-substring-no-properties 1 (1+ (buffer-size)))))) + (unless (string= new-data (match-string 0)) + (replace-match new-data t t)))) + (edit-indirect--run-hook-with-positions + 'edit-indirect-after-commit-functions beg-marker (point)) + (set-marker beg-marker nil) + (set-marker end-marker nil)))) + (set-buffer-modified-p nil))) + +(defun edit-indirect--run-hook-with-positions (hook beg end) + "Run HOOK with the specified positions BEG and END. +HOOK should be a symbol, a hook variable. +The functions are passed integer positions. +If a function changes the buffer contents, the next function will be +called with updated positions." + (let ((beg-marker (unless (markerp beg) (copy-marker beg))) + (end-marker (unless (markerp end) (copy-marker end)))) + (run-hook-wrapped hook + (lambda (f beg end) + (funcall f (marker-position beg) (marker-position end)) + nil) + (or beg-marker beg) (or end-marker end)) + (when beg-marker (set-marker beg-marker nil)) + (when end-marker (set-marker end-marker nil)))) + +(defun edit-indirect--abort () + "Abort indirect edit." + (edit-indirect--clean-up)) + +(defun edit-indirect--clean-up () + "Clean up an edit-indirect buffer." + (delete-overlay edit-indirect--overlay) + ;; Kill the overlay reference so that `edit-indirect--abort-on-kill-buffer' + ;; won't try to call us again. + (setq edit-indirect--overlay nil) + ;; If we created a window, get rid of it. Kill the buffer we created. + (if edit-indirect--should-quit-window + (quit-window t) + (kill-buffer))) + +(defun edit-indirect--rebind-save-hooks () + "Bind our `save-buffer' hooks in the current buffer. +Does nothing if the current buffer is not an edit-indirect buffer." + (when (edit-indirect-buffer-indirect-p) + (setq buffer-offer-save t) + (add-hook 'write-contents-functions #'edit-indirect--commit-on-save nil t))) + +(defun edit-indirect--commit-on-save () + "Commit the indirect edit. +Should only be called from `write-contents-functions'." + (edit-indirect--commit) + t) + +(defun edit-indirect--abort-on-kill-buffer () + "Abort indirect edit. +Should be called only from `kill-buffer-hook'." + (when edit-indirect--overlay + (edit-indirect--abort))) + +(defun edit-indirect--barf-if-not-indirect () + "Signal an error if the current buffer is not an edit-indirect buffer. +The error signaled is `edit-indirect-not-indirect'." + (unless edit-indirect--overlay + (signal 'edit-indirect-not-indirect '()))) + +(provide 'edit-indirect) +;;; edit-indirect.el ends here diff --git a/custom/elpa-mirror.el b/custom/elpa-mirror.el new file mode 100644 index 00000000..777293e2 --- /dev/null +++ b/custom/elpa-mirror.el @@ -0,0 +1,450 @@ +;;; elpa-mirror.el --- Create local package repository from installed packages + +;; Copyright (C) 2014-2020 Chen Bin + +;; Author: Chen Bin <chenbin.sh@gmail.com> +;; URL: http://github.com/redguardtoo/elpa-mirror +;; Package-Requires: ((emacs "25.1")) +;; Version: 2.2.2 +;; Keywords: tools +;; +;; This file is not part of GNU Emacs. + +;;; License: + +;; This file is part of elpa-mirror +;; +;; elpa-mirror 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. +;; +;; elpa-mirror is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This program will create a local package repository by from all +;; installed packages. +;; +;; Please note compile Emacs Lisp file (*.elc) from one version of Emacs +;; might not work with another version of Emacs. So you need this program +;; to compile package from local repository. +;; +;; This is the ONLY way to have 100% portable Emacs setup. +;; +;; Usage in Emacs, +;; Run `elpamr-create-mirror-for-installed'. +;; +;; CLI program tar is required. It's bundled with Windows10/Linux/macOS. +;; +;; Usage in Shell, +;; Emacs --batch -l ~/.emacs.d/init.el +;; -l ~/any-directory-you-prefer/elpa-mirror.el \ +;; --eval='(setq elpamr-default-output-directory "~/myelpa")' \ +;; --eval='(elpamr-create-mirror-for-installed) +;; +;; Use the repository created by elpa-mirror, +;; - Add `(setq package-archives '(("myelpa" . "~/myelpa/")))` into ~/.emacs +;; - Restart Emacs +;; +;; Tips, +;; - `elpamr-exclude-packages' excludes packages +;; +;; - `elpamr-tar-command-exclude-patterns' excludes file and directories in +;; package directory. +;; +;; - `elpamr-exclude-patterns-filter-function' lets users define a function to +;; exclude files and directories per package. +;; +;; Below setup adds directory "bin/" into package "vagrant-tramp". +;; +;; (setq elpamr-exclude-patterns-filter-function +;; (lambda (package-dir) +;; (let ((patterns elpamr-tar-command-exclude-patterns)) +;; (when (string-match "vagrant-tramp" package-dir) +;; (setq patterns (remove "*/bin" patterns))) +;; patterns))) + +;; - You can also setup repositories on Dropbox and Github. +;; See https://github.com/redguardtoo/elpa-mirror for details. +;; + +;;; Code: +(require 'package) + +(defcustom elpamr-default-output-directory nil + "The output directory use by `elpamr-create-mirror-for-installed'." + :type '(choice directory (const :tags "None" nil)) + :group 'elpa-mirror) + +(defcustom elpamr-exclude-packages nil + "Names of excluded packages." + :type '(repeat string) + :group 'elpa-mirror) + +(defcustom elpamr-tar-command-exclude-patterns + '("*.elc" + "*~" + "*autoloads.el" + "*.so" + "*.dylib" + "*.dll" + "*/bin" + "*/__pycache__") + "Exclude patterns passed tar's `--exclude' option. + +The patterns use shell glob syntax, not regexp syntax: + +* `*' matches any string, including `/'. +* `?' matches a single character. +* `[abc]' or `[a-z]' is a character class. +* `[^a-z]' or `[!a-z]' is a negated character class. +* `^' and `$' have a special meaning in BSD tar only. +* Special characters are quoted with `\\'. + +The patterns are anchored, meaning that they always start +matching at the start of the path. This is done by passing the +`--anchored' option when running with GNU tar, or pre-pending `^' +to every pattern when running with BSD tar. + +Examples: + +* Exclude files/directories that end with `.elc': `*.elc'. +* Exclude files/directories named `__pycache__': `*/__pycache__'. +* Exclude `bin' inside the `company' package: `company-*/bin'. + +Note that a slash at the start or the end of a pattern will cause +it to match nothing." + :type '(repeat string) + :group 'elpa-mirror) + +(defcustom elpamr-exclude-patterns-filter-function nil + "Filter `elpamr-tar-command-exclude-patterns' before using it per package. +A function with one parameter which is the package directory. +It returns the result to replace `elpamr-tar-command-exclude-patterns'." + :group 'elpa-mirror + :type 'hook) + +(defcustom elpamr-tar-executable + "tar" + "The tar executable used by elpa-mirror. +It can be BSD tar, but GNU tar is preferred." + :type 'string + :group 'elpa-mirror) + +(defcustom elpamr-finished-hook nil + "Hook run when command `elpamr-create-mirror-for-installed' run finished. +The hook function have one argument: output-directory." + :group 'elpa-mirror + :type 'hook) + +(defcustom elpamr-enable-log nil + "Enable log." + :type 'boolean + :group 'elpa-mirror) + +(defvar elpamr--log-buffer "*elpa-mirror log*" + "Destination buffer for log messages and command output.") + +(defun elpamr--log (format-string &rest args) + "Format ARGS with FORMAT-STRING, add the result to the log, and return it. +The log line will be pre-pended with an asterisk to distinguish it +from program output." + (when elpamr-enable-log + (let ((line (apply #'format format-string args))) + (with-current-buffer (get-buffer-create elpamr--log-buffer) + (insert "* " line "\n")) + line))) + +(defun elpamr--log-message (format-string &rest args) + "Format ARGS with FORMAT-STRING, add the result to the log and display it." + (when elpamr-enable-log + (apply #'elpamr--log format-string args) + (apply #'message format-string args))) + +(defun elpamr--log-error (format-string &rest args) + "Format ARGS with FORMAT-STRING, add the result to the log and signal an error." + (when elpamr-enable-log +(apply #'elpamr--log format-string args) + (apply #'error format-string args))) + +(defun elpamr--package-desc (item) + "Extract package information from ITEM." + (cadr item)) + +(defun elpamr--is-bsd-tar () + "Are we using BSD tar instead of GNU tar?" + (let* ((output (mapconcat #'identity (process-lines elpamr-tar-executable "--version") " ")) + ;; @see https://github.com/redguardtoo/elpa-mirror/issues/37 + ;; extra error message insert extra whitespace before "bsdtar" + (result (and output (string-match-p "\\(^[ \t]*\\|[ \t]\\)bsdtar" output)))) + (elpamr--log "Detected tar variant: %s" (if result "BSD" "GNU")) + result)) + +(defun elpamr--create-one-item-for-archive-contents (pkg) + "Access PKG extracted from `package-alist' directly." + (unless (member (symbol-name (car pkg)) elpamr-exclude-packages) + pkg)) + +(defun elpamr--fullpath (parent file) + "Full path of 'PARENT/FILE'." + (let* ((result (file-truename (concat (file-name-as-directory parent) file)))) + (elpamr--log "Converted to full path: %S %S -> %S" parent file result) + result)) + +(defun elpamr--clean-package-description (description) + "Clean DESCRIPTION." + (replace-regexp-in-string "-\*-.*-\*-" "" + (replace-regexp-in-string "\"" "" description t) + t)) + +(defun elpamr--get-dependency (item) + "Get ITEM dependency." + (package-desc-reqs (elpamr--package-desc item))) + +(defun elpamr--get-version (item) + "Get ITEM version." + (package-desc-version (elpamr--package-desc item))) + +(defun elpamr--get-summary (item) + "Get ITEM description." + (package-desc-summary (elpamr--package-desc item))) + +(defun elpamr--one-item-for-archive-contents (final-pkg) + "Format FINAL-PKG information into a string for archive-contents." + (format " (%s . [%S %S \"%s\" tar])\n" + (car final-pkg) + (elpamr--get-version final-pkg) + (elpamr--get-dependency final-pkg) + (elpamr--clean-package-description (elpamr--get-summary final-pkg)))) + +(defun elpamr--call-process-check (arguments) + "Call run tar program with the ARGUMENTS. +Log and signal an error if it exits with a non-zero status." + (let ((exit-status (apply #'call-process + elpamr-tar-executable + nil + (and elpamr-enable-log elpamr--log-buffer) + nil + arguments))) + (cond + ((not (= exit-status 0)) + (elpamr--log-error + "Program %s exited with non-zero status %s, see the %s buffer for details" + elpamr-tar-executable exit-status elpamr--log-buffer) + ) + (t + exit-status)))) + +(defun elpamr--run-tar (working-dir out-file dir-to-archive is-bsd-tar) + "Run tar in order to archive DIR-TO-ARCHIVE into OUT-FILE. +Paths are relative to WORKING-DIR. +IS-BSD-TAR should be non-nil if this function should use a +command compatible with BSD tar instead of GNU tar." + ;; We could detect BSD tar inside this function easily, but detecting it once + ;; and then passing it as an argument improves performance. + (let* ((exclude-opts (mapcar (lambda (s) + (concat "--exclude=" (if is-bsd-tar "^" "") s)) + (if elpamr-exclude-patterns-filter-function + (funcall elpamr-exclude-patterns-filter-function + dir-to-archive) + elpamr-tar-command-exclude-patterns))) + ;; set pwd of process + (default-directory working-dir) + ;; create tar using GNU tar + (tar-args + `("cf" ,out-file + ,@(unless is-bsd-tar '("--anchored")) + ,@exclude-opts + ;; tar 1.14 NEWS, + ;; @see https://git.savannah.gnu.org/cgit/tar.git/plain/NEWS?id=release_1_14 + ;; * New option --format allows to select the output archive format + ;; * The default output format can be selected at configuration time + ;; by presetting the environment variable DEFAULT_ARCHIVE_FORMAT. + ;; Allowed values are GNU, V7, OLDGNU and POSIX. + ,@(unless is-bsd-tar '("--format=gnu")) + ;; Improve reproducibility by not storing unnecessary metadata. + ;; These options are enough for archives in the GNU format, but if + ;; we ever switch to PAX, we'll need to add more (see + ;; <http://h2.jaguarpaw.co.uk/posts/reproducible-tar/> and + ;; <https://www.gnu.org/software/tar/manual/html_node/PAX-keywords.html>). + ,@(unless is-bsd-tar + ;; @see https://github.com/redguardtoo/elpa-mirror/issues/41 + '("--owner=root" + "--group=root" + "--mtime=1970-01-01 00:00:00 UTC")) + "--" ,dir-to-archive)) + ;; Don't archive macOS' file properties (see + ;; <https://superuser.com/q/259703>). + (process-environment (if (eq system-type 'darwin) + (cons "COPYFILE_DISABLE=" process-environment) + process-environment))) + (elpamr--log "Running tar: %S %S" elpamr-tar-executable tar-args) + (elpamr--call-process-check tar-args))) + +;;;###autoload +(defun elpamr-version () + "Current version." + (interactive) + (message "2.2.2")) + +(defun elpamr--win-executable-find (exe) + "Find EXE on windows." + (let* ((drivers '("c" "d" "e" "f")) + (i 0) + j + (dirs '(":\\\\cygwin64\\\\bin\\\\" + ":\\\\msys64\\\\usr\\\\bin\\\\")) + rlt) + (while (and (not rlt) + (< i (length dirs))) + (setq j 0) + (while (and (not rlt) + (< j (length drivers))) + (setq rlt (executable-find (concat (nth j drivers) (nth i dirs) exe))) + (setq j (1+ j))) + (setq i (1+ i))) + (unless rlt + ;; nothing found, fall back to exe + (setq rlt exe)) + rlt)) + +(defun elpamr-double-check-executable () + "Make sure `elpamr-tar-executable' is executable." + (when (eq system-type 'windows-nt) + + (cond + (elpamr-tar-executable + (unless (executable-find elpamr-tar-executable) + (setq elpamr-tar-executable (elpamr--win-executable-find elpamr-tar-executable)))) + + ((executable-find "tar") + (setq elpamr-tar-executable "tar"))))) + +(defun elpamr-delete-directory (directory) + "Delete DIRECTORY." + (ignore-errors + (delete-directory directory t))) + +;;;###autoload +(defun elpamr-create-mirror-for-installed (&optional output-directory recreate-directory) + "Export installed packages into a new directory. +Create the html files for the mirror site. + +The first valid directory found from the below list +will be used as mirror package's output directory: +1. Argument: OUTPUT-DIRECTORY +2. Variable: `elpamr-default-output-directory' +3. Ask user to provide. + +When RECREATE-DIRECTORY is non-nil, OUTPUT-DIRECTORY +will be deleted and recreated." + (interactive) + + ;; find tar program on Windows if GNU tar from Cygwin/MYSYS2 is installed + ;; and current `elpamr-tar-executable' is NOT executable. + (elpamr-double-check-executable) + + (let (final-pkg-list) + + ;; Erase the log (in case of multiple consecutive calls to this function). + (when elpamr-enable-log + (with-current-buffer (get-buffer-create elpamr--log-buffer) + (erase-buffer))) + + ;; Since Emacs 27, `package-initialize' is optional. + ;; but we still need it to initialize `package-alist'. + (unless package-alist (package-initialize)) + + ;; Quote from manual about package-alist: + ;; Alist of all packages available for activation. + ;; Each element has the form (PKG . DESCS), where PKG is a package + ;; name (a symbol) and DESCS is a non-empty list of `package-desc' structure, + ;; sorted by decreasing versions. + ;; Sorted for reproducibility. + (setq final-pkg-list + (let ((sorted-package-alist + (sort (copy-sequence package-alist) + (lambda (a b) + (string< (symbol-name (car a)) + (symbol-name (car b))))))) + (delq nil (mapcar #'elpamr--create-one-item-for-archive-contents + sorted-package-alist)))) + + ;; set output directory + (setq output-directory + (cond ((and output-directory + (stringp output-directory)) + (file-name-as-directory output-directory)) + ((and elpamr-default-output-directory + (stringp elpamr-default-output-directory)) + (file-name-as-directory elpamr-default-output-directory)) + (t (read-directory-name "Output directory: ")))) + + ;; Delete output directory if we need a clean output directory + (when (and recreate-directory + (file-directory-p output-directory)) + (elpamr--log-message "Re-creating %s" output-directory) + (elpamr-delete-directory output-directory)) + + ;; Create output directory if it does not exist. + (unless (file-directory-p output-directory) + (make-directory output-directory t)) + + (when (and (> (length final-pkg-list) 0) + output-directory + (file-directory-p output-directory)) + (let ((tmp-dir (make-temp-file "elpa" t)) + (is-bsd-tar (elpamr--is-bsd-tar)) + (cnt 0)) + + (dolist (package final-pkg-list) + (let* ((pkg-dir (package-desc-dir (car (cdr package)))) + (name (package-desc-name (car (cdr package)))) + (version-str (package-version-join (package-desc-version (car (cdr package))))) + (name-fixed (format "%s-%s" name version-str)) + (package-parent-dir-temp-p (not (string-match (concat "^" (file-truename package-user-dir)) + pkg-dir))) + (package-parent-dir (cond + (package-parent-dir-temp-p + tmp-dir) + (t + package-user-dir)))) + + (when package-parent-dir-temp-p + (copy-directory pkg-dir (elpamr--fullpath tmp-dir name-fixed))) + + (elpamr--run-tar package-parent-dir + (file-relative-name (concat (elpamr--fullpath output-directory name-fixed) ".tar") + package-parent-dir) + name-fixed + is-bsd-tar) + (message "Creating *.tar... %2d%% (%s)" + (/ (* cnt 100) (length final-pkg-list)) + pkg-dir)) + (setq cnt (1+ cnt))) + ;; clean up temp directory + (elpamr-delete-directory tmp-dir)) + + ;; output archive-contents + (elpamr--log-message "Creating archive-contents...") + (with-temp-buffer + (let* ((print-level nil) + (print-length nil)) + (insert "(1\n") + (dolist (final-pkg final-pkg-list) + ;; each package occupies one line + (insert (elpamr--one-item-for-archive-contents final-pkg))) + (insert ")")) + (write-file (elpamr--fullpath output-directory "archive-contents"))) + (run-hook-with-args 'elpamr-finished-hook output-directory) + (elpamr--log-message "DONE! Output directory: %s" output-directory)))) + +(provide 'elpa-mirror) +;;; elpa-mirror.el ends here diff --git a/custom/eplot.el b/custom/eplot.el new file mode 100644 index 00000000..c00a3e31 --- /dev/null +++ b/custom/eplot.el @@ -0,0 +1,3495 @@ +;;; eplot.el --- Manage and Edit Wordpress Posts -*- lexical-binding: t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: charts +;; Package: eplot +;; Version: 1.0 +;; Package-Requires: ((emacs "29.0.59") (pcsv "0.0")) + +;; eplot is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;;; Commentary: + +;; The main entry point is `M-x eplot' in a buffer with time series +;; data. +;; +;; If installing manually, put something like the following in your +;; Emacs init file (but adjust the path to where you've put eplot): +;; +;; (push "~/src/eplot/" load-path) +;; (autoload 'eplot "eplot" nil t) +;; (autoload 'eplot-mode "eplot" nil t) +;; (unless (assoc "\\.plt" auto-mode-alist) +;; (setq auto-mode-alist (cons '("\\.plt" . eplot-mode) auto-mode-alist))) + +;; This requires the pcsv package to parse CSV files. + +;;; Code: + +(require 'svg) +(require 'cl-lib) +(require 'face-remap) +(require 'eieio) +(require 'iso8601) +(require 'transient) + +(defvar eplot--user-defaults nil) +(defvar eplot--chart-headers nil) +(defvar eplot--plot-headers nil) +(defvar eplot--transient-settings nil) + + +(defvar eplot--colors + '("aliceblue" "antiquewhite" "aqua" "aquamarine" "azure" "beige" "bisque" + "black" "blanchedalmond" "blue" "blueviolet" "brown" "burlywood" + "cadetblue" "chartreuse" "chocolate" "coral" "cornflowerblue" "cornsilk" + "crimson" "cyan" "darkblue" "darkcyan" "darkgoldenrod" "darkgray" + "darkgreen" "darkgrey" "darkkhaki" "darkmagenta" "darkolivegreen" + "darkorange" "darkorchid" "darkred" "darksalmon" "darkseagreen" + "darkslateblue" "darkslategray" "darkslategrey" "darkturquoise" + "darkviolet" "deeppink" "deepskyblue" "dimgray" "dimgrey" "dodgerblue" + "firebrick" "floralwhite" "forestgreen" "fuchsia" "gainsboro" "ghostwhite" + "gold" "goldenrod" "gray" "green" "greenyellow" "grey" "honeydew" "hotpink" + "indianred" "indigo" "ivory" "khaki" "lavender" "lavenderblush" "lawngreen" + "lemonchiffon" "lightblue" "lightcoral" "lightcyan" "lightgoldenrodyellow" + "lightgray" "lightgreen" "lightgrey" "lightpink" "lightsalmon" + "lightseagreen" "lightskyblue" "lightslategray" "lightslategrey" + "lightsteelblue" "lightyellow" "lime" "limegreen" "linen" "magenta" + "maroon" "mediumaquamarine" "mediumblue" "mediumorchid" "mediumpurple" + "mediumseagreen" "mediumslateblue" "mediumspringgreen" "mediumturquoise" + "mediumvioletred" "midnightblue" "mintcream" "mistyrose" "moccasin" + "navajowhite" "navy" "oldlace" "olive" "olivedrab" "orange" "orangered" + "orchid" "palegoldenrod" "palegreen" "paleturquoise" "palevioletred" + "papayawhip" "peachpuff" "peru" "pink" "plum" "powderblue" "purple" "red" + "rosybrown" "royalblue" "saddlebrown" "salmon" "sandybrown" "seagreen" + "seashell" "sienna" "silver" "skyblue" "slateblue" "slategray" "slategrey" + "snow" "springgreen" "steelblue" "tan" "teal" "thistle" "tomato" + "turquoise" "violet" "wheat" "white" "whitesmoke" "yellow" "yellowgreen")) + +(defun eplot-set (header value) + "Set the default value of HEADER to VALUE. +To get a list of all possible HEADERs, use the `M-x +eplot-list-chart-headers' command. + +Also see `eplot-reset'." + (let ((elem (or (assq header eplot--chart-headers) + (assq header eplot--plot-headers)))) + (unless elem + (error "No such header type: %s" header)) + (eplot--add-default header value))) + +(defun eplot--add-default (header value) + ;; We want to preserve the order defaults have been added, so that + ;; we can apply them in the same order. This makes a difference + ;; when we're dealing with specs that have inheritence. + (setq eplot--user-defaults (delq (assq header eplot--user-defaults) + eplot--user-defaults)) + (setq eplot--user-defaults (list (cons header value)))) + +(defun eplot-reset (&optional header) + "Reset HEADER to defaults. +If HEADER is nil or not present, reset everything to defaults." + (if header + (setq eplot--user-defaults (delq (assq header eplot--user-defaults) + eplot--user-defaults)) + (setq eplot--user-defaults nil))) + +(unless (assoc "\\.plt" auto-mode-alist) + (setq auto-mode-alist (cons '("\\.plt" . eplot-mode) auto-mode-alist))) + +;;; eplot modes. + +(defvar-keymap eplot-mode-map + "C-c C-c" #'eplot-update-view-buffer + "C-c C-p" #'eplot-switch-view-buffer + "C-c C-e" #'eplot-list-chart-headers + "C-c C-v" #'eplot-customize + "C-c C-l" #'eplot-create-controls + "TAB" #'eplot-complete) + +;; # is working overtime in the syntax here: +;; It can be a color like Color: #e0e0e0, and +;; it can be a setting like 33 # Label: Apples, +;; when it starts a line it's a comment. +(defvar eplot-font-lock-keywords + `(("^[ \t\n]*#.*" . font-lock-comment-face) + ("^[^ :\n]+:" . font-lock-keyword-face) + ("#[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]\\([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]\\)?" . font-lock-variable-name-face) + ("#.*" . font-lock-builtin-face))) + +(define-derived-mode eplot-mode text-mode "eplot" + "Major mode for editing charts. +Use the \\[eplot-list-chart-headers] command to get a list of all +possible chart headers." + (setq-local completion-at-point-functions + (cons 'eplot--complete-header completion-at-point-functions)) + (setq-local font-lock-defaults + '(eplot-font-lock-keywords nil nil nil))) + +(defun eplot-complete () + "Complete headers." + (interactive) + (cond + ((let ((completion-fail-discreetly t)) + (completion-at-point)) + ;; Completion was performed; nothing else to do. + nil) + (t (indent-relative)))) + +(defun eplot--complete-header () + (or + ;; Complete headers names. + (and (or (looking-at ".*:") + (and (looking-at "[ \t]*$") + (save-excursion + (beginning-of-line) + (not (looking-at "\\(.+\\):"))))) + (lambda () + (let ((headers (mapcar + (lambda (h) + (if (looking-at ".*:") + (capitalize (symbol-name (car h))) + (concat (capitalize (symbol-name (car h))) ": "))) + (save-excursion + ;; If we're after the headers, then we want + ;; to complete over the plot headers. Otherwise, + ;; complete over the chart headers. + (if (and (not (bobp)) + (progn + (forward-line -1) + (re-search-backward "^[ \t]*$" nil t))) + eplot--plot-headers + eplot--chart-headers)))) + (completion-ignore-case t)) + (completion-in-region (pos-bol) (line-end-position) headers) + 'completion-attempted))) + ;; Complete header values. + (let ((hname nil)) + (and (save-excursion + (and (looking-at "[ \t]*$") + (progn + (beginning-of-line) + (and (looking-at "\\(.+\\):") + (setq hname (intern (downcase (match-string 1))))))) + (lambda () + (let ((valid (plist-get + (cdr (assq hname (append eplot--plot-headers + eplot--chart-headers))) + :valid)) + (completion-ignore-case t)) + (completion-in-region + (save-excursion + (search-backward ":" (pos-bol) t) + (skip-chars-forward ": \t") + (point)) + (line-end-position) + (mapcar #'symbol-name valid)) + 'completion-attempted))))))) + +(define-minor-mode eplot-minor-mode + "Minor mode to issue commands from an eplot data buffer." + :lighter " eplot") + +(defvar-keymap eplot-minor-mode-map + "H-l" #'eplot-eval-and-update) + +(defvar-keymap eplot-view-mode-map + "s" #'eplot-view-write-file + "w" #'eplot-view-write-scaled-file + "c" #'eplot-view-customize + "l" #'eplot-create-controls) + +(define-derived-mode eplot-view-mode special-mode "eplot view" + "Major mode for displaying eplots." + (setq-local revert-buffer-function #'eplot-update + cursor-type nil)) + +(defun eplot-view-write-file (file &optional width) + "Write the current chart to a file. +If you type in a file name that ends with something else than \"svg\", +ImageMagick \"convert\" will be used to convert the image first. + +If writing to a PNG file, \"rsvg-conver\" will be used instead if +it exists as this usually gives better results." + (interactive "FWrite to file name: ") + (when (and (file-exists-p file) + (not (yes-or-no-p "File exists, overwrite? "))) + (error "Not overwriting the file")) + (save-excursion + (goto-char (point-min)) + (let ((match + (text-property-search-forward 'display nil + (lambda (_ e) + (and (consp e) + (eq (car e) 'image)))))) + (unless match + (error "Can't find an image in the current buffer")) + (let ((svg (plist-get (cdr (prop-match-value match)) :data)) + (tmp " *eplot convert*") + (executable (if width "rsvg-convert" "convert")) + sfile ofile) + (unless svg + (error "Invalid image in the current buffer")) + (with-temp-buffer + (set-buffer-multibyte nil) + (svg-print svg) + (if (string-match-p "\\.svg\\'" file) + (write-region (point-min) (point-max) file) + (if (and (string-match-p "\\.png\\'" file) + (executable-find "rsvg-convert")) + (setq executable "rsvg-convert") + (unless (executable-find executable) + (error "%s isn't installed; can only save svg files" + executable))) + (when (and (equal executable "rsvg-convert") + (not (string-match-p "\\.png\\'" file)) + (not (executable-find "convert"))) + (error "Can only write PNG files when scaling because \"convert\" isn't installed")) + (unwind-protect + (progn + (setq sfile (make-temp-file "eplot" nil ".svg") + ofile (make-temp-file "eplot" nil ".png")) + (write-region (point-min) (point-max) sfile nil 'silent) + ;; We don't use `call-process-region', because + ;; convert doesn't seem to like that? + (let ((code (if (equal executable "rsvg-convert") + (apply + #'call-process + executable nil (get-buffer-create tmp) nil + `(,(format "--output=%s" + (expand-file-name ofile)) + ,@(and width + `(,(format "--width=%d" width) + "--keep-aspect-ratio")) + ,sfile)) + (call-process + executable nil (get-buffer-create tmp) nil + sfile file)))) + (eplot--view-error code tmp) + (when (file-exists-p ofile) + (if (string-match-p "\\.png\\'" file) + (rename-file ofile file) + (let ((code (call-process "convert" nil tmp nil + ofile file))) + (eplot--view-error code tmp)))) + (message "Wrote %s" file))) + ;; Clean-up. + (when (get-buffer tmp) + (kill-buffer tmp)) + (when (file-exists-p sfile) + (delete-file sfile)) + (when (file-exists-p ofile) + (delete-file sfile))))))))) + +(defun eplot--view-error (code tmp) + (unless (zerop code) + (error "Error code %d: %s" + code + (with-current-buffer tmp + (while (search-forward "[ \t\n]+" nil t) + (replace-match " ")) + (string-trim (buffer-string)))))) + +(defun eplot-view-write-scaled-file (width file) + "Write the current chart to a rescaled to a file. +The rescaling is done by \"rsvg-convert\", which has to be +installed. Rescaling is done when rendering, so this should give +you a clear, non-blurry version of the chart at any size." + (interactive "nWidth: \nFWrite to file: ") + (eplot-view-write-file file width)) + +(defun eplot-view-customize () + "Customize the settings for the chart in the current buffer." + (interactive) + (with-suppressed-warnings ((interactive-only eplot-customize)) + (eplot-customize))) + +(defvar eplot--data-buffer nil) +(defvar eplot--current-chart nil) + +(defun eplot () + "Plot the data in the current buffer." + (interactive) + (eplot-update-view-buffer)) + +(defun eplot-with-headers (header-file) + "Plot the data in the current buffer using headers from a file." + (interactive "fHeader file: ") + (eplot-update-view-buffer + (with-temp-buffer + (insert-file-contents header-file) + (eplot--parse-headers)))) + +(defun eplot-make-plot (headers &rest datas) + "Return an SVG based on DATA. +DATA should be pairs of headers, then followed by the plot data." + (with-temp-buffer + ;; Insert the headers. + (dolist (line headers) + (insert (format "%s:" (pop line))) + (dolist (elem line) + (insert (format " %s" elem))) + (insert "\n")) + ;; Then insert all the plot data sets. + (dolist (data datas) + (insert "\n") + (dolist (line data) + (dolist (elem line) + (insert (format "%s" elem) " ")) + (insert "\n"))) + ;;(setq a (buffer-string)) (debug) + (eplot--render (eplot--parse-buffer) t))) + +(defun eplot-switch-view-buffer () + "Switch to the eplot view buffer and render the chart." + (interactive) + (eplot-update-view-buffer nil t)) + +(defun eplot-update-view-buffer (&optional headers switch) + "Update the eplot view buffer based on the current data buffer." + (interactive) + ;; This is mainly useful during implementation. + (if (and (eq major-mode 'emacs-lisp-mode) + (get-buffer-window "*eplot*" t)) + (with-current-buffer "*eplot*" + (eplot-update) + (when-let ((win (get-buffer-window "*eplot*" t))) + (set-window-point win (point-min)))) + ;; Normal case. + (let* ((eplot--user-defaults (eplot--settings-table)) + (data (eplot--parse-buffer)) + (data-buffer (current-buffer)) + (window (selected-window))) + (unless data + (user-error "No data in the current buffer")) + (setq data (eplot--inject-headers data headers)) + (if (get-buffer-window "*eplot*" t) + (set-buffer "*eplot*") + (if switch + (pop-to-buffer-same-window "*eplot*") + (pop-to-buffer "*eplot*"))) + (let ((inhibit-read-only t)) + (erase-buffer) + (unless (eq major-mode 'eplot-view-mode) + (eplot-view-mode)) + (setq-local eplot--data-buffer data-buffer) + (let ((chart (eplot--render data))) + (with-current-buffer data-buffer + (setq-local eplot--current-chart chart))) + (insert "\n") + (when-let ((win (get-buffer-window "*eplot*" t))) + (set-window-point win (point-min)))) + (select-window window)))) + +(defun eplot--settings-table () + (if (not eplot--transient-settings) + eplot--user-defaults + (append eplot--user-defaults eplot--transient-settings))) + +(defun eplot--inject-headers (data headers) + ;; It's OK not to separate the plot headers from the chart + ;; headers. Collect them here, if any. + (when-let ((plot-headers + (cl-loop for elem in (mapcar #'car eplot--plot-headers) + for value = (eplot--vs elem headers) + when value + collect (progn + ;; Remove these headers from the data + ;; headers so that we don't get errors + ;; on undefined headers. + (setq headers (delq (assq elem headers) + headers)) + (cons elem value))))) + (dolist (plot (cdr (assq :plots data))) + (let ((headers (assq :headers plot))) + (if headers + (nconc headers plot-headers) + (nconc plot (list (list :headers plot-headers))))))) + (append data headers)) + +(defun eplot-eval-and-update () + "Helper command when developing." + (interactive nil emacs-lisp-mode) + (save-some-buffers t) + (elisp-eval-buffer) + (eval-defun nil) + (eplot-update-view-buffer)) + +;;; Parsing buffers. + +(defun eplot-update (&rest _ignore) + "Update the plot in the current buffer." + (interactive) + (unless eplot--data-buffer + (user-error "No data buffer associated with this eplot view buffer")) + (let ((data (with-current-buffer eplot--data-buffer + (eplot--parse-buffer))) + (eplot--user-defaults (with-current-buffer eplot--data-buffer + (eplot--settings-table))) + (inhibit-read-only t)) + (erase-buffer) + (let ((chart (eplot--render data))) + (with-current-buffer eplot--data-buffer + (setq-local eplot--current-chart chart))) + (insert "\n\n"))) + +(defun eplot--parse-buffer () + (if (eq major-mode 'org-mode) + (eplot--parse-org-buffer) + (eplot--parse-eplot-buffer))) + +(defun eplot--parse-eplot-buffer () + (if (eplot--csv-buffer-p) + (eplot--parse-csv-buffer) + (let ((buf (current-buffer))) + (with-temp-buffer + (insert-buffer-substring buf) + ;; Remove comments first. + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*#" nil t) + (delete-line)) + (goto-char (point-min)) + ;; First headers. + (let* ((data (eplot--parse-headers)) + (plot-headers + ;; It's OK not to separate the plot headers from the chart + ;; headers. Collect them here, if any. + (cl-loop for elem in (mapcar #'car eplot--plot-headers) + for value = (eplot--vs elem data) + when value + collect (progn + ;; Remove these headers from the data + ;; headers so that we don't get errors + ;; on undefined headers. + (setq data (delq (assq elem data) data)) + (cons elem value)))) + plots) + ;; Then the values. + (while-let ((plot (eplot--parse-values nil plot-headers))) + (setq plot-headers nil) + (push plot plots)) + (when plots + (push (cons :plots (nreverse plots)) data)) + data))))) + +(defun eplot--parse-headers () + (let ((data nil) + type value) + (while (looking-at "\\([^\n\t :]+\\):\\(.*\\)") + (setq type (intern (downcase (match-string 1))) + value (substring-no-properties (string-trim (match-string 2)))) + (forward-line 1) + ;; Get continuation lines. + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value " " (string-trim (match-string 1)))) + (forward-line 1)) + (if (eq type 'header-file) + (setq data (nconc data + (with-temp-buffer + (insert-file-contents value) + (eplot--parse-headers)))) + ;; We don't use `push' here because we want to preserve order + ;; also when inserting headers from other files. + (setq data (nconc data (list (cons type value)))))) + data)) + +(defun eplot--parse-values (&optional in-headers data-headers) + ;; Skip past separator lines. + (while (looking-at "[ \t]*\n") + (forward-line 1)) + (let* ((values nil) + ;; We may have plot-specific headers. + (headers (nconc (eplot--parse-headers) data-headers)) + (data-format (or (eplot--vyl 'data-format headers) + (eplot--vyl 'data-format in-headers))) + (two-values (memq 'two-values data-format)) + (xy (or (memq 'year data-format) + (memq 'date data-format) + (memq 'time data-format) + (memq 'xy data-format))) + (data-column (or (eplot--vn 'data-column headers) + (eplot--vn 'data-column in-headers)))) + (if-let ((data-file (eplot--vs 'data-file headers))) + (with-temp-buffer + (insert-file-contents data-file) + (setq values (cdr (assq :values (eplot--parse-values headers))) + headers (delq (assq 'data headers) headers))) + ;; Now we come to the data. The data is typically either just a + ;; number, or two numbers (in which case the first number is a + ;; date or a time). Labels ans settings can be introduced with + ;; a # char. + (while (looking-at "\\([-0-9. \t]+\\)\\([ \t]*#\\(.*\\)\\)?") + (let ((numbers (match-string 1)) + (settings (eplot--parse-settings (match-string 3))) + this) + (setq numbers (mapcar #'string-to-number + (split-string (string-trim numbers)))) + ;; If we're reading two dimensionalish data, the first + ;; number is the date/time/x. + (when xy + (setq this (list :x (pop numbers)))) + ;; Chop off all the numbers until we read the column(s) + ;; we're using. + (when data-column + (setq numbers (nthcdr (1- data-column) numbers))) + (when numbers + (setq this (nconc this (list :value (pop numbers))))) + (when two-values + (setq this (nconc this (list :extra-value (pop numbers))))) + (when settings + (setq this (nconc this (list :settings settings)))) + (when (plist-get this :value) + (push this values))) + (forward-line 1)) + (setq values (nreverse values))) + (and values + `((:headers . ,headers) (:values . ,values))))) + +(defun eplot--parse-settings (string) + (when string + (with-temp-buffer + (insert (string-trim string) "\n") + (goto-char (point-min)) + (while (re-search-forward "\\(.\\)," nil t) + (if (equal (match-string 1) "\\") + (replace-match "," t t) + (delete-char -1) + (insert "\n") + (when (looking-at "[ \t]+") + (replace-match "")))) + (goto-char (point-min)) + (eplot--parse-headers)))) + +;;; Accessing data. + +(defun eplot--vn (type data &optional default) + (if-let ((value (cdr (assq type data)))) + (string-to-number value) + default)) + +(defun eplot--vs (type data &optional default) + (or (cdr (assq type data)) default)) + +(defun eplot--vy (type data &optional default) + (if-let ((value (cdr (assq type data)))) + (intern (downcase value)) + default)) + +(defun eplot--vyl (type data &optional default) + (if-let ((value (cdr (assq type data)))) + (mapcar #'intern (split-string (downcase value))) + default)) + +(defmacro eplot-def (args doc-string) + (declare (indent defun)) + `(eplot--def ',(nth 0 args) ',(nth 1 args) ',(nth 2 args) ',(nth 3 args) + ,doc-string)) + +(defun eplot--def (name type default valid doc) + (setq eplot--chart-headers (delq (assq name eplot--chart-headers) + eplot--chart-headers)) + (push (list name + :type type + :default default + :doc doc + :valid valid) + eplot--chart-headers)) + +(eplot-def (width number) + "The width of the entire chart.") + +(eplot-def (height number) + "The height of the entire chart.") + +(eplot-def (format symbol normal (normal bar-chart horizontal-bar-chart)) + "The overall format of the chart.") + +(eplot-def (layout symbol nil (normal compact)) + "The general layout of the chart.") + +(eplot-def (mode symbol light (dark light)) + "Dark/light mode.") + +(eplot-def (margin-left number 70) + "The left margin.") + +(eplot-def (margin-right number 20) + "The right margin.") + +(eplot-def (margin-top number 40) + "The top margin.") + +(eplot-def (margin-bottom number 60) + "The bottom margin.") + +(eplot-def (x-axis-title-space number 5) + "The space between the X axis and the label.") + +(eplot-def (font string "sans-serif") + "The font to use in titles, labels and legends.") + +(eplot-def (font-size number 12) + "The font size.") + +(eplot-def (font-weight symbol bold (bold normal)) + "The font weight.") + +(eplot-def (label-font string (spec font)) + "The font to use for axes labels.") + +(eplot-def (label-font-size number (spec font-size)) + "The font size to use for axes labels.") + +(eplot-def (horizontal-label-font-size number (spec label-font-size)) + "The font size to use for horizontal labels.") + +(eplot-def (bar-font string (spec font)) + "The font to use for bar chart labels.") + +(eplot-def (bar-font-size number (spec font-size)) + "The font size to use for bar chart labels.") + +(eplot-def (bar-font-weight symbol (spec font-weight) (bold normal)) + "The font weight to use for bar chart labels.") + +(eplot-def (chart-color string "black") + "The foreground color to use in plots, axes, legends, etc. +This is used as the default, but can be overridden per thing.") + +(eplot-def (background-color string "white") + "The background color. +If you want a chart with a transparent background, use the color +\"none\".") + +(eplot-def (background-gradient string) + "Use this to get a gradient color in the background.") + +(eplot-def (axes-color string (spec chart-color)) + "The color of the axes.") + +(eplot-def (grid-color string "#e0e0e0") + "The color of the grid.") + +(eplot-def (grid symbol xy (xy x y off)) + "What grid axes to do.") + +(eplot-def (grid-opacity number) + "The opacity of the grid. +This should either be nil or a value between 0 and 1, where 0 is +fully transparent.") + +(eplot-def (grid-position symbol bottom (bottom top)) + "Whether to put the grid on top or under the plot.") + +(eplot-def (legend symbol nil (true nil)) + "Whether to do a legend.") + +(eplot-def (legend-color string (spec chart-color)) + "The color of legends (if any).") + +(eplot-def (legend-border-color string (spec chart-color)) + "The border color of legends (if any).") + +(eplot-def (legend-background-color string (spec background-color)) + "The background color of legends (if any).") + +(eplot-def (label-color string (spec axes-color)) + "The color of labels on the axes.") + +(eplot-def (surround-color string) + "The color between the plot area and the edges of the chart.") + +(eplot-def (border-color string) + "The color of the border of the chart, if any.") + +(eplot-def (border-width number) + "The width of the border of the chart, if any.") + +(eplot-def (frame-color string) + "The color of the frame of the plot, if any.") + +(eplot-def (frame-width number) + "The width of the frame of the plot, if any.") + +(eplot-def (min number) + "The minimum value in the chart. +This is normally computed automatically, but can be overridden + with this spec.") + +(eplot-def (max number) + "The maximum value in the chart. +This is normally computed automatically, but can be overridden + with this spec.") + +(eplot-def (title string) + "The title of the chart, if any.") + +(eplot-def (title-color string (spec chart-color)) + "The color of the title.") + +(eplot-def (x-title string) + "The title of the X axis, if any.") + +(eplot-def (y-title string) + "The title of the X axis, if any.") + +(eplot-def (x-label-format string) + "Format string for the X labels. +This is a `format' string.") + +(eplot-def (y-label-format string) + "Format string for the Y labels. +This is a `format' string.") + +(eplot-def (horizontal-label-left number) + "Position of the horizontal labels.") + +(eplot-def (x-label-orientation symbol horizontal (horizontal vertical)) + "Orientation of the X labels.") + +(eplot-def (background-image-file string) + "Use an image as the background.") + +(eplot-def (background-image-opacity number 1) + "The opacity of the background image.") + +(eplot-def (background-image-cover symbol all (all plot frame)) + "Position of the background image. +Valid values are `all' (the entire image), `plot' (the plot area) +and `frame' (the surrounding area).") + +(eplot-def (header-file string) + "File where the headers are.") + +(defvar eplot-compact-defaults + '((margin-left 30) + (margin-right 10) + (margin-top 20) + (margin-bottom 21) + (font-size 12) + (x-axis-title-space 3))) + +(defvar eplot-dark-defaults + '((chart-color "#c0c0c0") + (axes-color "#c0c0c0") + (grid-color "#404040") + (background-color "#101010") + (label-color "#c0c0c0") + (legend-color "#c0c0c0") + (legend-background-color "#000000") + (title-color "#c0c0c0"))) + +(defvar eplot-bar-chart-defaults + '((grid-position top) + (grid y) + (grid-opacity 0.2) + (min 0))) + +(defvar eplot-horizontal-bar-chart-defaults + '((grid-position top) + (grid-opacity 0.2) + (min 0))) + +(defclass eplot-chart () + ( + (plots :initarg :plots) + (data :initarg :data) + (xs) + (ys) + (x-values :initform nil) + (x-type :initform nil) + (x-min) + (x-max) + (x-ticks) + (y-ticks) + (y-labels) + (x-labels) + (print-format) + (x-tick-step) + (x-label-step) + (x-step-map :initform nil) + (y-tick-step) + (y-label-step) + (inhibit-compute-x-step :initform nil) + ;; ---- CUT HERE ---- + (axes-color :initarg :axes-color :initform nil) + (background-color :initarg :background-color :initform nil) + (background-gradient :initarg :background-gradient :initform nil) + (background-image-cover :initarg :background-image-cover :initform nil) + (background-image-file :initarg :background-image-file :initform nil) + (background-image-opacity :initarg :background-image-opacity :initform nil) + (bar-font :initarg :bar-font :initform nil) + (bar-font-size :initarg :bar-font-size :initform nil) + (bar-font-weight :initarg :bar-font-weight :initform nil) + (border-color :initarg :border-color :initform nil) + (border-width :initarg :border-width :initform nil) + (chart-color :initarg :chart-color :initform nil) + (font :initarg :font :initform nil) + (font-size :initarg :font-size :initform nil) + (font-weight :initarg :font-weight :initform nil) + (format :initarg :format :initform nil) + (frame-color :initarg :frame-color :initform nil) + (frame-width :initarg :frame-width :initform nil) + (grid :initarg :grid :initform nil) + (grid-color :initarg :grid-color :initform nil) + (grid-opacity :initarg :grid-opacity :initform nil) + (grid-position :initarg :grid-position :initform nil) + (header-file :initarg :header-file :initform nil) + (height :initarg :height :initform nil) + (horizontal-label-font-size :initarg :horizontal-label-font-size :initform nil) + (label-color :initarg :label-color :initform nil) + (label-font :initarg :label-font :initform nil) + (label-font-size :initarg :label-font-size :initform nil) + (layout :initarg :layout :initform nil) + (legend :initarg :legend :initform nil) + (legend-background-color :initarg :legend-background-color :initform nil) + (legend-border-color :initarg :legend-border-color :initform nil) + (legend-color :initarg :legend-color :initform nil) + (margin-bottom :initarg :margin-bottom :initform nil) + (margin-left :initarg :margin-left :initform nil) + (margin-right :initarg :margin-right :initform nil) + (margin-top :initarg :margin-top :initform nil) + (max :initarg :max :initform nil) + (min :initarg :min :initform nil) + (mode :initarg :mode :initform nil) + (surround-color :initarg :surround-color :initform nil) + (title :initarg :title :initform nil) + (title-color :initarg :title-color :initform nil) + (width :initarg :width :initform nil) + (x-axis-title-space :initarg :x-axis-title-space :initform nil) + (x-title :initarg :x-title :initform nil) + (y-title :initarg :y-title :initform nil) + (x-label-format :initarg :x-label-format :initform nil) + (x-label-orientation :initarg :x-label-orientation :initform nil) + (y-label-format :initarg :y-label-format :initform nil) + (horizontal-label-left :initarg :horizontal-label-left :initform nil) + ;; ---- CUT HERE ---- + )) + +;;; Parameters that are plot specific. + +(defmacro eplot-pdef (args doc-string) + (declare (indent defun)) + `(eplot--pdef ',(nth 0 args) ',(nth 1 args) ',(nth 2 args) ',(nth 3 args) + ,doc-string)) + +(defun eplot--pdef (name type default valid doc) + (setq eplot--plot-headers (delq (assq name eplot--plot-headers) + eplot--plot-headers)) + (push (list name + :type type + :default default + :valid valid + :doc doc) + eplot--plot-headers)) + +(eplot-pdef (smoothing symbol nil (moving-average nil)) + "Smoothing algorithm to apply to the data, if any. +Valid values are `moving-average' and, er, probably more to come.") + +(eplot-pdef (gradient string) + "Gradient to apply to the plot. +The syntax is: + + from-color to-color direction position + +The last two parameters are optional. + +direction is either `top-down' (the default), `bottom-up', +`left-right' or `right-left'). + +position is either `below' or `above'. + +to-color can be either a color name, or a string that defines +stops and colors: + + Gradient: black 25-purple-50-white-75-purple-black + +In that case, the second element specifies the percentage points +of where each color ends, so the above starts with black, then at +25% it's purple, then at 50% it's white, then it's back to purple +again at 75%, before ending up at black at a 100% (but you don't +have to include the 100% here -- it's understood).") + +(eplot-pdef (style symbol line ( line impulse point square circle cross + triangle rectangle curve)) + "Style the plot should be drawn in. +Valid values are listed below. Some styles take additional +optional parameters. + +line + Straight lines between values. + +curve + Curved lines between values. + +impulse + size: width of the impulse + +point + +square + +circle + size: diameter of the circle + fill-color: color to fill the center + +cross + size: length of the lines in the cross + +triangle + size: length of the sides of the triangle + fill-color: color to fill the center + +rectangle + size: length of the sides of the rectangle + fill-color: color to fill the center") + +(eplot-pdef (fill-color string) + "Color to use to fill the plot styles that are closed shapes. +I.e., circle, triangle and rectangle.") + +(eplot-pdef (color string (spec chart-color)) + "Color to draw the plot.") + +(eplot-pdef (data-format symbol single (single date time xy)) + "Format of the data. +By default, eplot assumes that each line has a single data point. +This can also be `date', `time' and `xy'. + +date: The first column is a date on ISO8601 format (i.e., YYYYMMDD). + +time: The first column is a clock (i.e., HHMMSS). + +xy: The first column is the X position.") + +(eplot-pdef (data-column number 1) + "Column where the data is.") + +(eplot-pdef (fill-border-color string) + "Border around the fill area when using a fill/gradient style.") + +(eplot-pdef (size number) + "Size of elements in styles that have meaningful sizes.") + +(eplot-pdef (size-factor number) + "Multiply the size of the elements by the value.") + +(eplot-pdef (data-file string) + "File where the data is.") + +(eplot-pdef (data-format symbol-list nil (nil two-values date time)) + "List of symbols to describe the data format. +Elements allowed are `two-values', `date' and `time'.") + +(eplot-pdef (name string) + "Name of the plot, which will be displayed if legends are switched on.") + +(eplot-pdef (legend-color string (spec chart-color)) + "Color for the name to be displayed in the legend.") + +(eplot-pdef (bezier-factor number 0.1) + "The Bezier factor to apply to curve plots.") + +(eplot-pdef (bar-max-width number) + "Max width of bars in bar plots.") + +(defclass eplot-plot () + ( + (values :initarg :values) + ;; ---- CUT HERE ---- + (bar-max-width :initarg :bar-max-width :initform nil) + (bezier-factor :initarg :bezier-factor :initform nil) + (color :initarg :color :initform nil) + (data-column :initarg :data-column :initform nil) + (data-file :initarg :data-file :initform nil) + (data-format :initarg :data-format :initform nil) + (fill-border-color :initarg :fill-border-color :initform nil) + (fill-color :initarg :fill-color :initform nil) + (gradient :initarg :gradient :initform nil) + (legend-color :initarg :legend-color :initform nil) + (name :initarg :name :initform nil) + (size :initarg :size :initform nil) + (size-factor :initarg :size-factor :initform nil) + (smoothing :initarg :smoothing :initform nil) + (style :initarg :style :initform nil) + ;; ---- CUT HERE ---- + )) + +(defun eplot--make-plot (data) + "Make an `eplot-plot' object and initialize based on DATA." + (let ((plot (make-instance 'eplot-plot + :values (cdr (assq :values data))))) + ;; Get the program-defined defaults. + (eplot--object-defaults plot eplot--plot-headers) + ;; One special case. I don't think this hack is quite right... + (when (or (eq (eplot--vs 'mode data) 'dark) + (eq (cdr (assq 'mode eplot--user-defaults)) 'dark)) + (setf (slot-value plot 'color) "#c0c0c0")) + ;; Use the headers. + (eplot--object-values plot (cdr (assq :headers data)) eplot--plot-headers) + plot)) + +(defun eplot--make-chart (data) + "Make an `eplot-chart' object and initialize based on DATA." + (let ((chart (make-instance 'eplot-chart + :plots (mapcar #'eplot--make-plot + (eplot--vs :plots data)) + :data data))) + ;; First get the program-defined defaults. + (eplot--object-defaults chart eplot--chart-headers) + ;; Then do the "meta" variables. + (eplot--meta chart data 'mode 'dark eplot-dark-defaults) + (eplot--meta chart data 'layout 'compact eplot-compact-defaults) + (eplot--meta chart data 'format 'bar-chart eplot-bar-chart-defaults) + (eplot--meta chart data 'format 'horizontal-bar-chart + eplot-horizontal-bar-chart-defaults) + ;; Set defaults from user settings/transients. + (cl-loop for (name . value) in eplot--user-defaults + when (assq name eplot--chart-headers) + do + (setf (slot-value chart name) value) + (eplot--set-dependent-values chart name value)) + ;; Finally, use the data from the chart. + (eplot--object-values chart data eplot--chart-headers) + ;; If not set, recompute the margins based on the font sizes (if + ;; the font size has been changed from defaults). + (when (or (assq 'font-size eplot--user-defaults) + (assq 'font-size data)) + (with-slots ( title x-title y-title + margin-top margin-bottom margin-left + font-size font font-weight) + chart + (when (or title x-title y-title) + (let ((text-height + (eplot--text-height (concat title x-title y-title) + font font-size font-weight))) + (when (and title + (and (not (assq 'margin-top eplot--user-defaults)) + (not (assq 'margin-top data)))) + (cl-incf margin-top (* text-height 1.4))) + (when (and x-title + (and (not (assq 'margin-bottom eplot--user-defaults)) + (not (assq 'margin-bottom data)))) + (cl-incf margin-bottom (* text-height 1.4))) + (when (and y-title + (and (not (assq 'margin-left eplot--user-defaults)) + (not (assq 'margin-left data)))) + (cl-incf margin-left (* text-height 1.4))))))) + chart)) + +(defun eplot--meta (chart data slot value defaults) + (when (or (eq (cdr (assq slot eplot--user-defaults)) value) + (eq (eplot--vy slot data) value)) + (eplot--set-theme chart defaults))) + +(defun eplot--object-defaults (object headers) + (dolist (header headers) + (when-let ((default (plist-get (cdr header) :default))) + (setf (slot-value object (car header)) + ;; Allow overrides via `eplot-set'. + (or (cdr (assq (car header) eplot--user-defaults)) + (if (and (consp default) + (eq (car default) 'spec)) + ;; Chase dependencies. + (eplot--default (cadr default)) + default)))))) + +(defun eplot--object-values (object data headers) + (cl-loop for (name . value) in data + do (unless (eq name :plots) + (let ((spec (cdr (assq name headers)))) + (if (not spec) + (error "%s is not a valid spec" name) + (let ((value + (cl-case (plist-get spec :type) + (number + (string-to-number value)) + (symbol + (intern (downcase value))) + (symbol-list + (mapcar #'intern (split-string (downcase value)))) + (t + value)))) + (setf (slot-value object name) value) + (eplot--set-dependent-values object name value))))))) + +(defun eplot--set-dependent-values (object name value) + (dolist (slot (gethash name (eplot--dependecy-graph))) + (setf (slot-value object slot) value) + (eplot--set-dependent-values object slot value))) + +(defun eplot--set-theme (chart map) + (cl-loop for (slot value) in map + do (setf (slot-value chart slot) value))) + +(defun eplot--default (slot) + "Find the default value for SLOT, chasing dependencies." + (let ((spec (cdr (assq slot eplot--chart-headers)))) + (unless spec + (error "Invalid slot %s" slot)) + (let ((default (plist-get spec :default))) + (if (and (consp default) + (eq (car default) 'spec)) + (eplot--default (cadr default)) + (or (cdr (assq slot eplot--user-defaults)) default))))) + +(defun eplot--dependecy-graph () + (let ((table (make-hash-table))) + (dolist (elem eplot--chart-headers) + (let ((default (plist-get (cdr elem) :default))) + (when (and (consp default) + (eq (car default) 'spec)) + (push (car elem) (gethash (cadr default) table))))) + table)) + +(defun eplot--render (data &optional return-image) + "Create the chart and display it. +If RETURN-IMAGE is non-nil, return it instead of displaying it." + (let* ((chart (eplot--make-chart data)) + svg) + (with-slots ( width height xs ys + margin-left margin-right margin-top margin-bottom + grid-position plots x-min format + x-label-orientation) + chart + ;; Set the size of the chart based on the window it's going to + ;; be displayed in. It uses the *eplot* window by default, or + ;; the current one if that isn't displayed. + (let ((factor (image-compute-scaling-factor image-scaling-factor))) + (unless width + (setq width (truncate + (/ (* (window-pixel-width + (get-buffer-window "*eplot*" t)) + 0.9) + factor)))) + (unless height + (setq height (truncate + (/ (* (window-pixel-height + (get-buffer-window "*eplot*" t)) + 0.9) + factor))))) + (setq svg (svg-create width height) + xs (- width margin-left margin-right) + ys (- height margin-top margin-bottom)) + ;; Protect against being called in an empty buffer. + (if (not (and plots + ;; Sanity check against the user choosing dimensions + ;; that leave no space for the plot. + (> ys 0) (> xs 0))) + ;; Just draw the basics. + (eplot--draw-basics svg chart) + + ;; Horizontal bar charts are special. + (when (eq format 'horizontal-bar-chart) + (eplot--adjust-horizontal-bar-chart chart data)) + ;; Compute min/max based on all plots, and also compute x-ticks + ;; etc. + (eplot--compute-chart-dimensions chart) + (when (and (eq x-label-orientation 'vertical) + (eplot--default-p 'margin-bottom (slot-value chart 'data))) + (eplot--adjust-vertical-x-labels chart)) + ;; Analyze values and adjust values accordingly. + (eplot--adjust-chart chart) + ;; Compute the Y labels -- this may adjust `margin-left'. + (eplot--compute-y-labels chart) + ;; Compute the X labels -- this may adjust `margin-bottom'. + (eplot--compute-x-labels chart) + ;; Draw background/borders/titles/etc. + (eplot--draw-basics svg chart) + + (when (eq grid-position 'top) + (eplot--draw-plots svg chart)) + + (eplot--draw-x-ticks svg chart) + (unless (eq format 'horizontal-bar-chart) + (eplot--draw-y-ticks svg chart)) + + ;; Draw axes. + (with-slots ( margin-left margin-right margin-margin-top + margin-bottom axes-color) + chart + (svg-line svg margin-left margin-top margin-left + (+ (- height margin-bottom) 5) + :stroke axes-color) + (svg-line svg (- margin-left 5) (- height margin-bottom) + (- width margin-right) (- height margin-bottom) + :stroke axes-color)) + + (when (eq grid-position 'bottom) + (eplot--draw-plots svg chart))) + + (with-slots (frame-color frame-width) chart + (when (or frame-color frame-width) + (svg-rectangle svg margin-left margin-top xs ys + :stroke-width frame-width + :fill "none" + :stroke-color frame-color))) + (eplot--draw-legend svg chart)) + + (if return-image + svg + (svg-insert-image svg) + chart))) + +(defun eplot--adjust-horizontal-bar-chart (chart data) + (with-slots ( plots bar-font bar-font-size bar-font-weight margin-left + width margin-right xs) + chart + (dolist (plot plots) + (with-slots ( data-format values) plot + (push 'xy data-format) + ;; Flip the values -- we want the values to be on the X + ;; axis instead. + (setf values + (cl-loop for value in values + for i from 1 + collect (list :value i + :x (plist-get value :value) + :settings + (plist-get value :settings)))) + (when (eplot--default-p 'margin-left data) + (setf margin-left + (+ (cl-loop for value in values + maximize + (eplot--text-width + (eplot--vs 'label (plist-get value :settings)) + bar-font bar-font-size bar-font-weight)) + 20) + xs (- width margin-left margin-right))))))) + +(defun eplot--draw-basics (svg chart) + (with-slots ( width height + chart-color font font-size font-weight + margin-left margin-right margin-top margin-bottom + background-color label-color + xs ys) + chart + ;; Add background. + (eplot--draw-background chart svg 0 0 width height) + (with-slots ( background-image-file background-image-opacity + background-image-cover) + chart + (when (and background-image-file + ;; Sanity checks to avoid erroring out later. + (file-exists-p background-image-file) + (file-regular-p background-image-file)) + (apply #'svg-embed svg background-image-file "image/jpeg" nil + :opacity background-image-opacity + :preserveAspectRatio "xMidYMid slice" + (if (memq background-image-cover '(all frame)) + `(:x 0 :y 0 :width ,width :height ,height) + `(:x ,margin-left :y ,margin-top :width ,xs :height ,ys))) + (when (eq background-image-cover 'frame) + (eplot--draw-background chart svg margin-left margin-right xs ys)))) + ;; Area between plot and edges. + (with-slots (surround-color) chart + (when surround-color + (svg-rectangle svg 0 0 width height + :fill surround-color) + (svg-rectangle svg margin-left margin-top + xs ys + :fill background-color))) + ;; Border around the entire chart. + (with-slots (border-width border-color) chart + (when (or border-width border-color) + (svg-rectangle svg 0 0 width height + :stroke-width (or border-width 1) + :fill "none" + :stroke-color (or border-color chart-color)))) + ;; Frame around the plot. + (with-slots (frame-width frame-color) chart + (when (or frame-width frame-color) + (svg-rectangle svg margin-left margin-top xs ys + :stroke-width (or frame-width 1) + :fill "none" + :stroke-color (or frame-color chart-color)))) + ;; Title and legends. + (with-slots (title title-color) chart + (when title + (svg-text svg title + :font-family font + :text-anchor "middle" + :font-weight font-weight + :font-size font-size + :fill title-color + :x (+ margin-left (/ (- width margin-left margin-right) 2)) + :y (+ 3 (/ margin-top 2))))) + (with-slots (x-title) chart + (when x-title + (svg-text svg x-title + :font-family font + :text-anchor "middle" + :font-weight font-weight + :font-size font-size + :fill label-color + :x (+ margin-left (/ (- width margin-left margin-right) 2)) + :y (- height (/ margin-bottom 4))))) + (with-slots (y-title) chart + (when y-title + (let ((text-height + (eplot--text-height y-title font font-size font-weight))) + (svg-text svg y-title + :font-family font + :text-anchor "middle" + :font-weight font-weight + :font-size font-size + :fill label-color + :transform + (format "translate(%s,%s) rotate(-90)" + (- (/ margin-left 2) (/ text-height 2) 4) + (+ margin-top + (/ (- height margin-bottom margin-top) 2))))))))) + +(defun eplot--draw-background (chart svg left top width height) + (with-slots (background-gradient background-color) chart + (let ((gradient (eplot--parse-gradient background-gradient)) + id) + (when gradient + (setq id (format "gradient-%s" (make-temp-name "grad"))) + (eplot--gradient svg id 'linear + (eplot--stops (eplot--vs 'from gradient) + (eplot--vs 'to gradient)) + (eplot--vs 'direction gradient))) + (apply #'svg-rectangle svg left top width height + (if gradient + `(:gradient ,id) + `(:fill ,background-color)))))) + +(defun eplot--compute-chart-dimensions (chart) + (with-slots ( min max plots x-values x-min x-max x-ticks + print-format font-size + xs + inhibit-compute-x-step x-type x-step-map format + x-tick-step x-label-step + label-font label-font-size x-label-format) + chart + (let ((set-min min) + (set-max max)) + (dolist (plot plots) + (with-slots (values data-format) plot + (let* ((vals (nconc (seq-map (lambda (v) (plist-get v :value)) values) + (and (memq 'two-values data-format) + (seq-map + (lambda (v) (plist-get v :extra-value)) + values))))) + ;; Set the x-values based on the first plot. + (unless x-values + (setq print-format (cond + ((memq 'year data-format) 'year) + ((memq 'date data-format) 'date) + ((memq 'time data-format) 'time) + (t 'number))) + (cond + ((or (memq 'xy data-format) + (memq 'year data-format)) + (setq x-values (cl-loop for val in values + collect (plist-get val :x)) + x-min (if (eq format 'horizontal-bar-chart) + 0 + (seq-min x-values)) + x-max (seq-max x-values) + x-ticks (eplot--get-ticks x-min x-max xs)) + (when (memq 'year data-format) + (setq print-format 'literal-year))) + ((memq 'date data-format) + (setq x-values + (cl-loop for val in values + collect + (time-to-days + (encode-time + (decoded-time-set-defaults + (iso8601-parse-date + (format "%d" (plist-get val :x))))))) + x-min (seq-min x-values) + x-max (seq-max x-values) + inhibit-compute-x-step t) + (let ((xs (eplot--get-date-ticks + x-min x-max xs + label-font label-font-size x-label-format))) + (setq x-ticks (car xs) + print-format (cadr xs) + x-tick-step 1 + x-label-step 1 + x-step-map (nth 2 xs)))) + ((memq 'time data-format) + (setq x-values + (cl-loop for val in values + collect + (time-convert + (encode-time + (decoded-time-set-defaults + (iso8601-parse-time + (format "%06d" (plist-get val :x))))) + 'integer)) + x-min (car x-values) + x-max (car (last x-values)) + inhibit-compute-x-step t) + (let ((xs (eplot--get-time-ticks + x-min x-max xs label-font label-font-size + x-label-format))) + (setq x-ticks (car xs) + print-format (cadr xs) + x-tick-step 1 + x-label-step 1 + x-step-map (nth 2 xs)))) + (t + ;; This is a one-dimensional plot -- we don't have X + ;; values, really, so we just do zero to (1- (length + ;; values)). + (setq x-type 'one-dimensional + x-values (cl-loop for i from 0 + repeat (length values) + collect i) + x-min (car x-values) + x-max (car (last x-values)) + x-ticks x-values)))) + (unless set-min + (setq min (min (or min 1.0e+INF) (seq-min vals)))) + (unless set-max + (setq max (max (or max -1.0e+INF) (seq-max vals)))))))))) + +(defun eplot--adjust-chart (chart) + (with-slots ( x-tick-step x-label-step y-tick-step y-label-step + min max ys format inhibit-compute-x-step + y-ticks xs x-values print-format + x-label-format label-font label-font-size data + x-ticks) + chart + (setq y-ticks (and max + (eplot--get-ticks + min + ;; We get 5% more ticks to check whether we + ;; should extend max. + (if (eplot--default-p 'max data) + (* max 1.05) + max) + ys))) + (when (eplot--default-p 'max data) + (setq max (max max (car (last y-ticks))))) + (if (eq format 'bar-chart) + (setq x-tick-step 1 + x-label-step 1) + (unless inhibit-compute-x-step + (let ((xt (eplot--compute-x-ticks + xs x-ticks print-format + x-label-format label-font label-font-size))) + (setq x-tick-step (car xt) + x-label-step (cadr xt))))) + (when max + (let ((yt (eplot--compute-y-ticks + ys y-ticks + (eplot--text-height "100" label-font label-font-size)))) + (setq y-tick-step (car yt) + y-label-step (cadr yt)))) + ;; If max is less than 2% off from a pleasant number, then + ;; increase max. + (when (eplot--default-p 'max data) + (cl-loop for tick in (reverse y-ticks) + when (and (< max tick) + (< (e/ (- tick max) (- max min)) 0.02)) + return (progn + (setq max tick) + ;; Chop off any further ticks. + (setcdr (member tick y-ticks) nil)))) + + (when y-ticks + (if (and (eplot--default-p 'min data) + (< (car y-ticks) min)) + (setq min (car y-ticks)) + ;; We may be extending the bottom of the chart to get pleasing + ;; numbers. We don't want to be drawing the chart on top of the + ;; X axis, because the chart won't be visible there. + (when (and nil + (<= min (car y-ticks)) + ;; But not if we start at origo, because that just + ;; looks confusing. + (not (zerop min))) + (setq min (- (car y-ticks) + ;; 2% of the value range. + (* 0.02 (- (car (last y-ticks)) (car y-ticks)))))))))) + +(defun eplot--adjust-vertical-x-labels (chart) + (with-slots ( x-step-map x-ticks format plots + print-format x-label-format label-font + label-font-size margin-bottom + bar-font bar-font-size bar-font-weight) + chart + ;; Make X ticks. + (let ((width + (cl-loop + for xv in (or x-step-map x-ticks) + for x = (if (consp xv) (car xv) xv) + for i from 0 + for value = (and (equal format 'bar-chart) + (elt (slot-value (car plots) 'values) i)) + for label = (if (equal format 'bar-chart) + (eplot--vs 'label + (plist-get value :settings) + ;; When we're doing bar charts, we + ;; want default labeling to start with + ;; 1 and not zero. + (format "%s" (1+ x))) + (eplot--format-value x print-format x-label-format)) + maximize (if (equal format 'bar-chart) + (eplot--text-width + label bar-font bar-font-size bar-font-weight) + (eplot--text-width + label label-font label-font-size))))) + ;; Ensure that we have enough room to display the X labels + ;; (unless overridden). + (with-slots ( height margin-top ys + y-ticks y-tick-step y-label-step min max) + chart + (setq margin-bottom (max margin-bottom (+ width 40)) + ys (- height margin-top margin-bottom)))))) + +(defun eplot--compute-x-labels (chart) + (with-slots ( x-step-map x-ticks + format plots print-format x-label-format x-labels + x-tick-step x-label-step + x-label-orientation margin-bottom) + chart + ;; Make X ticks. + (setf x-labels + (cl-loop + for xv in (or x-step-map x-ticks) + for x = (if (consp xv) (car xv) xv) + for do-tick = (if (consp xv) + (nth 1 xv) + (zerop (e% x x-tick-step))) + for do-label = (if (consp xv) + (nth 2 xv) + (zerop (e% x x-label-step))) + for i from 0 + for value = (and (equal format 'bar-chart) + (elt (slot-value (car plots) 'values) i)) + collect (list + (if (equal format 'bar-chart) + (eplot--vs 'label + (plist-get value :settings) + ;; When we're doing bar charts, we + ;; want default labeling to start with + ;; 1 and not zero. + (format "%s" (1+ x))) + (eplot--format-value x print-format x-label-format)) + do-tick + do-label))))) + +(defun eplot--draw-x-ticks (svg chart) + (with-slots ( x-step-map x-ticks format layout print-format + margin-left margin-right margin-top margin-bottom + x-min x-max xs + width height + axes-color label-color + grid grid-opacity grid-color + font x-tick-step x-label-step x-label-format x-label-orientation + label-font label-font-size + plots x-labels + x-values + bar-font bar-font-size bar-font-weight + plots) + chart + (let ((font label-font) + (font-size label-font-size) + (font-weight 'normal) + (label-settings nil)) + (when (equal format 'bar-chart) + (setq font bar-font + font-size bar-font-size + font-weight bar-font-weight + label-settings (mapcar (lambda (e) + (plist-get e :settings)) + (slot-value (car plots) 'values)))) + ;; Make X ticks. + (cl-loop with label-height + for xv in (or x-step-map x-ticks) + for x = (if (consp xv) (car xv) xv) + for i from 0 + for (label do-tick do-label) in x-labels + for px = (if (equal format 'bar-chart) + (+ margin-left + (/ (/ xs (length x-values)) 2) + (* (e/ i (length x-values)) + xs)) + (+ margin-left + (* (/ (- (* 1.0 x) x-min) (- x-max x-min)) + xs))) + for this-font-weight = + (if (equal format 'bar-chart) + (or (cdr (assq 'label-font-weight (nth i label-settings))) + font-weight) + font-weight) + ;; We might have one extra stride outside the area -- don't + ;; draw it. + when (<= px (- width margin-right)) + do + (when do-tick + ;; Draw little tick. + (unless (equal format 'bar-chart) + (svg-line svg + px (- height margin-bottom) + px (+ (- height margin-bottom) + (if do-label + 4 + 2)) + :stroke axes-color)) + (when (or (eq grid 'xy) (eq grid 'x)) + (svg-line svg px margin-top + px (- height margin-bottom) + :opacity grid-opacity + :stroke grid-color))) + (when (and do-label + ;; We want to skip marking the first X value + ;; unless we're a bar chart or we're a one + ;; dimensional chart. + (or (equal format 'bar-chart) + t + (not (= x-min (car x-values))) + (eq x-type 'one-dimensional) + (and (not (zerop x)) (not (zerop i))))) + (if (eq x-label-orientation 'vertical) + (progn + (unless label-height + ;; The X position we're putting the label at is + ;; based on the bottom of the lower-case + ;; characters. So we want to ignore descenders + ;; etc, so we use "xx" to determine the height + ;; to be able to center the text. + (setq label-height + (eplot--text-height + ;; If the labels are numerical, we need + ;; to center them using the height of + ;; numbers. + (if (string-match "^[0-9]+$" label) + "10" + ;; Otherwise center them on the baseline. + "xx") + font font-size this-font-weight))) + (svg-text svg label + :font-family font + :text-anchor "end" + :font-size font-size + :font-weight this-font-weight + :fill label-color + :transform + (format "translate(%s,%s) rotate(-90)" + (+ px (/ label-height 2)) + (- height margin-bottom -10)))) + (svg-text svg label + :font-family font + :text-anchor "middle" + :font-size font-size + :font-weight this-font-weight + :fill label-color + :x px + :y (+ (- height margin-bottom) + font-size + (if (equal format 'bar-chart) + (if (equal layout 'compact) 3 5) + 2))))))))) + +(defun eplot--stride (chart values) + (with-slots (xs x-type format) chart + (if (eq x-type 'one-dimensional) + (e/ xs + ;; Fenceposting bar-chart vs everything else. + (if (eq format 'bar-chart) + (length values) + (1- (length values)))) + (e/ xs (length values))))) + +(defun eplot--default-p (slot data) + "Return non-nil if SLOT is at the default value." + (and (not (assq slot eplot--user-defaults)) + (not (assq slot data)))) + +(defun eplot--compute-y-labels (chart) + (with-slots ( y-ticks y-labels + width height min max xs ys + margin-top margin-bottom margin-left margin-right + y-tick-step y-label-step y-label-format) + chart + ;; First collect all the labels we're thinking about outputting. + (setq y-labels + (cl-loop for y in y-ticks + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 y) min) (- max min)) + ys)) + when (and (<= margin-top py (- height margin-bottom)) + (zerop (e% y y-tick-step)) + (zerop (e% y y-label-step))) + collect (eplot--format-y + y (- (cadr y-ticks) (car y-ticks)) nil + y-label-format))) + ;; Check the labels to see whether we have too many digits for + ;; what we're actually going to display. Man, this is a lot of + ;; back-and-forth and should be rewritten to be less insanely + ;; inefficient. + (when (= (seq-count (lambda (label) + (string-match "\\." label)) + y-labels) + (length y-labels)) + (setq y-labels + (cl-loop with max = (cl-loop for label in y-labels + maximize (eplot--decimal-digits + (string-to-number label))) + for label in y-labels + collect (format (if (zerop max) + "%d" + (format "%%.%df" max)) + (string-to-number label))))) + (setq y-labels (cl-coerce y-labels 'vector)) + ;; Ensure that we have enough room to display the Y labels + ;; (unless overridden). + (when (eplot--default-p 'margin-left (slot-value chart 'data)) + (with-slots (label-font label-font-size) chart + (setq margin-left (max margin-left + (+ (eplot--text-width + (elt y-labels (1- (length y-labels))) + label-font label-font-size) + 10)) + xs (- width margin-left margin-right)))))) + +(defun eplot--draw-y-ticks (svg chart) + (with-slots ( y-ticks y-labels y-tick-step y-label-step label-color + label-font label-font-size + width height min max ys + margin-top margin-bottom margin-left margin-right + axes-color + grid grid-opacity grid-color) + chart + ;; Make Y ticks. + (cl-loop with lnum = 0 + with text-height = (eplot--text-height + "012" label-font label-font-size) + for y in y-ticks + for i from 0 + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 y) min) (- max min)) + ys)) + do + (when (and (<= margin-top py (- height margin-bottom)) + (zerop (e% y y-tick-step))) + (svg-line svg margin-left py + (- margin-left 3) py + :stroke-color axes-color) + (when (or (eq grid 'xy) (eq grid 'y)) + (svg-line svg margin-left py + (- width margin-right) py + :opacity grid-opacity + :stroke-color grid-color)) + (when (zerop (e% y y-label-step)) + (svg-text svg (elt y-labels lnum) + :font-family label-font + :text-anchor "end" + :font-size label-font-size + :fill label-color + :x (- margin-left 6) + :y (+ py (/ text-height 2) -1)) + (cl-incf lnum)))))) + +(defun eplot--text-width (text font font-size &optional font-weight) + (string-pixel-width + (propertize text 'face + (list :font (font-spec :family font + :weight (or font-weight 'normal) + :size font-size))))) + +(defvar eplot--text-size-cache (make-hash-table :test #'equal)) + +(defun eplot--text-height (text font font-size &optional font-weight) + (cdr (eplot--text-size text font font-size font-weight))) + +(defun eplot--text-size (text font font-size font-weight) + (let ((key (list text font font-size font-weight))) + (or (gethash key eplot--text-size-cache) + (let ((size (eplot--text-size-1 text font font-size font-weight))) + (setf (gethash key eplot--text-size-cache) size) + size)))) + +(defun eplot--text-size-1 (text font font-size font-weight) + (if (not (executable-find "convert")) + ;; This "default" text size is kinda bogus. + (cons (* (length text) font-size) font-size) + (let* ((size (* font-size 10)) + (svg (svg-create size size)) + text-size) + (svg-rectangle svg 0 0 size size :fill "black") + (svg-text svg text + :font-family font + :text-anchor "middle" + :font-size font-size + :font-weight (or font-weight 'normal) + :fill "white" + :x (/ size 2) + :y (/ size 2)) + (with-temp-buffer + (set-buffer-multibyte nil) + (svg-print svg) + (let* ((file (make-temp-file "eplot" nil ".svg")) + (png (file-name-with-extension file ".png"))) + (unwind-protect + (progn + (write-region (point-min) (point-max) file nil 'silent) + ;; rsvg-convert is 5x faster than convert when doing SVG, so + ;; if we have it, we use it. + (when (executable-find "rsvg-convert") + (unwind-protect + (call-process "rsvg-convert" nil nil nil + (format "--output=%s" png) file) + (when (file-exists-p png) + (delete-file file) + (setq file png)))) + (erase-buffer) + (when (zerop (call-process "convert" nil t nil + "-trim" "+repage" file "info:-")) + (goto-char (point-min)) + (when (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\)" nil t) + (setq text-size + (cons (string-to-number (match-string 1)) + (string-to-number (match-string 2))))))) + (when (file-exists-p file) + (delete-file file))))) + (or text-size + ;; This "default" text size is kinda bogus. + (cons (* (length text) font-size) font-size))))) + +(defun eplot--draw-legend (svg chart) + (with-slots ( legend plots + margin-left margin-top + font font-size font-weight + background-color axes-color + legend-color legend-background-color legend-border-color) + chart + (when (eq legend 'true) + (when-let ((names + (cl-loop for plot in plots + for name = (slot-value plot 'name) + when name + collect + (cons name (slot-value plot 'color))))) + (svg-rectangle svg (+ margin-left 20) (+ margin-top 20) + (format "%dpx" + (+ 10 + (seq-max + (mapcar (lambda (name) + (eplot--text-width (car name) + font font-size)) + names)))) + (* font-size (+ (length names) 2)) + :font-size font-size + :fill-color legend-background-color + :stroke-color legend-border-color) + (cl-loop for name in names + for i from 0 + do (svg-text svg (car name) + :font-family font + :text-anchor "front" + :font-size font-size + :font-weight font-weight + :fill (or (cdr name) legend-color) + :x (+ margin-left 25) + :y (+ margin-top 40 (* i font-size)))))))) + +(defun eplot--format-y (y spacing whole format-string) + (format (or format-string "%s") + (cond + ((or (= (round (* spacing 100)) 10) (= (round (* spacing 100)) 20)) + (format "%.1f" y)) + ((< spacing 0.01) + (format "%.3f" y)) + ((< spacing 1) + (format "%.2f" y)) + ((and (< spacing 1) (not (zerop (mod (* spacing 10) 1)))) + (format "%.1f" y)) + ((zerop (% spacing 1000000000)) + (format "%dG" (/ y 1000000000))) + ((zerop (% spacing 1000000)) + (format "%dM" (/ y 1000000))) + ((zerop (% spacing 1000)) + (format "%dk" (/ y 1000))) + ((>= spacing 1) + (format "%s" y)) + ((not whole) + (format "%.1f" y)) + (t + (format "%s" y))))) + +(defun eplot--format-value (value print-format label-format) + (replace-regexp-in-string + ;; Texts in SVG collapse multiple spaces into one. So do it here, + ;; too, so that width calculations are correct. + " +" " " + (cond + ((eq print-format 'date) + (format-time-string + (or label-format "%Y-%m-%d") (eplot--days-to-time value))) + ((eq print-format 'year) + (format-time-string (or label-format "%Y") (eplot--days-to-time value))) + ((eq print-format 'time) + (format-time-string (or label-format "%H:%M:%S") value)) + ((eq print-format 'minute) + (format-time-string (or label-format "%H:%M") value)) + ((eq print-format 'hour) + (format-time-string (or label-format "%H") value)) + (t + (format (or label-format "%s") value))))) + +(defun eplot--compute-x-ticks (xs x-values print-format x-label-format + label-font label-font-size) + (let* ((min (seq-min x-values)) + (max (seq-max x-values)) + (count (length x-values)) + (max-print (eplot--format-value max print-format x-label-format)) + ;; We want each label to be spaced at least as long apart as + ;; the length of the longest label, with room for two blanks + ;; in between. + (min-spacing (* 1.2 (eplot--text-width max-print label-font + label-font-size))) + (digits (eplot--decimal-digits (- (cadr x-values) (car x-values)))) + (every (e/ 1 (expt 10 digits)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) xs) + (list every every)) + ;; We have to prune X labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ((< (* count 10) xs) + (list every + (let ((label-step every)) + (while (> (/ (- max min) label-step) (/ xs min-spacing)) + (setq label-step (eplot--next-weed label-step))) + label-step))) + ;; We have to reduce both grid lines and labels. + (t + (let ((tick-step every)) + (while (> (/ (- max min) tick-step) (/ xs 10)) + (setq tick-step (eplot--next-weed tick-step))) + (list tick-step + (let ((label-step tick-step)) + (while (> (/ (- max min) label-step) (/ xs min-spacing)) + (setq label-step (eplot--next-weed label-step)) + (while (not (zerop (% label-step tick-step))) + (setq label-step (eplot--next-weed label-step)))) + label-step))))))) + +(defun eplot--compute-y-ticks (ys y-values text-height) + (let* ((min (car y-values)) + (max (car (last y-values))) + (count (length y-values)) + ;; We want each label to be spaced at least as long apart as + ;; the height of the label. + (min-spacing (+ text-height 10)) + (digits (eplot--decimal-digits (- (cadr y-values) (car y-values)))) + (every (e/ 1 (expt 10 digits)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) ys) + (list every every)) + ;; We have to prune Y labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ((< (* count 10) ys) + (list every + (let ((label-step every)) + (while (> (/ (- max min) label-step) (/ ys min-spacing)) + (setq label-step (eplot--next-weed label-step))) + label-step))) + ;; We have to reduce both grid lines and labels. + (t + (let ((tick-step 1)) + (while (> (/ count tick-step) (/ ys 10)) + (setq tick-step (eplot--next-weed tick-step))) + (list tick-step + (let ((label-step tick-step)) + (while (> (/ (- max min) label-step) (/ ys min-spacing)) + (setq label-step (eplot--next-weed label-step))) + label-step))))))) + +(defvar eplot--pleasing-numbers '(1 2 5 10)) + +(defun eplot--next-weed (weed) + (let (digits series) + (if (>= weed 1) + (setq digits (truncate (log weed 10)) + series (/ weed (expt 10 digits))) + (setq digits (eplot--decimal-digits weed) + series (truncate (* weed (expt 10 digits))))) + (let ((next (cadr (memq series eplot--pleasing-numbers)))) + (unless next + (error "Invalid weed: %s" weed)) + (if (>= weed 1) + (* next (expt 10 digits)) + (e/ next (expt 10 digits)))))) + +(defun eplot--parse-gradient (string) + (when string + (let ((bits (split-string string))) + (list + (cons 'from (nth 0 bits)) + (cons 'to (nth 1 bits)) + (cons 'direction (intern (or (nth 2 bits) "top-down"))) + (cons 'position (intern (or (nth 3 bits) "below"))))))) + +(defun eplot--smooth (values algo xs) + (if (not algo) + values + (let* ((vals (cl-coerce values 'vector)) + (max (1- (length vals))) + (period (* 4 (ceiling (/ max xs))))) + (cl-case algo + (moving-average + (cl-loop for i from 0 upto max + collect (e/ (cl-loop for ii from 0 upto (1- period) + sum (elt vals (min (+ i ii) max))) + period))))))) + +(defun eplot--vary-color (color n) + (let ((colors ["#e6194b" "#3cb44b" "#ffe119" "#4363d8" "#f58231" "#911eb4" + "#46f0f0" "#f032e6" "#bcf60c" "#fabebe" "#008080" "#e6beff" + "#9a6324" "#fffac8" "#800000" "#aaffc3" "#808000" "#ffd8b1" + "#000075" "#808080" "#ffffff" "#000000"])) + (unless (equal color "vary") + (setq colors + (if (string-search " " color) + (split-string color) + (list color)))) + (elt colors (mod n (length colors))))) + +(defun eplot--pv (plot slot &optional default) + (let ((user (cdr (assq slot eplot--user-defaults)))) + (when (and (stringp user) (zerop (length user))) + (setq user nil)) + (or user (slot-value plot slot) default))) + +(defun eplot--draw-plots (svg chart) + (if (eq (slot-value chart 'format) 'horizontal-bar-chart) + (eplot--draw-horizontal-bar-chart svg chart) + (eplot--draw-normal-plots svg chart))) + +(defun eplot--draw-normal-plots (svg chart) + (with-slots ( plots chart-color height format + margin-bottom margin-left + min max xs ys + margin-top + x-values x-min x-max + label-font label-font-size) + chart + ;; Draw all the plots. + (cl-loop for plot in (reverse plots) + for plot-number from 0 + for values = (slot-value plot 'values) + for vals = (eplot--smooth + (seq-map (lambda (v) (plist-get v :value)) values) + (slot-value plot 'smoothing) + xs) + for polygon = nil + for gradient = (eplot--parse-gradient (eplot--pv plot 'gradient)) + for lpy = nil + for lpx = nil + for style = (if (eq format 'bar-chart) + 'bar + (slot-value plot 'style)) + for bar-max-width = (eplot--pv plot 'bar-max-width) + for bar-width = (and (eq style 'bar) + (min (or bar-max-width most-positive-fixnum) + (/ xs (length x-values)))) + for bar-gap = (and (eq style 'bar) + (if (< bar-width + (or bar-max-width most-positive-fixnum)) + (* bar-width 0.1) + 0)) + for clip-id = (format "url(#clip-%d)" plot-number) + do + (svg--append + svg + (dom-node 'clipPath + `((id . ,(format "clip-%d" plot-number))) + (dom-node 'rect + `((x . ,margin-left) + (y . , margin-top) + (width . ,xs) + (height . ,ys))))) + (unless gradient + (when-let ((fill (slot-value plot 'fill-color))) + (setq gradient `((from . ,fill) (to . ,fill) + (direction . top-down) (position . below))))) + (when gradient + (if (eq (eplot--vs 'position gradient) 'above) + (push (cons margin-left margin-top) polygon) + (push (cons margin-left (- height margin-bottom)) polygon))) + (cl-loop + for val in vals + for value in values + for x in x-values + for i from 0 + for settings = (plist-get value :settings) + for color = (eplot--vary-color + (eplot--vs 'color settings (slot-value plot 'color)) + i) + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 val) min) (- max min)) + ys)) + for px = (if (eq style 'bar) + (+ margin-left + (/ (/ xs (length x-values)) 2) + (* (e/ i (length x-values)) + xs)) + (+ margin-left + (* (e/ (- x x-min) (- x-max x-min)) + xs))) + do + ;; Some data points may have texts. + (when-let ((text (eplot--vs 'text settings))) + (svg-text svg text + :font-family label-font + :text-anchor "middle" + :font-size label-font-size + :font-weight 'normal + :fill color + :x px + :y (- py (eplot--text-height + text label-font label-font-size) + -5))) + ;; You may mark certain points. + (when-let ((mark (eplot--vy 'mark settings))) + (cl-case mark + (cross + (let ((s (eplot--element-size val plot settings 3))) + (svg-line svg (- px s) (- py s) + (+ px s) (+ py s) + :clip-path clip-id + :stroke color) + (svg-line svg (+ px s) (- py s) + (- px s) (+ py s) + :clip-path clip-id + :stroke color))) + (otherwise + (svg-circle svg px py 3 + :fill color)))) + (cl-case style + (bar + (if (not gradient) + (svg-rectangle + svg + (+ (- px (e/ bar-width 2)) (e/ bar-gap 2)) + py + (- bar-width bar-gap) + (- height margin-bottom py) + :clip-path clip-id + :fill color) + (let ((id (format "gradient-%s" (make-temp-name "grad")))) + (eplot--gradient svg id 'linear + (eplot--stops (eplot--vs 'from gradient) + (eplot--vs 'to gradient)) + (eplot--vs 'direction gradient)) + (svg-rectangle + svg + (+ (- px (e/ bar-width 2)) (e/ bar-gap 2)) + py + (- bar-width bar-gap) + (- height margin-bottom py) + :clip-path clip-id + :gradient id)))) + (impulse + (let ((width (eplot--element-size val plot settings 1))) + (if (= width 1) + (svg-line svg + px py + px (- height margin-bottom) + :clip-path clip-id + :stroke color) + (svg-rectangle svg + (- px (e/ width 2)) py + width (- height py margin-bottom) + :clip-path clip-id + :fill color)))) + (point + (svg-line svg px py (1+ px) (1+ py) + :clip-path clip-id + :stroke color)) + (line + ;; If we're doing a gradient, we're just collecting + ;; points and will draw the polygon later. + (if gradient + (push (cons px py) polygon) + (when lpx + (svg-line svg lpx lpy px py + :stroke-width (eplot--pv plot 'size 1) + :clip-path clip-id + :stroke color)))) + (curve + (push (cons px py) polygon)) + (square + (if gradient + (progn + (when lpx + (push (cons lpx py) polygon)) + (push (cons px py) polygon)) + (when lpx + (svg-line svg lpx lpy px lpy + :clip-path clip-id + :stroke color) + (svg-line svg px lpy px py + :clip-path clip-id + :stroke color)))) + (circle + (svg-circle svg px py + (eplot--element-size val plot settings 3) + :clip-path clip-id + :stroke color + :fill (eplot--vary-color + (eplot--vs + 'fill-color settings + (or (slot-value plot 'fill-color) "none")) + i))) + (cross + (let ((s (eplot--element-size val plot settings 3))) + (svg-line svg (- px s) (- py s) + (+ px s) (+ py s) + :clip-path clip-id + :stroke color) + (svg-line svg (+ px s) (- py s) + (- px s) (+ py s) + :clip-path clip-id + :stroke color))) + (triangle + (let ((s (eplot--element-size val plot settings 5))) + (svg-polygon svg + (list + (cons (- px (e/ s 2)) (+ py (e/ s 2))) + (cons px (- py (e/ s 2))) + (cons (+ px (e/ s 2)) (+ py (e/ s 2)))) + :clip-path clip-id + :stroke color + :fill-color + (or (slot-value plot 'fill-color) "none")))) + (rectangle + (let ((s (eplot--element-size val plot settings 3))) + (svg-rectangle svg (- px (e/ s 2)) (- py (e/ s 2)) + s s + :clip-path clip-id + :stroke color + :fill-color + (or (slot-value plot 'fill-color) "none"))))) + (setq lpy py + lpx px)) + + ;; We're doing a gradient of some kind (or a curve), so + ;; draw it now when we've collected the polygon. + (when polygon + ;; We have a "between" chart, so collect the data points + ;; from the "extra" values, too. + (when (memq 'two-values (slot-value plot 'data-format)) + (cl-loop + for val in (nreverse + (seq-map (lambda (v) (plist-get v :extra-value)) + values)) + for x from (1- (length vals)) downto 0 + for py = (- (- height margin-bottom) + (* (/ (- (* 1.0 val) min) (- max min)) + ys)) + for px = (+ margin-left + (* (e/ (- x x-min) (- x-max x-min)) + xs)) + do + (cl-case style + (line + (push (cons px py) polygon)) + (square + (when lpx + (push (cons lpx py) polygon)) + (push (cons px py) polygon))) + (setq lpx px lpy py))) + (when gradient + (if (eq (eplot--vs 'position gradient) 'above) + (push (cons lpx margin-top) polygon) + (push (cons lpx (- height margin-bottom)) polygon))) + (let ((id (format "gradient-%d" plot-number))) + (when gradient + (eplot--gradient svg id 'linear + (eplot--stops (eplot--vs 'from gradient) + (eplot--vs 'to gradient)) + (eplot--vs 'direction gradient))) + (if (eq style 'curve) + (apply #'svg-path svg + (nconc + (cl-loop + with points = (cl-coerce + (nreverse polygon) 'vector) + for i from 0 upto (1- (length points)) + collect + (cond + ((zerop i) + `(moveto ((,(car (elt points 0)) . + ,(cdr (elt points 0)))))) + (t + `(curveto + (,(eplot--bezier + (eplot--pv plot 'bezier-factor) + i points)))))) + (and gradient '((closepath)))) + `( :clip-path ,clip-id + :stroke-width ,(eplot--pv plot 'size 1) + :stroke ,(slot-value plot 'color) + ,@(if gradient + `(:gradient ,id) + `(:fill "none")))) + (svg-polygon + svg (nreverse polygon) + :clip-path clip-id + :gradient id + :stroke (slot-value plot 'fill-border-color)))))))) + +(defun eplot--element-size (value plot settings default) + (eplot--vn 'size settings + (if (slot-value plot 'size-factor) + (* value (slot-value plot 'size-factor)) + (or (slot-value plot 'size) default)))) + +(defun eplot--draw-horizontal-bar-chart (svg chart) + (with-slots ( plots chart-color height format + margin-bottom margin-left + min max xs ys + margin-top + x-values x-min x-max + label-font label-font-size label-color + horizontal-label-left horizontal-label-font-size) + chart + (dolist (plot plots) + (cl-loop with values = (slot-value plot 'values) + with stride = (e/ ys (length values)) + with label-height = (eplot--text-height "xx" label-font + label-font-size) + with bar-gap = (* stride 0.1) + for i from 0 + for value in values + for settings = (plist-get value :settings) + for bar-max-width = (eplot--pv plot 'bar-max-width) + for py = (+ margin-top (* i stride)) + for px = (* (e/ (plist-get value :x) x-max) xs) + for color = (eplot--vary-color + (eplot--vs 'color settings (slot-value plot 'color)) + i) + do + (svg-rectangle svg + margin-left + (+ py (e/ bar-gap 2) + (if (and bar-max-width + (< bar-max-width (- stride bar-gap))) + (- (/ stride 2) (/ bar-max-width 2)) + 0)) + px + (if bar-max-width + (min bar-max-width (- stride bar-gap)) + (- stride bar-gap)) + :fill color) + (svg-text svg (eplot--vs 'label settings) + :font-family label-font + :text-anchor "left" + :font-size horizontal-label-font-size + :font-weight 'normal + :fill label-color + :x (or horizontal-label-left 5) + :y (+ py label-height + (/ stride 2))))))) + +(defun eplot--stops (from to) + (append `((0 . ,from)) + (cl-loop for (pct col) on (split-string to "-") by #'cddr + collect (if col + (cons (string-to-number pct) col) + (cons 100 pct))))) + +(defun eplot--gradient (svg id type stops &optional direction) + "Add a gradient with ID to SVG. +TYPE is `linear' or `radial'. + +STOPS is a list of percentage/color pairs. + +DIRECTION is one of `top-down', `bottom-up', `left-right' or `right-left'. +nil means `top-down'." + (svg--def + svg + (apply + #'dom-node + (if (eq type 'linear) + 'linearGradient + 'radialGradient) + `((id . ,id) + (x1 . ,(if (eq direction 'left-right) 1 0)) + (x2 . ,(if (eq direction 'right-left) 1 0)) + (y1 . ,(if (eq direction 'bottom-up) 1 0)) + (y2 . ,(if (eq direction 'top-down) 1 0))) + (mapcar + (lambda (stop) + (dom-node 'stop `((offset . ,(format "%s%%" (car stop))) + (stop-color . ,(cdr stop))))) + stops)))) + +(defun e% (num1 num2) + (let ((factor (max (expt 10 (eplot--decimal-digits num1)) + (expt 10 (eplot--decimal-digits num2))))) + (% (truncate (* num1 factor)) (truncate (* num2 factor))))) + +(defun eplot--decimal-digits (number) + (- (length (replace-regexp-in-string + "0+\\'" "" + (format "%.10f" (- number (truncate number))))) + 2)) + +(defun e/ (&rest numbers) + (if (cl-every #'integerp numbers) + (let ((int (apply #'/ numbers)) + (float (apply #'/ (* 1.0 (car numbers)) (cdr numbers)))) + (if (= int float) + int + float)) + (apply #'/ numbers))) + +(defun eplot--get-ticks (min max height &optional whole) + (let* ((diff (abs (- min max))) + (even (eplot--pleasing-numbers (* (e/ diff height) 10))) + (factor (max (expt 10 (eplot--decimal-digits even)) + (expt 10 (eplot--decimal-digits diff)))) + (fmin (truncate (* min factor))) + (feven (truncate (* factor even))) + start) + (when whole + (setq even 1 + feven factor)) + + (setq start + (cond + ((< min 0) + (+ (floor fmin) + feven + (- (% (floor fmin) feven)) + (- feven))) + (t + (- fmin (% fmin feven))))) + (cl-loop for x from start upto (* max factor) by feven + collect (e/ x factor)))) + +(defun eplot--days-to-time (days) + (days-to-time (- days (time-to-days 0)))) + +(defun eplot--get-date-ticks (start end xs label-font label-font-size + x-label-format &optional skip-until) + (let* ((duration (- end start)) + (limits + (list + (list (/ 368 16) 'date + (lambda (_d) t)) + (list (/ 368 4) 'date + ;; Collect Mondays. + (lambda (decoded) + (= (decoded-time-weekday decoded) 1))) + (list (/ 368 2) 'date + ;; Collect 1st and 15th. + (lambda (decoded) + (or (= (decoded-time-day decoded) 1) + (= (decoded-time-day decoded) 15)))) + (list (* 368 2) 'date + ;; Collect 1st of every month. + (lambda (decoded) + (= (decoded-time-day decoded) 1))) + (list (* 368 4) 'date + ;; Collect every quarter. + (lambda (decoded) + (and (= (decoded-time-day decoded) 1) + (memq (decoded-time-month decoded) '(1 4 7 10))))) + (list (* 368 8) 'date + ;; Collect every half year. + (lambda (decoded) + (and (= (decoded-time-day decoded) 1) + (memq (decoded-time-month decoded) '(1 7))))) + (list 1.0e+INF 'year + ;; Collect every Jan 1st. + (lambda (decoded) + (and (= (decoded-time-day decoded) 1) + (= (decoded-time-month decoded) 1))))))) + ;; First we collect the potential ticks. + (while (or (>= duration (caar limits)) + (and skip-until (>= skip-until (caar limits)))) + (pop limits)) + (let* ((x-ticks (cl-loop for day from start upto end + for time = (eplot--days-to-time day) + for decoded = (decode-time time) + when (funcall (nth 2 (car limits)) decoded) + collect day)) + (count (length x-ticks)) + (print-format (nth 1 (car limits))) + (max-print (eplot--format-value (car x-ticks) print-format + x-label-format)) + (min-spacing (* 1.2 (eplot--text-width max-print label-font + label-font-size)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) xs) + (list x-ticks print-format)) + ;; We have to prune X labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ((< (* count 10) xs) + (cond + ((not (cdr limits)) + (eplot--year-ticks + x-ticks xs label-font label-font-size x-label-format)) + ;; The Mondays grid is special, because it doesn't resolve + ;; into any of the bigger limits evenly. + ((= (caar limits) (/ 368 4)) + (let* ((max-print (eplot--format-value + (car x-ticks) print-format x-label-format)) + (min-spacing (* 1.2 (eplot--text-width + max-print label-font label-font-size))) + (weed-factor 2)) + (while (> (* (/ (length x-ticks) weed-factor) min-spacing) xs) + (setq weed-factor (* weed-factor 2))) + (list x-ticks 'date + (cl-loop for val in x-ticks + for i from 0 + collect (list val t (zerop (% i weed-factor))))))) + (t + (pop limits) + (catch 'found + (while limits + (let ((candidate + (cl-loop for day in x-ticks + for time = (eplot--days-to-time day) + for decoded = (decode-time time) + collect (list day t + (not (not + (funcall (nth 2 (car limits)) + decoded))))))) + (setq print-format (nth 1 (car limits))) + (let* ((max-print (eplot--format-value + (car x-ticks) print-format x-label-format)) + (min-spacing (* 1.2 (eplot--text-width + max-print label-font + label-font-size))) + (num-labels (seq-count (lambda (v) (nth 2 v)) + candidate))) + (when (and (not (zerop num-labels)) + (< (* num-labels min-spacing) xs)) + (throw 'found (list x-ticks print-format candidate))))) + (pop limits)) + (eplot--year-ticks + x-ticks xs label-font label-font-size x-label-format))))) + ;; We have to reduce both grid lines and labels. + (t + (eplot--get-date-ticks start end xs label-font label-font-size + x-label-format (caar limits))))))) + +(defun eplot--year-ticks (x-ticks xs label-font label-font-size x-label-format) + (let* ((year-ticks (mapcar (lambda (day) + (decoded-time-year + (decode-time (eplot--days-to-time day)))) + x-ticks)) + (xv (eplot--compute-x-ticks + xs year-ticks 'year x-label-format label-font label-font-size))) + (let ((tick-step (car xv)) + (label-step (cadr xv))) + (list x-ticks 'year + (cl-loop for year in year-ticks + for val in x-ticks + collect (list val + (zerop (% year tick-step)) + (zerop (% year label-step)))))))) + +(defun eplot--get-time-ticks (start end xs label-font label-font-size + x-label-format + &optional skip-until) + (let* ((duration (- end start)) + (limits + (list + (list (* 2 60) 'time + (lambda (_d) t)) + (list (* 2 60 60) 'time + ;; Collect whole minutes. + (lambda (decoded) + (zerop (decoded-time-second decoded)))) + (list (* 3 60 60) 'minute + ;; Collect five minutes. + (lambda (decoded) + (zerop (% (decoded-time-minute decoded) 5)))) + (list (* 4 60 60) 'minute + ;; Collect fifteen minutes. + (lambda (decoded) + (and (zerop (decoded-time-second decoded)) + (memq (decoded-time-minute decoded) '(0 15 30 45))))) + (list (* 8 60 60) 'minute + ;; Collect half hours. + (lambda (decoded) + (and (zerop (decoded-time-second decoded)) + (memq (decoded-time-minute decoded) '(0 30))))) + (list 1.0e+INF 'hour + ;; Collect whole hours. + (lambda (decoded) + (and (zerop (decoded-time-second decoded)) + (zerop (decoded-time-minute decoded)))))))) + ;; First we collect the potential ticks. + (while (or (>= duration (caar limits)) + (and skip-until (>= skip-until (caar limits)))) + (pop limits)) + (let* ((x-ticks (cl-loop for time from start upto end + for decoded = (decode-time time) + when (funcall (nth 2 (car limits)) decoded) + collect time)) + (count (length x-ticks)) + (print-format (nth 1 (car limits))) + (max-print (eplot--format-value (car x-ticks) print-format + x-label-format)) + (min-spacing (* (+ (length max-print) 2) (e/ label-font-size 2)))) + (cond + ;; We have room for every X value. + ((< (* count min-spacing) xs) + (list x-ticks print-format)) + ;; We have to prune X labels, but not grid lines. (We shouldn't + ;; have a grid line more than every 10 pixels.) + ;; If we're plotting just seconds, then just weed out some seconds. + ((and (< (* count 10) xs) + (= (caar limits) (* 2 60))) + (let ((xv (eplot--compute-x-ticks + xs x-ticks 'time x-label-format label-font label-font-size))) + (let ((tick-step (car xv)) + (label-step (cadr xv))) + (list x-ticks 'time + (cl-loop for val in x-ticks + collect (list val + (zerop (% val tick-step)) + (zerop (% val label-step)))))))) + ;; Normal case for pruning labels, but not grid lines. + ((< (* count 10) xs) + (if (not (cdr limits)) + (eplot--hour-ticks x-ticks xs label-font label-font-size + x-label-format) + (pop limits) + (catch 'found + (while limits + (let ((candidate + (cl-loop for val in x-ticks + for decoded = (decode-time val) + collect (list val t + (not (not + (funcall (nth 2 (car limits)) + decoded))))))) + (setq print-format (nth 1 (car limits))) + (let ((min-spacing (* (+ (length max-print) 2) + (e/ label-font-size 2)))) + (when (< (* (seq-count (lambda (v) (nth 2 v)) candidate) + min-spacing) + xs) + (throw 'found (list x-ticks print-format candidate))))) + (pop limits)) + (eplot--hour-ticks x-ticks xs label-font label-font-size + x-label-format)))) + ;; We have to reduce both grid lines and labels. + (t + (eplot--get-time-ticks start end xs label-font label-font-size + x-label-format (caar limits))))))) + +(defun eplot--hour-ticks (x-ticks xs label-font label-font-size + x-label-format) + (let* ((eplot--pleasing-numbers '(1 3 6 12)) + (hour-ticks (mapcar (lambda (time) + (decoded-time-hour (decode-time time))) + x-ticks)) + (xv (eplot--compute-x-ticks + xs hour-ticks 'year x-label-format label-font label-font-size))) + (let ((tick-step (car xv)) + (label-step (cadr xv))) + (list x-ticks 'hour + (cl-loop for hour in hour-ticks + for val in x-ticks + collect (list val + (zerop (% hour tick-step)) + (zerop (% hour label-step)))))))) + +(defun eplot--int (number) + (cond + ((integerp number) + number) + ((= number (truncate number)) + (truncate number)) + (t + number))) + +(defun eplot--pleasing-numbers (number) + (let* ((digits (eplot--decimal-digits number)) + (one (e/ 1 (expt 10 digits))) + (two (e/ 2 (expt 10 digits))) + (five (e/ 5 (expt 10 digits)))) + (catch 'found + (while t + (when (< number one) + (throw 'found one)) + (setq one (* one 10)) + (when (< number two) + (throw 'found two)) + (setq two (* two 10)) + (when (< number five) + (throw 'found five)) + (setq five (* five 10)))))) + +(defun eplot-parse-and-insert (file) + "Parse and insert a file in the current buffer." + (interactive "fEplot file: ") + (let ((default-directory (file-name-directory file))) + (setq-local eplot--current-chart + (eplot--render (with-temp-buffer + (insert-file-contents file) + (eplot--parse-buffer)))))) + +(defun eplot-list-chart-headers () + "Pop to a buffer showing all chart parameters." + (interactive) + (pop-to-buffer "*eplot help*") + (let ((inhibit-read-only t)) + (special-mode) + (erase-buffer) + (insert "The following headers influence the overall\nlook of the chart:\n\n") + (eplot--list-headers eplot--chart-headers) + (ensure-empty-lines 2) + (insert "The following headers are per plot:\n\n") + (eplot--list-headers eplot--plot-headers) + (goto-char (point-min)))) + +(defun eplot--list-headers (headers) + (dolist (header (sort (copy-sequence headers) + (lambda (e1 e2) + (string< (car e1) (car e2))))) + (insert (propertize (capitalize (symbol-name (car header))) 'face 'bold) + "\n") + (let ((start (point))) + (insert (plist-get (cdr header) :doc) "\n") + (when-let ((valid (plist-get (cdr header) :valid))) + (insert "Possible values are: " + (mapconcat (lambda (v) (format "`%s'" v)) valid ", ") + ".\n")) + (indent-rigidly start (point) 2)) + (ensure-empty-lines 1))) + +(defvar eplot--transients + '((("Size" + ("sw" "Width") + ("sh" "Height") + ("sl" "Margin-Left") + ("st" "Margin-Top") + ("sr" "Margin-Right") + ("sb" "Margin-Bottom")) + ("Colors" + ("ca" "Axes-Color") + ("cb" "Border-Color") + ("cc" "Chart-Color") + ("cf" "Frame-Color") + ("cs" "Surround-Color") + ("ct" "Title-Color")) + ("Background" + ("bc" "Background-Color") + ("bg" "Background-Gradient") + ("bi" "Background-Image-File") + ("bv" "Background-Image-Cover") + ("bo" "Background-Image-Opacity"))) + (("General" + ("gt" "Title") + ("gf" "Font") + ("gs" "Font-Size") + ("ge" "Font-Weight") + ("go" "Format") + ("gw" "Frame-Width") + ("gh" "Header-File") + ("gi" "Min") + ("ga" "Max") + ("gm" "Mode") + ("gr" "Reset" eplot--reset-transient) + ("gv" "Save" eplot--save-transient)) + ("Axes, Grid & Legend" + ("xx" "X-Title") + ("xy" "Y-Title") + ("xf" "Label-Font") + ("xz" "Label-Font-Size") + ("xs" "X-Axis-Title-Space") + ("xl" "X-Label-Format") + ("xa" "Y-Label-Format") + ("il" "Grid-Color") + ("io" "Grid-Opacity") + ("ip" "Grid-Position") + ("ll" "Legend") + ("lb" "Legend-Background-Color") + ("lo" "Legend-Border-Color") + ("lc" "Legend-Color")) + ("Plot" + ("ps" "Style") + ("pc" "Color") + ("po" "Data-Column") + ("pr" "Data-format") + ("pn" "Fill-Border-Color") + ("pi" "Fill-Color") + ("pg" "Gradient") + ("pz" "Size") + ("pm" "Smoothing") + ("pb" "Bezier-Factor"))))) + +(defun eplot--define-transients () + (cl-loop for row in eplot--transients + collect (cl-coerce + (cl-loop for column in row + collect + (cl-coerce + (cons (pop column) + (mapcar #'eplot--define-transient column)) + 'vector)) + 'vector))) + +(defun eplot--define-transient (action) + (list (nth 0 action) + (nth 1 action) + ;; Allow explicit commands. + (or (nth 2 action) + ;; Make a command for altering a setting. + (lambda () + (interactive) + (eplot--execute-transient (nth 1 action)))))) + +(defun eplot--execute-transient (action) + (with-current-buffer (or eplot--data-buffer (current-buffer)) + (unless eplot--transient-settings + (setq-local eplot--transient-settings nil)) + (let* ((name (intern (downcase action))) + (spec (assq name (append eplot--chart-headers eplot--plot-headers))) + (type (plist-get (cdr spec) :type))) + ;; Sanity check. + (unless spec + (error "No such header type: %s" name)) + (setq eplot--transient-settings + (append + eplot--transient-settings + (list + (cons + name + (cond + ((eq type 'number) + (read-number (format "Value for %s (%s): " action type))) + ((string-match "color" (downcase action)) + (eplot--read-color (format "Value for %s (color): " action))) + ((string-match "font" (downcase action)) + (eplot--read-font-family + (format "Value for %s (font family): " action))) + ((string-match "gradient" (downcase action)) + (eplot--read-gradient action)) + ((string-match "file" (downcase action)) + (read-file-name (format "File for %s: " action))) + ((eq type 'symbol) + (intern + (completing-read (format "Value for %s: " action) + (plist-get (cdr spec) :valid) + nil t))) + (t + (read-string (format "Value for %s (string): " action)))))))) + (eplot-update-view-buffer)))) + +(defun eplot--read-gradient (action) + (format "%s %s %s %s" + (eplot--read-color (format "%s from color: " action)) + (eplot--read-color (format "%s to color: " action)) + (completing-read (format "%s direction: " action) + '(top-down bottom-up left-right right-left) + nil t) + (completing-read (format "%s position: " action) + '(below above) + nil t))) + +(defun eplot--reset-transient () + (interactive) + (with-current-buffer (or eplot--data-buffer (current-buffer)) + (setq-local eplot--transient-settings nil) + (eplot-update-view-buffer))) + +(defun eplot--save-transient (file) + (interactive "FSave parameters to file: ") + (when (and (file-exists-p file) + (not (yes-or-no-p "File exists; overwrite? "))) + (user-error "Exiting")) + (let ((settings (with-current-buffer (or eplot--data-buffer (current-buffer)) + eplot--transient-settings))) + (with-temp-buffer + (cl-loop for (name . value) in settings + do (insert (capitalize (symbol-name name)) ": " + (format "%s" value) "\n")) + (write-region (point-min) (point-max) file)))) + +(defvar-keymap eplot-control-mode-map + "RET" #'eplot-control-update + "TAB" #'eplot-control-next-field + "C-<tab>" #'eplot-control-next-field + "<backtab>" #'eplot-control-prev-field) + +(define-derived-mode eplot-control-mode special-mode "eplot control" + (setq-local completion-at-point-functions + (cons 'eplot--complete-control completion-at-point-functions)) + (add-hook 'before-change-functions #'eplot--process-text-input-before nil t) + (add-hook 'after-change-functions #'eplot--process-text-value nil t) + (add-hook 'after-change-functions #'eplot--process-text-input nil t) + (setq-local nobreak-char-display nil) + (setq truncate-lines t)) + +(defun eplot--complete-control () + ;; Complete headers names. + (when-let* ((input (get-text-property (point) 'input)) + (name (plist-get input :name)) + (spec (cdr (assq name (append eplot--plot-headers + eplot--chart-headers)))) + (start (plist-get input :start)) + (end (- (plist-get input :end) 2)) + (completion-ignore-case t)) + (skip-chars-backward " " start) + (or + (and (eq (plist-get spec :type) 'symbol) + (lambda () + (let ((valid (plist-get spec :valid))) + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end + (mapcar #'symbol-name valid)) + 'completion-attempted))) + (and (string-match "color" (symbol-name name)) + (lambda () + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end eplot--colors) + 'completion-attempted)) + (and (string-match "\\bfile\\b" (symbol-name name)) + (lambda () + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end (directory-files ".")) + 'completion-attempted)) + (and (string-match "\\bfont\\b" (symbol-name name)) + (lambda () + (completion-in-region + (save-excursion + (skip-chars-backward "^ " start) + (point)) + end + (eplot--font-families)) + 'completion-attempted))))) + +(defun eplot--read-font-family (prompt) + "Prompt for a font family, possibly offering autocomplete." + (let ((families (eplot--font-families))) + (if families + (completing-read prompt families) + (read-string prompt)))) + +(defun eplot--font-families () + (when (executable-find "fc-list") + (let ((fonts nil)) + (with-temp-buffer + (call-process "fc-list" nil t nil ":" "family") + (goto-char (point-min)) + (while (re-search-forward "^\\([^,\n]+\\)" nil t) + (push (downcase (match-string 1)) fonts))) + (seq-uniq (sort fonts #'string<))))) + +(defun eplot-control-next-input () + "Go to the next input field." + (interactive) + (when-let ((match (text-property-search-forward 'input))) + (goto-char (prop-match-beginning match)))) + +(defun eplot-control-update () + "Update the chart based on the current settings." + (interactive) + (let ((settings nil)) + (save-excursion + (goto-char (point-min)) + (while-let ((match (text-property-search-forward 'input))) + (when (equal (get-text-property (prop-match-beginning match) 'face) + 'eplot--input-changed) + (let* ((name (plist-get (prop-match-value match) :name)) + (spec (cdr (assq name (append eplot--plot-headers + eplot--chart-headers)))) + (value + (or (plist-get (prop-match-value match) :value) + (plist-get (prop-match-value match) :original-value)))) + (setq value (string-trim (string-replace "\u00A0" " " value))) + (push (cons name + (cl-case (plist-get spec :type) + (number + (string-to-number value)) + (symbol + (intern (downcase value))) + (symbol-list + (mapcar #'intern (split-string (downcase value)))) + (t + value))) + settings))))) + (with-current-buffer eplot--data-buffer + (setq-local eplot--transient-settings (nreverse settings)) + (eplot-update-view-buffer)))) + +(defvar eplot--column-width nil) + +(defun eplot-create-controls () + "Pop to a buffer that lists all parameters and allows editing." + (interactive) + (with-current-buffer (or eplot--data-buffer (current-buffer)) + (let ((settings eplot--transient-settings) + (data-buffer (current-buffer)) + (chart eplot--current-chart) + ;; Find the max width of all the different names. + (width (seq-max + (mapcar (lambda (e) + (length (cadr e))) + (apply #'append + (mapcar #'cdr + (apply #'append eplot--transients)))))) + (transients (mapcar #'copy-sequence + (copy-sequence eplot--transients)))) + (unless chart + (user-error "Must be called from an eplot buffer that has rendered a chart")) + ;; Rearrange the transients a bit for better display. + (let ((size (caar transients))) + (setcar (car transients) (caadr transients)) + (setcar (cadr transients) size)) + (pop-to-buffer "*eplot controls*") + (unless (eq major-mode 'eplot-control-mode) + (eplot-control-mode)) + (setq-local eplot--data-buffer data-buffer + eplot--column-width (+ width 12 2)) + (let ((inhibit-read-only t) + (before-change-functions nil) + (after-change-functions nil)) + (erase-buffer) + (cl-loop for column in transients + for cn from 0 + do + (goto-char (point-min)) + (end-of-line) + (cl-loop + for row in column + do + (if (zerop cn) + (when (not (bobp)) + (insert (format (format "%%-%ds" (+ width 14)) "") + "\n")) + (unless (= (count-lines (point-min) (point)) 1) + (if (eobp) + (progn + (insert (format (format "%%-%ds" (+ width 14)) "") + "\n") + (insert (format (format "%%-%ds" (+ width 14)) "") + "\n") + (forward-line -1) + (end-of-line)) + (forward-line 1) + (end-of-line)))) + ;; If we have a too-long input in the first column, + ;; then go to the next line. + (when (and (> cn 0) + (> (- (point) (pos-bol)) + (+ width 12 2))) + (forward-line 1) + (end-of-line)) + (insert (format (format "%%-%ds" (+ width 14)) + (propertize (pop row) 'face 'bold))) + (if (looking-at "\n") + (forward-line 1) + (insert "\n")) + (cl-loop + for elem in row + for name = (cadr elem) + for slot = (intern (downcase name)) + when (null (nth 2 elem)) + do + (let* ((object (if (assq slot eplot--chart-headers) + chart + (car (slot-value chart 'plots)))) + (value (format "%s" + (or (cdr (assq slot settings)) + (if (not (slot-boundp object slot)) + "" + (or (slot-value object slot) + "")))))) + (end-of-line) + ;; If we have a too-long input in the first column, + ;; then go to the next line. + (when (and (> cn 0) + (> (- (point) (pos-bol)) + (+ width 12 2))) + (forward-line 1) + (end-of-line)) + (when (and (> cn 0) + (bolp)) + (insert (format (format "%%-%ds" (+ width 14)) "") "\n") + (forward-line -1) + (end-of-line)) + (insert (format (format "%%-%ds" (1+ width)) name)) + (eplot--input slot value + (if (cdr (assq slot settings)) + 'eplot--input-changed + 'eplot--input-default)) + (if (looking-at "\n") + (forward-line 1) + (insert "\n"))))))) + (goto-char (point-min))))) + +(defface eplot--input-default + '((t :background "#505050" + :foreground "#a0a0a0" + :box (:line-width 1))) + "Face for eplot default inputs.") + +(defface eplot--input-changed + '((t :background "#505050" + :foreground "white" + :box (:line-width 1))) + "Face for eplot changed inputs.") + +(defvar-keymap eplot--input-map + :full t :parent text-mode-map + "RET" #'eplot-control-update + "TAB" #'eplot-input-complete + "C-a" #'eplot-move-beginning-of-input + "C-e" #'eplot-move-end-of-input + "C-k" #'eplot-kill-input + "C-<tab>" #'eplot-control-next-field + "<backtab>" #'eplot-control-prev-field) + +(defun eplot-input-complete () + "Complete values in inputs." + (interactive) + (cond + ((let ((completion-fail-discreetly t)) + (completion-at-point)) + ;; Completion was performed; nothing else to do. + nil) + ((not (get-text-property (point) 'input)) + (eplot-control-next-input)) + (t + (user-error "No completion in this field")))) + +(defun eplot-move-beginning-of-input () + "Move to the start of the current input field." + (interactive) + (if (= (point) (eplot--beginning-of-field)) + (goto-char (pos-bol)) + (goto-char (eplot--beginning-of-field)))) + +(defun eplot-move-end-of-input () + "Move to the end of the current input field." + (interactive) + (let ((input (get-text-property (point) 'input))) + (if (or (not input) + (= (point) (1- (plist-get input :end)))) + (goto-char (pos-eol)) + (goto-char (1+ (eplot--end-of-field)))))) + +(defun eplot-control-next-field () + "Move to the beginning of the next field." + (interactive) + (let ((input (get-text-property (point) 'input)) + (start (point))) + (when input + (goto-char (plist-get input :end))) + (let ((match (text-property-search-forward 'input))) + (if match + (goto-char (prop-match-beginning match)) + (goto-char start) + (user-error "No next field"))))) + +(defun eplot-control-prev-field () + "Move to the beginning of the previous field." + (interactive) + (let ((input (get-text-property (point) 'input)) + (start (point))) + (when input + (goto-char (plist-get input :start)) + (unless (bobp) + (forward-char -1))) + (let ((match (text-property-search-backward 'input))) + (unless match + (goto-char start) + (user-error "No previous field"))))) + +(defun eplot-kill-input () + "Remove the part of the input after point." + (interactive) + (let ((end (1+ (eplot--end-of-field)))) + (kill-new (string-trim (buffer-substring (point) end))) + (delete-region (point) end))) + +(defun eplot--input (name value face) + (let ((start (point)) + input) + (insert value) + (when (< (length value) 11) + (insert (make-string (- 11 (length value)) ?\u00A0))) + (put-text-property start (point) 'face face) + (put-text-property start (point) 'inhibit-read-only t) + (put-text-property start (point) 'input + (setq input + (list :name name + :size 11 + :is-default (eq face 'eplot--input-default) + :original-value value + :original-face face + :start (set-marker (make-marker) start) + :value value))) + (put-text-property start (point) 'local-map eplot--input-map) + ;; This seems like a NOOP, but redoing the properties like this + ;; somehow makes `delete-region' work better. + (set-text-properties start (point) (text-properties-at start)) + (insert (propertize " " 'face face + 'input input + 'inhibit-read-only t + 'local-map eplot--input-map)) + (plist-put input :end (point-marker)) + (insert " "))) + +(defun eplot--end-of-field () + (- (plist-get (get-text-property (point) 'input) :end) 2)) + +(defun eplot--beginning-of-field () + (plist-get (get-text-property (point) 'input) :start)) + +(defvar eplot--prev-deletion nil) + +(defun eplot--process-text-input-before (beg end) + (message "Before: %s %s" beg end) + (cond + ((= beg end) + (setq eplot--prev-deletion nil)) + ((> end beg) + (setq eplot--prev-deletion (buffer-substring beg end))))) + +(defun eplot--process-text-input (beg end _replace-length) + ;;(message "After: %s %s %s %s" beg end replace-length eplot--prev-deletion) + (when-let ((props (if eplot--prev-deletion + (text-properties-at 0 eplot--prev-deletion) + (if (get-text-property end 'input) + (text-properties-at end) + (text-properties-at beg)))) + (input (plist-get props 'input))) + ;; The action concerns something in the input field. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (size (plist-get input :size))) + (save-excursion + (set-text-properties beg (- (plist-get input :end) 2) props) + (goto-char (1- (plist-get input :end))) + (let* ((remains (- (point) (plist-get input :start) 1)) + (trim (- size remains 1))) + (if (< remains size) + ;; We need to add some padding. + (insert (apply #'propertize (make-string trim ?\u00A0) + props)) + ;; We need to delete some padding, but only delete + ;; spaces at the end. + (setq trim (abs trim)) + (while (and (> trim 0) + (eql (char-after (1- (point))) ?\u00A0)) + (delete-region (1- (point)) (point)) + (cl-decf trim)) + (when (> trim 0) + (eplot--possibly-open-column))))) + ;; We re-set the properties so that they are continguous. This + ;; somehow makes the machinery that decides whether we can kill + ;; a word work better. + (set-text-properties (plist-get input :start) + (1- (plist-get input :end)) props) + ;; Compute what the value is now. + (let ((value (buffer-substring-no-properties + (plist-get input :start) + (plist-get input :end)))) + (when (string-match "\u00A0+\\'" value) + (setq value (substring value 0 (match-beginning 0)))) + (plist-put input :value value))))) + +(defun eplot--possibly-open-column () + (save-excursion + (when-let ((input (get-text-property (point) 'input))) + (goto-char (plist-get input :end))) + (unless (looking-at " *\n") + (skip-chars-forward " ") + (while (not (eobp)) + (let ((text (buffer-substring (point) (pos-eol)))) + (delete-region (point) (pos-eol)) + (forward-line 1) + (if (eobp) + (insert (make-string eplot--column-width ?\s) text "\n") + (forward-char eplot--column-width) + (if (get-text-property (point) 'input) + (forward-line 1) + (insert text) + ;; We have to fix up the markers. + (save-excursion + (let* ((match (text-property-search-backward 'input)) + (input (prop-match-value match))) + (plist-put input :start + (set-marker (plist-get input :start) + (prop-match-beginning match))) + (plist-put input :end + (set-marker (plist-get input :end) + (+ (prop-match-end match) 1)))))))))))) + +(defun eplot--process-text-value (beg _end _replace-length) + (when-let* ((input (get-text-property beg 'input))) + (let ((inhibit-read-only t)) + (when (plist-get input :is-default) + (put-text-property (plist-get input :start) + (plist-get input :end) + 'face + (if (equal (plist-get input :original-value) + (plist-get input :value)) + 'eplot--input-default + 'eplot--input-changed)))))) + +(defun eplot--read-color (prompt) + "Read an SVG color." + (completing-read prompt eplot--colors)) + +(eval `(transient-define-prefix eplot-customize () + "Customize Chart" + ,@(eplot--define-transients))) + +(defun eplot--bezier (factor i points) + (cl-labels ((padd (p1 p2) + (cons (+ (car p1) (car p2)) (+ (cdr p1) (cdr p2)))) + (psub (p1 p2) + (cons (- (car p1) (car p2)) (- (cdr p1) (cdr p2)))) + (pscale (factor point) + (cons (* factor (car point)) (* factor (cdr point))))) + (let* ((start (elt points (1- i))) + (end (elt points i)) + (prev (if (< (- i 2) 0) + start + (elt points (- i 2)))) + (next (if (> (1+ i) (1- (length points))) + end + (elt points (1+ i)))) + (start-control-point + (padd start (pscale factor (psub end prev)))) + (end-control-point + (padd end (pscale factor (psub start next))))) + (list (car start-control-point) + (cdr start-control-point) + (car end-control-point) + (cdr end-control-point) + (car end) + (cdr end))))) + +;;; CSV Parsing Stuff. + +(defun eplot--csv-buffer-p () + (save-excursion + (goto-char (point-min)) + (let ((min 1.0e+INF) + (max -1.0e+INF) + (total 0) + (lines 0)) + (while (not (eobp)) + (let ((this 0)) + (while (search-forward "," (pos-eol) t) + (cl-incf total) + (cl-incf this)) + (forward-line 1) + (cl-incf lines) + (setq min (min min this) + max (max max this)))) + (let ((mid (e/ total lines))) + ;; If we have a comma on each line, and it's fairly evenly + ;; distributed, it's a CSV buffer. + (and (>= min 1) + (< (* mid 0.9) min) + (> (* mid 1.1) max)))))) + +(defun eplot--numericalp (value) + (string-match-p "\\`[-.0-9]*\\'" value)) + +(defun eplot--numberish (value) + (if (or (zerop (length value)) + (not (eplot--numericalp value))) + value + (string-to-number value))) + +(defun eplot--parse-csv-buffer () + (unless (fboundp 'pcsv-parse-buffer) + (user-error "You need to install the pcsv package to parse CSV files")) + (let ((csv (and (fboundp 'pcsv-parse-buffer) + ;; This repeated check is just to silence the byte + ;; compiler. + (pcsv-parse-buffer))) + names) + ;; Check whether the first line looks like a header. + (when (and (length> csv 1) + ;; The second line is all numbers... + (cl-every #'eplot--numericalp (nth 1 csv)) + ;; .. and the first line isn't. + (not (cl-every #'eplot--numericalp (nth 0 csv)))) + (setq names (pop csv))) + (list + (cons 'legend (and names "true")) + (cons :plots + (cl-loop + for column from 1 upto (1- (length (car csv))) + collect + (list (cons :headers + (list + (cons 'name (elt names column)) + (cons 'data-format + (cond + ((cl-every (lambda (e) (<= (length e) 4)) + (mapcar #'car csv)) + "year") + ((cl-every (lambda (e) (= (length e) 8)) + (mapcar #'car csv)) + "date") + (t + "number"))) + (cons 'color (eplot--vary-color "vary" (1- column))))) + (cons + :values + (cl-loop for line in csv + collect (list :x (eplot--numberish (car line)) + :value (eplot--numberish + (elt line column))))))))))) + +(declare-function org-element-parse-buffer "org-element") + +(defun eplot--parse-org-buffer () + (require 'org-element) + (let* ((table (nth 2 (nth 2 (org-element-parse-buffer)))) + (columns (cl-loop for cell in (nthcdr 2 (nth 2 table)) + collect (substring-no-properties (nth 2 cell)))) + (value-column (or (seq-position columns "value") 0)) + (date-column (seq-position columns "date"))) + `((:plots + ((:headers + ,@(and date-column '((data-format . "date")))) + (:values + ,@(cl-loop for row in (nthcdr 4 table) + collect + (let ((cells (cl-loop for cell in (nthcdr 2 row) + collect (substring-no-properties + (nth 2 cell))))) + (list :value (string-to-number (elt cells value-column)) + :x (string-to-number + (replace-regexp-in-string + "[^0-9]" "" (elt cells date-column))) + ))))))))) + +(provide 'eplot) + +;;; eplot.el ends here diff --git a/custom/gptel-prompts.el b/custom/gptel-prompts.el new file mode 100644 index 00000000..a2b266f2 --- /dev/null +++ b/custom/gptel-prompts.el @@ -0,0 +1,418 @@ +;;; gptel-prompts.el --- GPTel directive management using files -*- lexical-binding: t -*- + +;; Copyright (C) 2025 John Wiegley + +;; Author: John Wiegley <johnw@gnu.org> +;; Created: 19 May 2025 +;; Version: 1.0 +;; Keywords: ai gptel prompts +;; X-URL: https://github.com/jwiegley/dot-emacs +;; Package-Requires: ((emacs "24.1")) + +;; This file is NOT part of GNU Emacs. + +;;; License: + +;; 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, 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package provides enhanced prompt management capabilities for GPTel, +;; allowing you to organize and dynamically load AI prompts from external +;; files rather than hardcoding them in your Emacs configuration. + +;; Key Features: +;; +;; * Multi-format prompt support: Load prompts from .txt, .md, .org, .json, +;; .eld (Emacs Lisp data), .el (Emacs Lisp functions), and .poet/.jinja +;; (Prompt Poet/Jinja2 templates) +;; +;; * Template interpolation: Use Jinja2-style {{variable}} syntax with +;; customizable variables and dynamic functions +;; +;; * File watching: Automatically reload prompts when files change +;; +;; * Project-aware prompts: Automatically load project-specific conventions +;; from CONVENTIONS.md or CLAUDE.md files +;; +;; * Conversation format support: Handle multi-turn conversations with +;; system/user/assistant roles + +;; Setup: +;; +;; (use-package gptel-prompts +;; :after (gptel) +;; :custom +;; (gptel-prompts-directory "~/my-prompts") +;; :config +;; (gptel-prompts-update) +;; ;; Optional: auto-reload on file changes +;; (gptel-prompts-add-update-watchers)) + +;; File Formats: +;; +;; * Plain text (.txt, .md, .org): Used as-is for system prompts +;; * JSON (.json): Array of {role: "system/user/assistant", content: "..."} +;; * Emacs Lisp data (.eld): List format for conversations +;; * Emacs Lisp code (.el): Lambda functions for dynamic prompts +;; * Prompt Poet (.poet, .j2, .jinja, .jinja2): YAML + Jinja2 templates + +;; Template Variables: +;; +;; Use {{variable_name}} in your prompts. Variables can be defined in +;; `gptel-prompts-template-variables' or generated dynamically by functions +;; in `gptel-prompts-template-functions'. + +;; Project Integration: +;; +;; Add `gptel-prompts-project-conventions' to `gptel-directives' to +;; automatically load project-specific prompts from CONVENTIONS.md or +;; CLAUDE.md files in your project root. + +;;; Code: + +(require 'cl-lib) +(require 'cl-macs) +(require 'rx) +(require 'filenotify) +(require 'gptel) + +(defgroup gptel-prompts nil + "Helper library for managing GPTel prompts (aka directives)." + :group 'gptel) + +(defcustom gptel-prompts-directory "~/.emacs.d/prompts" + "*Directory where GPTel prompts are defined, one per file. + +Note that files can be of different types, which will cause them to be +represented as directives differently. See `gptel-prompts-file-regexp' +for more information." + :type 'file + :group 'gptel-prompts) + +(defcustom gptel-prompts-file-regexp + (rx "." (group + (or "txt" + "md" + "org" + "eld" + "el" + (seq "j" (optional "inja") (optional "2")) + "poet" + "json")) + string-end) + "*Directory where GPTel prompts are defined, one per file. + +Note that files can be of different types, which will cause them +to be represented as directives differently: + + .txt, .md, .org Purely textual prompts that are used as-is + .eld Must be a Lisp list represent a conversation: + SYSTEM, USER, ASSISTANT, [USER, ASSISTANT, ...] + .el Must evaluate to a Lisp function + .poet See https://github.com/character-ai/prompt-poet + .json JSON list of role-assigned prompts" + :type 'regexp + :group 'gptel-prompts) + +(defcustom gptel-prompts-template-variables nil + "*An alist of names to strings used during template expansion. + +Example: + ((\"name\" . \"John\") + (\"hobbies\" . \"Emacs\")) + +These would referred to using {{ name }} and {{ hobbies }} in the +prompt template." + :type '(alist :key-type string :value-type string) + :group 'gptel-prompts) + +(defcustom gptel-prompts-template-functions + '(gptel-prompts-add-current-time) + "*Set of functions run when a template prompt is used. + +These are called when the template is going to be used by +`gptel-request'. Each function receives the name of the template file, +and must return either nil or an alist of variable values to prepend to +`gptel-prompts-template-variables'. See that variable's documentation +for the expected format." + :type '(list function) + :group 'gptel-prompts) + +(defun gptel-prompts-process-prompts (prompts) + "Convert from a list of PROMPTS in dialog format, to GPTel. + +For example: + + (((role . \"system\") + (content . \"Sample\") + (name . \"system instructions\")) + ((role . \"system\") + (content . \"Sample\") + (name . \"further system instructions\")) + ((role . \"user\") + (content . \"Sample\") + (name . \"User message\")) + ((role . \"assistant\") + (content . \"Sample\") + (name . \"Model response\")) + ((role . \"user\") + (content . \"Sample\") + (name . \"Second user message\"))) + +Becomes: + + (\"system instructions\nfurther system instructions\" + (prompt \"User message\") + (response \"Model response\") + (prompt \"Second user message\"))" + (let ((system "") result) + (dolist (prompt prompts) + (let ((content (alist-get 'content prompt)) + (role (alist-get 'role prompt))) + (cond + ((string= role "system") + (setq system (if (string-empty-p system) + content + (concat system "\n" content)))) + ((string= role "user") + (setq result (cons (list 'prompt content) result))) + ((string= role "assistant") + (setq result (cons (list 'response content) result))) + ((string= role "tool") + (error "Tools not yet supported in Poet prompts")) + (t + (error "Role not recognized in prompt: %s" + (pp-to-string prompt)))))) + (cons system (nreverse result)))) + +(defun gptel-prompts-interpolate (prompt &optional file) + "Expand Jinja-style references to `gptel-prompts-template-variables'. +The references are expected in the string PROMPT, possibly from FILE. +`gptel-prompts-template-functions' are called to add to this list as +well, so some variables can be dynamic in nature." + (require 'templatel) + (let ((vars (apply #'append + (mapcar #'(lambda (f) (funcall f file)) + gptel-prompts-template-functions)))) + (templatel-render-string + prompt + (cl-remove-duplicates + (append vars gptel-prompts-template-variables) + :test #'string= :from-end t :key #'car)))) + +(defun gptel-prompts-interpolate-buffer () + "Expand Jinja-style references to `gptel-prompts-template-variables'. +See `gptel-prompts-interpolate'. +This function can be added to `gptel-prompt-transform-functions'." + (let ((replacement (gptel-prompts-interpolate (buffer-string)))) + (delete-region (point-min) (point-max)) + (insert replacement))) + +(defun gptel-prompts-poet (file) + "Read Yaml + Jinja FILE in prompt-poet format." + (require 'yaml) + (gptel-prompts-process-prompts + (mapcar #'yaml--hash-table-to-alist + (yaml-parse-string + (gptel-prompts-interpolate + (with-temp-buffer + (insert-file-contents file) + (buffer-string)) + file))))) + +(defun gptel-prompts-process-file (file) + "Process FILE and return appropriate content. + +FILE is a string path to the file to be processed. + +Handles different file types based on extension: +- .eld files: Read as Emacs Lisp data, must evaluate to a list +- .el files: Read as Emacs Lisp code, must evaluate to a function/lambda +- .json files: Parse as JSON array and process as prompts via + `gptel-prompts-process-prompts' +- .j2/.jinja/.jinja2/.poet files: Return lambda that calls + `gptel-prompts-poet' with FILE +- Other files: Return trimmed file contents as plain text string + +Returns the processed content in the appropriate format for each file +type. Signals an error if the file content doesn't match expected format +for typed files." + (cond ((string-match "\\.eld\\'" file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (let ((lst (read (current-buffer)))) + (if (listp lst) + lst + (error "Emacs Lisp data prompts must evaluate to a list"))))) + ((string-match "\\.el\\'" file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (let ((func (read (current-buffer)))) + (if (and (functionp func) + (listp func) + (eq 'lambda (car func))) + func + (error "Emacs Lisp prompts must evaluate to a function/lambda"))))) + ((string-match "\\.json\\'" file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (let ((conversation (json-read))) + (if (vectorp conversation) + (gptel-prompts-process-prompts (seq-into conversation 'list)) + (error "Emacs Lisp prompts must evaluate to a list"))))) + ((string-match "\\.\\(j\\(inja\\)?2?\\|poet\\)\\'" file) + `(lambda () (gptel-prompts-poet ,file))) + (t + (with-temp-buffer + (insert-file-contents file) + (string-trim (buffer-string)))))) + +(defun gptel-prompts-read-directory (dir) + "Read prompts from directory DIR and establish them in `gptel-directives'." + (cl-loop for file in (directory-files dir t gptel-prompts-file-regexp) + collect (cons (intern (file-name-sans-extension + (file-name-nondirectory file))) + (gptel-prompts-process-file file)))) + +(defun gptel-prompts-update () + "Update `gptel-directives' from files in `gptel-prompts-directory'." + (interactive) + (dolist (prompt (gptel-prompts-read-directory gptel-prompts-directory)) + (setq gptel-directives + (cl-delete-if #'(lambda (x) (eq (car x) (car prompt))) + gptel-directives)) + (add-to-list 'gptel-directives prompt))) + +(defun gptel-prompts-add-current-time (_file) + "Add the current time as a variable for Poet interpolation." + `(("current_time" . ,(format-time-string "%F %T")))) + +(defun gptel-prompts-add-update-watchers () + "Watch all files in DIR and run CALLBACK when any is modified." + (let ((watches (list (file-notify-add-watch + gptel-prompts-directory '(change) + #'(lambda (&rest _events) + (gptel-prompts-update)))))) + (dolist (file (directory-files gptel-prompts-directory + t gptel-prompts-file-regexp)) + (when (file-regular-p file) + (push (file-notify-add-watch file '(change) + #'(lambda (&rest _events) + (gptel-prompts-update))) + watches))) + watches)) + +(defvar gptel-prompts--project-conventions-alist nil + "Alist mapping projects to project conventions for LLMs.") + +(defcustom gptel-prompts-project-files + '("CONVENTIONS.md" + "CLAUDE.md" + "AGENTS.md" + (".github" . "copilot-instructions\\.md") + (".instructions.d" . "^.*\\.md$") + ".instructions.md") + "A list of files or directories with prompts for the current project. +Entries can be strings (file/directory names) or cons cells where the +CAR is a directory path and the CDR is either a regexp string or a +filter function for selecting which files in that directory should be +chosen. + +The first matching rule in the list for a given project is used, with +the rest ignored. + +If a directory is specified without a filter (as a plain string), all +markdown files within it will be aggregated into a single prompt." + :type '(repeat (choice file directory + (cons directory (choice regexp function)))) + :group 'gptel-prompts) + +(defun gptel-prompts--read-directory-filtered (dir regexp-or-function) + "Read files from DIR for which REGEXP-OR-FUNCTION is a match." + (when (and (file-directory-p dir) + (file-readable-p dir)) + (let ((files + (cl-remove-if-not + (cond + ((functionp regexp-or-function) + (lambda (f) + (funcall regexp-or-function (file-name-nondirectory f)))) + ((stringp regexp-or-function) + (lambda (f) + (string-match-p regexp-or-function (file-name-nondirectory f)))) + (t (error "Invalid filter: %s" regexp-or-function))) + (directory-files dir t "^[^.].*" t)))) + (unless (null files) + (mapconcat + (lambda (file) + (when (and (file-regular-p file) + (file-readable-p file)) + (with-temp-buffer + (insert-file-contents file) + (buffer-string)))) + files "\n\n"))))) + +(defun gptel-prompts--read-directory (dir) + "Read all Markdown files from DIR, concated together." + (let ((contents + (mapconcat + (lambda (file) + (when (and (file-regular-p file) + (file-readable-p file)) + (with-temp-buffer + (insert-file-contents file) + (buffer-string)))) + (directory-files dir t "^[^.].*\\.md$" t) + "\n\n"))) + (unless (string-empty-p contents) + contents))) + +(defun gptel-prompts-project-conventions () + "System prompt is obtained from project CONVENTIONS. +This function should be added to `gptel-directives'. To replace +the default directive, use: + + (setf (alist-get \\'default gptel-directives) + #\\'gptel-project-conventions)" + (when-let* ((project (project-current)) + (root (project-root project))) + (with-memoization + (alist-get root gptel-prompts--project-conventions-alist + nil nil #'equal) + (or (cl-loop + for item in gptel-prompts-project-files + for path = (expand-file-name + (if (consp item) (car item) item) + root) + when (file-readable-p path) + return (cond + ((consp item) + (gptel-prompts--read-directory-filtered (car item) (cdr item))) + ((file-directory-p path) + (gptel-prompts--read-directory path)) + (t + (with-temp-buffer + (insert-file-contents path) + (buffer-string))))) + "You are a helpful assistant. Respond concisely.")))) + +(provide 'gptel-prompts) + +;;; gptel-prompts.el ends here diff --git a/custom/org-checklist.el b/custom/org-checklist.el new file mode 100644 index 00000000..e7d9b468 --- /dev/null +++ b/custom/org-checklist.el @@ -0,0 +1,153 @@ +;;; org-checklist.el --- org functions for checklist handling -*- lexical-binding: t; -*- + +;; Copyright (C) 2008-2014, 2021 James TD Smith + +;; Author: James TD Smith (@ ahktenzero (. mohorovi cc)) +;; Version: 1.0 +;; Keywords: org, checklists +;; +;; 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 3, 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides some functions for handing repeated tasks which involve +;; checking off a list of items. By setting the RESET_CHECK_BOXES property in an +;; item, when the TODO state is set to done all checkboxes under that item are +;; cleared. If the LIST_EXPORT_BASENAME property is set, a file will be created +;; using the value of that property plus a timestamp, containing all the items +;; in the list which are not checked. Additionally the user will be prompted to +;; print the list. +;; +;; I use this for to keep track of stores of various things (food stores, +;; components etc) which I check periodically and use the exported list of items +;; which are not present as a shopping list. +;; +;;; Usage: +;; (require 'org-checklist) +;; +;; Set the RESET_CHECK_BOXES and LIST_EXPORT_BASENAME properties in items as +;; needed. +;; +;; https://orgmode.org/worg/org-contrib/org-checklist.html +;; https://git.sr.ht/~bzg/org-contrib/blob/master/lisp/org-checklist.el +;; +;;; Code: +(require 'org) +(defvar org-state) +;; FIXME: This library requires +;; https://git.savannah.gnu.org/cgit/a2ps.git/tree/contrib/emacs/a2ps-print.el file +;; It is a part of a2ps distribution. +(load "a2ps-print" 'no-error) +(defvar a2ps-switches) +(declare-function a2ps-buffer "a2ps-print" (argp)) + +(setq org-default-properties (cons "RESET_CHECK_BOXES" (cons "LIST_EXPORT_BASENAME" org-default-properties))) + +(defgroup org-checklist nil + "Extended checklist handling for org" + :tag "Org-checklist" + :group 'org) + +(defcustom org-checklist-export-time-format "%Y%m%d%H%M" + "The format of timestamp appended to LIST_EXPORT_BASENAME to + make the name of the export file." + :link '(function-link format-time-string) + :group 'org-checklist + :type 'string) + +(defcustom org-checklist-export-function 'org-export-as-ascii + "function used to prepare the export file for printing" + :group 'org-checklist + :type '(radio (function-item :tag "ascii text" org-export-as-ascii) + (function-item :tag "HTML" org-export-as-html) + (function-item :tag "LaTeX" :value org-export-as-latex) + (function-item :tag "XOXO" :value org-export-as-xoxo))) + +(defcustom org-checklist-export-params nil + "options for the export function file for printing" + :group 'org-checklist + :type '(repeat string)) + +(defcustom org-checklist-a2ps-params nil + "options for a2ps for printing" + :group 'org-checklist + :type '(repeat string)) + +(defun org-reset-checkbox-state-maybe () + "Reset all checkboxes in an entry if the `RESET_CHECK_BOXES' property is set" + (interactive "*") + (if (org-entry-get (point) "RESET_CHECK_BOXES") + (org-reset-checkbox-state-subtree))) + + +(defun org-make-checklist-export () + "Produce a checklist containing all unchecked items from a list +of checkbox items" + (interactive "*") + (when (org-entry-get (point) "LIST_EXPORT_BASENAME") + (let* ((export-file (concat (org-entry-get (point) "LIST_EXPORT_BASENAME" nil) + "-" (format-time-string + org-checklist-export-time-format) + ".org")) + (print (pcase (org-entry-get (point) "PRINT_EXPORT" nil) + (`(or "" "nil" nil) nil) + (`nil (y-or-n-p "Print list? ")) + (_ t))) + exported-lines + (title "Checklist export")) + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (org-update-checkbox-count-maybe) + (if (fboundp 'org-fold-show-subtree) + (org-fold-show-subtree) + (with-no-warnings (org-show-subtree))) + (goto-char (point-min)) + (when (looking-at org-complex-heading-regexp) + (setq title (match-string 4))) + (goto-char (point-min)) + (let ((end (point-max))) + (while (< (point) end) + (when (and (org-at-item-checkbox-p) + (or (string= (match-string 0) "[ ]") + (string= (match-string 0) "[-]"))) + (setq exported-lines + (nconc exported-lines (list (thing-at-point 'line))))) + (beginning-of-line 2))) + (set-buffer (get-buffer-create export-file)) + (org-insert-heading) + (insert (or title export-file) "\n") + (dolist (entry exported-lines) (insert entry)) + (org-update-checkbox-count-maybe) + (write-file export-file) + (when print + (funcall org-checklist-export-function + org-checklist-export-params) + (let* ((current-a2ps-switches a2ps-switches) + (a2ps-switches (append current-a2ps-switches + org-checklist-a2ps-params))) + (a2ps-buffer nil)))))))) + +(defun org-checklist () + (when (member org-state org-done-keywords) ;; org-state dynamically bound in org.el/org-todo + (org-make-checklist-export) + (org-reset-checkbox-state-maybe))) + +(add-hook 'org-after-todo-state-change-hook 'org-checklist) + +(provide 'org-checklist) + +;;; org-checklist.el ends here diff --git a/custom/pdf-continuous-scroll-mode-latest.el b/custom/pdf-continuous-scroll-mode-latest.el new file mode 100644 index 00000000..b05890c4 --- /dev/null +++ b/custom/pdf-continuous-scroll-mode-latest.el @@ -0,0 +1,1046 @@ +;;; pdf-continuous-scroll-mode.el --- Continuous scroll for pdf-tools -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Daniel Laurens Nicolai + +;; Author: Daniel Laurens Nicolai <dalanicolai@gmail.com> +;; Version: 0 +;; Keywords: pdf-tools, +;; Package-Requires: ((emacs "27.1") (pdf-tools "1.0")) +;; URL: https://github.com/dalanicolai/pdf-continuous-scroll-mode.el + + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Usage: + +;;; Code: +(require 'pdf-tools) +(require 'pdf-annot) +(require 'image-mode) +(require 'svg) +(require 'cl-lib) + +(defgroup book nil + "Bookroll customizations.") + +(defcustom book-scroll-fraction 32 + "The scroll step size in 1/fraction of page." + :type 'integer) + +(defcustom book-page-vertical-margin 5 + "The size of the vertical margins around a page." + :type 'integer) + +(defcustom book-reverse-scrolling nil + "Reverse default scrolling direction" + :group 'pdf-continuous-scroll + :type 'boolean) + +(defvar-local book-number-of-pages 0) +(defvar-local book-contents-end-pos 0) + +;; (defmacro book-current-page (&optional win) +;; `(image-mode-window-get 'page ,win)) +(defmacro book-overlays (&optional window) `(image-mode-window-get 'overlays ,window)) +(defmacro book-image-sizes (&optional window) `(image-mode-window-get 'image-sizes ,window)) +(defmacro book-image-positions (&optional window) `(image-mode-window-get 'image-positions ,window)) +(defmacro book-currently-displayed-pages (&optional window) `(image-mode-window-get 'displayed-pages ,window)) + +;; the following function only exists for backward compatibility +(defun pdf-continuous-scroll-mode () + (print "This is a new version of pdf-continuous-scroll-mode.el +Despite the name, the `pdf-continuous-scroll-mode' itself has +been removed. You should make sure that you remove the function +from the pdf-view-mode-hook. If you prefer to use the previous +'2-buffer' version, then you can download and load the file from +the previous commit at +https://github.com/dalanicolai/pdf-continuous-scroll-mode.el/tree/615dcfbf7a9b2ff602a39da189e5eb766600047f.")) + +(make-obsolete 'pdf-continuous-scroll-mode nil "3 February 2022") + +(defun image-mode-winprops (&optional window cleanup) + "Return winprops of WINDOW. +A winprops object has the shape (WINDOW . ALIST). +WINDOW defaults to `selected-window' if it displays the current buffer, and +otherwise it defaults to t, used for times when the buffer is not displayed." + (cond ((null window) + (setq window + (if (eq (current-buffer) (window-buffer)) (selected-window) t))) + ((eq window t)) + ((not (windowp window)) + (error "Not a window: %s" window))) + (when-let (o (nth 272 (assq 'overlays (assq window image-mode-winprops-alist)))) + (message "%s" (image-property (overlay-get o 'display) :type))) + (when cleanup + (setq image-mode-winprops-alist + (delq nil (mapcar (lambda (winprop) + (let ((w (car-safe winprop))) + (if (or (not (windowp w)) (window-live-p w)) + winprop))) + image-mode-winprops-alist)))) + (let ((winprops (assq window image-mode-winprops-alist))) + ;; For new windows, set defaults from the latest. + (if winprops + ;; Move window to front. + (setq image-mode-winprops-alist + (cons winprops (delq winprops image-mode-winprops-alist))) + (setq winprops (cons window + (copy-alist (cdar image-mode-winprops-alist)))) + ;; Add winprops before running the hook, to avoid inf-loops if the hook + ;; triggers window-configuration-change-hook. + (setq image-mode-winprops-alist + (cons winprops image-mode-winprops-alist)) + (run-hook-with-args 'image-mode-new-window-functions winprops)) + winprops)) + +;; We overwrite the following image-mode function to make it also +;; reapply winprops when the overlay has the 'invisible property +(defun image-get-display-property () + (or (get-char-property (point-min) 'display + ;; There might be different images for different displays. + (if (eq (window-buffer) (current-buffer)) + (selected-window))) + (get-char-property (point-min) 'invisible + ;; There might be different images for different displays. + (if (eq (window-buffer) (current-buffer)) + (selected-window))))) + +(defun image-set-window-vscroll (vscroll) + (setf (image-mode-window-get 'vscroll) vscroll + (image-mode-window-get 'relative-vscroll) (/ (float vscroll) + (car (last (book-image-positions))))) + (set-window-vscroll (selected-window) vscroll t)) + +(defun image-mode-reapply-winprops () + ;; When set-window-buffer, set hscroll and vscroll to what they were + ;; last time the image was displayed in this window. + (when (listp image-mode-winprops-alist) + ;; Beware: this call to image-mode-winprops can't be optimized away, + ;; because it not only gets the winprops data but sets it up if needed + ;; (e.g. it's used by doc-view to display the image in a new window). + (let* ((winprops (image-mode-winprops nil t)) + (hscroll (image-mode-window-get 'hscroll winprops)) + (vscroll (round (* (image-mode-window-get 'relative-vscroll winprops) + (car (last (book-image-positions))))))) + (when (image-get-display-property) ;Only do it if we display an image! + (if hscroll (set-window-hscroll (selected-window) hscroll)) + (if vscroll (set-window-vscroll (selected-window) vscroll t)))))) + +(defun book-create-image-positions (image-sizes) + (let ((sum 0) + (positions (list 0))) + (dolist (s image-sizes) + ;; the margin is added on both sides + (setq sum (+ sum (cdr s) (* 2 (or book-page-vertical-margin pdf-view-image-relief)))) + (push sum positions)) + (nreverse positions))) + +(defun book-create-overlays-list (winprops) + "Create list of overlays spread out over the buffer contents. +Pass non-nil value for include-first when the buffer text starts with a match." + ;; first overlay starts at 1 + ;; (setq book-contents-end-pos (goto-char (point-max))) + (goto-char book-contents-end-pos) + (let ((eobp (eobp)) + overlays) + (if (eobp) + (insert " ") + (forward-char)) + (push (make-overlay (1- (point)) (point)) overlays) + (let ((overlays-list (dotimes (_ (1- (length (book-image-sizes))) (nreverse overlays)) + (if eobp + (insert "\n ") + (forward-char 2)) + (push (make-overlay (1- (point)) (point)) overlays)))) + ;; all windows require their overlays to apply to the window only because + ;; the windows and therefore bookroll's might have different sizes (see + ;; `overlay-properties') + (mapc (lambda (o) (overlay-put o 'window (car winprops))) overlays-list) + (image-mode-window-put 'overlays overlays-list winprops))) + (goto-char (point-min)) + (set-buffer-modified-p nil)) + +(defun book-create-empty-page (size) + (pcase-let* ((`(,w . ,h) size)) + (svg-image (svg-create w h) + :margin (cons 0 book-page-vertical-margin)))) + +(defun book-create-placeholders () + (let* ((constant-size (cl-every #'eql (book-image-sizes) (cdr (book-image-sizes)))) + (ph (when constant-size (book-create-empty-page (car (book-image-sizes)))))) + (dotimes (i (length (book-image-sizes))) + ;; (let ((p (1+ i)));; shift by 1 to match with page numbers + ;; (overlay-put (nth i overlays-list) 'display (or ph (book-create-empty-page (nth i (book-image-sizes)))))))) + (overlay-put (nth i (book-overlays)) 'display (or ph (book-create-empty-page (nth i (book-image-sizes)))))))) + +(defun book-current-page () + (interactive) + (let ((i 0) + (cur-pos (window-vscroll nil t))) + (while (<= (nth (1+ i) (book-image-positions)) (+ cur-pos (/ (window-pixel-height) 2))) + (setq i (1+ i))) + (1+ i))) + +(defun book-page-triplet (page) + ;; first handle the cases when the doc has only one or two pages + (pcase (pdf-info-number-of-pages) + (1 '(1)) + (2 '(1 2)) + (_ (pcase page + (1 '(1 2)) + ((pred (= book-number-of-pages)) (list page (- page 1))) + (p (list (- p 1) p (+ p 1))))))) + +(defun book-remove-page-image (page) + ;; remove page image means insert back empty image (placeholder) + (overlay-put (nth (1- page) (book-overlays)) + 'display + (book-create-empty-page (nth (1- page) (book-image-sizes))))) + + +(defun book-scroll-to-page (page) + (interactive "n") + ;; (book-update-page-triplet page) + (let* ((elt (1- page))) + (set-window-vscroll nil + (+ (nth elt (book-image-positions)) + (or book-page-vertical-margin pdf-view-image-relief)) + t))) + +(defvar pdf-continuous-suppress-introduction nil) + +(define-derived-mode pdf-view-mode special-mode "PDFView" + "Major mode in PDF buffers. + +PDFView Mode is an Emacs PDF viewer. It displays PDF files as +PNG images in Emacs buffers." + :group 'pdf-view + :abbrev-table nil + :syntax-table nil + ;; Setup a local copy for remote files. + (when (and (or jka-compr-really-do-compress + (let ((file-name-handler-alist nil)) + (not (and buffer-file-name + (file-readable-p buffer-file-name))))) + (pdf-tools-pdf-buffer-p)) + (let ((tempfile (pdf-util-make-temp-file))) + (write-region nil nil tempfile nil 'no-message) + (setq-local pdf-view--buffer-file-name tempfile))) + ;; Decryption needs to be done before any other function calls into + ;; pdf-info.el (e.g. from the mode-line during redisplay during + ;; waiting for process output). + (pdf-view-decrypt-document) + + ;; Setup scroll functions + (if (boundp 'mwheel-scroll-up-function) ; not --without-x build + (setq-local mwheel-scroll-up-function + #'pdf-view-scroll-up-or-next-page)) + (if (boundp 'mwheel-scroll-down-function) + (setq-local mwheel-scroll-down-function + #'pdf-view-scroll-down-or-previous-page)) + + ;; Clearing overlays + (add-hook 'change-major-mode-hook + (lambda () + (remove-overlays (point-min) (point-max) 'pdf-view t)) + nil t) + (remove-overlays (point-min) (point-max) 'pdf-view t) ;Just in case. + + ;; Setup other local variables. + (setq-local mode-line-position + '(" P" (:eval (number-to-string (pdf-view-current-page))) + ;; Avoid errors during redisplay. + "/" (:eval (or (ignore-errors + (number-to-string (pdf-cache-number-of-pages))) + "???")))) + (setq-local auto-hscroll-mode nil) + (setq-local pdf-view--server-file-name (pdf-view-buffer-file-name)) + ;; High values of scroll-conservatively seem to trigger + ;; some display bug in xdisp.c:try_scrolling . + (setq-local scroll-conservatively 0) + (setq-local cursor-type nil) + (setq-local buffer-read-only t) + (setq-local view-read-only nil) + (setq-local bookmark-make-record-function + 'pdf-view-bookmark-make-record) + (setq-local revert-buffer-function #'pdf-view-revert-buffer) + ;; No auto-save at the moment. + (setq-local buffer-auto-save-file-name nil) + ;; Disable image rescaling. + (when (boundp 'image-scaling-factor) + (setq-local image-scaling-factor 1)) + ;; No undo at the moment. + (unless buffer-undo-list + (buffer-disable-undo)) + ;; Enable transient-mark-mode, so region deactivation when quitting + ;; will work. + (setq-local transient-mark-mode t) + ;; In Emacs >= 24.4, `cua-copy-region' should have been advised when + ;; loading pdf-view.el so as to make it work with + ;; pdf-view-mode. Disable cua-mode if that is not the case. + ;; FIXME: cua-mode is a global minor-mode, but setting cua-mode to + ;; nil seems to do the trick. + (when (and (bound-and-true-p cua-mode) + (version< emacs-version "24.4")) + (setq-local cua-mode nil)) + + (setq-local book-contents-end-pos (point-max)) + (setq-local book-number-of-pages (pdf-cache-number-of-pages)) + + (add-hook 'window-configuration-change-hook + 'pdf-view-redisplay-some-windows nil t) + (add-hook 'deactivate-mark-hook 'pdf-view-deactivate-region nil t) + (add-hook 'write-contents-functions + 'pdf-view--write-contents-function nil t) + (add-hook 'kill-buffer-hook 'pdf-view-close-document nil t) + (pdf-view-add-hotspot-function + 'pdf-view-text-regions-hotspots-function -9) + + ;; Keep track of display info + (add-hook 'image-mode-new-window-functions + 'pdf-view-new-window-function nil t) + (image-mode-setup-winprops) + + (unless pdf-continuous-suppress-introduction + (pdf-continuous-introduce)) + + ;; Issue a warning in the future about incompatible modes. + (run-with-timer 1 nil (lambda (buffer) + (when (buffer-live-p buffer) + (pdf-view-check-incompatible-modes buffer) + + (unless pdf-continuous-suppress-introduction + (switch-to-buffer "*pdf-continuous-introduction*")))) + (current-buffer))) + +(defun pdf-continuous-toggle-message () + (interactive) + (setq pdf-continuous-suppress-introduction + (if pdf-continuous-suppress-introduction + nil + (message "pdf-continuous message suppressed") + t))) + +(defun pdf-continuous-introduce () + (with-current-buffer (get-buffer-create "*pdf-continuous-introduction*") + (insert "NEW PDF CONTINUOUS SCROLL: INTRODUCTION 3 February 2022 + +Welcome to the new pdf-continuous-scroll-mode, now finally +providing continuous scroll in a single buffer. 🎉🍾 + +Despite the name, the `pdf-continuous-scroll-mode' itself has +been removed. You should make sure that you remove the function +from the pdf-view-mode-hook. If you prefer to use the previous +'2-buffer' version, then you can download and load the file from +the previous commit at +https://github.com/dalanicolai/pdf-continuous-scroll-mode.el/tree/615dcfbf7a9b2ff602a39da189e5eb766600047f. + +My apologies for this rude interruption, however this behavior is +only temporary (until this functionality gets merged into +pdf-tools in May or so). + +There are two reasons for this interruption: + +- second, to inform you about how to obtain or set indicators + allowing you to differentiate between the pages. The default + design uses the customizable `book-page-vertical-margin' + variable, which sets vertical margins for the page images. If + your Emacs theme has a different background color than your + books page color, this will nicely indicate the page + 'transitions'. However, if the background color and the page + color are the same, then you can set the + `book-page-vertical-margin' to 0 and instead set + `pdf-view-image-relief' to some non negative number to help you + differentiate between the pages. + + Also, redisplay (e.g. splitting buffers), does not work + flawlessly yet, but you can simply split and start scrolling, + or use `M-x pdf-view-goto-page', in the buffers and the display + problem will 'fix itself'. (To fix the root of the problem, I + probably have to make `image-mode-reapply-winprops' use + 'relative' instead of `absolute' vscroll. Also, I have noticed, + that, while in Spacemacs redisplay works almost fine, in + vanilla Emacs the vscroll does not get restored despite + `image-mode-reapply-winprops' getting called.) + +- first, I would like to inform you that I would be very happy + with any small donation if you can afford it (I guess most + Emacs PDF-tools users are students). Despite the low number of + lines of code here (of which a large part is adapted from + pdf-view.el), creating this package has cost me a lot of + effort. I think writing the code has only cost me about 0.001 + percent of the time, while most of the time has been invested + in investigating pdf-tools and doc-view and their very opaque + and non-trivial display mechanisms. + + You can find donate buttons on the + pdf-continuous-scroll-mode.el github page + (https://github.com/dalanicolai/pdf-continuous-scroll-mode.el). + + With the help of donations I could work on fixing bugs and on + improving pdf-tools and image-mode documentation (which are + really great packages, but they lack documentation. If about 50 + lines of documentation had been available, it would probably + have saved me two/three weeks of work). + + Besides that, I have also written an alternative pdf + server (https://github.com/vedang/pdf-tools/pull/61) using + python with the excellent pymupdf + package (https://pymupdf.readthedocs.io/en/latest/). Again in + that case, writing the code was only a tiny fraction of the + total work. This alternative server provides new kinds of + annotation functionality like line, arrow and free text + annotations. Furthermore, it offers the possibility to send + python code directly to the server, so that it is possible to + use the full features provided by pymupdf. + + The combined work has cost me almost two months of almost full + time investigating, debugging, iterating. + + To save you a long interesting story, I just mention that + currently I am dependent on others for paying my rent and my + food. Otherwise, I would have been even more happy by + sharing/donating this package without asking for any donations. + + I have created a few more packages that can be found and are + described at my github profile + page (https://github.com/dalanicolai). + +You can toggle off this message by doing `M-x +pdf-continuous-toggle-message' or setting +`pdf-continuous-suppress-introduction' to non-nil in your +dotfile. Or you can simply close this buffer and start reading. + +Thank you. +Daniel + +Happy scrolling!" +) + (goto-char (point-min)))) + + +;; Despite what its docstring says, this function does not go to page in all +;; `pdf-view' windows when WINDOW is non-nil. +(defun pdf-view-goto-page (page &optional window) + "Go to PAGE in PDF. + +If optional parameter WINDOW, go to PAGE in all `pdf-view' +windows." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (read-number "Page: ")))) + (unless (and (>= page 1) + (<= page (pdf-cache-number-of-pages))) + (error "No such page: %d" page)) + (unless window + (setq window + (if (pdf-util-pdf-window-p) + (selected-window) + t))) + (save-selected-window + ;; Select the window for the hooks below. + (when (window-live-p window) + (select-window window 'norecord)) + (let ((changing-p + (not (eq page (pdf-view-current-page window))))) + (when changing-p + (run-hooks 'pdf-view-before-change-page-hook) + (setf (pdf-view-current-page window) page) + (run-hooks 'pdf-view-change-page-hook)) + (when (window-live-p window) + (pdf-view-redisplay window)) + (when changing-p + (pdf-view-deactivate-region) + (force-mode-line-update) + (run-hooks 'pdf-view-after-change-page-hook)))) + (image-set-window-vscroll (+ (nth (1- page) (book-image-positions)) + (or book-page-vertical-margin pdf-view-image-relief))) + nil) + +(defun pdf-continuous-scroll-forward (&optional pixels) + ;; (defun pdf-view-next-line-or-next-page () + (interactive) + ;; because pages could have different heights, we calculate the step size on each scroll + ;; TODO define constant scroll size if doc has single page height + (let* ((scroll-step-size (/ (cdr (pdf-view-image-size)) book-scroll-fraction)) + (page-end (nth (pdf-view-current-page) (book-image-positions))) + (vscroll (window-vscroll nil t)) + (new-vscroll (image-set-window-vscroll (if (< vscroll (- (car (last (book-image-positions))) + (window-pixel-height))) + (+ vscroll (or pixels scroll-step-size)) + (message "End of book") + vscroll)))) + (when (> (+ new-vscroll (/ (window-pixel-height) 2)) page-end) + (let ((old-page (pdf-view-current-page)) + (new-page (alist-get 'page (cl-incf (pdf-view-current-page))))) + (when (> old-page 1) + (book-remove-page-image (1- old-page)) + (setf (book-currently-displayed-pages) (delete (1- old-page) (book-currently-displayed-pages)))) + (when (< new-page (pdf-info-number-of-pages)) + (pdf-view-display-triplet new-page))))) + ;; :width doc-view-image-width + ;; :pointer 'arrow + ;; :margin (cons 0 book-page-vertical-margin)))))) + (sit-for 0)) + +(defun pdf-continuous-scroll-backward (&optional pixels) + ;; (defun pdf-view-next-line-or-next-page () + (interactive) + ;; because pages could have different heights, we calculate the step size on each scroll + ;; TODO define constant scroll size if doc has single page height + (let* ((scroll-step-size (/ (cdr (pdf-view-image-size)) book-scroll-fraction)) + (page-beg (nth (1- (pdf-view-current-page)) (book-image-positions))) + (new-vscroll (image-set-window-vscroll (- (window-vscroll nil t) (or pixels scroll-step-size))))) + (when (< (+ new-vscroll (/ (window-pixel-height) 2)) page-beg) + (let ((old-page (pdf-view-current-page)) + (new-page (alist-get 'page (cl-decf (pdf-view-current-page))))) + (when (< old-page (pdf-info-number-of-pages)) + (book-remove-page-image (1+ old-page)) + (setf (book-currently-displayed-pages) (delete (1+ old-page) (book-currently-displayed-pages)))) + (when (> new-page 1) + (pdf-view-display-triplet new-page))))) + ;; :width doc-view-image-width + ;; :pointer 'arrow + ;; :margin (cons 0 book-page-vertical-margin)))))) + (sit-for 0)) + +(defun pdf-cs-mouse-scroll-forward () + (interactive) + (with-selected-window + (or (caadr last-input-event) (selected-window)) + (if book-reverse-scrolling + (pdf-continuous-scroll-backward nil) + (pdf-continuous-scroll-forward nil)))) + +(defun pdf-cs-mouse-scroll-backward () + (interactive) + (with-selected-window + (or (caadr last-input-event) (selected-window)) + (if book-reverse-scrolling + (pdf-continuous-scroll-forward nil) + (pdf-continuous-scroll-backward nil)))) + +(defun pdf-continuous-next-page () + (interactive) + (pdf-continuous-scroll-forward (+ (cdr (nth (1- (book-current-page)) (book-image-sizes))) + (* 2 (or book-page-vertical-margin pdf-view-image-relief))))) + +(defun pdf-continuous-previous-page () + (interactive) + (pdf-continuous-scroll-backward (+ (cdr (nth (1- (book-current-page)) (book-image-sizes))) + (* 2 (or book-page-vertical-margin pdf-view-image-relief))))) + +(defun pdf-cscroll-first-page () + (interactive) + (pdf-view-goto-page 1)) + +(defun pdf-cscroll-last-page () + (interactive) + (pdf-view-goto-page (pdf-cache-number-of-pages))) + +(defun pdf-view-create-page (page &optional window) + "Create an image of PAGE for display on WINDOW." + (let* ((size (pdf-view-desired-image-size page window)) + (data (pdf-cache-renderpage + page (car size) + (if (not pdf-view-use-scaling) + (car size) + (* 2 (car size))))) + (hotspots (pdf-view-apply-hotspot-functions + window page size))) + (pdf-view-create-image data + :width (car size) + :margin (cons 0 book-page-vertical-margin) + :map hotspots + :pointer 'arrow))) + +(defun pdf-view-image-size (&optional displayed-p window) + ;; TODO: add WINDOW to docstring. + "Return the size in pixel of the current image. + +If DISPLAYED-P is non-nil, return the size of the displayed +image. These values may be different, if slicing is used." + ;; (if displayed-p + ;; (with-selected-window (or window (selected-window)) + ;; (image-display-size + ;; (image-get-display-property) t)) + (image-size (pdf-view-current-image window) t)) + +(defun pdf-view-display-page (page &optional window) + "Display page PAGE in WINDOW." + (with-selected-window window + + (let* ((image-sizes (let (s) + (dotimes (i (pdf-info-number-of-pages) (nreverse s)) + (push (pdf-view-desired-image-size (1+ i)) s)))) + (image-positions (book-create-image-positions image-sizes))) + (image-mode-window-put 'image-sizes image-sizes) + (image-mode-window-put 'image-positions image-positions)) + + (let ((inhibit-read-only t)) + (book-create-placeholders))) + + (setf (pdf-view-window-needs-redisplay window) nil) + ;; (setf (pdf-view-current-page window) page) + + (pdf-view-display-triplet page window)) + +(defun pdf-view-display-triplet (page &optional window inhibit-slice-p) + ;; TODO: write documentation! + (let ((ol (pdf-view-current-overlay window)) + (display-pages (book-page-triplet page))) + (when (window-live-p (overlay-get ol 'window)) + (dolist (p (book-currently-displayed-pages window)) + (unless (member p display-pages) + (book-remove-page-image p))) + (dolist (p display-pages) + (let* ((image (pdf-view-create-page p window)) + (size (image-size image t)) + (slice (if (not inhibit-slice-p) + (pdf-view-current-slice window))) + (displayed-width (floor + (if slice + (* (nth 2 slice) + (car (image-size image))) + (car (image-size image)))))) + (when (= p page) + (setf (pdf-view-current-image window) image)) + ;; In case the window is wider than the image, center the image + ;; horizontally. + (overlay-put (nth (1- p) (book-overlays window)) 'before-string + (when (> (window-width window) + displayed-width) + (propertize " " 'display + `(space :align-to + ,(/ (- (window-width window) + displayed-width) 2))))) + ;; (message "%s %s" p window) + ;; (print (image-property image :type)) + (overlay-put (nth (1- p) (book-overlays window)) 'display + (if slice + (list (cons 'slice + (pdf-util-scale slice size 'round)) + image) + image)) + (cl-pushnew p (book-currently-displayed-pages window)))) + (image-property (overlay-get (nth (1- page) (book-overlays window)) 'display) :type) + (let* ((win (overlay-get ol 'window)) + (hscroll (image-mode-window-get 'hscroll win)) + (vscroll (if-let (vs (image-mode-window-get 'relative-vscroll (image-mode-winprops))) + (round (* vs + (car (last (book-image-positions window))))) + (image-mode-window-get 'vscroll win)))) + ;; Reset scroll settings, in case they were changed. + (if hscroll (set-window-hscroll win hscroll)) + (if vscroll (set-window-vscroll + win vscroll pdf-view-have-image-mode-pixel-vscroll))) + ;; (setq test-overlay (overlay-properties (nth (1- page) (book-overlays (print window))))) + (setq currently-displayed-pages display-pages)))) + +(defun pdf-view-display-image (image &optional window inhibit-slice-p) + ;; TODO: write documentation! + (let ((ol (pdf-view-current-overlay window))) + (when (window-live-p (overlay-get ol 'window)) + (let* ((size (image-size image t)) + (slice (if (not inhibit-slice-p) + (pdf-view-current-slice window))) + (displayed-width (floor + (if slice + (* (nth 2 slice) + (car (image-size image))) + (car (image-size image))))) + (p (pdf-view-current-page))) + (setf (pdf-view-current-image window) image) + ;; (move-overlay ol (point-min) (point-max)) + ;; In case the window is wider than the image, center the image + ;; horizontally. + (overlay-put (nth (1- p) (book-overlays)) 'before-string + (when (> (window-width window) + displayed-width) + (propertize " " 'display + `(space :align-to + ,(/ (- (window-width window) + displayed-width) 2))))) + (overlay-put (nth (1- p) (book-overlays)) 'display + (if slice + (list (cons 'slice + (pdf-util-scale slice size 'round)) + image) + image)) + (let* ((win (overlay-get ol 'window)) + (hscroll (image-mode-window-get 'hscroll win)) + (vscroll (image-mode-window-get 'vscroll win))) + ;; Reset scroll settings, in case they were changed. + (if hscroll (set-window-hscroll win hscroll)) + (if vscroll (set-window-vscroll + win vscroll pdf-view-have-image-mode-pixel-vscroll))))))) + +(defun pdf-view-redisplay (&optional window) + "Redisplay page in WINDOW. + +If WINDOW is t, redisplay pages in all windows." + (unless pdf-view-inhibit-redisplay + (if (not (eq t window)) + (pdf-view-display-page + (pdf-view-current-page window) + window) + (print "hello") + (dolist (win (get-buffer-window-list nil nil t)) + (pdf-view-display-page + (pdf-view-current-page win) + win)) + (when (consp image-mode-winprops-alist) + (dolist (window (mapcar #'car image-mode-winprops-alist)) + (unless (or (not (window-live-p window)) + (eq (current-buffer) + (window-buffer window))) + (setf (pdf-view-window-needs-redisplay window) t))))) + (force-mode-line-update))) + +(defun pdf-view-redisplay-some-windows () + (pdf-view-maybe-redisplay-resized-windows) + (dolist (window (get-buffer-window-list nil nil t)) + (when (pdf-view-window-needs-redisplay window) + (pdf-view-redisplay window)))) + +(defun pdf-view-new-window-function (winprops) + ;; TODO: write documentation! + ;; (message "New window %s for buf %s" (car winprops) (current-buffer)) + (cl-assert (or (eq t (car winprops)) + (eq (window-buffer (car winprops)) (current-buffer)))) + (let ((ol (image-mode-window-get 'overlay winprops))) + (if ol + (progn + (setq ol (copy-overlay ol)) + ;; `ol' might actually be dead. + (move-overlay ol (point-min) book-contents-end-pos)) + (setq ol (make-overlay (point-min) book-contents-end-pos nil t)) + (overlay-put ol 'pdf-view t)) + (overlay-put ol 'window (car winprops)) + (unless (windowp (car winprops)) + ;; It's a pseudo entry. Let's make sure it's not displayed (the + ;; `window' property is only effective if its value is a window). + (cl-assert (eq t (car winprops))) + (delete-overlay ol)) + (image-mode-window-put 'overlay ol winprops) + ;; Clean up some overlays. + (dolist (ov (overlays-in (point-min) (point-max))) + (when (and (windowp (overlay-get ov 'window)) + (not (window-live-p (overlay-get ov 'window)))) + (delete-overlay ov))) + (when (windowp (car winprops)) + (overlay-put ol 'invisible t) + (let* ((image-sizes (let (s) + (dotimes (i (pdf-info-number-of-pages) (nreverse s)) + (push (pdf-view-desired-image-size (1+ i)) s)))) + (image-positions (book-create-image-positions image-sizes))) + (image-mode-window-put 'image-sizes image-sizes winprops) + (image-mode-window-put 'image-positions image-positions winprops)) + (let ((inhibit-read-only t)) + (book-create-overlays-list winprops) + (book-create-placeholders)) + ;; We're not displaying an image yet, so let's do so. This + ;; happens when the buffer is displayed for the first time. + ;; (when (null (print (image-mode-window-get 'image winprops))) + (with-selected-window (car winprops) + (pdf-view-goto-page + (or (image-mode-window-get 'page t) 1)))))) + +(defun pdf-view-mouse-set-region (event &optional allow-extend-p + rectangle-p) + "Select a region of text using the mouse with mouse event EVENT. + +Allow for stacking of regions, if ALLOW-EXTEND-P is non-nil. + +Create a rectangular region, if RECTANGLE-P is non-nil. + +Stores the region in `pdf-view-active-region'." + (interactive "@e") + (setq pdf-view--have-rectangle-region rectangle-p) + (unless (and (eventp event) + (mouse-event-p event)) + (signal 'wrong-type-argument (list 'mouse-event-p event))) + (unless (and allow-extend-p + (or (null (get this-command 'pdf-view-region-window)) + (equal (get this-command 'pdf-view-region-window) + (selected-window)))) + (pdf-view-deactivate-region)) + (put this-command 'pdf-view-region-window + (selected-window)) + (let* ((window (selected-window)) + (pos (event-start event)) + (begin-inside-image-p t) + (begin (if (posn-image pos) + (posn-object-x-y pos) + (setq begin-inside-image-p nil) + (posn-x-y pos))) + (abs-begin (posn-x-y pos)) + pdf-view-continuous + region) + (when (pdf-util-track-mouse-dragging (event 0.05) + (message "1 %s" (window-vscroll nil t)) + (let* ((pos (event-start event)) + (end (posn-object-x-y pos)) + (end-inside-image-p + (and (eq window (posn-window pos)) + (posn-image pos)))) + (when (or end-inside-image-p + begin-inside-image-p) + (cond + ((and end-inside-image-p + (not begin-inside-image-p)) + ;; Started selection outside the image, setup begin. + (let* ((xy (posn-x-y pos)) + (dxy (cons (- (car xy) (car begin)) + (- (cdr xy) (cdr begin)))) + (size (pdf-view-image-size t))) + (setq begin (cons (max 0 (min (car size) + (- (car end) (car dxy)))) + (max 0 (min (cdr size) + (- (cdr end) (cdr dxy))))) + ;; Store absolute position for later. + abs-begin (cons (- (car xy) + (- (car end) + (car begin))) + (- (cdr xy) + (- (cdr end) + (cdr begin)))) + begin-inside-image-p t))) + ((and begin-inside-image-p + (not end-inside-image-p)) + ;; Moved outside the image, setup end. + (let* ((xy (posn-x-y pos)) + (dxy (cons (- (car xy) (car abs-begin)) + (- (cdr xy) (cdr abs-begin)))) + (size (pdf-view-image-size t))) + (setq end (cons (max 0 (min (car size) + (+ (car begin) (car dxy)))) + (max 0 (min (cdr size) + (+ (cdr begin) (cdr dxy))))))))) + (let ((iregion (if rectangle-p + (list (min (car begin) (car end)) + (min (cdr begin) (cdr end)) + (max (car begin) (car end)) + (max (cdr begin) (cdr end))) + (list (car begin) (cdr begin) + (car end) (cdr end))))) + (setq region + (pdf-util-scale-pixel-to-relative iregion)) + (message "2 %s" (window-vscroll nil t)) + (pdf-view-display-region + (cons region pdf-view-active-region) + rectangle-p) + ;; the following somehow messes up activating regions + ;; (pdf-util-scroll-to-edges iregion) + )))) + (setq pdf-view-active-region + (append pdf-view-active-region + (list region))) + (pdf-view--push-mark)))) + + +;;; Fix jump to link (from outline) + +(defun pdf-links-action-perform (link) + "Follow LINK, depending on its type. + +This may turn to another page, switch to another PDF buffer or +invoke `pdf-links-browse-uri-function'. + +Interactively, link is read via `pdf-links-read-link-action'. +This function displays characters around the links in the current +page and starts reading characters (ignoring case). After a +sufficient number of characters have been read, the corresponding +link's link is invoked. Additionally, SPC may be used to +scroll the current page." + (interactive + (list (or (pdf-links-read-link-action "Activate link (SPC scrolls): ") + (error "No link selected")))) + (let-alist link + (cl-case .type + ((goto-dest goto-remote) + (let ((window (selected-window))) + (cl-case .type + (goto-dest + (unless (> .page 0) + (error "Link points to nowhere"))) + (goto-remote + (unless (and .filename (file-exists-p .filename)) + (error "Link points to nonexistent file %s" .filename)) + (setq window (display-buffer + (or (find-buffer-visiting .filename) + (find-file-noselect .filename)))))) + (with-selected-window window + (when (derived-mode-p 'pdf-view-mode) + (when (> .page 0) + (pdf-view-goto-page .page)) + (when .top + ;; Showing the tooltip delays displaying the page for + ;; some reason (sit-for/redisplay don't help), do it + ;; later. + + ;; TODO fix lambda/pdf-util-tooltip-arrow for compatibility with + ;; continuous scroll + ;; (run-with-idle-timer 0.001 nil + ;; (lambda () + ;; (when (window-live-p window) + ;; (with-selected-window window + ;; (when (derived-mode-p 'pdf-view-mode) + ;; (pdf-util-tooltip-arrow .top)))))) + ) + )))) + (uri + (funcall pdf-links-browse-uri-function .uri)) + (t + (error "Unrecognized link type: %s" .type))) + nil)) + +;; (defun pdf-isearch-search-function (string &rest _) +;; "Search for STRING in the current PDF buffer. + +;; This is a Isearch interface function." +;; (when (> (length string) 0) +;; (let ((same-search-p (pdf-isearch-same-search-p)) +;; (oldpage pdf-isearch-current-page) +;; (matches (pdf-isearch-search-page string)) +;; next-match) +;; ;; matches is a list of list of edges ((x0 y1 x1 y2) ...), +;; ;; sorted top to bottom ,left to right. Coordinates are in image +;; ;; space. +;; (unless isearch-forward +;; (setq matches (reverse matches))) +;; (when pdf-isearch-filter-matches-function +;; (setq matches (funcall pdf-isearch-filter-matches-function matches))) +;; ;; Where to go next ? +;; (setq pdf-isearch-current-page (pdf-view-current-page) +;; pdf-isearch-current-matches matches +;; next-match +;; (pdf-isearch-next-match +;; oldpage pdf-isearch-current-page +;; pdf-isearch-current-match matches +;; same-search-p +;; isearch-forward) +;; pdf-isearch-current-parameter +;; (list string isearch-regexp +;; isearch-case-fold-search isearch-word)) +;; (cond +;; (next-match +;; (setq pdf-isearch-current-match next-match) +;; (pdf-isearch-hl-matches next-match matches) +;; (pdf-isearch-focus-match next-match) +;; ;; Don't get off track. +;; (when (or (and (bobp) (not isearch-forward)) +;; (and (eobp) isearch-forward)) +;; (goto-char (1+ (/ (buffer-size) 2)))) +;; ;; Signal success to isearch. +;; (if isearch-forward +;; (re-search-forward ".") +;; (re-search-backward "."))) +;; ((and (not pdf-isearch-narrow-to-page) +;; (not (pdf-isearch-empty-match-p matches))) +;; (let ((next-page (pdf-isearch-find-next-matching-page +;; string pdf-isearch-current-page t))) +;; (when next-page +;; (pdf-view-goto-page next-page) +;; (pdf-isearch-search-function string)))))))) + +;;; Fix occur (TODO fix isearch and remove this function) + +(defun pdf-occur-goto-occurrence (&optional no-select-window-p) + "Go to the occurrence at point. + +If EVENT is nil, use occurrence at current line. Select the +PDF's window, unless NO-SELECT-WINDOW-P is non-nil. + +FIXME: EVENT not used at the moment." + (interactive) + (let ((item (tabulated-list-get-id))) + (when item + (let* ((doc (plist-get item :document)) + (page (plist-get item :page)) + (match (plist-get item :match-edges)) + (buffer (if (bufferp doc) + doc + (or (find-buffer-visiting doc) + (find-file-noselect doc)))) + window) + (if no-select-window-p + (setq window (display-buffer buffer)) + (pop-to-buffer buffer) + (setq window (selected-window))) + (with-selected-window window + (when page + (pdf-view-goto-page page)) + ;; Abuse isearch. + ;; (when match + ;; (let ((pixel-match + ;; (pdf-util-scale-relative-to-pixel match)) + ;; (pdf-isearch-batch-mode t)) + ;; (pdf-isearch-hl-matches pixel-match nil t) + ;; (pdf-isearch-focus-match-batch pixel-match))) + ))))) + + +(define-key pdf-view-mode-map (kbd "C-n") #'pdf-continuous-scroll-forward) +(define-key pdf-view-mode-map (kbd "<down>") #'pdf-continuous-scroll-forward) +(define-key pdf-view-mode-map (kbd "<wheel-down>") #'pdf-cs-mouse-scroll-forward) +(define-key pdf-view-mode-map (kbd "<mouse-5>") #'pdf-cs-mouse-scroll-forward) +(define-key pdf-view-mode-map (kbd "C-p") #'pdf-continuous-scroll-backward) +(define-key pdf-view-mode-map (kbd "<up>") #'pdf-continuous-scroll-backward) +(define-key pdf-view-mode-map (kbd "<wheel-up>") #'pdf-cs-mouse-scroll-backward) +(define-key pdf-view-mode-map (kbd "<mouse-4>") #'pdf-cs-mouse-scroll-backward) +(define-key pdf-view-mode-map "n" #'pdf-continuous-next-page) +(define-key pdf-view-mode-map "p" #'pdf-continuous-previous-page) +(define-key pdf-view-mode-map (kbd "<prior>") 'pdf-continuous-previous-page) +(define-key pdf-view-mode-map (kbd "<next>") 'pdf-continuous-next-page) +;; (define-key pdf-view-mode-map (kbd "M-<") #'pdf-cscroll-view-goto-page) +(define-key pdf-view-mode-map (kbd "M-g g") #'pdf-cscroll-view-goto-page) +(define-key pdf-view-mode-map (kbd "M-g M-g") #'pdf-cscroll-view-goto-page) +(define-key pdf-view-mode-map (kbd "M-<") #'pdf-cscroll-first-page) +(define-key pdf-view-mode-map (kbd "M->") #'pdf-cscroll-last-page) +(define-key pdf-view-mode-map [remap forward-char] #'pdf-cscroll-image-forward-hscroll) +(define-key pdf-view-mode-map [remap right-char] #'pdf-cscroll-image-forward-hscroll) +(define-key pdf-view-mode-map [remap backward-char] #'pdf-cscroll-image-backward-hscroll) +(define-key pdf-view-mode-map [remap left-char] #'pdf-cscroll-image-backward-hscroll) +(define-key pdf-view-mode-map "T" #'pdf-cscroll-toggle-mode-line) +(define-key pdf-view-mode-map "M" #'pdf-cscroll-toggle-narrow-mode-line) +(define-key pdf-view-mode-map (kbd "q") '(lambda () (interactive) (pdf-continuous-scroll-mode -1))) +(define-key pdf-view-mode-map "Q" #'pdf-cscroll-kill-buffer-and-windows) +(define-key pdf-view-mode-map (kbd "C-c C-a l") #'pdf-cscroll-annot-list-annotations) + +(when (boundp 'spacemacs-version) + (evil-define-key 'evilified pdf-view-mode-map + "j" #'pdf-continuous-scroll-forward + (kbd "<mouse-5>") #'pdf-continuous-scroll-forward + "k" #'pdf-continuous-scroll-backward + (kbd "<mouse-4>") #'pdf-continuous-scroll-backward + "J" #'pdf-continuous-next-page + "K" #'pdf-continuous-previous-page + ;; (kbd "C-j") #'pdf-view-scroll-up-or-next-page + ;; (kbd "C-k") #'pdf-view-scroll-down-or-previous-page + (kbd "g t") #'pdf-view-goto-page + (kbd "g g") #'pdf-cscroll-first-page + "G" #'pdf-cscroll-last-page + ;; "M" #'pdf-cscroll-toggle-mode-line + ;; "q" #'pdf-cscroll-kill-buffer-and-windows + ;; "l" #'pdf-cscroll-image-forward-hscroll + ;; "h" #'pdf-cscroll-image-backward-hscroll + )) + +(provide 'pdf-continuous-scroll-mode) + +;;; pdf-continuous-scroll-mode.el ends here diff --git a/custom/pdf-continuous-scroll-mode.el b/custom/pdf-continuous-scroll-mode.el new file mode 100644 index 00000000..7748149d --- /dev/null +++ b/custom/pdf-continuous-scroll-mode.el @@ -0,0 +1,434 @@ +;;; pdf-continuous-scroll-mode.el --- Continuous scroll minor mode for pdf-tools -*- lexical-binding: t; -*- +;; Copyright (C) 2020 Daniel Laurens Nicolai + +;; Author: Daniel Laurens Nicolai <dalanicolai@gmail.com> +;; with modifications by: Craig Jennings <c@ecjennings.net> +;; Version: 0 +;; Keywords: files +;; Package-Requires: ((emacs "27.1")) +;; URL: https://github.com/dalanicolai/pdf-continuous-scroll-mode.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Usage: + +;;; Code: +(eval-when-compile + (require 'pdf-view)) +(require 'pdf-annot) + +(defvar pdf-cscroll-mode-line-format) +(defvar pdf-cscroll-mode-line-original-face) + +(defcustom pdf-continuous-scroll-step-size 4 + "Step size in lines (integer) for continuous scrolling." + :group 'pdf-continuous-scroll + :type 'integer) + +(defcustom pdf-continuous-scroll-reverse-scrolling nil + "Reverse default scrolling direction." + :group 'pdf-continuous-scroll + :type 'boolean) + +(defcustom pdf-continuous-scroll-custom-min-height nil + "Reverse default scrolling direction." + :group 'pdf-continuous-scroll + :type 'number) + +(defun pdf-continuous-scroll-window-dual-p () + "Return t if current scroll window status is dual, else nil." + (or (equal 'upper (alist-get 'pdf-scroll-window-status (window-parameters))) + (equal 'lower (alist-get 'pdf-scroll-window-status (window-parameters))))) + +(defun pdf-continuous-scroll-close-window-when-dual () + (when (pdf-continuous-scroll-window-dual-p) + (let ((window-status (alist-get 'pdf-scroll-window-status (window-parameters)))) + (save-excursion + (if (equal window-status 'upper) + (windmove-down) + (windmove-up)) + (delete-window) + (set-window-parameter nil 'pdf-scroll-window-status 'single))))) + +(defun pdf-continuous-scroll-forward-line (&optional arg) + "Scroll upward by ARG lines if possible, else go to the next page. +This function is an adapted version of +`pdf-view-next-line-or-next-page'. Although the ARG is kept here, +this function generally works best without ARG is 1. To increase +the step size for scrolling use the ARG in +`pdf-continuous-scroll-forward'" + (if pdf-continuous-scroll-mode + (let ((current-file buffer-file-name) + (hscroll (window-hscroll)) + (cur-page (pdf-view-current-page))) + (print (format + "%s: window-total-height %s, frame-height %s\n +next line: vscroll value, second next line: output value (image-next-line)" + (alist-get 'pdf-scroll-window-status (window-parameters)) + (window-total-height) + (frame-height)) + (get-buffer-create "*pdf-scroll-log*")) + (if (not (equal (alist-get 'pdf-scroll-window-status (window-parameters)) 'lower)) + (when (= (print + (window-vscroll nil pdf-view-have-image-mode-pixel-vscroll) + (get-buffer-create "*pdf-scroll-log*")) + (print (image-next-line arg) (get-buffer-create "*pdf-scroll-log*"))) + (cond + ((not (window-full-height-p)) + (condition-case nil + (window-resize (get-buffer-window) -1 nil t) + (error (delete-window) + (pop-to-buffer (get-file-buffer current-file)) + (set-window-parameter nil 'pdf-scroll-window-status 'single))) + (image-next-line 1)) + (t + (if (= (pdf-view-current-page) (pdf-cache-number-of-pages)) + (message "No such page: %s" (+ (pdf-view-current-page) 1)) + (display-buffer + (current-buffer) + '((display-buffer-below-selected) + (inhibit-same-window . t) + (window-height . 1))) + (set-window-parameter nil 'pdf-scroll-window-status 'upper) + (windmove-down) + (set-window-parameter nil 'pdf-scroll-window-status 'lower) + (pdf-view-goto-page cur-page) + (pdf-view-next-page) + (when (/= cur-page (pdf-view-current-page)) + (image-bob) + (image-bol 1)) + (image-set-window-hscroll hscroll) + (windmove-up) + (image-next-line 1))))) + (condition-case nil + (window-resize (get-buffer-window) +1 nil t) + (error (windmove-up) + (delete-window) + (pop-to-buffer (get-file-buffer current-file)) + (set-window-parameter nil 'pdf-scroll-window-status 'single))) + (windmove-up) + (image-next-line 1) + (windmove-down))) + (message "pdf-continuous-scroll-mode not activated"))) + +(defun pdf-continuous-scroll-forward (arg) + (interactive "P") + (let ((arg (or arg pdf-continuous-scroll-step-size))) + (dotimes (_ arg) (pdf-continuous-scroll-forward-line 1)))) + +(defun pdf-continuous-scroll-mouse-scroll-forward () + (interactive) + (with-selected-window + (or (caadr last-input-event) (selected-window)) + (if pdf-continuous-scroll-reverse-scrolling + (pdf-continuous-scroll-backward nil) + (pdf-continuous-scroll-forward nil)))) + +(defun pdf-continuous-scroll-backward-line (&optional arg) + "Scroll down by ARG lines if possible, else go to the previous page. +This function is an adapted version of +`pdf-view-previous-line-or-previous-page'. Although the ARG is +kept here, this function generally works best without ARG is 1. +To increase the step size for scrolling use the ARG in +`pdf-continuous-scroll-backward'" + (if pdf-continuous-scroll-mode + (let ((hscroll (window-hscroll)) + (cur-page (pdf-view-current-page)) + (window-min-height (or pdf-continuous-scroll-custom-min-height + window-min-height))) + (print + (format + "%s: window-total-height %s, frame-height %s\n +next line: vscroll value, second next line: output value (image-previous-line)" + (alist-get 'pdf-scroll-window-status (window-parameters)) + (window-total-height) + (frame-height)) + (get-buffer-create "*pdf-scroll-log*")) + (cond ((equal (alist-get 'pdf-scroll-window-status (window-parameters)) 'lower) + (cond ((= (window-total-height) window-min-height) + (delete-window) + (set-window-parameter nil 'pdf-scroll-window-status 'single) + (image-next-line 1)) + (t (condition-case nil + (window-resize (get-buffer-window) -1 nil t) + (error nil)) + (windmove-up) + (image-next-line 1) + (windmove-down)))) + (t (when (= (print + (window-vscroll nil pdf-view-have-image-mode-pixel-vscroll) + (get-buffer-create "*pdf-scroll-log*")) + (print + (image-previous-line arg) + (get-buffer-create "*pdf-scroll-log*"))) + (if (= (pdf-view-current-page) 1) + (message "No such page: 0") + (display-buffer-in-direction + (current-buffer) + (cons '(direction . above) '((window-height . 1)))) + (set-window-parameter nil 'pdf-scroll-window-status 'lower) + (windmove-up) + (set-window-parameter nil 'pdf-scroll-window-status 'upper) + (pdf-view-goto-page cur-page) + (pdf-view-previous-page) + (when (/= cur-page (pdf-view-current-page)) + (image-eob) + (image-bol 1)) + (image-set-window-hscroll hscroll) + (window-resize (get-buffer-window) 1 nil t))) + (cond ((< (window-total-height) (- (frame-height) window-min-height)) + (condition-case nil + (window-resize (get-buffer-window) 1 nil t) + (error nil))) + ((= (window-total-height) (- (frame-height) window-min-height)) + (set-window-parameter nil 'pdf-scroll-window-status 'single) + (windmove-down) + (delete-window)))))) + (message "pdf-continuous-scroll-mode not activated"))) + +(defun pdf-continuous-scroll-backward (arg) + (interactive "P") + (let ((arg (or arg pdf-continuous-scroll-step-size))) + (dotimes (_ arg) (pdf-continuous-scroll-backward-line 1)))) + +(defun pdf-continuous-scroll-mouse-scroll-backwards () + (interactive) + (with-selected-window + (or (caadr last-input-event) (selected-window)) + (if pdf-continuous-scroll-reverse-scrolling + (pdf-continuous-scroll-forward nil) + (pdf-continuous-scroll-backward nil)))) + +(defun pdf-continuous-next-page (arg) + (declare (interactive-only pdf-view-previous-page)) + (interactive "p") + (if pdf-continuous-scroll-mode + (let ((window-status (alist-get 'pdf-scroll-window-status (window-parameters)))) + (let ((document-length (pdf-cache-number-of-pages))) + (if (if (equal window-status 'upper) + (= (pdf-view-current-page) (- document-length 1)) + (= (pdf-view-current-page) document-length)) + (message "No such page: %s" (+ document-length 1)) + (cond ((equal window-status 'upper) + (windmove-down) + (with-no-warnings + (pdf-view-next-page arg)) + (windmove-up) + (with-no-warnings + (pdf-view-next-page arg))) + ((equal window-status 'lower) + (windmove-up) + (with-no-warnings + (pdf-view-next-page arg)) + (windmove-down) + (with-no-warnings + (pdf-view-next-page arg))) + (t (pdf-view-next-page)))))))) + +(defun pdf-continuous-previous-page (arg) + (declare (interactive-only pdf-view-previous-page)) + (interactive "p") + (if pdf-continuous-scroll-mode + (let ((window-status (alist-get 'pdf-scroll-window-status (window-parameters)))) + (if (if (equal window-status 'lower) + (= (pdf-view-current-page) 2) + (= (pdf-view-current-page) 1)) + (message "No such page: 0") + (cond ((equal window-status 'upper) + (windmove-down) + (with-no-warnings + (pdf-view-previous-page arg)) + (windmove-up) + (with-no-warnings + (pdf-view-previous-page arg))) + ((equal window-status 'lower) + (windmove-up) + (with-no-warnings + (pdf-view-previous-page arg)) + (windmove-down) + (with-no-warnings + (pdf-view-previous-page arg))) + (t (pdf-view-previous-page))))))) + +(defun pdf-cscroll-view-goto-page (page &optional window) + "Go to PAGE in PDF. + +If optional parameter WINDOW, go to PAGE in all `pdf-view' +windows." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (read-number "Page: ")))) + (unless (and (>= page 1) + (<= page (pdf-cache-number-of-pages))) + (error "No such page: %d" page)) + (pdf-continuous-scroll-close-window-when-dual) + (pdf-view-goto-page page window)) + +(defun pdf-cscroll-first-page () + (interactive) + (pdf-continuous-scroll-close-window-when-dual) + (pdf-view-goto-page 1)) + +(defun pdf-cscroll-last-page () + (interactive) + (pdf-continuous-scroll-close-window-when-dual) + (pdf-view-goto-page (pdf-cache-number-of-pages))) + +(defun pdf-cscroll-kill-buffer-and-windows () + (interactive) + (pdf-continuous-scroll-close-window-when-dual) + (kill-this-buffer)) + +(defun pdf-cscroll-image-forward-hscroll (&optional n) + (interactive "p") + (let ((window-status (alist-get 'pdf-scroll-window-status (window-parameters)))) + (cond ((equal window-status 'upper) + (windmove-down) + (image-forward-hscroll n) + (windmove-up) + (image-forward-hscroll n)) + ((equal window-status 'lower) + (windmove-up) + (image-forward-hscroll n) + (windmove-down) + (image-forward-hscroll n)) + (t (image-forward-hscroll n))))) + +(defun pdf-cscroll-image-backward-hscroll (&optional n) + (interactive "p") + (let ((window-status (alist-get 'pdf-scroll-window-status (window-parameters)))) + (cond ((equal window-status 'upper) + (windmove-down) + (image-forward-hscroll (- n)) + (windmove-up) + (image-forward-hscroll (- n))) + ((equal window-status 'lower) + (windmove-up) + (image-forward-hscroll (- n)) + (windmove-down) + (image-forward-hscroll (- n))) + (t (image-forward-hscroll (- n)))))) + +(defun pdf-cscroll-toggle-mode-line () + (interactive) + (if (not mode-line-format) + (setq mode-line-format pdf-cscroll-mode-line-format) + (setq pdf-cscroll-mode-line-format mode-line-format) + (setq mode-line-format nil))) + +(defun pdf-cscroll-toggle-narrow-mode-line () + (interactive) + (if (plist-get (custom-face-attributes-get 'mode-line (selected-frame)) :height) + (custom-set-faces + (list 'mode-line + (list + (list t pdf-cscroll-mode-line-original-face)))) + (setq pdf-cscroll-mode-line-original-face + (custom-face-attributes-get 'mode-line (selected-frame))) + (custom-set-faces + ;; custom-set-faces was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(mode-line ((t (:background "black" :height 0.1))))) + )) + +(defun pdf-cscroll-imenu () + (interactive) + (pdf-continuous-scroll-close-window-when-dual) + (cond ((fboundp 'counsel-imenu) (counsel-imenu)) + ((fboundp 'helm-imenu) (helm-imenu)) + (t (imenu (list (imenu-choose-buffer-index)))))) + +(defun pdf-cscroll-annot-list-annotations () + (interactive) + (pdf-continuous-scroll-close-window-when-dual) + (pdf-annot-list-annotations)) + + +(setq pdf-continuous-scroll-mode-map (make-sparse-keymap)) +(define-key pdf-continuous-scroll-mode-map (kbd "C-n") #'pdf-continuous-scroll-forward) +(define-key pdf-continuous-scroll-mode-map (kbd "<down>") #'pdf-continuous-scroll-forward) +(define-key pdf-continuous-scroll-mode-map (kbd "<wheel-down>") #'pdf-continuous-scroll-mouse-scroll-forward) +(define-key pdf-continuous-scroll-mode-map (kbd "<mouse-5>") #'pdf-continuous-scroll-mouse-scroll-forward) +(define-key pdf-continuous-scroll-mode-map (kbd "C-p") #'pdf-continuous-scroll-backward) +(define-key pdf-continuous-scroll-mode-map (kbd "<up>") #'pdf-continuous-scroll-backward) +(define-key pdf-continuous-scroll-mode-map (kbd "<wheel-up>") #'pdf-continuous-scroll-mouse-scroll-backwards) +(define-key pdf-continuous-scroll-mode-map (kbd "<mouse-4>") #'pdf-continuous-scroll-mouse-scroll-backwards) +(define-key pdf-continuous-scroll-mode-map "n" #'pdf-continuous-next-page) +(define-key pdf-continuous-scroll-mode-map "p" #'pdf-continuous-previous-page) +(define-key pdf-continuous-scroll-mode-map (kbd "<prior>") 'pdf-continuous-previous-page) +(define-key pdf-continuous-scroll-mode-map (kbd "<next>") 'pdf-continuous-next-page) +;; (define-key pdf-continuous-scroll-mode-map (kbd "M-<") #'pdf-cscroll-view-goto-page) +(define-key pdf-continuous-scroll-mode-map (kbd "M-g g") #'pdf-cscroll-view-goto-page) +(define-key pdf-continuous-scroll-mode-map (kbd "M-g M-g") #'pdf-cscroll-view-goto-page) +(define-key pdf-continuous-scroll-mode-map (kbd "M-<") #'pdf-cscroll-first-page) +(define-key pdf-continuous-scroll-mode-map (kbd "M->") #'pdf-cscroll-last-page) +(define-key pdf-continuous-scroll-mode-map [remap forward-char] #'pdf-cscroll-image-forward-hscroll) +(define-key pdf-continuous-scroll-mode-map [remap right-char] #'pdf-cscroll-image-forward-hscroll) +(define-key pdf-continuous-scroll-mode-map [remap backward-char] #'pdf-cscroll-image-backward-hscroll) +(define-key pdf-continuous-scroll-mode-map [remap left-char] #'pdf-cscroll-image-backward-hscroll) +(define-key pdf-continuous-scroll-mode-map "T" #'pdf-cscroll-toggle-mode-line) +(define-key pdf-continuous-scroll-mode-map "h" #'pdf-cscroll-toggle-narrow-mode-line) +(define-key pdf-continuous-scroll-mode-map (kbd "q") #'(lambda () (interactive) (pdf-continuous-scroll-mode -1))) +(define-key pdf-continuous-scroll-mode-map "Q" #'pdf-cscroll-kill-buffer-and-windows) +(define-key pdf-continuous-scroll-mode-map (kbd "C-c C-a l") #'pdf-cscroll-annot-list-annotations) + +;;;###autoload +(with-eval-after-load 'pdf-view + (define-key pdf-view-mode-map "c" #'pdf-continuous-scroll-mode)) + +(when (boundp 'spacemacs-version) + (evil-define-minor-mode-key 'evilified 'pdf-continuous-scroll-mode + "j" #'pdf-continuous-scroll-forward + (kbd "<mouse-5>") #'pdf-continuous-scroll-mouse-scroll-forward + "k" #'pdf-continuous-scroll-backward + (kbd "<mouse-4>") #'pdf-continuous-scroll-mouse-scroll-backwards + "J" #'pdf-continuous-next-page + "K" #'pdf-continuous-previous-page + ;; (kbd "C-j") #'pdf-view-scroll-up-or-next-page + ;; (kbd "C-k") #'pdf-view-scroll-down-or-previous-page + (kbd "g t") #'pdf-cscroll-view-goto-page + (kbd "g g") #'pdf-cscroll-first-page + "G" #'pdf-cscroll-last-page + "M" #'pdf-cscroll-toggle-mode-line + "q" #'pdf-cscroll-kill-buffer-and-windows + "l" #'pdf-cscroll-image-forward-hscroll + "h" #'pdf-cscroll-image-backward-hscroll) + (spacemacs/set-leader-keys-for-minor-mode + 'pdf-continuous-scroll-mode + (kbd "a l") #'pdf-cscroll-annot-list-annotations)) + +;;;###autoload +(define-minor-mode pdf-continuous-scroll-mode + "Emulate continuous scroll with two synchronized buffers" + + :init-value nil + :lighter " Continuous" + :keymap pdf-continuous-scroll-mode-map + (unless pdf-continuous-scroll-mode + (pdf-continuous-scroll-close-window-when-dual)) + (set-window-parameter nil 'pdf-scroll-window-status 'single) + (defun pdf-outline-imenu-activate-link (&rest args) + ;; bug #14029 + (pdf-continuous-scroll-close-window-when-dual) + (when (eq (nth 2 args) 'pdf-outline-imenu-activate-link) + (setq args (cdr args))) + (pdf-links-action-perform (nth 2 args)))) + +(provide 'pdf-continuous-scroll-mode) +;;; pdf-continuous-scroll-mode.el ends here diff --git a/custom/profile-dotemacs.el b/custom/profile-dotemacs.el new file mode 100644 index 00000000..f16e8652 --- /dev/null +++ b/custom/profile-dotemacs.el @@ -0,0 +1,200 @@ +;;; profile-dotemacs.el --- Profile your Emacs init file + +;; Copyright (C) 2010, 2012 David Engster + +;; Author: David Engster <dengste@eml.cc> + +;; This file is NOT part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is to easily profile your Emacs init file (or any other +;; script-like Emacs Lisp file, for that matter). + +;; It will go over all sexp's (balanced expressions) in the file and +;; run them through `benchmark-run'. It will then show the file with +;; overlays applied in a way that let you easily find out which sexp's +;; take the most time. Since time is relative, it's not the absolute +;; value that counts but the percentage of the total running time. +;; +;; * All other sexp's with a percentage greater than +;; `profile-dotemacs-low-percentage' will be preceded by a +;; highlighted line, showing the results from `benchmark-run'. +;; Also, the more 'reddish' the background of the sexp, the more +;; time it needs. + +;; * All other sexp's will be grayed out to indicate that their +;; running time is miniscule. You can still see the benchmark +;; results in the minibuffer by hovering over the sexp with the +;; mouse. + +;; You can only benchmark full sexp's, so if you wrapped large parts +;; of your init file in some conditional clause, you'll have to remove +;; that for getting finer granularity. + +;;; Usage: + +;; Start emacs as follows: +;; +;; emacs -Q -l <PATH>/profile-dotemacs.el -f profile-dotemacs +;; +;; with <PATH> being the path to where this file resides. + +;;; Caveats (thanks to Raffaele Ricciardi for reporting those): + +;; - The usual `--debug-init' for debugging your init file won't work +;; with profile-dotemacs, so you'll have to call +;; `toggle-debug-on-error', either on the commandline or at the +;; beginning of your init file. +;; - `load-file-name' is nil when the init file is being loaded +;; by the profiler. This might matter if you perform the +;; bulk of initializations in a different file. +;; - Starting external shells like IELM or eshell in your init file +;; might mess with overlay creation, so this must not be done. + +;;; Download: + +;; You can always get the latest version from +;; http://randomsample.de/profile-dotemacs.el + +;;; Code: + +(require 'thingatpt) +(require 'benchmark) + +;; User variables + +(defvar profile-dotemacs-file "~/.emacs.d/init.el" + "File to be profiled.") + +(defvar profile-dotemacs-low-percentage 3 + "Percentage which should be considered low. +All sexp's with a running time below this percentage will be +grayed out.") + +(defface profile-dotemacs-time-face + '((((background dark)) (:background "OrangeRed1")) + (t (:background "red3"))) + "Background color to indicate percentage of total time.") + +(defface profile-dotemacs-low-percentage-face + '((((background dark)) (:foreground "gray25")) + (t (:foreground "gray75"))) + "Face for sexps below `profile-dotemacs-low-percentage'.") + +(defface profile-dotemacs-highlight-face + '((((background dark)) (:background "blue")) + (t (:background "yellow"))) + "Highlight face for benchmark results.") + +;; Main function + +(defun profile-dotemacs () + "Load `profile-dotemacs-file' and benchmark its sexps." + (interactive) + (with-current-buffer (find-file-noselect profile-dotemacs-file t) + (setq buffer-read-only t) ;; just to be sure + (goto-char (point-min)) + (let (start end results) + (while + (< (point) + (setq end (progn + (forward-sexp 1) + (point)))) + (forward-sexp -1) + (setq start (point)) + (add-to-list + 'results + `(,start ,end + ,(benchmark-run + (eval (sexp-at-point))))) + (goto-char end)) + (profile-dotemacs-show-results results) + (switch-to-buffer (current-buffer))))) + +;; Helper functions + +(defun profile-dotemacs-show-results (results) + "Show timings from RESULTS in current buffer." + (let ((totaltime (profile-dotemacs-totaltime results)) + current percentage ov) + (while results + (let* ((current (pop results)) + (ov (make-overlay (car current) (cadr current))) + (current (car (last current))) + (percentage (/ (+ (car current) (nth 2 current)) + totaltime)) + col benchstr lowface) + (setq col + (profile-dotemacs-percentage-color + percentage + (face-background 'default) + (face-background 'profile-dotemacs-time-face))) + (setq percentage (round (* 100 percentage))) + (setq benchstr (profile-dotemacs-make-benchstr current)) + (overlay-put ov 'help-echo benchstr) + (if (and (numberp profile-dotemacs-low-percentage) + (< percentage profile-dotemacs-low-percentage)) + (overlay-put ov 'face 'profile-dotemacs-low-percentage-face) + (overlay-put ov 'before-string + (propertize benchstr + 'face 'profile-dotemacs-highlight-face)) + (overlay-put ov 'face + `(:background ,col))))) + (setq ov (make-overlay (1- (point-max)) (point-max))) + (overlay-put ov 'after-string + (propertize + (format "\n-----------------\nTotal time: %.2fs\n" + totaltime) + 'face 'profile-dotemacs-highlight-face)))) + +(defun profile-dotemacs-totaltime (results) + "Calculate total time of RESULTS." + (let ((totaltime 0)) + (mapc (lambda (x) + (let ((cur (car (last x)))) + (setq totaltime (+ totaltime (car cur) (nth 2 cur))))) + results) + totaltime)) + +(defun profile-dotemacs-percentage-color (percent col-begin col-end) + "Calculate color according to PERCENT between COL-BEGIN and COL-END." + (let* ((col1 (color-values col-begin)) + (col2 (color-values col-end)) + (col + (mapcar (lambda (c) + (round + (+ (* (- 1 percent) (nth c col1)) + (* percent (nth c col2))))) + '(0 1 2)))) + (format "RGB:%04x/%04x/%04x" + (car col) + (nth 1 col) + (nth 2 col)))) + +(defun profile-dotemacs-make-benchstr (timings) + "Create descriptive benchmark string from TIMINGS." + (format + (concat + "<Percentage: %d ; " + "Time: %.2f ; " + "Number of GC: %d ; " + "Time for GC: %.2f>\n") + percentage + (car timings) (nth 1 timings) (nth 2 timings))) + + +;; profile-dotemacs.el ends here diff --git a/custom/titlecase-data.el b/custom/titlecase-data.el new file mode 100644 index 00000000..a6468586 --- /dev/null +++ b/custom/titlecase-data.el @@ -0,0 +1,721 @@ +;;; titlecase-data.el --- Data for titlecase.el -*- lexical-binding: t; -*- + +;; Author: Case Duckworth <acdw@acdw.net> +;; Maintainer: Case Duckworth <acdw@acdw.net> +;; URL: https://github.com/duckwork/titlecase.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Since the `titlecase' package requires a lot of data, that data lives here so +;; as to not clog up the main package. + +;; Since [[https://github.com/duckwork/titlecase.el/issues/23][Issue #23]] makes +;; a good point that I should like, make more sense in the commentary and README +;; of this repository. At the same time, those couple of comments I wrote in +;; there I don't want to just /delete/, so until I write this up in a proper +;; blog post, I've included it here, in the data file, because this is where +;; these implementation notes will be of most interest. + +;; The only setting you really should need to set is =titlecase-style=, which +;; see. Each of these styles has a different set of rules regarding which words +;; to capitalize in a title. After you've set =titlecase-style=, you can bind +;; the command =titlecase-dwim= to a key, or call it using M-x, and it will +;; either title-case your region (if it's active) or the current line. + +;; The tricky part is figuring out what words to capitalize in the title. + +;; Articles (~a~, ~an~, ~the~) are downcased. + +;; The first word of a title and all "important words" (generally nouns, +;; pronouns, adjectives, verbs, and adverbs) are capitalized. The last word of +;; a title is always capitalized, but only in Chicago, AP, Bluebook, AMA, NY +;; Times, and Wikipedia. + +;; /All/ prepositions are downcased in Chicago, MLA, AP, NY Times, and +;; Wikipedia, regardless of length; for APA, Bluebook, AMA, and Wikipedia, only +;; prepositions shorter than 5 letters are (presumably, capitalize those longer +;; than 5 letters, however only Wikipedia was clear on that point). + +;; Coordinating conjunctions are capitalized in Chicago and APA (presumably), +;; but downcased in MLA, AP, Bluebook, AMA, NY Times, and Wikipedia. + +;; Hyphenated words are tricky: I could possibly figure out a way to have lookup +;; tables to determine when to capitalize the second part of a hyphenated word, +;; but I haven't implemented them yet. At any rate, the rules tend to be vague +;; enough that it's hard to program anyway: For example, Chicago, APA, MLA, and +;; AP lowercase the second word "after a hyphenated prefix (e.g., Mid-, Anti-, +;; Super, etc.) in compound modifiers," but MLA and APA capitalize the second +;; part of "hyphenated major words (e.g., Self-Report not Self-report). + +;; Perhaps unsurprisingly, the AMA (American Medical Association, used in the +;; scientific community) has the most comprehensive capitalization rules around +;; hyphenated words. I'll just copy-paste the bullet points here: + +;; - Lowercase the second word in a hyphenated compound when it is +;; a prefix or suffix (e.g., "Anti-itch","world-wide") or part of a single word. +;; - Capitalize the second word in a hyphenated compound if both words are equal +;; and not suffices or prefixes (e.g., "Cost-Benefit") +;; - Capitalize the first non-Greek letter after a lowercase Greek letter (e.g., +;; "ω-Bromohexanoic") +;; - Lowercase the first non-Greek letter after a capital Greek letter (e.g., +;; "Δ-9-tetrahydrocannabinol") #+end_quote + +;; (The AMA also has a rule about capitilizing the genus but not species +;; epithet, but the lookup on that would be wild as hell, so I trust yall to +;; know on that one.) + +;; ~To~ as an infinitive is downcased in all /except/ AP. This is a rule I +;; simply cannot implement without knowing whether the /next/ word is a verb, +;; which would require expensive lookups, which even then wouldn't be foolproof. + +;; Now that I'm thinking about it, most styles count phrasal verbs (like "play +;; with") as important enough to capitalize, when "with" would usually /not/ be +;; capitalized, but again, open categories like phrasal verbs simply do not work +;; in a package like this. + +;; ALL OF THIS IS TO SAY that titlecase offers a best-effort attempt to +;; titlecase a line or region of text, but you should absolutely +;; double-triple-check against the style guide you're writing for if you're +;; trying for publication or something like that. + +;; SEE ALSO: + +;; Prior art: + +;; - https://emacs.stackexchange.com/questions/66361/#66362 +;; - https://github.com/novoid/title-capitalization.el +;; - https://hungyi.net/posts/programmers-way-to-title-case/ + +;; Rules: + +;; - https://capitalizemytitle.com/#capitalizationrules +;; - https://titlecaseconverter.com/rules/ + +;;; 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 new file mode 100644 index 00000000..43947822 --- /dev/null +++ b/custom/titlecase.el @@ -0,0 +1,396 @@ +;;; titlecase.el --- Title-case phrases -*- lexical-binding: t; -*- + +;; Author: Case Duckworth <acdw@acdw.net> +;; Maintainer: Case Duckworth <acdw@acdw.net> +;; Version: 0.3.0 +;; URL: https://codeberg.org/acdw/titlecase.el +;; Package-Requires: ((emacs "25.1")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library strives to be the most accurate possible with title-casing +;; sentences, lines, and regions of text in English prose according to a number +;; of styles guides' capitalization rules. It is necessarily a best-effort; due +;; to the vaguaries of written English it's impossible to completely correctly +;; capitalize aribtrary titles. So be sure to proofread and copy-edit your +;; titles before sending them off to be published, and never trust a computer. + +;; INSTALLATION and USE: + +;; Make sure both titlecase.el and titlecase-data.el are in your `load-path', +;; and `require' titlecase. You should then be able to call the interactive +;; functions defined in this file. + +;;; CUSTOMIZATION: + +;; Only two customization options are probably going to be of any interest: +;; `titlecase-style' (the style to use for capitalizing titles), and +;; `titlecase-dwim-non-region-function', which determines what to do when +;; `titlecase-dwim' isn't acting on a region. + +;; If you want to use your own title-casing code, or a third party, you can +;; customize `titlecase-command' to something other than its default. One +;; possibility is titlecase.pl, written John Gruber and Aristotle Pagaltzis: +;; https://github.com/ap/titlecase. + +;;; Code: + +(require 'browse-url) ; `browse-url-button-regexp' +(require 'cl-lib) ; `cl-loop' +(require 'seq) ; `seq-some' +(require 'thingatpt) ; `bounds-of-thing-at-point' +(require 'titlecase-data) + +(defgroup titlecase nil + "Customization for title-casing phrases." + :prefix "titlecase-" + :group 'text) + +(defvar titlecase-styles '((chicago . "Chicago Style") + (apa . "APA Style") + (mla . "MLA Style") + (ap . "AP Style") + (bluebook . "Bluebook Style") + (ama . "AMA Style") + (nyt . "New York Times Style") + (wikipedia . "Wikipedia Style") + (imdb . "IMDB Style") + (sentence . "Sentence style")) + "Available styles for title-casing.") + +(defvar titlecase-default-case-function #'capitalize-word + "What to do to a word when a style doesn't specify what to do.") + +(defcustom titlecase-normalize-functions '(titlecase--lowercase-all-caps) + "List of functions for normalizing input before title-casing. +Each function will be passed 3 arguments: the beginning and +ending points of the region to operate on, as well as the +title-casing style. They are called one after another in order +in a `save-excursion' block." + :type '(repeat function)) + +(defcustom titlecase-skip-words-regexps (list "\\b[[:upper:]]+\\b" + browse-url-button-regexp) + "Regexps of words to skip when titlecasing. +Each regexp in this list will be tested on each word considered +for title-casing, and if the regexp matches the entire word, the +word will be skipped. + +NOTE: These regexps will be matched against the title-cased +region /after/ normalizing it, which means that, by default, if +the region is in all-caps before calling `titlecase-region', it +will be downcased before title-casing. Thus, some of these +regexps might not match when expected. This behavior is a +trade-off between possible user expectations. To change this +behavior, customize `titlecase-normalize-functions'." + :type '(repeat regexp)) + +(defcustom titlecase-style 'wikipedia + "Which style to use when title-casing." + :type (cons 'choice (cl-loop + for style in titlecase-styles + collect (list 'const :tag (cdr style) (car style)) + into choices + finally return choices))) + +(defcustom titlecase-force-cap-after-punc "[.?!\\/;:\n\r]" + "Regexp to force the next word capitalized." + :type 'regexp) + +(defcustom titlecase-dwim-non-region-function #'titlecase-line + "What to do with `titlecase-dwim' when region isn't active. +Recommended: `titlecase-line' or `titlecase-sentence'." + :type 'function) + +(defcustom titlecase-command #'titlecase--region-with-style + "Command to use for titlecasing titles. +This option can be one of two things: + +A string value, or a list of string values, is interpreted as a +system command to run using `call-process-region' on a temp +buffer containing the text to titlecase. Just a string is +interpreted as the command to run, with no arguments. A list of +strings will pass those strings as aruguments to the command-line +program. In that list, the symbol `style' will be replaced with +the the string of the title-casing style that's passed. + +A function value is interpreted as the function to call on the +region. The function will be called with three arguments: the +beginning and end of the region, and the style (see +`titlecase-style') to capitalize it in.") + +(defcustom titlecase-downcase-sentences nil + "Whether to downcase words after the first in \"sentence\" style. +If nil, titlecasing using the \"sentence\" style will leave all +words as-is. If t, \"sentence\"-style titlecasing will downcase +words that don't begin a sentence." + :type 'boolean) + +(defun titlecase--region-with-style-impl (begin end style) + "Title-case implementation. +`titlecase-force-cap-after-punc' must be handled by the caller. +This is expected to have run in a block that uses `save-excursion' and +`save-match-data'. See documentation for `titlecase--region-with-style' +for docs on BEGIN, END and STYLE." + (let ( ;; Constants during this function's runtime. + (case-fold-search nil) + (downcase-word-list (symbol-value + (intern (format "titlecase-lowercase-%s" + style))))) + + ;; Normalize the text in region by calling `titlecase-normalize-functions' + ;; in order. + (dolist (fn titlecase-normalize-functions) + (save-excursion + (funcall fn begin end style))) + + ;; Skip blank lines & white-space (where `current-word' would return nil). + ;; It's important this uses the same logic that `current-word' uses to scan + ;; for words, or this may be nil when it's not expected. See #11. + (goto-char begin) + (skip-syntax-forward "^w" end) + (setq begin (point)) + + ;; And loop over the rest. + (catch :done + (while (< (point) end) + (let ((this-word (current-word))) + (cond + ;; Skip words matching `titlecase-skip-words-regexps'. + ((looking-at (format "%s" + (mapconcat #'identity + titlecase-skip-words-regexps + "\\|"))) + (goto-char (match-end 0)) + ;; TODO: Document what this does (it's late) + (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 just capitalizes the first word. Since we can't be + ;; sure how the user has already capitalized anything, we just skip + ;; the current word. HOWEVER, there are times when downcasing the + ;; rest of the sentence is warranted. --- NOTE 2022-05-09: Now I'm + ;; thinking about it, does `sentence' style need to do anything + ;; whatsoever? Maybe I just need to include a test toward the top of + ;; the enclosing function to make `titlecase-default-case-function' + ;; be `downcase-word' if `titlecase-downcase-sentences' is true... or + ;; something of that nature. I might be over-engineering this, is + ;; what I'm saying. Curious, isn't it? + ((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/custom/utilities/vcf-conversion-helpers.el b/custom/utilities/vcf-conversion-helpers.el new file mode 100644 index 00000000..334edc4e --- /dev/null +++ b/custom/utilities/vcf-conversion-helpers.el @@ -0,0 +1,388 @@ +;;; vcf-conversion-helpers.el --- vcf conversion utility functions -*- coding: utf-8; lexical-binding: t; -*- + +;;; Commentary: +;; + +;;; Code: + +(defun cj/clean-vcf-for-import (input-vcf output-vcf) + "Clean and prepare VCF file for import to org-contacts." + (interactive "fInput VCF file: \nFOutput VCF file: ") + (with-temp-buffer + (insert-file-contents input-vcf) + (goto-char (point-min)) + + ;; First, clean up multi-line fields (unfold them) BEFORE processing + ;; This ensures PHOTO and other multi-line fields are on single lines + (goto-char (point-min)) + (while (re-search-forward "\n[ \t]+" nil t) + (replace-match " " t t)) + + ;; Handle birthdays while the structure is intact + (goto-char (point-min)) + (while (re-search-forward "^BDAY:\\(.*\\)$" nil t) + (let* ((bday-value (match-string 1)) + (full-match (match-string 0)) + (match-start (match-beginning 0)) + (match-end (match-end 0)) + (cleaned-bday + (cond + ;; Full date format: 19700805 -> 1970-08-05 + ((string-match "^\\([0-9]\\{4\\}\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)$" bday-value) + (format "BDAY:%s-%s-%s" + (match-string 1 bday-value) + (match-string 2 bday-value) + (match-string 3 bday-value))) + ;; Month-day only: --0714 -> use current year or set to 1900 + ((string-match "^--\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)$" bday-value) + (format "BDAY:1900-%s-%s" + (match-string 1 bday-value) + (match-string 2 bday-value))) + ;; Text format incomplete: convert to note + ((string-match "VALUE=text" bday-value) + nil) ; We'll add as note later + ;; Keep as is if already in good format + (t full-match)))) + (when cleaned-bday + (goto-char match-start) + (delete-region match-start match-end) + (insert cleaned-bday) + (goto-char match-end)))) + + ;; Convert item-prefixed TEL and EMAIL fields to standard format + (goto-char (point-min)) + (while (re-search-forward "^item[0-9]+\\.\\(TEL\\|EMAIL\\)\\(.*?\\):\\(.+\\)$" nil t) + (let ((field-type (match-string 1)) + (field-params (match-string 2)) + (field-value (match-string 3))) + (replace-match (format "%s%s:%s" field-type field-params field-value) t t))) + + ;; NOW remove unwanted fields (but not the converted TEL/EMAIL fields) + (let ((remove-patterns + '("^PHOTO:.*$" + "^X-ABRELATEDNAMES:.*$" + "^X-ABLabel:.*$" + "^X-FILE-AS:.*$" + "^VERSION:.*$" + "^item[0-9]+\\.X-.*$" ; Only remove item-prefixed X- fields + "^CATEGORIES:.*Imported on.*$"))) + (dolist (pattern remove-patterns) + (goto-char (point-min)) + (while (re-search-forward pattern nil t) + (delete-region (line-beginning-position) + (min (1+ (line-end-position)) (point-max)))))) + + ;; Process each VCARD to ensure it has an FN field or remove if no identifying info + (goto-char (point-min)) + (let ((vcards-to-remove '())) + (while (re-search-forward "^BEGIN:VCARD" nil t) + (let ((vcard-start (match-beginning 0)) + (has-fn nil) + (has-n nil) + (has-org nil) + (fn-value nil) + (n-value nil) + (org-value nil)) + (when (re-search-forward "^END:VCARD" nil t) + (let ((vcard-end (match-end 0))) + (save-excursion + (save-restriction + (narrow-to-region vcard-start vcard-end) + + ;; Check for FN field + (goto-char (point-min)) + (when (re-search-forward "^FN:\\(.+\\)$" nil t) + (setq has-fn t) + (setq fn-value (match-string 1))) + + ;; Check for N field (structured name) + (goto-char (point-min)) + (when (re-search-forward "^N:\\(.+\\)$" nil t) + (setq has-n t) + (setq n-value (match-string 1))) + + ;; Check for ORG field + (goto-char (point-min)) + (when (re-search-forward "^ORG:\\(.+\\)$" nil t) + (setq has-org t) + (setq org-value (match-string 1))) + + ;; If no FN but has N or ORG, synthesize FN + (when (and (not has-fn) (or has-n has-org)) + (goto-char (point-min)) + (if (re-search-forward "^BEGIN:VCARD$" nil t) + (let ((synthesized-fn + (cond + ;; Try to build from N field first + (has-n + (let* ((n-parts (split-string n-value ";")) + (last-name (nth 0 n-parts)) + (first-name (nth 1 n-parts)) + (middle-name (nth 2 n-parts)) + (prefix (nth 3 n-parts)) + (suffix (nth 4 n-parts)) + (name-parts '())) + ;; Build name in "First Middle Last" order + (when (and prefix (not (string-empty-p prefix))) + (push prefix name-parts)) + (when (and first-name (not (string-empty-p first-name))) + (push first-name name-parts)) + (when (and middle-name (not (string-empty-p middle-name))) + (push middle-name name-parts)) + (when (and last-name (not (string-empty-p last-name))) + (push last-name name-parts)) + (when (and suffix (not (string-empty-p suffix))) + (push suffix name-parts)) + (if name-parts + (string-join (reverse name-parts) " ") + ;; If N field exists but is empty, fall back to ORG + (when has-org + (replace-regexp-in-string ";" ", " org-value))))) + ;; Use ORG field if no N field + (has-org + (replace-regexp-in-string ";" ", " org-value)) + (t nil)))) + (when synthesized-fn + (end-of-line) + (insert (format "\nFN:%s" synthesized-fn)) + (setq has-fn t))))) + + ;; Mark for removal if no identifying information + (when (not (or has-fn has-n has-org)) + (push (cons vcard-start vcard-end) vcards-to-remove)) + + (widen))))))) + + ;; Remove VCARDs with no identifying information (in reverse order to preserve positions) + (dolist (vcard-range (reverse vcards-to-remove)) + (delete-region (car vcard-range) (cdr vcard-range)) + (message "Removed VCARD with no identifying information"))) + + ;; Remove empty lines within VCARDs + (goto-char (point-min)) + (while (re-search-forward "^BEGIN:VCARD" nil t) + (let ((start (point))) + (when (re-search-forward "^END:VCARD" nil t) + (save-restriction + (narrow-to-region start (match-beginning 0)) + (goto-char (point-min)) + (delete-matching-lines "^$") + (widen))))) + + ;; Add back VERSION field (required for valid VCF) + (goto-char (point-min)) + (while (re-search-forward "^BEGIN:VCARD$" nil t) + (end-of-line) + (insert "\nVERSION:3.0")) + + ;; Save cleaned file + (write-region (point-min) (point-max) output-vcf) + (message "Cleaned VCF saved to %s" output-vcf))) + + +(defun split-vcf-file (vcf-file output-dir) + "Split a combined VCF file into individual contact files." + (interactive "fVCF file to split: \nDOutput directory: ") + (mkdir output-dir t) + (with-temp-buffer + (insert-file-contents vcf-file) + (goto-char (point-min)) + (let ((count 0) + (contact-name "")) + (while (re-search-forward "^BEGIN:VCARD" nil t) + (let ((start (match-beginning 0))) + (when (re-search-forward "^END:VCARD" nil t) + (let* ((end (match-end 0)) + (vcard (buffer-substring start end))) + ;; Try to extract name for better filename + (with-temp-buffer + (insert vcard) + (goto-char (point-min)) + (if (re-search-forward "^FN:\\(.+\\)$" nil t) + (setq contact-name + (replace-regexp-in-string + "[^A-Za-z0-9-_]" "_" + (match-string 1))) + (setq contact-name (format "contact-%04d" count)))) + ;; Write individual VCF file + (let ((filename (format "%s/%s.vcf" output-dir contact-name))) + (with-temp-file filename + (insert vcard)) + (cl-incf count)))))) + (message "Split into %d contact files in %s" count output-dir)))) + + +(defun cj/convert-cleaned-vcf-to-org-contacts (vcf-file org-file) + "Convert cleaned VCF file to org-contacts format." + (interactive "fCleaned VCF file: \nFOrg file to create: ") + (with-temp-buffer + (insert-file-contents vcf-file) + (let ((contacts '()) + (contact-count 0)) ; Add a counter for the final message + (goto-char (point-min)) + (while (re-search-forward "^BEGIN:VCARD" nil t) + (let ((vcard-start (point)) + (contact (make-hash-table :test 'equal))) + (when (re-search-forward "^END:VCARD" nil t) + (let ((vcard-end (match-beginning 0))) + (save-restriction + (narrow-to-region vcard-start vcard-end) + (goto-char (point-min)) + + ;; Extract FN (Full Name) + (when (re-search-forward "^FN:\\(.+\\)$" nil t) + (puthash "name" (match-string 1) contact)) + + ;; Extract EMAIL (can have multiple) + (goto-char (point-min)) + (let ((emails '())) + (while (re-search-forward "^EMAIL[^:]*:\\(.+\\)$" nil t) + (push (match-string 1) emails)) + (when emails + (puthash "email" (string-join (reverse emails) " ") contact))) + + ;; Extract PHONE (can have multiple) + (goto-char (point-min)) + (let ((phones '())) + (while (re-search-forward "^TEL[^:]*:\\(.+\\)$" nil t) + (let ((phone (match-string 1))) + ;; Clean up phone numbers slightly + (setq phone (replace-regexp-in-string "^\\+1 " "" phone)) + (push phone phones))) + (when phones + (puthash "phone" (string-join (reverse phones) ", ") contact))) + + ;; Extract ORG + (goto-char (point-min)) + (when (re-search-forward "^ORG:\\(.+\\)$" nil t) + (let ((org-value (match-string 1))) + ;; Handle semicolon-separated org values + (setq org-value (replace-regexp-in-string ";" ", " org-value)) + (puthash "org" org-value contact))) + + ;; Extract TITLE + (goto-char (point-min)) + (when (re-search-forward "^TITLE:\\(.+\\)$" nil t) + (puthash "title" (match-string 1) contact)) + + ;; Extract ADDRESS + (goto-char (point-min)) + (when (re-search-forward "^ADR[^:]*:\\(.+\\)$" nil t) + (let ((addr (match-string 1))) + ;; VCF address format: ;;Street;City;State;Zip;Country + ;; Clean up the semicolons + (setq addr (replace-regexp-in-string ";" " " addr)) + (setq addr (replace-regexp-in-string " +" " " addr)) + (puthash "address" addr contact))) + + ;; Extract NOTE + (goto-char (point-min)) + (when (re-search-forward "^NOTE:\\(.+\\)$" nil t) + (let ((note (match-string 1))) + ;; Unescape VCF note formatting + (setq note (replace-regexp-in-string "\\\\n" "\n " note)) + (setq note (replace-regexp-in-string "\\\\:" ":" note)) + (puthash "note" note contact))) + + ;; Extract BDAY (should be cleaned format now) + (goto-char (point-min)) + (when (re-search-forward "^BDAY:\\(.+\\)$" nil t) + (let ((bday (match-string 1))) + ;; Convert to org format + (when (string-match "\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)" bday) + (let ((year (match-string 1 bday)) + (month (match-string 2 bday)) + (day (match-string 3 bday))) + (if (string= year "1900") ; Our placeholder for unknown years + (puthash "birthday" + (format "<%%(diary-anniversary %d %d)>" + (string-to-number month) + (string-to-number day)) + contact) + (puthash "birthday" (format "<%s-%s-%s>" year month day) contact)))))) + + ;; Extract URL + (goto-char (point-min)) + (when (re-search-forward "^URL:\\(.+\\)$" nil t) + (puthash "url" (match-string 1) contact)) + + ;; Extract NICKNAME + (goto-char (point-min)) + (when (re-search-forward "^NICKNAME:\\(.+\\)$" nil t) + (puthash "nickname" (match-string 1) contact)) + + (widen)))) + + ;; Only add contact if it has a name + (when (gethash "name" contact) + (push contact contacts) + (setq contact-count (1+ contact-count))))) + + ;; Write to org file + (with-temp-file org-file + (insert "#+TITLE: Contacts\n") + (insert "#+STARTUP: overview\n") + (insert "#+CATEGORY: contacts\n\n") + + ;; Sort contacts by name + (setq contacts (sort (reverse contacts) + (lambda (a b) + (string< (or (gethash "name" a) "") + (or (gethash "name" b) ""))))) + + (dolist (contact contacts) + (insert (format "* %s\n" (gethash "name" contact ""))) + (insert " :PROPERTIES:\n") + + ;; Add all properties + (when-let ((email (gethash "email" contact))) + (insert (format " :EMAIL: %s\n" email))) + (when-let ((phone (gethash "phone" contact))) + (insert (format " :PHONE: %s\n" phone))) + (when-let ((org-name (gethash "org" contact))) + (insert (format " :COMPANY: %s\n" org-name))) + (when-let ((title (gethash "title" contact))) + (insert (format " :TITLE: %s\n" title))) + (when-let ((addr (gethash "address" contact))) + (insert (format " :ADDRESS: %s\n" addr))) + (when-let ((bday (gethash "birthday" contact))) + (insert (format " :BIRTHDAY: %s\n" bday))) + (when-let ((url (gethash "url" contact))) + (insert (format " :URL: %s\n" url))) + (when-let ((nick (gethash "nickname" contact))) + (insert (format " :NICKNAME: %s\n" nick))) + + (insert " :END:\n") + + ;; Add note as body text + (when-let ((note (gethash "note" contact))) + (insert (format "\n %s\n" note))) + + (insert "\n"))) + + ;; Message is now inside the let block where contact-count is accessible + (message "Converted %d contacts to %s" contact-count org-file)))) + + +(defun cj/delete-contact-files () + "Delete contact conversion files without confirmation." + (interactive) + (let ((files '("~/downloads/contacts-clean.vcf" + "~/sync/org/contacts.org"))) + (dolist (file files) + (let ((expanded-file (expand-file-name file))) + (when (file-exists-p expanded-file) + (delete-file expanded-file) + (message "Deleted: %s" expanded-file)))))) + +(cj/delete-contact-files) + +(cj/clean-vcf-for-import "~/downloads/contacts.vcf" + "~/downloads/contacts-clean.vcf") + +;; convert it to org contacts +(cj/convert-cleaned-vcf-to-org-contacts "~/downloads/contacts-clean.vcf" + "~/sync/org/contacts.org") + +(provide 'vcf-conversion-helpers) +;;; vcf-conversion-helpers.el ends here. |