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
|
;;; Modifications to the basic R-tree following "The R*-tree: An
;;; Efficient and Robust Access Method for Points and Rectangles",
;;; Beckmann, Kriegel, Schneider and Seeger, Proc. ACM Int. Conf. on
;;; Management of Data, 1990
(in-package "SPATIAL-TREES-IMPL")
(defclass r*-tree (r-tree)
((removed-number :initarg :removed-number :accessor removed-number)))
(defmethod initialize-instance :after ((tree r*-tree) &rest args)
(declare (ignore args))
(unless (slot-boundp tree 'removed-number)
(setf (slot-value tree 'removed-number)
(round (* (max-per-node tree) 3/10)))))
(defmethod make-spatial-tree ((kind (eql :r*)) &rest initargs)
(apply #'make-instance 'r*-tree
:root-node (make-instance 'spatial-tree-leaf-node :records nil)
initargs))
;;; 4.1 Algorithm ChooseSubtree
(defun overlap (x others tree)
(loop for y in others
sum (let ((i (intersection x (mbr y tree))))
(if i (area i) 0))))
(defun height (tree)
(labels ((height-above (node)
(if (typep node 'spatial-tree-leaf-node)
0
(1+ (height-above (car (children node)))))))
(height-above (root-node tree))))
(defun choose-subtree (thing node level tree)
(cond
((= level 0) node)
((typep (car (children node)) 'spatial-tree-leaf-node)
(check (= level 1) "Search in CHOOSE-SUBTREE too deep")
;; NOTE: does not contain the probabilistic optimization near the
;; end of section 4.1
(do* ((children (children node) (cdr children))
(child (car children) (car children))
(candidate child)
(min-overlap-extension
(- (overlap (minimum-bound (mbr thing tree) (mbr child tree))
(remove child (children node))
tree)
(overlap (mbr child tree)
(remove child (children node))
tree))))
((null children)
(check (typep candidate 'spatial-tree-leaf-node)
"CHOOSE-SUBTREE candidate ~S is not a leaf node" candidate)
candidate)
(let* ((new-overlap (overlap (minimum-bound (mbr thing tree) (mbr child tree))
(remove child (children node))
tree))
(old-overlap (overlap (mbr child tree)
(remove child (children node))
tree))
(extension (- new-overlap old-overlap)))
(when (or (< extension min-overlap-extension)
(and (= extension min-overlap-extension)
(< (- (area (minimum-bound (mbr thing tree) (mbr child tree)))
(area (mbr child tree)))
(- (area (minimum-bound (mbr thing tree) (mbr candidate tree)))
(area (mbr candidate tree))))))
(setf min-overlap-extension extension
candidate child)))))
(t (do* ((children (children node) (cdr children))
(child (car children) (car children))
(candidate child)
(min-extension (- (area (minimum-bound (mbr child tree) (mbr thing tree)))
(area (mbr child tree)))))
((null children) (choose-subtree thing candidate (1- level) tree))
(let* ((new-area (area (minimum-bound (mbr child tree) (mbr thing tree))))
(old-area (area (mbr child tree)))
(extension (- new-area old-area)))
(when (or (< extension min-extension)
(and (= extension min-extension)
(< old-area (area (mbr candidate tree)))))
(setf min-extension extension
candidate child)))))))
(defmethod choose-leaf (r (tree r*-tree))
(choose-subtree r (root-node tree) (height tree) tree))
;;; 4.2 Split of the R*-tree
(defun margin (rectangle)
(let ((result 0))
(do ((lows (lows rectangle) (cdr lows))
(highs (highs rectangle) (cdr highs)))
((null lows) result)
(incf result (- (car highs) (car lows))))))
(defun choose-split-axis (entries tree)
(let ((max-per-node (max-per-node tree))
(min-per-node (min-per-node tree)))
(do ((lows (lows (mbr (car entries) tree)) (cdr lows))
(axis 0 (1+ axis))
(min-margin)
(min-axis 0))
((null lows) min-axis)
(let ((sort-by-low (sort (copy-list entries) #'<
:key (lambda (x) (nth axis (lows (mbr x tree))))))
(sort-by-high (sort (copy-list entries) #'<
:key (lambda (x) (nth axis (highs (mbr x tree)))))))
(do ((k 1 (1+ k)))
((> k (- (+ 2 max-per-node) (* 2 min-per-node))))
(cond
((null min-margin)
(setf min-margin (min (+ (margin (minimum-bound-of (subseq sort-by-low 0 (+ min-per-node k -1)) tree))
(margin (minimum-bound-of (subseq sort-by-low (+ min-per-node k -1)) tree)))
(+ (margin (minimum-bound-of (subseq sort-by-high 0 (+ min-per-node k -1)) tree))
(margin (minimum-bound-of (subseq sort-by-high (+ min-per-node k -1)) tree))))))
(t (let ((min (min (+ (margin (minimum-bound-of (subseq sort-by-low 0 (+ min-per-node k -1)) tree))
(margin (minimum-bound-of (subseq sort-by-low (+ min-per-node k -1)) tree)))
(+ (margin (minimum-bound-of (subseq sort-by-high 0 (+ min-per-node k -1)) tree))
(margin (minimum-bound-of (subseq sort-by-high (+ min-per-node k -1)) tree))))))
(when (< min min-margin)
(setf min-margin min
min-axis axis))))))))))
(defun choose-split-index (entries axis tree)
(let ((max-per-node (max-per-node tree))
(min-per-node (min-per-node tree)))
(let ((one) (two)
;; this is a safe upper bound to the minimum overlap value
(min-overlap-value (area (minimum-bound-of entries tree))))
(let ((sort-by-low (sort (copy-list entries) #'<
:key (lambda (x) (nth axis (lows (mbr x tree))))))
(sort-by-high (sort (copy-list entries) #'<
:key (lambda (x) (nth axis (highs (mbr x tree)))))))
(do ((k 1 (1+ k)))
((> k (- (+ 2 max-per-node) (* 2 min-per-node))) (values one two))
(let ((a (subseq sort-by-low 0 (+ min-per-node k -1)))
(b (subseq sort-by-low (+ min-per-node k -1))))
(let* ((i (intersection (minimum-bound-of a tree)
(minimum-bound-of b tree)))
(overlap-value (if i (area i) 0)))
(when (or (< overlap-value min-overlap-value)
(and (= overlap-value min-overlap-value)
(< (+ (area (minimum-bound-of a tree))
(area (minimum-bound-of b tree))))))
(setf min-overlap-value overlap-value
one a
two b))))
(let ((a (subseq sort-by-high 0 (+ min-per-node k -1)))
(b (subseq sort-by-high (+ min-per-node k -1))))
(let* ((i (intersection (minimum-bound-of a tree)
(minimum-bound-of b tree)))
(overlap-value (if i (area i) 0)))
(when (or (< overlap-value min-overlap-value)
(and (= overlap-value min-overlap-value)
(< (+ (area (minimum-bound-of a tree))
(area (minimum-bound-of b tree))))))
(setf min-overlap-value overlap-value
one a
two b)))))))))
(defmethod split-node ((tree r*-tree) new node)
(let ((new-node (make-node-like node))
(entries (cons new (children node))))
(let ((axis (choose-split-axis entries tree)))
(multiple-value-bind (one two)
(choose-split-index entries axis tree)
(setf (children node) one
(slot-value node 'mbr) (minimum-bound-of one tree))
(setf (children new-node) two
(slot-value new-node 'mbr) (minimum-bound-of two tree))
new-node))))
;;; 4.3 Forced Reinsert
(defvar *data-rectangle*)
(defvar *overflowed-levels* nil)
(defun reinsert (thing tree node level)
(let* ((entries (cons thing (children node)))
(mbr (minimum-bound-of entries tree))
(cmbr (mapcar #'- (highs mbr) (lows mbr)))
(sorted (sort (copy-list entries) #'>
:key (lambda (entry)
(let* ((r (mbr entry tree))
(cs (mapcar #'- (highs r) (lows r))))
(loop for cm in cmbr
for c in cs
;; squared distance is fine
sum (expt (- cm c) 2)))))))
(let ((removed (subseq sorted 0 (removed-number tree))))
(setf (children node) (subseq sorted (removed-number tree))
(slot-value node 'mbr) (minimum-bound-of (children node) tree))
(dolist (entry (reverse removed))
(%insert entry tree level)))))
(defun overflow-treatment (thing tree node level)
(if (member level *overflowed-levels*)
(split-node tree thing node)
(let ((*overflowed-levels* (cons level *overflowed-levels*)))
(reinsert thing tree node level))))
(defun %insert (thing tree level)
(let ((node (choose-subtree thing (root-node tree) level tree)))
(cond
((< (length (children node)) (max-per-node tree))
(push thing (children node))
(adjust-tree tree node))
(t
(let ((new-node (overflow-treatment thing tree node level)))
(let ((new (adjust-tree tree node new-node)))
(when new
(let ((new-root
(make-instance 'spatial-tree-node
:children (list (root-node tree) new))))
(setf (parent (root-node tree)) new-root
(root-node tree) new-root
(parent new) new-root)))))))))
(defmethod insert ((r t) (tree r*-tree))
(let ((*data-rectangle* r))
(%insert (make-leaf-node-entry :datum r
:rectangle (funcall (rectfun tree) r))
tree
(height tree)))
tree)
|
