blob: 43df4dc500e74145a21d6062d1a70061fc8f6cae (
plain) (
blame)
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
;;; tree.el --- Working with Trees -*- lexical-binding: t -*-
;; Author: William Carroll <wpcarro@gmail.com>
;;; Commentary:
;; Some friendly functions that hopefully will make working with trees cheaper
;; and therefore more appealing!
;;
;; Tree terminology:
;; - leaf: node with zero children.
;; - root: node with zero parents.
;; - depth: measures a node's distance from the root node. This implies the
;; root node has a depth of zero.
;; - height: measures the longest traversal from a node to a leaf. This implies
;; that a leaf node has a height of zero.
;; - balanced?
;;
;; Tree variants:
;; - binary: the maximum number of children is two.
;; - binary search: the maximum number of children is two and left sub-trees are
;; lower in value than right sub-trees.
;; - rose: the number of children is variable.
;;; Code:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dependencies
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'prelude)
(require 'list)
(require 'set)
(require 'tuple)
(require 'series)
(require 'random)
(require 'maybe)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Library
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cl-defstruct tree xs)
(cl-defstruct node value children)
(cl-defun tree/node (value &optional children)
"Create a node struct of VALUE with CHILDREN."
(make-node :value value
:children children))
(defun tree/reduce-breadth (acc f xs)
"Reduce over XS breadth-first applying F to each x and ACC (in that order).
Breadth-first traversals guarantee to find the shortest path in a graph.
They're typically more difficult to implement than DFTs and may also incur
higher memory costs on average than their depth-first counterparts.")
;; TODO: Support :order as 'pre | 'in | 'post.
;; TODO: Troubleshoot why I need defensive (nil? node) check.
(defun tree/reduce-depth (acc f node)
"Reduce over NODE depth-first applying F to each NODE and ACC.
F is called with each NODE, ACC, and the current depth.
Depth-first traversals have the advantage of typically consuming less memory
than their breadth-first equivalents would have. They're also typically
easier to implement using recursion. This comes at the cost of not
guaranteeing to be able to find the shortest path in a graph."
(cl-labels ((do-reduce-depth
(acc f node depth)
(let ((acc-new (funcall f node acc depth)))
(if (or (maybe/nil? node)
(tree/leaf? node))
acc-new
(list/reduce
acc-new
(lambda (node acc)
(tree/do-reduce-depth
acc
f
node
(number/inc depth)))
(node-children node))))))
(do-reduce-depth acc f node 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun tree/height (xs)
"Return the height of tree XS.")
;; TODO: Troubleshoot why need for (nil? node). Similar misgiving
;; above.
(defun tree/leaf-depths (xs)
"Return a list of all of the depths of the leaf nodes in XS."
(list/reverse
(tree/reduce-depth
'()
(lambda (node acc depth)
(if (or (maybe/nil? node)
(tree/leaf? node))
(list/cons depth acc)
acc))
xs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generators
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO: Consider parameterizing height, forced min-max branching, random
;; distributions, etc.
;; TODO: Bail out before stack overflowing by consider branching, current-depth.
(cl-defun tree/random (&optional (value-fn (lambda (_) nil))
(branching-factor 2))
"Randomly generate a tree with BRANCHING-FACTOR using VALUE-FN to compute the
node values. VALUE-FN is called with the current-depth of the node. Useful for
generating test data. Warning this function can overflow the stack."
(cl-labels ((do-random
(d vf bf)
(make-node
:value (funcall vf d)
:children (->> (series/range 0 (number/dec bf))
(list/map
(lambda (_)
(when (random/boolean?)
(do-random d vf bf))))))))
(do-random 0 value-fn branching-factor)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun tree/instance? (tree)
"Return t if TREE is a tree struct."
(node-p tree))
(defun tree/leaf? (node)
"Return t if NODE has no children."
(maybe/nil? (node-children node)))
(defun tree/balanced? (n xs)
"Return t if the tree, XS, is balanced.
A tree is balanced if none of the differences between any two depths of two leaf
nodes in XS is greater than N."
(> n (->> xs
tree/leaf-depths
set/from-list
set/count
number/dec)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst tree/enable-testing? t
"When t, test suite runs.")
;; TODO: Create set of macros for a proper test suite including:
;; - describe (arbitrarily nestable)
;; - it (arbitrarily nestable)
;; - line numbers for errors
;; - accumulated output for synopsis
;; - do we want describe *and* it? Why not a generic label that works for both?
(when tree/enable-testing?
(let ((tree-a (tree/node 1
(list (tree/node 2
(list (tree/node 5)
(tree/node 6)))
(tree/node 3
(list (tree/node 7)
(tree/node 8)))
(tree/node 4
(list (tree/node 9)
(tree/node 10))))))
(tree-b (tree/node 1
(list (tree/node 2
(list (tree/node 5)
(tree/node 6)))
(tree/node 3)
(tree/node 4
(list (tree/node 9)
(tree/node 10)))))))
;; instance?
(prelude/assert (tree/instance? tree-a))
(prelude/assert (tree/instance? tree-b))
(prelude/refute (tree/instance? '(1 2 3)))
(prelude/refute (tree/instance? "oak"))
;; balanced?
(prelude/assert (tree/balanced? 1 tree-a))
(prelude/refute (tree/balanced? 1 tree-b))
(message "Tests pass!")))
(provide 'tree)
;;; tree.el ends here
|
