blob: 62881f1171fd1c63c39a28f3cbc942cc36c36fa9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
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))))
|
