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