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