building trees

1 files changed, 152 insertions, 0 deletions

diff --git a/zhsh.lisp b/zhsh.lisp
index 48cb959..62881f1 100644
--- a/zhsh.lisp
+++ b/zhsh.lisp
@@ -1,3 +1,155 @@
 ;;;; zhsh.lisp
 
 (in-package #:zhsh)
+
+;; edit operations
+;; 1. change (a → b)
+;; 2. delete (a → Λ)
+;; 3. insert (Λ → b)
+
+;; need to get the ith node of a tree according to postorder numbering
+
+;; need to be able to calc the left most leaf descendent of a tree
+;; rooted at a given node, itself accessed by postorder index
+
+;; need to be able to lookup the parents of nodes, by their postorder index.
+
+(defclass postorder-tree ()
+  ((data
+    :accessor tree-data
+    :initarg :data
+    :initform (error "Must supply a tree data array.")
+    :documentation
+    "An array of shape (N 3) where (aref structure i 0) is a node,
+    (aref structure i 1) is the index of the node's parent, and 
+    (aref structure i 2) is a list of the node's children.")))
+
+(defun node (tree i)
+  (aref (tree-data tree) i 0))
+
+(defun parent (tree i)
+  (aref (tree-data tree) i 1))
+
+(defun parent-node (tree i)
+  (when (parent-index tree i)
+    (node tree (parent-index tree i))))
+
+(defun children (tree root)
+  (aref (tree-data tree) root 2))
+
+(defun leafp (tree i)
+  (null (aref (tree-data tree) i 2)))
+
+(defun node-count (list)
+  "Returns the number of nodes in the tree rooted at LIST, where atoms
+   are leaf nodes and sublists are subtrees."
+  (if (consp list) 
+      (+ 1 (reduce #'+ (mapcar #'node-count list)))
+      1))
+
+(defun child-p (tree i j)
+  "Is I a direct child of J?"
+  (= (parent-index tree i) j))
+
+(defun descendents (tree root)
+  (labels ((rec (node)
+             (when (children tree node)
+               (append (children tree node)
+                       (mapcan #'rec (children tree node))))))
+    (rec root)))
+
+(defun descendent-leaves (tree root)
+  (labels
+      ((rec (node)
+         (when (children tree node)
+           (append (remove-if-not #'local-leaf-p (children tree node))
+                   (mapcan #'rec (children tree node)))))
+       (local-leaf-p (node)
+         (leafp tree node)))
+    (rec root)))
+
+(defun root-node (tree)
+  (1- (car (array-dimensions (tree-data tree)))))
+
+(defun depth (tree)
+  (labels ((rec (node)
+             (1+
+              (cond
+                ((null (children tree node))
+                 0)
+                ((null (rest (children tree node)))
+                 (rec (first (children tree node))))
+                (t
+                 (apply #'max (mapcar #'rec (children tree node))))))))
+    (rec (root-node tree))))
+
+(defun leftmost-leaf-below (tree i)
+  (apply #'min (descendent-leaves tree i)))
+
+(defun postorder-sequentialize (list op)
+  "LIST is a tree represented as a s-expression. OP is a function of
+   two arguments, an integer index and a tree node, and one optional
+   argument holding a parent node.
+
+   POSTORDER-SEQUENTIALIZE LIST OP calls OP on each index and node in
+   postorder.  Indices start at 0
+
+   Example:
+
+  (postorder-sequentialize '((a b) ((c d) e)) 
+                            (lambda (idx node &optional parent)
+                              (if parent 
+                                (print (list idx '-> node 'under parent)
+                                (print (list idx '-> node))))))
+
+  (0 -> A UNDER (A B)) 
+  (1 -> B UNDER (A B)) 
+  (2 -> (A B) UNDER ((A B) ((C D) E))) 
+  (3 -> C UNDER (C D)) 
+  (4 -> D UNDER (C D)) 
+  (5 -> (C D) UNDER ((C D) E)) 
+  (6 -> E UNDER ((C D) E)) 
+  (7 -> ((C D) E) UNDER ((A B) ((C D) E))) 
+  (8 -> ((A B) ((C D) E))) "
+  (if (null list) (funcall op 0 list) 
+      (let ((idx -1))
+        (labels ((rec (node &optional (parent nil parent-p))
+                   (when (consp node)
+                     (dolist (sub node)
+                       (rec sub node)))
+                   (if parent-p 
+                       (funcall op (incf idx) node parent)
+                       (funcall op (incf idx) node))))
+          (rec list)))))
+
+
+(defun list->postorder-tree (list)
+  (let ((node-data
+          (make-hash-table :test 'eq))
+        (node-count 0))
+    ;; build up data needed to intantiate a tree
+    (postorder-sequentialize
+     list
+     (lambda (idx node &optional parent)
+       (incf node-count)
+       (setf (gethash node node-data) (list idx parent))))
+    ;; build the tree data
+    (let ((tree-data
+            (make-array (list node-count 3)
+                        :initial-element nil)))
+      (maphash
+       (lambda (node info)
+         (let* ((idx
+                  (first info))
+                (parent-node
+                  (second info))
+                (parent-idx
+                  (first (gethash parent-node node-data))))
+           (setf (aref tree-data idx 0) node 
+                 (aref tree-data idx 1) parent-idx)
+           (when parent-node 
+             (push idx
+                   (aref tree-data parent-idx 2)))))
+       node-data)
+      (make-instance 'postorder-tree :data tree-data))))
+