diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/scripts/cdm-mode.el | 300 |
1 files changed, 151 insertions, 149 deletions
diff --git a/emacs/scripts/cdm-mode.el b/emacs/scripts/cdm-mode.el index 1f8edb0..d62c6a4 100644 --- a/emacs/scripts/cdm-mode.el +++ b/emacs/scripts/cdm-mode.el @@ -1,31 +1,31 @@ -;; Time-stamp: <2020-06-04 20:42:03 (tslil@bison)> +;; Time-stamp: <2022-04-17 09h45 EDT (academic)> (defvar cdm-arr-type-list '(("arrow" . "a") - ("2-cell arrow" . "n") - ("id" . "d") - ("universal" . "u") - ("2-cell" . "cn") - ("2-cell iso" . "cni") - ("2-cell eq" . "cne") - ("3-cell" . "ct") - ("3-cell eq" . "cte") - ("proarrow" . "proarrow") - ("proid" . "proequal") - ("prodotted" . "prodotted") - ("parallel" . "p") - ("monomorphism" . "m") - ("epimorphism" . "e"))) + ("2-cell arrow" . "n") + ("id" . "d") + ("universal" . "u") + ("2-cell" . "cn") + ("2-cell iso" . "cni") + ("2-cell eq" . "cne") + ("3-cell" . "ct") + ("3-cell eq" . "cte") + ("proarrow" . "proarrow") + ("proid" . "proequal") + ("prodotted" . "prodotted") + ("parallel" . "p") + ("monomorphism" . "m") + ("epimorphism" . "e"))) (defvar cdm-parr-dir-list '(("left -> right" . 0) - ("right -> left" . 1) - ("up -> down" . 2) - ("down -> up" . 3))) + ("right -> left" . 1) + ("up -> down" . 2) + ("down -> up" . 3))) (defvar cdm-wrap-list '("diagram" "tikzpicture" "diagram*" "vdiagram" "vsubdiagram" "hsubdiagram")) -(defvar cdm--pos-list '("below" "right" "left" "above" - "midway" "below right" "below left" - "above right" "above left" "none")) +(defvar cdm--pos-list '("below" "right" "left" "above" "at" + "midway" "below right" "below left" + "above right" "above left" "none")) (defvar cdm-scale-arrow "la") @@ -46,21 +46,21 @@ (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)))))) + (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))) + ((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) @@ -69,16 +69,16 @@ (defun cdm--sort-p (s1 s2) (let ((n1 (cdm--is-natural (cdr s1))) - (n2 (cdm--is-natural (cdr s2)))) + (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))) + (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) @@ -87,35 +87,35 @@ (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)))))) + (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)) + (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--complete (prompt list) (let* ((completion-table (lambda (string pred action) - (if (eq action 'metadata) - '(metadata (display-sort-function . identity) - (cycle-sort-function . identity)) - (complete-with-action action list string pred))))) + (if (eq action 'metadata) + '(metadata (display-sort-function . identity) + (cycle-sort-function . identity)) + (complete-with-action action list string pred))))) (completing-read prompt list))) (defun cdm--complete-alist (prompt list) @@ -127,8 +127,9 @@ (when p (cond ((string-equal "none" p) nil) + ((string-equal "at" p) p ) ((string-equal "midway" p) (concat p ", from= ")) - (t (concat p " of= ")))))) + (t (concat p "= of ")))))) (defun cdm--not-so-smart-move () (back-to-indentation) @@ -136,37 +137,38 @@ (end-of-line) (newline-and-indent))) -(defun cdm--insert-raw-node (name modifiers content &optional goto) +(defun cdm--insert-raw-node (name modifiers content &optional goto extra) (cdm--not-so-smart-move) - (insert "\\node(" name ")[" modifiers "]{" content "};") + (insert "\\node(" name ")" (if extra extra "") "[" 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 "};") + (insert "\\path (" starting ") to node(" name ")[auto=false" modifiers "]{" content "} (" ending ");") (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))) + (last-number (if last-name (string-to-number last-name) 0))) (unless (and (= 0 last-number) - last-name) - (number-to-string (+ 1 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 (when cdm--node-list (cdm--complete-position))) - (rel-to (when position (cdm--complete-alist position cdm--node-list))) - (midway-other (when (and position - (string-prefix-p "midway" position)) - (cdm--complete-alist "midway, ending=" cdm--node-list)))) + (read-string "New node name: " (cdm--next-name)))) + (position (when cdm--node-list (cdm--complete-position))) + (at (string-equal "at" position)) + (rel-to (when (and position (not at)) (cdm--complete-alist position cdm--node-list))) + (extra (when at (concat "at (" (read-string "at: ") ")"))) + (midway-other (when (and position + (string-prefix-p "midway" position)) + (cdm--complete-alist "midway, ending=" cdm--node-list)))) (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)))) + (cdm--insert-raw-path name rel-to midway-other ",la" "$$" 7) + (cdm--insert-raw-node name (if rel-to (concat position rel-to) "") "$$" 3 extra)))) (defun cdm--string-good-p (str) (and str (string-or-null-p str) (not (string-blank-p str)))) @@ -178,67 +180,67 @@ (end-of-line) (newline-and-indent) (let* ((iso (string-suffix-p "i" type)) - (typ (substring-no-properties type 1 (if iso -1 (length type)))) - (yes-props (cdm--string-good-p label-props)) - (yes-slide (cdm--string-good-p slide)) - (yes-length (cdm--string-good-p length)) - (yes-type (not (string-equal typ "n"))) - - (lps (if (or yes-props yes-type yes-slide yes-length) - (concat "[" (if yes-props label-props "") "]") "")) - (tys (if (or yes-type yes-slide yes-length) - (concat "[" typ "]") "")) - (sls (if (or yes-slide yes-length) - (concat "[" (if yes-slide slide cdm-default-cell-slide) "]") - "")) - (lns (if yes-length (concat "[" length "]") ""))) + (typ (substring-no-properties type 1 (if iso -1 (length type)))) + (yes-props (cdm--string-good-p label-props)) + (yes-slide (cdm--string-good-p slide)) + (yes-length (cdm--string-good-p length)) + (yes-type (not (string-equal typ "n"))) + + (lps (if (or yes-props yes-type yes-slide yes-length) + (concat "[" (if yes-props label-props "") "]") "")) + (tys (if (or yes-type yes-slide yes-length) + (concat "[" typ "]") "")) + (sls (if (or yes-slide yes-length) + (concat "[" (if yes-slide slide cdm-default-cell-slide) "]") + "")) + (lns (if yes-length (concat "[" length "]") ""))) (insert "\\cell" (if iso "i" "") - lps tys sls lns - "{" from-node "}" - "{" to-node "}" - "{};")) + lps tys sls lns + "{(" from-node ")}" + "{(" to-node ")}" + "{};")) (backward-char 2)) (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 ");") + (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-parallel-arrows (from-node to-node &optional labelled) (let* ((ty (cdm--complete-alist "Select parallel arrow directionality: " 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))))))) + (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)))) + (dest (car curr)) + (expr (cadr curr))) + `(let ((,dest ,expr)) + (when ,dest (let*-unless-null ,list ,@body)))) `(progn ,@body))) (defun cdm--concat-arrow-scale (string) @@ -253,65 +255,65 @@ ;; TODO: recast i.t.o let*-unless-null (let ((type (cdm--complete-alist "Select arrow type: " cdm-arr-type-list))) (when type - (let* ((par (string-equal "p" type)) - (cell (string-prefix-p "c" type)) - (extra (when (and (not par) (not cell) extra-props) - (read-string "Extra properties: "))) - (from-node (cdm--complete-alist "From: " cdm--node-list)) - (to-node (cdm--complete-alist "To: " cdm--node-list)) - (labelled (unless (string-suffix-p "d" type) - (char-equal ?\C-m (read-char "Labelled (Return = yes)?")))) - (label-props (when (and (not par) labelled) - (cdm--concat-arrow-scale (read-string "Label properties: ")))) - (slide (when cell - (read-string "Slide: "))) - (length (when cell (read-string "Length: ")))) - (cond - (par (cdm--insert-parallel-arrows from-node to-node labelled)) - (cell (cdm--insert-cell-tex from-node to-node type label-props slide length)) - (t (cdm--insert-arrow-tex from-node to-node type label-props extra)))))))) + (let* ((par (string-equal "p" type)) + (cell (string-prefix-p "c" type)) + (extra (when (and (not par) (not cell) extra-props) + (read-string "Extra properties: "))) + (from-node (cdm--complete-alist "From: " cdm--node-list)) + (to-node (cdm--complete-alist "To: " cdm--node-list)) + (labelled (unless (string-suffix-p "d" type) + (char-equal ?\C-m (read-char "Labelled (Return = yes)?")))) + (label-props (when (and (not par) labelled) + (cdm--concat-arrow-scale (read-string "Label properties: ")))) + (slide (when cell + (read-string "Slide: "))) + (length (when cell (read-string "Length: ")))) + (cond + (par (cdm--insert-parallel-arrows from-node to-node labelled)) + (cell (cdm--insert-cell-tex from-node to-node type label-props slide length)) + (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) + cdm--square-nodes nil) (message "Square progress reset.")) ;; TODO: Orientation? This is broken with swaps if one changes orientation... (defun cdm--prompt-insert-arrow-square (node-1 node-2 swap) (when (cdm--get-nodes) (let (r d - (swap (cdm--concat-arrow-scale swap))) + (swap (cdm--concat-arrow-scale swap))) (dolist (n cdm--node-list) - (when (or (string-equal node-1 (cdr n)) - (string-equal node-2 (cdr n))) - (add-to-list 'r n))) + (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-alist "Domain for arrow: " cdm--node-list)) (if (string-equal d node-1) - (cdm--insert-arrow-tex d node-2 "a" swap) - (cdm--insert-arrow-tex d node-1 "a" swap))))) + (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))) + (n cdm--square-nodes) + (s (cdm--next-name))) ;; Insert stuff (cond ((= p 7) (cdm--prompt-insert-arrow-square (nth 3 n) (nth 1 n) "")) ((= p 6) (cdm--prompt-insert-arrow-square (nth 2 n) (nth 0 n) "swap")) ((= p 5) (cdm--prompt-insert-arrow-square (nth 3 n) (nth 2 n) "swap")) ((= p 4) (cdm--prompt-insert-arrow-square (nth 1 n) (nth 0 n) "")) - ((= 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 3) (cdm--insert-raw-node s "" "$$" 3 (concat " at (" (caddr n) "-|" (cadr n) ") "))) + ((= 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))))) + (add-to-list 'cdm--square-nodes s t))))) (defun cdm--init () (require 'subr-x) |