;; Time-stamp: <2020-06-04 20:42:03 (tslil@bison)>
(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")))
(defvar cdm-parr-dir-list '(("left -> right" . 0)
("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-scale-arrow "la")
(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--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--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)))))
(completing-read prompt list)))
(defun cdm--complete-alist (prompt list)
(let ((result (cdm--complete prompt list)))
(when result (cdr (assoc-string result list)))))
(defun cdm--complete-position ()
(let ((p (cdm--complete "Select relative position: " cdm--pos-list)))
(when p
(cond
((string-equal "none" p) nil)
((string-equal "midway" p) (concat p ", from= "))
(t (concat p " of= "))))))
(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 (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))))
(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))))
(defvar cdm-default-cell-slide "\\cellslide")
(defvar cdm-default-cell-length "\\celllength")
(defun cdm--insert-cell-tex (from-node to-node type &optional label-props slide length)
(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 "]") "")))
(insert "\\cell" (if iso "i" "")
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 ");")
(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)))))))
(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--concat-arrow-scale (string)
(concat cdm-scale-arrow (if (string-blank-p string) "" ",") string))
(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-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))))))))
(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 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)))
(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-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)))))
(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) ""))
((= 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 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 ()
(require 'subr-x)
(require 'cl-lib))
(define-minor-mode cdm-mode
"Minor mode to help with commutative diagrams"
:lighter " CDM" :keymap cdm-mode-map
(cdm--init))
(provide 'cdm-mode)