-
Notifications
You must be signed in to change notification settings - Fork 0
/
cl-trees.lisp
273 lines (210 loc) · 9.92 KB
/
cl-trees.lisp
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
;;;; cl-trees.lisp
(in-package #:cl-trees)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; binary search trees (PBI book)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct node
contents
(prev nil)
(post nil))
(defun bst-insert (obj bst before)
(cond ((null bst) (make-node :contents obj))
(t
(let ((contents (node-contents bst)))
(cond ((eql obj contents) bst)
((funcall before obj contents)
(make-node
:contents contents
:prev (bst-insert obj (node-prev bst) before)
:after (node-after bst)))
(t
(make-node
:contents contents
:prev (node-prev bst)
:after (bst-insert obj (node-post bst) before))))))))
;;; cost is very low because all rest ist shared with previous tree
;;; entry finding is simpler than divide and conquer of array
(defun bst-find (obj bst before)
(cond ((null bst) nil)
(t
(let ((contents (node-contents bst)))
(cond ((eql obj contents) bst)
((funcall before obj contents)
(bst-find obj (node-prev bst) before))
(t
(bst-find obj (nocd-post bst) before)))))))
;;; removing node: Graham 137 page 74
;;; destructive version: Graham 137 page 202
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; intervall trees
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct interval
(start 0.0)
(end 0.0)
(description nil))
(defstruct inverval-node
contents
(before nil)
(overlapping nil)
(after nil))
(defun before-p (iv1 iv2)
(< (interval-start iv1) (interval-end iv2)))
(defun overlapping-p (iv1 iv2 &key (type "open"))
(cond ((equal type "open")
(and (< (interval-start iv2) (interval-end iv1))
(< (interval-start iv1) (interval-end iv2))))
((equal type "closed")
(and (not (before-p iv1 iv2))
(not (before-p iv2 iv1))))
(t
(error "Please specify correct :type")))) ; is this really correct?
(defun interval-insert (iv tree &key (type "open"))
(if (null tree)
(make-interval-node :contents iv))
(let ((contents (interval-node-contents tree)))
(make-interval-node
:contents contents
:before (if (before-p iv contents)
(interval-insert iv (interval-node-before tree))
(interval-node-before tree))
:overlapping (if (overlapping-p iv contents)
(interval-insert iv (interval-node-overlapping tree))
(interval-node-overlapping tree))
:after (if (before-p contents iv) ;; after
(interval-insert iv (interval-node-after tree))
(interval-node-after tree)))))
(defun interval-find (iv tree)
(if (null tree)
nil
(let ((contents (interval-node-contents tree)))
(if (equal iv contents)
tree
(interval-find iv
(cond ((before-p iv contents)
(interval-node-before tree))
((overlapping-p iv contents)
(interval-node-overlapping tree))
((after-p iv contents)
(interval-node-after tree))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; find all before intervals in tree to iv
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (defun find-prev (iv tree)
;; (if (null tree)
;; nil
;; (let ((contents (interval-node-contents tree)))
;; (cond ((prev-p iv contents)
;; ;; search the before AND overlapping subtrees
;; (append (find-prev iv (interval-node-prev tree))
;; (find-prev iv (interval-node-over tree))))
;; ((over-p iv contents)
;; ;; search all three subtrees
;; (append (find-prev iv (interval-node-prev tree))
;; (find-prev iv (interval-node-over tree))
;; (find-prev iv (interval-node-post tree))))
;; ((after iv contents) ; error in book! forgot opening paren
;; ;; include current interval AND search overlaps and after subtrees
;; (cons contents
;; (append (find-prev iv (interval-node-over tree))
;; (find-prev iv (interval-node-post tree)))))))))
;; if interval is before current one,
;; don't include current one or the ones AFTER it,
;; since they will surely not be before given interval, but to search other two branches.
;; if there is overlap, current interval is still not included, but all three subtrees needs to be searched.
;; if given interval is after current interval, current interval does satisfy
;; criterion, so put it on beginning of list
;; resulting from searching the overlaps and after subtrees.
;; which is actually:
;; (defun find-before (iv tree)
;; (cond ((null tree) nil)
;; (t (let ((contents (interval-node-contents tree)))
;; (cond ((before-p iv contents)
;; ;; search before AND overlapping subtrees
;; (append (find-before iv (interval-node-before tree))
;; (find-before iv (interval-node-overlapping tree))))
;; ((overlapping-p iv contents)
;; ;; search all three subtrees
;; (append (find-before iv (interval-node-before tree))
;; (find-before iv (interval-node-overlapping tree))
;; (find-before iv (interval-node-after tree))))
;; (t ;; after
;; ;; search after AND overlapping subtrees
;; (append (list contents)
;; (find-before iv (interval-node-overlapping tree))
;; (find-before iv (interval-node-after tree)))))))))
;;;; using append you can emulate 'cons-ing
;; (cons 'a '(b c)) ;; => '(a b c)
;; (append (list a) '(b c)) => '(a b c)
;;;; nice trick:
;;;; using append you can leave out elements by putting/returning nil at that position
;; (append '(a) '() '(b)) => '(a b)
;; (append '(a) nil '(c)) => '(a c)
;; (append nil '(b c)) => '(b c)
;; that I will use now.
(defun find-before (iv tree)
(cond ((null tree) nil)
(t (let ((contents (interval-node-contents tree)))
(append (if (before-p contents iv) (list contents) '())
(find-before iv (if (before-p contents iv) '() (interval-node-before tree)))
(find-before iv (interval-node-overlapping tree))
(find-before iv (if (before-p iv contents) '() (interval-node-after tree))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; find all overlapping intervals in tree
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; do corresponding for find-post and find-overlap
;; (defun find-over (iv tree)
;; (if (null tree)
;; nil
;; (let ((contents (interval-node-contents tree)))
;; (cond ((prev-p iv contents)
;; ;; search all but don't add current interval
;; (append (find-over iv (interval-node-prev tree))
;; (find-over iv (interval-node-over tree))
;; (find-over iv (interval-node-post tree))))
;; ((over-p iv contents)
;; ;; include current interval AND search all tree
;; (cons contents
;; (append (find-over iv (interval-node-prev tree))
;; (find-over iv (interval-node-over tree))
;; (find-over iv (interval-node-post tree)))))
;; ((post-p iv contents)
;; ;; search all but don't add current interval
;; (append (find-over iv (interval-node-prev tree))
;; (find-over iv (interval-node-over tree))
;; (find-over iv (interval-node-post tree))))))))
(defun find-overlapping (iv tree)
(cond ((null tree) nil)
(t ;; if overlapping include current interval AND search all tree else only search all tree
(append (if (overlapping-p iv (interval-node-contents tree)) (list contents) nil)
(find-overlapping iv (interval-node-before tree))
(find-overlapping iv (interval-node-overlapping tree))
(find-overlapping iv (interval-node-after tree))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; find all after intervals in tree
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; the same for after
;; (defun find-post (iv tree)
;; (if (null tree)
;; nil
;; (let ((contents (interval-node-contents tree)))
;; (cond ((prev-p iv contents)
;; ;; include current interval AND search the overlaps AND post subtrees
;; (cons contents
;; (append (find-post iv (interval-node-over tree))
;; (find-post iv (interval-node-post tree)))))
;; ((over-p iv contents)
;; ;; search all three subtrees
;; (append (find-post iv (interval-node-prev tree))
;; (find-post iv (interval-node-over tree))
;; (find-post iv (interval-node-post tree))))
;; ((post-p iv contents)
;; ;; search overlaps and post subtrees
;; (append (find-post iv (interval-node-over tree))
;; (find-post iv (interval-node-post tree))))))))
(defun find-after (iv tree)
(cond ((null tree) nil)
(t (let ((contents (interval-node-contents tree)))
(append (if (before-p iv contents) (list contents) '())
(find-after iv (if (before-p contents iv) '() (interval-node-before tree)))
(find-after iv (interval-node-overlapping tree))
(find-after iv (if (before-p iv contents) '() (interval-node-after tree))))))))