;;; -*- lexical-binding: t -*-

;; Time-stamp: <2026-08-10 21h19 BST (763f23aa)>

(require 'cl)

(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" "at"
            "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 "at" p) p )
       ((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 extra)
  (cdm--not-so-smart-move)
  (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 ") 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)))
      (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)))
     (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 ",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))))

(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 "" "$$" 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)))))

(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)