From ac1a4884d03fc0495c773500d8a13f84b695fa43 Mon Sep 17 00:00:00 2001
From: tslil clingman <>
Date: Wed, 11 Sep 2019 19:18:14 -0400
Subject: Init

---
 emacs/scripts/cdm-mode.el | 342 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 342 insertions(+)
 create mode 100644 emacs/scripts/cdm-mode.el

(limited to 'emacs/scripts/cdm-mode.el')

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)
-- 
cgit v1.2.3