-
Notifications
You must be signed in to change notification settings - Fork 0
/
cl-quad.lisp
239 lines (205 loc) · 7.46 KB
/
cl-quad.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
;; Copyright 2015 Andrew "Drew" Dudash
;;
;; This file is part of cl-quad.
;;
;; cl-quad is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; cl-quad is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with cl-quad. If not, see <http://www.gnu.org/licenses/>.
(in-package #:cl-quad)
;; Define the top class and exposed methods.
(defclass quad-tree ()
((root :initform nil
:initarg :root)
(bound :initform (no-value)
:initarg :bound)
(size :initform 1
:initarg :size))
(:documentation "Represents a point region quad tree with the given bucket size and initial bounds. Bucket size defaults to one."))
(defgeneric insert (tree item)
(:documentation "Return a new tree with item inserted."))
(defmethod insert ((tree quad-tree) item)
(with-slots (root bound size) tree
(make-instance 'quad-tree
:root (insert-helper root item size bound)
:bound bound
:size size)))
(defgeneric locate (tree item &key test)
(:documentation "Return the matching item."))
(defmethod locate ((tree quad-tree) item &key test)
(with-slots (root bound size) tree
(locate-helper root item size bound :test test)))
(defgeneric purge (tree item &key test)
(:documentation "Return a new tree with item removed."))
(defmethod purge ((tree quad-tree) item &key test)
(with-slots (root bound size) tree
(make-instance 'quad-tree
:root (purge-helper root item bound :test test)
:bound bound
:size size)))
;; Define the node classes.
(defclass quad-tree-node-branch ()
((north-east :initform (no-value)
:initarg :ne
:reader ne)
(north-west :initform (no-value)
:initarg :nw
:reader nw)
(south-west :initform (no-value)
:initarg :sw
:reader sw)
(south-east :initform (no-value)
:initarg :se
:reader se)))
(defclass quad-tree-node-leaf ()
((max-size :initform 1
:initarg :size
:reader max-size)
(elements :initform (list)
:initarg :elements
:reader elements)))
;; Define the helper methods.
(defgeneric insert-helper (node item size bound)
(:documentation "Return a new node with the given item inserted."))
(defmethod insert-helper ((node null) item size bound)
(let ((new-leaf (make-instance 'quad-tree-node-leaf :size size)))
(insert-helper new-leaf item size bound)))
(defmethod insert-helper ((node quad-tree-node-leaf) item size bound)
(let ((elements (elements node)))
(flet ((room-in-node-p ()
(< (length elements) size)))
(if (room-in-node-p)
(make-instance 'quad-tree-node-leaf
:size size
:elements (cons item elements))
(reduce (lambda (node item)
(insert-helper node item size bound))
(cons item elements)
:initial-value (make-instance 'quad-tree-node-branch
:ne nil
:nw nil
:sw nil
:se nil))))))
(defmethod insert-helper ((node quad-tree-node-branch) item size bound)
(case (quadrant bound item)
((ne origin) (make-instance 'quad-tree-node-branch
:ne (insert-helper (ne node) item size (north-east bound))
:nw (nw node)
:sw (sw node)
:se (se node)))
((nw) (make-instance 'quad-tree-node-branch
:ne (ne node)
:nw (insert-helper (nw node) item size (north-west bound))
:sw (sw node)
:se (se node)))
((sw) (make-instance 'quad-tree-node-branch
:ne (ne node)
:nw (nw node)
:sw (insert-helper (sw node) item size (south-west bound))
:se (se node)))
((se) (make-instance 'quad-tree-node-branch
:ne (ne node)
:nw (nw node)
:sw (sw node)
:se (insert-helper (se node) item size (south-east bound))))))
(defgeneric purge-helper (node item bounds &key test)
(:documentation "Returns a node that doesn't contain the given item."))
(defmethod purge-helper ((node null) item bound &key test)
(declare (ignore item bound test))
node)
(defmethod purge-helper ((node quad-tree-node-leaf) item bound &key test)
(let ((new-elements (remove item (elements node) :test test)))
(if new-elements
(make-instance 'quad-tree-node-leaf :elements new-elements)
nil)))
(defmethod purge-helper ((node quad-tree-node-branch) item bound &key test)
(case (quadrant bound item)
((ne origin) (make-instance 'quad-tree-node-branch
:ne (purge-helper (ne node) item (north-east bound) :test test)
:nw (nw node)
:sw (sw node)
:se (se node)))
((nw) (make-instance 'quad-tree-node-branch
:ne (ne node)
:nw (purge-helper (nw node) item (north-west bound) :test test)
:sw (sw node)
:se (se node)))
((sw) (make-instance 'quad-tree-node-branch
:ne (ne node)
:nw (nw node)
:sw (purge-helper (sw node) item (south-west bound) :test test)
:se (se node)))
((se) (make-instance 'quad-tree-node-branch
:ne (ne node)
:nw (nw node)
:sw (sw node)
:se (purge-helper (se node) item (south-east bound) :test test)))))
(defgeneric locate-helper (node item size bound &key test)
(:documentation "Returns two values. The first value is item found or nil if it could not be found and the second value is true if the item is found otherwise nil."))
(defmethod locate-helper ((node null) item size bound &key test)
(declare (ignore item size bound test))
(values nil nil))
(defmethod locate-helper ((node quad-tree-node-leaf) item size bound &key test)
(find item (elements node) :test test))
(defmethod locate-helper ((node quad-tree-node-branch) item size bound &key test)
(case (quadrant bound item)
((ne origin) (locate-helper (ne node) item size (north-east bound) :test test))
((nw) (locate-helper (nw node) item size (north-west bound) :test test))
((sw) (locate-helper (sw node) item size (south-west bound) :test test))
((se) (locate-helper (se node) item size (south-east bound) :test test))))
;; Define some print methods for debugging.
(defmethod print-object ((node quad-tree) stream)
(with-slots (root) node
(format stream "~a" root)))
(defmethod print-object ((node quad-tree-node-leaf) stream)
(format stream "(leaf :elements ~a)" (elements node)))
(defmethod print-object ((node quad-tree-node-branch) stream)
(format stream "(branch :ne ~a :nw ~a :sw ~a :se ~a)"
(ne node) (nw node) (sw node) (se node)))
;; Tests
(test insert-and-locate
(flet ((point-test (a b)
(and (= (x a) (x b))
(= (y a) (y b)))))
(let* ((points (list (make-instance 'point
:x 5
:y 5)
(make-instance 'point
:x 7
:y 7)
(make-instance 'point
:x 3
:y 3)
(make-instance 'point
:x 7
:y 3)
(make-instance 'point
:x 3
:y 7)
(make-instance 'point
:x 2
:y 2)))
(tree (reduce #'insert
points
:initial-value
(make-instance 'quad-tree
:bound (make-instance 'bound
:x-low 0
:x-high 8
:y-low 0
:y-high 8)))))
(loop for point in points
do (is (locate tree point :test #'point-test)))
(is (not (locate (purge tree
(make-instance 'point :x 2 :y 2)
:test #'point-test)
(make-instance 'point :x 2 :y 2)
:test #'point-test))))))