;;; -*- mode:lisp; package: tv; base:10.; -*- ;;;

;;;  tree-menu

;;;  This file contains code to implement tree-oriented menus.

;;;  A tree is in the classical sense a recursive collection of
;;; parents and children.  This facility pops up a menu displaying
;;; a tree, and allows the user to select one member of the tree.
;;; Except for the geometry, this behaves similar to any other
;;; type of menu.

;;;  The description of the tree is a normal menu-item list,
;;; with one additional feature:  each element should have a :parent
;;; value which is the tag of the parent in the list
;;; of menu items.  The root of the tree should have :parent value
;;; of T.  
;;;
;;;  Important constraints.
;;;  2.  The tag of the root-parent MUST BE ':root.
;;;
;;;An example follows:
;;;
;;;  '(("Parent Node" :value :parent :font fonts:tr12i
;;;                   :documentation "This is the parent node in this tree."
;;;                   :parent t :tag :parent)
;;;    ("Subnode"     :value foo :font fonts:tr12i :parent :parent)
;;;    ("Another subnode" :value foo :parent :parent :tag :boo)
;;;    ("asldfj"      :value boo :parent :boo))



;;;  ****************************************************************
;;;  Necessary Loads, Constants, Declarations.
;;;  ****************************************************************

(defconst test-item-list '(("Parent Node"   :value 1 :font fonts:tr12b
					    :documentation "This is the parent node"
					    :parent t :tag :root)
			   ("Foo"           :value 2 :font fonts:cptfontb
					    :parent :root :tag :foo)
			   ("Not in tree"   :value 'foo :documentation
					    "This item  is not in the tree.")
			   ("Moo"           :value 4 :parent :foo :tag :moo)
			   ("Goo"           :value 5 :parent :foo :tag :goo)
			   ("Bar"           :value 3 :font fonts:cptfontb
					    :parent :root :tag :bar)
			   ("Gai"           :value 6 :parent :bar :tag :gai)
			   ("Pan"           :value 7 :parent :bar :tag :pan)
			   ("Deeper node"   :value 8 :parent :pan :tag :deep
					    :font fonts:tr12i)
			   ("Other deeper"  :value 9. :parent :pan :tag :deep2
					    :font fonts:tr12i)
			   ("Deepest"       :value 10. :parent :deep :tag :really
					    :font fonts:medfnt)))



;;;  ****************************************************************
;;;  Internal Macros, Structure Definitions, FLAVOR definitions.
;;;  ****************************************************************


;;;  Basic flavor for tree-menus.  This will handle the drawing message
;;; to lay things out correctly.
(defflavor tree-menu-mixin
	((tree-depth nil)
	 (tree-width nil)
	 )
	(basic-menu graphics-mixin))


(defflavor momentary-tree-menu
	()
	(tree-menu-mixin momentary-menu))

(defflavor multiple-tree-menu
	()
	(multiple-tree-menu-mixin tree-menu-mixin momentary-multiple-menu))

(defflavor multiple-tree-menu-mixin
	()
	()
  (:required-flavors tree-menu-mixin multiple-menu-mixin))



;;;  ****************************************************************
;;;  Internal Code
;;;  ****************************************************************


;;;  Some of this was stolen from BASIC-MENU.
(DEFMETHOD (tree-menu-mixin :SET-ITEM-LIST) (NEW-ITEM-LIST)
  "This after method sets up the children property in each menu
 item so that we can later look up a nodes children instead of
 having to calculate.
   Treat the item list as a disembodied property-list."
  (SETQ ITEM-LIST NEW-ITEM-LIST
	LAST-ITEM NIL
	CURRENT-ITEM NIL)
  (loop for item in item-list
	for j = (get item ':tag)
	;; Have to putprop on cddr of item, or we'll destroy the
	;; value slot, which is special.
	if j					;If this is a tree item
	do (putprop (cddr item)
		    (loop for it in item-list
			  for i = (get it ':tag)
			  if (eq (get it ':parent) j)
			  collect i)
		    ':children))
  (setq tree-depth (send self ':calculate-tree-depth)
	tree-width (1+ (send self ':calculate-tree-width)))
  (send self ':set-geometry tree-depth tree-width)
  (send self ':massage-item-list)
  (FUNCALL-SELF ':SET-FONT-MAP (MENU-COMPUTE-FONT-MAP NEW-ITEM-LIST))
  (MENU-COMPUTE-GEOMETRY T)		;Recompute parameters, and redraw menu
  NEW-ITEM-LIST)


(DEFMETHOD (MULTIPLE-tree-MENU-MIXIN :SET-ITEM-LIST) (NEW-ITEM-LIST)
  (FUNCALL-SELF ':SET-HIGHLIGHTED-ITEMS NIL)
  (SETQ ITEM-LIST (MULTIPLE-MENU-HACK-ITEM-LIST NEW-ITEM-LIST)
	LAST-ITEM NIL
	CURRENT-ITEM NIL)
  (FUNCALL-SELF ':SET-FONT-MAP (MENU-COMPUTE-FONT-MAP ITEM-LIST))
  (loop for item in item-list
	for j = (get item ':tag)
	;; Have to putprop on cddr of item, or we'll destroy the
	;; value slot, which is special.
	if j					;If this is a tree item
	do (putprop (cddr item)
		    (loop for it in item-list
			  for i = (get it ':tag)
			  if (eq (get it ':parent) j)
			  collect i)
		    ':children))
  (setq tree-depth (send self ':calculate-tree-depth)
	tree-width (1+ (send self ':calculate-tree-width)))
  (send self ':set-geometry tree-depth tree-width)
  (send self ':massage-item-list)
  (MENU-COMPUTE-GEOMETRY T)		;Recompute parameters, and redraw menu
  ITEM-LIST)



(defmethod (tree-menu-mixin :after :set-item-list)
	   (&rest ignore)
  (send self ':set-save-bits t)
  (send self ':set-deexposed-typeout-action ':permit)
  )


(defmethod (tree-menu-mixin :calculate-tree-depth)
	   ()
  "Recursive procedure to determine the maximum depth of the tree."
  (1+ (loop for child in (get (find-item ':root item-list) ':children)
	    maximize (deep item-list (find-item child item-list) 1))))

(defun deep (item-list item level)
  "If the item has children, this maximizes recursion over the
 children.  Otherwise, just returns the current level."
  (let ((children (get item ':children)))
    (if children
	(loop for child in children
	      maximize (deep item-list (find-item child item-list) (1+ level)))
	level)))

(defun find-item (tag item-list)
    "Given the tag of an item, finds the correct item."
    (loop for item in item-list
	  if (eq tag (get item ':tag)) return item))


(defmethod (tree-menu-mixin :calculate-tree-width)
	   ()
  "Calculates the width of the tree, which is simply the number
 of terminal leaves in the tree."
  (loop for item in item-list
	count (and (get item ':tag)
		   (null (get item ':children)))))



;;;
;;;
(defmethod (tree-menu-mixin :massage-item-list)
    (&aux new-list)
  "Completely rearranges the menu's item-list, inserting needed blank
 items, to get the correct layout.  The position of each item in the
 menu can be calculated using get-depth and get-position on each item.
 We build a completely new list to do this."
  ;; Make a dummy list full of non-selectable items.
  (setq new-list (make-list (* tree-depth tree-width)
			    ':initial-value '("" :no-select t)))
  ;; Now, loop over all the current items, placing them in the dummy list.
  (loop for item in item-list
	with inc = 0
	if (get item ':tag)
	do (setf (nth (+ (* tree-depth (get-position item item-list))
			 (get-depth item item-list))
		      new-list)
		 item)
	unless (or (memq ':no-select item) (get item ':tag))
	do (setf (nth (+ (* tree-depth (1- tree-width)) inc) new-list)
		 item)
	AND do (format t "~% Item: ~A" item)
	AND do (incf inc))
  
  (setq item-list new-list))


;;;
;;;
(defmethod (tree-menu-mixin :before :choose)
	   (&rest ignore)
  "This :after daemon draws all the connecting lines to show the
 tree structure."
  (loop for item in item-list
	if (get item ':children)
	do (loop for ch in (get item ':children)
		 for child = (find-item ch item-list)
		 do (send self ':draw-menu-line item child))))

;;;
;;;
(defconst *tree-menu-fudge* -2.
  "Small amount (in pixels) to separate tree-lines from the labels.
 Otherwise, they would touch.")

;;;
;;;
(defmethod (tree-menu-mixin :draw-menu-line)
	   (parent child)
  "Draws a line from parent to child in the menu."
  (multiple-value-bind (pstr pfon)
      (menu-item-string parent)
    (multiple-value-bind (cstr cfon)
	(menu-item-string child)
      (let ((parent-row (get-position parent item-list))
	    (parent-col (get-depth parent item-list))
	    (child-row (get-position child item-list))
	    (child-col (get-depth child item-list))
	    (parent-width (send self ':string-length pstr 0 nil nil pfon))
	    (child-width (send self ':string-length cstr 0 nil nil cfon)))
	(send self ':draw-line
	      (- (* (1+ parent-col) column-width)
		 menu-intercolumn-spacing *tree-menu-fudge*
		 (// (- column-width menu-intercolumn-spacing parent-width) 2.))
	      (+ (* parent-row row-height) (// row-height 2.))
	      (+ (* child-col column-width) *tree-menu-fudge*
		 (// (- column-width menu-intercolumn-spacing child-width) 2.))
	      (+ (* child-row row-height) (// row-height 2.)))))))

;;;
;;;
(defun-method tree-sort-item-lessp tree-menu-mixin (menu-item-1 menu-item-2)
  "The sorting-predicate for sorting items in the item-list of a tree-menu.
 ItemA is less than ItemB iff
   1. It is higher-up in the tree, or
   2. A and B are both direct descendents of the root item and A appears
     first in the ordering initially, or
   3. A's parent is less than B's parent."
  (cond ;; Check condition 2 first (easiest.)
	((and (eq (get menu-item-1 ':parent) ':root)
	      (eq (get menu-item-2 ':parent) ':root))
	 (< (find-position-in-list-equal menu-item-1 item-list)
	    (find-position-in-list-equal menu-item-2 item-list)))
	;; Now check condition 1.
	((< (get-depth menu-item-1 item-list)
	    (get-depth menu-item-2 item-list))
	 t)
	;; Now make sure both are at same level
	((= (get-depth menu-item-1 item-list)
	    (get-depth menu-item-2 item-list))
	 (tree-sort-item-lessp (get-parent menu-item-1 item-list)
			       (get-parent menu-item-2 item-list)))))


;;;
;;;
(defun get-depth (item item-list)
  "Returns the depth within the tree (specified in the item-list) of the
 item."
  (cond ((eq ':root (get item ':tag)) 0)
	(t (1+ (get-depth (get-parent item item-list) item-list)))))

;;;
;;;
(defun get-relative-position (item item-list)
  "Returns the position of this item with respect to its parent.
 If it is the first child, its position is 0.  If this node IS
 the root node, the position is by definition 0.  If the node is
 not the first child, its position includes the width of all the
 children before it."
  (if (eq (get item ':tag) ':root) 0.
      ;; Loop over all nodes on the same level as this one up to but not
      ;; including this one.  Sum up the "width" of these nodes.
      (loop for node in (get (find-item (get item ':parent) item-list) ':children)
	    until (eq node (get item ':tag))
	    sum (get-width (find-item node item-list) item-list))))

;;;
;;;
(defun get-width (item item-list)
  "Returns the width of an item.  This is the number of terminal children."
  (if (get item ':children)
      (loop for child in (get item ':children)
	    for ch = (find-item child item-list)
	    sum (get-width ch item-list))
      1.))

;;;
;;;
(defun get-position (item item-list)
  "Returns the position of this item with respect to the root of
 the tree.  This calls get-relative-position all the way back up
 the tree."
  (loop for parent first item then (find-item (get parent ':parent) item-list)
	until (eq (get parent ':tag) ':root)
	summing (get-relative-position parent item-list)))

;;;
;;;
(defun get-parent (item item-list)
  "Returns the parent item of the current item.  If this item is
 the root node, returns T."
  (cond ((eq (get item ':tag) ':root) t)
	(t (find-item (get item ':parent) item-list))))