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 Rtree 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
(inpackage "SPATIALTREESIMPL")
(defclass r*tree (rtree)
((removednumber :initarg :removednumber :accessor removednumber)))
(defmethod initializeinstance :after ((tree r*tree) &rest args)
(declare (ignore args))
(unless (slotboundp tree 'removednumber)
(setf (slotvalue tree 'removednumber)
(round (* (maxpernode tree) 3/10)))))
(defmethod makespatialtree ((kind (eql :r*)) &rest initargs)
(apply #'makeinstance 'r*tree
:rootnode (makeinstance 'spatialtreeleafnode :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 ((heightabove (node)
(if (typep node 'spatialtreeleafnode)
0
(1+ (heightabove (car (children node)))))))
(heightabove (rootnode tree))))
(defun choosesubtree (thing node level tree)
(cond
((= level 0) node)
((typep (car (children node)) 'spatialtreeleafnode)
(check (= level 1) "Search in CHOOSESUBTREE 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)
(minoverlapextension
( (overlap (minimumbound (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 'spatialtreeleafnode)
"CHOOSESUBTREE candidate ~S is not a leaf node" candidate)
candidate)
(let* ((newoverlap (overlap (minimumbound (mbr thing tree) (mbr child tree))
(remove child (children node))
tree))
(oldoverlap (overlap (mbr child tree)
(remove child (children node))
tree))
(extension ( newoverlap oldoverlap)))
(when (or (< extension minoverlapextension)
(and (= extension minoverlapextension)
(< ( (area (minimumbound (mbr thing tree) (mbr child tree)))
(area (mbr child tree)))
( (area (minimumbound (mbr thing tree) (mbr candidate tree)))
(area (mbr candidate tree))))))
(setf minoverlapextension extension
candidate child)))))
(t (do* ((children (children node) (cdr children))
(child (car children) (car children))
(candidate child)
(minextension ( (area (minimumbound (mbr child tree) (mbr thing tree)))
(area (mbr child tree)))))
((null children) (choosesubtree thing candidate (1 level) tree))
(let* ((newarea (area (minimumbound (mbr child tree) (mbr thing tree))))
(oldarea (area (mbr child tree)))
(extension ( newarea oldarea)))
(when (or (< extension minextension)
(and (= extension minextension)
(< oldarea (area (mbr candidate tree)))))
(setf minextension extension
candidate child)))))))
(defmethod chooseleaf (r (tree r*tree))
(choosesubtree r (rootnode 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 choosesplitaxis (entries tree)
(let ((maxpernode (maxpernode tree))
(minpernode (minpernode tree)))
(do ((lows (lows (mbr (car entries) tree)) (cdr lows))
(axis 0 (1+ axis))
(minmargin)
(minaxis 0))
((null lows) minaxis)
(let ((sortbylow (sort (copylist entries) #'<
:key (lambda (x) (nth axis (lows (mbr x tree))))))
(sortbyhigh (sort (copylist entries) #'<
:key (lambda (x) (nth axis (highs (mbr x tree)))))))
(do ((k 1 (1+ k)))
((> k ( (+ 2 maxpernode) (* 2 minpernode))))
(cond
((null minmargin)
(setf minmargin (min (+ (margin (minimumboundof (subseq sortbylow 0 (+ minpernode k 1)) tree))
(margin (minimumboundof (subseq sortbylow (+ minpernode k 1)) tree)))
(+ (margin (minimumboundof (subseq sortbyhigh 0 (+ minpernode k 1)) tree))
(margin (minimumboundof (subseq sortbyhigh (+ minpernode k 1)) tree))))))
(t (let ((min (min (+ (margin (minimumboundof (subseq sortbylow 0 (+ minpernode k 1)) tree))
(margin (minimumboundof (subseq sortbylow (+ minpernode k 1)) tree)))
(+ (margin (minimumboundof (subseq sortbyhigh 0 (+ minpernode k 1)) tree))
(margin (minimumboundof (subseq sortbyhigh (+ minpernode k 1)) tree))))))
(when (< min minmargin)
(setf minmargin min
minaxis axis))))))))))
(defun choosesplitindex (entries axis tree)
(let ((maxpernode (maxpernode tree))
(minpernode (minpernode tree)))
(let ((one) (two)
;; this is a safe upper bound to the minimum overlap value
(minoverlapvalue (area (minimumboundof entries tree))))
(let ((sortbylow (sort (copylist entries) #'<
:key (lambda (x) (nth axis (lows (mbr x tree))))))
(sortbyhigh (sort (copylist entries) #'<
:key (lambda (x) (nth axis (highs (mbr x tree)))))))
(do ((k 1 (1+ k)))
((> k ( (+ 2 maxpernode) (* 2 minpernode))) (values one two))
(let ((a (subseq sortbylow 0 (+ minpernode k 1)))
(b (subseq sortbylow (+ minpernode k 1))))
(let* ((i (intersection (minimumboundof a tree)
(minimumboundof b tree)))
(overlapvalue (if i (area i) 0)))
(when (or (< overlapvalue minoverlapvalue)
(and (= overlapvalue minoverlapvalue)
(< (+ (area (minimumboundof a tree))
(area (minimumboundof b tree))))))
(setf minoverlapvalue overlapvalue
one a
two b))))
(let ((a (subseq sortbyhigh 0 (+ minpernode k 1)))
(b (subseq sortbyhigh (+ minpernode k 1))))
(let* ((i (intersection (minimumboundof a tree)
(minimumboundof b tree)))
(overlapvalue (if i (area i) 0)))
(when (or (< overlapvalue minoverlapvalue)
(and (= overlapvalue minoverlapvalue)
(< (+ (area (minimumboundof a tree))
(area (minimumboundof b tree))))))
(setf minoverlapvalue overlapvalue
one a
two b)))))))))
(defmethod splitnode ((tree r*tree) new node)
(let ((newnode (makenodelike node))
(entries (cons new (children node))))
(let ((axis (choosesplitaxis entries tree)))
(multiplevaluebind (one two)
(choosesplitindex entries axis tree)
(setf (children node) one
(slotvalue node 'mbr) (minimumboundof one tree))
(setf (children newnode) two
(slotvalue newnode 'mbr) (minimumboundof two tree))
newnode))))
;;; 4.3 Forced Reinsert
(defvar *datarectangle*)
(defvar *overflowedlevels* nil)
(defun reinsert (thing tree node level)
(let* ((entries (cons thing (children node)))
(mbr (minimumboundof entries tree))
(cmbr (mapcar #' (highs mbr) (lows mbr)))
(sorted (sort (copylist 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 (removednumber tree))))
(setf (children node) (subseq sorted (removednumber tree))
(slotvalue node 'mbr) (minimumboundof (children node) tree))
(dolist (entry (reverse removed))
(%insert entry tree level)))))
(defun overflowtreatment (thing tree node level)
(if (member level *overflowedlevels*)
(splitnode tree thing node)
(let ((*overflowedlevels* (cons level *overflowedlevels*)))
(reinsert thing tree node level))))
(defun %insert (thing tree level)
(let ((node (choosesubtree thing (rootnode tree) level tree)))
(cond
((< (length (children node)) (maxpernode tree))
(push thing (children node))
(adjusttree tree node))
(t
(let ((newnode (overflowtreatment thing tree node level)))
(let ((new (adjusttree tree node newnode)))
(when new
(let ((newroot
(makeinstance 'spatialtreenode
:children (list (rootnode tree) new))))
(setf (parent (rootnode tree)) newroot
(rootnode tree) newroot
(parent new) newroot)))))))))
(defmethod insert ((r t) (tree r*tree))
(let ((*datarectangle* r))
(%insert (makeleafnodeentry :datum r
:rectangle (funcall (rectfun tree) r))
tree
(height tree)))
tree)
