diff options
Diffstat (limited to 'emacs/scripts/cdm-mode.el')
| -rw-r--r-- | emacs/scripts/cdm-mode.el | 342 |
1 files changed, 342 insertions, 0 deletions
diff --git a/emacs/scripts/cdm-mode.el b/emacs/scripts/cdm-mode.el new file mode 100644 index 0000000..03fcc76 --- /dev/null +++ b/emacs/scripts/cdm-mode.el @@ -0,0 +1,342 @@ +;; Time-stamp: <2019-05-22 19:10:33 (tslil@basingstoke)> + +(defvar cdm-arr-type-list '(("arrow" . "a") + ("id" . "d") + ("proarrow" . "proarrow") + ("proid" . "proequal") + ("prodotted" . "prodotted") + ("2-square" . "sn") + ("id-square" . "sd") + ("universal" . "u") + ("2-cell" . "n") + ("3-cell" . "t") + ("3-square" . "st") + ("parallel" . "p") + ("monomorphism" . "m") + ("epimorphism" . "e"))) + +(defvar cdm-parr-dir-list '(("left -> right" . 0) + ("right -> left" . 1) + ("up -> down" . 2) + ("down -> up" . 3))) + +(defvar cdm-wrap-list '("diagram" "tikzpicture" "diagram*" "dgrm")) + +(defvar cdm--pos-list '("below" "right" "left" "above" + "midway" "below right" "below left" + "above right" "above left" "none")) + +(defvar cdm-cell-len ".3cm") + +(defvar cdm--use-helm nil) + +(defvar cdm-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c a") 'cdm-insert-arrow) + (define-key map (kbd "C-c n") 'cdm-insert-node) + (define-key map (kbd "C-c d") 'cdm-insert-square) + (define-key map (kbd "C-c r") 'cdm-square-reset) + map)) + +(defvar cdm--node-list nil) +(defvar cdm--pos-helm-source nil) +(defvar cdm--node-helm-source nil) +(defvar cdm--parr-dir-helm-source nil) +(defvar cdm--arr-type-helm-source nil) + +(defvar cdm--strip-label t) + +(defvar cdm--square-progress 0) +(defvar cdm--square-nodes nil) + +(defun cdm--find-enclosing-pair () + (let* ((p (point)) s e + (lst (cl-loop + for delim in cdm-wrap-list collect + (save-excursion + (when (and + (setq s (search-backward (concat "\\begin{" delim "}") 0 t)) + (setq e (search-forward (concat "\\end{" delim "}") nil t)) + (<= s p) (<= p e)) + (list s e)))))) + (cl-flet + ((nearest (best curr) + (if (or (not best) + (and curr + (> (car curr) (car best)) + (< (cadr curr) (cadr best)))) + curr best))) + (reduce #'nearest lst :initial-value nil)))) + +(defun cdm--is-natural (str) + (when (and str (string-match "[0-9]+" str)) + (string-to-number str))) + +(defun cdm--sort-p (s1 s2) + (let ((n1 (cdm--is-natural (cdr s1))) + (n2 (cdm--is-natural (cdr s2)))) + (if (and n1 n2) (> n1 n2) + (string-lessp (cdr s1) (cdr s2))))) + +(defun cdm--strip-label-f (str) + (let ((strs (split-string str "$+"))) + (if (and (= 3 (length strs)) + (string-blank-p (car strs)) + (string-blank-p (caddr strs))) + (cadr strs) str))) + +;; TODO: This will probably pick up nodes in the text of other nodes. +(defun cdm--scan-for-nodes (start end) + (save-excursion + (setq cdm--node-list nil) + (goto-char start) + (let (node-start node-end label-start label-end) + (while (setq node-start (search-forward "node(" end t)) + (setq node-end (search-forward ")" end t) + label-start (search-forward "{" end t) + label-end (progn (backward-char) + (ignore-errors (1+ (forward-list))))) + (when (and node-end label-start label-end (< 1 (- node-end node-start))) + (let* ((temp (if (and label-end label-start (> label-end label-start)) + (buffer-substring-no-properties label-start (- label-end 2)) + "This literal will never appear in the list.")) + (node (buffer-substring-no-properties node-start (1- node-end))) + (label (if (string-blank-p temp) (concat node "\t(no label)") + (concat (if cdm--strip-label (cdm--strip-label-f temp) temp) + "\t(" node ")")))) + (push `(,label . ,node) cdm--node-list)))))) + cdm--node-list) + +(defun cdm--get-nodes () + (let ((enclosing-pair (cdm--find-enclosing-pair))) + (if enclosing-pair + (progn (apply #'cdm--scan-for-nodes enclosing-pair) + (setq cdm--node-list (sort (copy-list cdm--node-list) #'cdm--sort-p)) + (or cdm--node-list t)) + (error "Not currently in an enclosing diagram environment.")))) + +(defun cdm--ivy-complete (prompt list) + (cdr (assoc-string (ivy-read prompt list) list))) + +(defun cdm--complete-nodes (prompt) + (if cdm--use-helm (helm :sources cdm--node-helm-source + :prompt prompt + :buffer "*helm-node*") + (cdm--ivy-complete prompt cdm--node-list))) + +(defun cdm--complete-position () + (let* ((prompt "Select relative position: ") + (p (if cdm--use-helm (helm :sources cdm--pos-helm-source + :prompt prompt + :buffer "*helm-position*") + (ivy-read prompt cdm--pos-list)))) + (when p + (cond + ((string-equal "none" p) nil) + ((string-equal "midway" p) (concat p ", from= ")) + (t (concat p " of= ")))))) + +(defun cdm--complete-arr-type () + (let ((prompt "Select arrow type: ")) + (if cdm--use-helm (helm :sources cdm--arr-type-helm-source + :prompt prompt + :buffer "*helm-arrow*")) + (cdm--ivy-complete prompt cdm-arr-type-list))) + +(defun cdm--not-so-smart-move () + (back-to-indentation) + (unless (= (point) (line-end-position)) + (end-of-line) + (newline-and-indent))) + +(defun cdm--insert-raw-node (name modifiers content &optional goto) + (cdm--not-so-smart-move) + (insert "\\node(" name ")[" modifiers "]{" content "};") + (when goto (backward-char goto))) + +(defun cdm--insert-raw-path (name starting ending modifiers content &optional goto) + (cdm--not-so-smart-move) + (insert "\\path(" starting ") -- (" ending ")node(" + name ")[auto=false" modifiers "]{" content "};") + (when goto (backward-char goto))) + +(defun cdm--next-name () + (when (cdm--get-nodes) + (let* ((last-name (cdar cdm--node-list)) + (last-number (if last-name (string-to-number last-name) 0))) + (unless (and (= 0 last-number) + last-name) + (number-to-string (+ 1 last-number)))))) + +(defun cdm-insert-node (&optional node-name) + (interactive) + (let* ((name (or node-name + (read-string "New node name: " (cdm--next-name)))) + (position (cdm--complete-position)) + (rel-to (when position (cdm--complete-nodes position))) + (midway-other (when (and position + (string-prefix-p "midway" position)) + (cdm--complete-nodes "midway, ending=")))) + (if midway-other + (cdm--insert-raw-path name rel-to midway-other ",midway" "$$" 3) + (cdm--insert-raw-node name (if rel-to (concat position rel-to) "") "$$" 3)))) + +(defun cdm--string-good-p (str) + (and str (string-or-null-p str) (not (string-blank-p str)))) + +(defun cdm--insert-arrow-tex (from-node to-node type &optional label-props draw-style misc) + (end-of-line) + (newline-and-indent) + (insert "\\draw[" type + (if (cdm--string-good-p draw-style) + (concat "," draw-style) "") + "]" + (if (cdm--string-good-p misc) misc "") + "(" from-node ")to" + (if label-props + (concat " node[" label-props "]{$$}") "") + "(" to-node ");") + (when label-props (search-backward "$}"))) + +(defun cdm--insert-arrow-square-tex (from-node to-node type &optional label-props extra) + (cdm--insert-arrow-tex "\\p2" "\\p3" type + (unless (string-equal type "d") + (concat label-props "inner sep=0,swap")) + extra + (concat "let \\p1 = ($(" + from-node ")!.5!(" + to-node ")$), \\p2 = ($(\\p1)!" cdm-cell-len "!(" + from-node ")$), \\p3 =($(\\p1)!" cdm-cell-len "!(" + to-node ")$) in "))) + +(defun cdm--insert-parallel-arrows (from-node to-node &optional labelled) + (let* ((prompt "Select parallel arrow directionality: ") + (ty (if cdm--use-helm (helm :sources cdm--parr-dir-helm-source + :prompt prompt + :buffer "*helm-parr*") + (cdm--ivy-complete prompt cdm-parr-dir-list)))) + (when ty + (let ((dirs (case ty + (0 '(".east" . ".west" )) + (1 '(".west" . ".east" )) + (2 '(".south". ".north")) + (3 '(".north". ".south")))) + (pre-str (concat "[" (if (< ty 2) "y" "x") "shift=")) + (plus "+0.6ex]") + (minus "-0.6ex]") + (swaps (if (or (= ty 0) (= ty 2)) '("" . "swap") '("swap" . "")))) + (cdm--insert-arrow-tex (concat pre-str plus from-node (car dirs)) + (concat pre-str plus to-node (cdr dirs)) + "a" (when labelled (car swaps))) + (cdm--insert-arrow-tex (concat pre-str minus from-node (car dirs)) + (concat pre-str minus to-node (cdr dirs)) + "a" (when labelled (cdr swaps))))))) + +(defmacro let*-unless-null (list &rest body) + (if list + (let* ((curr (pop list)) + (dest (car curr)) + (expr (cadr curr))) + `(let ((,dest ,expr)) + (when ,dest (let*-unless-null ,list ,@body)))) + `(progn ,@body))) + +(defun cdm-insert-arrow (extra-props) + (interactive "P") + (when (cdm--get-nodes) + (unless cdm--node-list + (error "Cannot insert an arrow, no nodes found.")) + (end-of-line) + ;; TODO: recast i.t.o let*-unless-null + (let ((type (cdm--complete-arr-type))) + (when type + (let* ((par (string-equal "p" type)) + (extra (when (and (not par) extra-props) + (read-string "Extra properties: "))) + (from-node (cdm--complete-nodes "From: ")) + (to-node (cdm--complete-nodes "To: ")) + (labelled (unless (string-suffix-p "d" type) + (char-equal ?\C-m (read-char "Labelled (Return = yes)?")))) + (label-props (when (and (not par) labelled) + (read-string "Label properties: ")))) + (cond + (par (cdm--insert-parallel-arrows from-node to-node labelled)) + ((string-prefix-p "s" type) + (cdm--insert-arrow-square-tex from-node to-node + (string-remove-prefix "s" type) + label-props + extra)) + (t (cdm--insert-arrow-tex from-node to-node type label-props extra)))))))) + + +(defun cdm-square-reset () + (interactive) + (setq cdm--square-progress 0 + cdm--square-nodes nil) + (message "Square progress reset.")) + +;; TODO: Orientation? This is broken with swaps if you change orientation... +(defun cdm--prompt-insert-arrow-square (node-1 node-2 swap) + (when (cdm--get-nodes) + (let (r d) + (dolist (n cdm--node-list) + (when (or (string-equal node-1 (cdr n)) + (string-equal node-2 (cdr n))) + (add-to-list 'r n))) + (setq cdm--node-list r) + (setq d (cdm--complete-nodes "Domain for arrow: ")) + (if (string-equal d node-1) + (cdm--insert-arrow-tex d node-2 "a" swap) + (cdm--insert-arrow-tex d node-1 "a" swap))))) + +(defun cdm-insert-square () + (interactive) + (let ((p cdm--square-progress) + (n cdm--square-nodes) + (s (cdm--next-name))) + ;; Insert stuff + (cond + ((= p 7) (cdm--prompt-insert-arrow-square (nth 3 n) (nth 1 n) "swap")) + ((= p 6) (cdm--prompt-insert-arrow-square (nth 2 n) (nth 0 n) "")) + ((= p 5) (cdm--prompt-insert-arrow-square (nth 3 n) (nth 2 n) "")) + ((= p 4) (cdm--prompt-insert-arrow-square (nth 1 n) (nth 0 n) "swap")) + ((= p 3) (cdm--insert-raw-node s (concat "below of=" (cadr n)) "$$" 3)) + ((= p 2) (cdm--insert-raw-node s (concat "below of=" (car n)) "$$" 3)) + ((= p 1) (cdm--insert-raw-node s (concat "right of=" (car n)) "$$" 3)) + ((= p 0) (cdm-insert-node s))) + ;; Adjust state + (if (= p 7) (cdm-square-reset) + (setq cdm--square-progress (1+ cdm--square-progress)) + (when (and (<= p 3) (>= p 0)) + (add-to-list 'cdm--square-nodes s t))))) + +(defun cdm--init-helm () + (setq cdm--pos-helm-source (helm-build-sync-source "position" + :candidates 'cdm--pos-list + :fuzzy-match t + :nomark t) + cdm--arr-type-helm-source (helm-build-sync-source "arrow-type" + :candidates 'cdm-arr-type-list + :fuzzy-match t + :nomark t) + cdm--node-helm-source (helm-build-sync-source "nodes" + :candidates 'cdm--node-list + :fuzzy-match t + :nomark t + :multiline t) + cdm--parr-dir-helm-source (helm-build-sync-source "parr-dir" + :candidates 'cdm-parr-dir-list + :fuzzy-match t + :nomark t))) + +(defun cdm--init () + (require 'subr-x) + (require 'cl) + (if cdm--use-helm (cdm--init-helm)) ) + +(define-minor-mode cdm-mode + "Minor mode to help with commutative diagrams" + :lighter " CDM" :keymap cdm-mode-map + (cdm--init)) + +(provide 'cdm-mode) |