;;;; insert-tree.el
;;;; Copyright (c) 2022, 2025 Devon Sean McCullough (assigned to FSF)
;;;; Licensed under the GNU GPL; the usual boilerplate applies.

;; (insert-tree '(root0 leaf1 (branch2 leaf3 leaf4))
;;              #'identity
;;              #'prin1-to-string)
;; => ("(root0 leaf1 (branch2 leaf3 leaf4))" ("root0") ("leaf1") ("(branch2 leaf3 leaf4)" ("branch2") ("leaf3") ("leaf4")))
;;	(root0 leaf1 (branch2 leaf3 leaf4))
;;	├→root0
;;	├→leaf1
;;	└→(branch2 leaf3 leaf4)
;;	  ├→branch2
;;	  ├→leaf3
;;	  └→leaf4

;; (insert-tree '(root0 #1= leaf1 (branch2 leaf3 #1#) leaf4)
;;              (lambda (node)
;;                (if (consp node)
;;                    (cdr node)))
;;              (lambda (node)
;;                (if (consp node)
;;                    (car node)
;;                  node)))
;; => (root0 (leaf1) (branch2 (leaf3) [leaf1]) (leaf4))
;;	root0
;;	├→leaf1
;;	├→branch2
;;	│ ├→leaf3
;;	│ └→[leaf1]
;;	└→leaf4

(defcustom insert-tree-line-style :unicode
  "Line drawing character set for `insert-tree' to use,
:unicode by default. Ask if neither :unicode nor :ascii."
  ;; TO DO
  ;; Maybe add :unicode-nospace option to not delimit leaves
  ;; Maybe add :vt100 style
  ;; Read defcustom and tty docs
  :group 'insert-tree
  :type 'symbol
  :options '(:unicode :ascii nil)
  :require 'insert-tree
  :safe t)

(defun insert-tree (root get-branches get-name)
  "Render arbitrary object ROOT as a tree.
Function GET-BRANCHES gets a list of branches of a node.
Function GET-NAME gets the eq-unique name of a node.
See `insert-tree-line-style' for line drawing options."
  ;; TO DO
  ;; Reconsider name and arguments
  ;;	keyword arguments if too numerous
  ;;	optional indent style arg, e.g., center of parent name
  ;; Either return s-expression or print tree depending on arguments
  ;;	with a render-name argument, e.g., return [NAME] or " NAME"
  ;;	given a node and optional already-seen argument
  ;;	which could be N for #N#
  ;;	two-pass option with -N for #N=
  ;; Use to decorate dired, disassemble, etc.
  ;; Comments below about word syntax are no longer correct - maybe propertize & fix copy-click
  (let ((seen '())
	(lines (cdr (assq (if (member insert-tree-line-style '(:unicode :ascii))
			      insert-tree-line-style
			    (setq insert-tree-line-style (if (y-or-n-p "Unicode line drawing? ")
							     :unicode :ascii)))
			  '((:unicode . " │├└→") ; arrow not word syntax - ok for copy-click
			    ;; (:unicode* . " │├└─") ; box weirdly word syntax - bad for copy-click
			    (:ascii . " |+\\-"))))))
    (labels ((render (prefix twig node)
	       (when prefix
		 (princ (substring prefix 2))
		 (princ (char-to-string (aref lines twig)))
		 (princ (char-to-string (aref lines 4))))
	       (setq prefix (concat prefix
				    (char-to-string (aref lines (if (= 2 twig) 1 0)))
				    " "))
	       (let ((leaf (funcall get-name node))
		     (branches (funcall get-branches node)))
		 (cond ((memq node seen)
			(prog1 (princ (vector leaf)) ; mark as link
			  (terpri)))
		       (t (push node seen)
			  (cons (prog1 (princ leaf)
				  (terpri))
				;; (mapcar #'render (funcall get-branches node))
				(loop
				 for tail on branches
				 for more = (cdr tail)
				 for twig = (if (cdr tail) 2 3)
				 collect (render prefix twig (car tail)))))))))
      (render nil 4 root))))

(provide 'insert-tree)

;;;; end insert-tree.el