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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
;;; File: binary-tree.lisp -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;;; The following definitions implement binary search trees.
;;; They are not balanced as yet. Currently, they all order their
;;; elements by #'<, and test for identity of elements by #'eq.
(defstruct search-tree-node
"node for binary search tree"
value ;; list of objects with equal key
num-elements ;; size of the value set
key ;; f-cost of the a-star-nodes
parent ;; parent of search-tree-node
leftson ;; direction of search-tree-nodes with lesser f-cost
rightson ;; direction of search-tree-nodes with greater f-cost
)
(defun make-search-tree (root-elem root-key &aux root)
"return dummy header for binary search tree, with initial
element root-elem whose key is root-key."
(setq root
(make-search-tree-node
:value nil
:parent nil
:rightson nil
:leftson (make-search-tree-node
:value (list root-elem)
:num-elements 1
:key root-key
:leftson nil :rightson nil)))
(setf (search-tree-node-parent
(search-tree-node-leftson root)) root)
root)
(defun create-sorted-tree (list-of-elems key-fun &aux root-elem root)
"return binary search tree containing list-of-elems ordered according
tp key-fun"
(if (null list-of-elems)
nil
(progn
(setq root-elem (nth (random (length list-of-elems)) list-of-elems))
(setq list-of-elems (remove root-elem list-of-elems :test #'eq))
(setq root (make-search-tree root-elem
(funcall key-fun root-elem)))
(dolist (elem list-of-elems)
(insert-element elem root (funcall key-fun elem)))
root)))
(defun empty-tree (root)
"Predicate of search trees; return t iff empty."
(null (search-tree-node-leftson root)))
(defun leftmost (tree-node &aux next)
"return leftmost descendant of tree-node"
;; used by pop-least-element and inorder-successor
(loop (if (null (setq next (search-tree-node-leftson tree-node)))
(return tree-node)
(setq tree-node next))))
(defun rightmost (header &aux next tree-node)
"return rightmost descendant of header"
;; used by pop-largest-element
;; recall that root of tree is leftson of header, which is a dummy
(setq tree-node (search-tree-node-leftson header))
(loop (if (null (setq next (search-tree-node-rightson tree-node)))
(return tree-node)
(setq tree-node next))))
(defun pop-least-element (header)
"return least element of binary search tree; delete from tree as side-effect"
;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of
;; which have same f-cost = key slot of search-tree-node. This function
;; arbitrarily returns first element of list with smallest f-cost,
;; then deletes it from the list. If it was the last element of the list
;; for the node with smallest key, that node is deleted from the search
;; tree. (That's why we have a pointer to the node's parent).
;; Node with smallest f-cost is leftmost descendant of header.
(let* ( (place (leftmost header))
(result (pop (search-tree-node-value place))) )
(decf (search-tree-node-num-elements place))
(when (null (search-tree-node-value place))
(when (search-tree-node-rightson place)
(setf (search-tree-node-parent
(search-tree-node-rightson place))
(search-tree-node-parent place)))
(setf (search-tree-node-leftson
(search-tree-node-parent place))
(search-tree-node-rightson place)))
result))
(defun pop-largest-element (header)
"return largest element of binary search tree; delete from tree as side-effect"
;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of
;; which have same key slot of search-tree-node. This function
;; arbitrarily returns first element of list with largest key
;; then deletes it from the list. If it was the last element of the list
;; for the node with largest key, that node is deleted from the search
;; tree. We need to take special account of the case when the largest element
;; is the last element in the root node of the search-tree. In this case, it
;; will be in the leftson of the dummy header. In all other cases,
;; it will be in the rightson of its parent.
(let* ( (place (rightmost header))
(result (pop (search-tree-node-value place))) )
(decf (search-tree-node-num-elements place))
(when (null (search-tree-node-value place))
(cond ( (eq place (search-tree-node-leftson header))
(setf (search-tree-node-leftson header)
(search-tree-node-leftson place)) )
(t (when (search-tree-node-leftson place)
(setf (search-tree-node-parent
(search-tree-node-leftson place))
(search-tree-node-parent place)))
(setf (search-tree-node-rightson
(search-tree-node-parent place))
(search-tree-node-leftson place)))))
result))
(defun least-key (header)
"return least key of binary search tree; no side effects"
(search-tree-node-key (leftmost header)))
(defun largest-key (header)
"return least key of binary search tree; no side effects"
(search-tree-node-key (rightmost header)))
(defun insert-element (element parent key
&optional (direction #'search-tree-node-leftson)
&aux place)
"insert new element at proper place in binary search tree"
;; See Reingold and Hansen, Data Structures, sect. 7.2.
;; When called initially, parent will be the header, hence go left.
;; Element is an a-star-node. If tree node with key = f-cost of
;; element already exists, just push element onto list in that
;; node's value slot. Else have to make new tree node.
(loop (cond ( (null (setq place (funcall direction parent)))
(let ( (new-node (make-search-tree-node
:value (list element) :num-elements 1
:parent parent :key key
:leftson nil :rightson nil)) )
(if (eq direction #'search-tree-node-leftson)
(setf (search-tree-node-leftson parent) new-node)
(setf (search-tree-node-rightson parent) new-node)))
(return t))
( (= key (search-tree-node-key place))
(push element (search-tree-node-value place))
(incf (search-tree-node-num-elements place))
(return t))
( (< key (search-tree-node-key place))
(setq parent place)
(setq direction #'search-tree-node-leftson) )
(t (setq parent place)
(setq direction #'search-tree-node-rightson)))))
(defun randomized-insert-element (element parent key
&optional (direction #'search-tree-node-leftson)
&aux place)
"insert new element at proper place in binary search tree -- break
ties randomly"
;; This is just like the above, except that elements with equal keys
;; are shuffled randomly. Not a "perfect shuffle", but the point is
;; just to randomize whenever an arbitrary choice is to be made.
(loop (cond ( (null (setq place (funcall direction parent)))
(let ( (new-node (make-search-tree-node
:value (list element) :num-elements 1
:parent parent :key key
:leftson nil :rightson nil)) )
(if (eq direction #'search-tree-node-leftson)
(setf (search-tree-node-leftson parent) new-node)
(setf (search-tree-node-rightson parent) new-node)))
(return t))
( (= key (search-tree-node-key place))
(setf (search-tree-node-value place)
(randomized-push element (search-tree-node-value place)))
(incf (search-tree-node-num-elements place))
(return t))
( (< key (search-tree-node-key place))
(setq parent place)
(setq direction #'search-tree-node-leftson) )
(t (setq parent place)
(setq direction #'search-tree-node-rightson)))))
(defun randomized-push (element list)
"return list with element destructively inserted at random into list"
(let ((n (random (+ 1 (length list)))) )
(cond ((= 0 n)
(cons element list))
(t (push element (cdr (nthcdr (- n 1) list)))
list))))
(defun find-element (element parent key
&optional (direction #'search-tree-node-leftson)
&aux place)
"return t if element is int tree"
(loop (cond ( (null (setq place (funcall direction parent)))
(return nil) )
( (= key (search-tree-node-key place))
(return (find element (search-tree-node-value place)
:test #'eq)) )
( (< key (search-tree-node-key place))
(setq parent place)
(setq direction #'search-tree-node-leftson) )
(t (setq parent place)
(setq direction #'search-tree-node-rightson)))))
(defun delete-element (element parent key &optional (error-p t)
&aux (direction #'search-tree-node-leftson)
place)
"delete element from binary search tree"
;; When called initially, parent will be the header.
;; Have to search for node containing element, using key, also
;; keep track of parent of node. Delete element from list for
;; node; if it's the last element on that list, delete node from
;; binary tree. See Reingold and Hansen, Data Structures, pp. 301, 309.
;; if error-p is t, signals error if element not found; else just
;; returns t if element found, nil otherwise.
(loop (setq place (funcall direction parent))
(cond ( (null place) (if error-p
(error "delete-element: element not found")
(return nil)) )
( (= key (search-tree-node-key place))
(cond ( (find element (search-tree-node-value place) :test #'eq)
;; In this case we've found the right binary
;; search-tree node, so we should delete the
;; element from the list of nodes
(setf (search-tree-node-value place)
(remove element (search-tree-node-value place)
:test #'eq))
(decf (search-tree-node-num-elements place))
(when (null (search-tree-node-value place))
;; If we've deleted the last element, we
;; should delete the node from the binary search tree.
(cond ( (null (search-tree-node-leftson place))
;; If place has no leftson sub-tree, replace it
;; by its right sub-tree.
(when (search-tree-node-rightson place)
(setf (search-tree-node-parent
(search-tree-node-rightson place))
parent))
(if (eq direction #'search-tree-node-leftson)
(setf (search-tree-node-leftson parent)
(search-tree-node-rightson place))
(setf (search-tree-node-rightson parent)
(search-tree-node-rightson place))) )
( (null (search-tree-node-rightson place) )
;; Else if place has no right sub-tree,
;; replace it by its left sub-tree.
(when (search-tree-node-leftson place)
(setf (search-tree-node-parent
(search-tree-node-leftson place))
parent))
(if (eq direction #'search-tree-node-leftson)
(setf (search-tree-node-leftson parent)
(search-tree-node-leftson place))
(setf (search-tree-node-rightson parent)
(search-tree-node-leftson place))) )
(t ;; Else find the "inorder-successor" of
;; place, which must have nil leftson.
;; Let it replace place, making its left
;; sub-tree be place's current left
;; sub-tree, and replace it by its own
;; right sub-tree. (For details, see
;; Reingold & Hansen, Data Structures, p. 301.)
(let ( (next (inorder-successor place)) )
(setf (search-tree-node-leftson next)
(search-tree-node-leftson place))
(setf (search-tree-node-parent
(search-tree-node-leftson next))
next)
(if (eq direction #'search-tree-node-leftson)
(setf (search-tree-node-leftson
parent) next)
(setf (search-tree-node-rightson parent)
next))
(unless (eq next (search-tree-node-rightson
place))
(setf (search-tree-node-leftson
(search-tree-node-parent next))
(search-tree-node-rightson next))
(when (search-tree-node-rightson next)
(setf (search-tree-node-parent
(search-tree-node-rightson next))
(search-tree-node-parent next)))
(setf (search-tree-node-rightson next)
(search-tree-node-rightson
place))
(setf (search-tree-node-parent
(search-tree-node-rightson next))
next))
(setf (search-tree-node-parent next)
(search-tree-node-parent place))))))
(return t))
(t (if error-p
(error "delete-element: element not found")
(return nil)))) )
( (< key (search-tree-node-key place))
(setq parent place)
(setq direction #'search-tree-node-leftson))
(t (setq parent place)
(setq direction #'search-tree-node-rightson)))))
(defun inorder-successor (tree-node)
"return inorder-successor of tree-node assuming it has a right son"
;; this is used by function delete-element when deleting a node from
;; the binary search tree. See Reingold and Hansen, pp. 301, 309.
;; The inorder-successor is the leftmost descendant of the rightson.
(leftmost (search-tree-node-rightson tree-node)))
(defun list-elements (parent &aux child)
"return list of elements in tree"
(append (when (setq child (search-tree-node-leftson parent))
(list-elements child))
(search-tree-node-value parent)
(when (setq child (search-tree-node-rightson parent))
(list-elements child))))
|
