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

;;; Modifications to the R*tree as in "The Xtree: An Index Structure
;;; for HighDimensional Data", Berchtold, Keim and Kriegel,
;;; Proc. 22th Int. Conf. on Very Large Databases, 1996
(inpackage "SPATIALTREESIMPL")
(defclass xtree (r*tree)
((maxoverlap :initarg :maxoverlap :reader maxoverlap)))
(defmethod initializeinstance :after ((tree xtree) &rest args)
(declare (ignore args))
(unless (slotboundp tree 'maxoverlap)
(setf (slotvalue tree 'maxoverlap) 1/5)))
(defmethod makespatialtree ((kind (eql :x)) &rest initargs)
(apply #'makeinstance 'xtree
:rootnode (makeinstance 'spatialtreeleafnode :records nil)
initargs))
(defclass xtreenode (spatialtreenode)
((splittree :initarg :splittree :accessor splittree)))
;;; Do we actually need to keep track of what is and what isn't a
;;; supernode? I'm not sure that we do...
(defclass xtreesupernode (xtreenode)
())
;;; FIXME: leaf supernodes (and leaf nodes) don't need a split tree.
(defclass xtreeleafsupernode (xtreesupernode spatialtreeleafnode)
())
;;; Split trees.
;;;
;;; In the Xtree algorithms, we are required to store the 'split
;;; history' of a node. In typical academic fashion, this is
;;; extremely badly explained in the paper itself; I think I've
;;; reconstructed what's necessary, but it's not obvious that it's a
;;; huge win.
;;;
;;; In clearer terms, then, when we split a node, we record in the
;;; node's parent (which is possibly the new root node of the tree)
;;; the split in a 'split tree', which we represent using
;;; nonNULLterminated conses. When a node overflows, we replace it
;;; in its parent's split tree with a cons of the original node and
;;; the new one; when the root node overflows, the new root node
;;; acquires a split tree of (old . new).
;;;
;;; A new nonleaf node, meanwhile, must result from a split of a
;;; previous such nonleaf node with its own splittree information.
;;; We construct two new split trees from the original node's split
;;; tree, such that the tree structure is preserved as much as
;;; possible while retaining only those children contained in the
;;; redistributed nodes.
;;;
;;; When a node comes to be split, one potentially good split of its
;;; children is into the two sets defined by its left and rightsplit
;;; trees; this is exploited, unless the split is too unbalanced, if
;;; the ordinary topological split fails to find a sufficiently good
;;; partition.
(defun findconswithleaf (object conses)
(cond
((atom conses) nil)
((eq (car conses) object) conses)
((eq (cdr conses) object) conses)
(t (or (findconswithleaf object (car conses))
(findconswithleaf object (cdr conses))))))
(defun leavesofsplittree (splittree)
(cond
((atom splittree) (list splittree))
(t (append (leavesofsplittree (car splittree))
(leavesofsplittree (cdr splittree))))))
(defun splittreefromset (set splittree)
(cond
((atom splittree) (find splittree set))
(t (let ((car (splittreefromset set (car splittree)))
(cdr (splittreefromset set (cdr splittree))))
(cond
((null car) cdr)
((null cdr) car)
(t (cons car cdr)))))))
(defvar *split*)
;;; Figure 7: Xtree Insertion Algorithm for Directory Nodes
(defmethod adjusttree ((tree xtree) node &optional new)
(check (or (null new)
(or (and (typep node 'spatialtreeleafnode)
(typep new 'spatialtreeleafnode))
(and (not (typep node 'spatialtreeleafnode))
(not (typep new 'spatialtreeleafnode)))))
"oh dear")
(cond
((eq node (rootnode tree)) new)
(t
(setf (slotvalue node 'mbr) (minimumboundof (children node) tree))
(let ((parent (parent node)))
(if new
(cond
((< (length (children parent)) (maxpernode tree))
(push new (children parent))
(setf (parent new) parent)
(let ((cons (findconswithleaf node (splittree parent))))
(if (eq node (car cons))
(rplaca cons (cons node new))
(progn
(check (eq node (cdr cons)) "Aargh1")
(rplacd cons (cons node new)))))
(adjusttree tree parent))
(t
(let ((cons (findconswithleaf node (splittree parent))))
(if (eq node (car cons))
(rplaca cons (cons node new))
(progn
(check (eq node (cdr cons)) "Aargh2")
(rplacd cons (cons node new)))))
(let ((newparent (let ((*split* node))
(splitnode tree new parent))))
(dolist (child (children parent))
(setf (parent child) parent))
(when newparent
(dolist (child (children newparent))
(setf (parent child) newparent)))
(adjusttree tree parent newparent))))
(adjusttree tree parent))))))
(defmethod insert ((o t) (tree xtree))
(let* ((entry (makeleafnodeentry :datum o
:rectangle (funcall (rectfun tree) o)))
(node (choosesubtree entry (rootnode tree) (height tree) tree)))
(cond
((< (length (children node)) (maxpernode tree))
(push entry (children node))
(adjusttree tree node))
(t
(let ((newnode (splitnode tree entry node)))
(let ((new (adjusttree tree node newnode)))
(when new
(let ((newroot
(makeinstance 'xtreenode
:children (list (rootnode tree) new))))
(setf (parent (rootnode tree)) newroot
(splittree newroot) (cons (rootnode tree) new)
(rootnode tree) newroot
(parent new) newroot)))))))
tree))
;;; Figure 8: Xtree Split Algorithm for Directory Nodes
(defmethod splitnode ((tree xtree) new node)
(let ((newnode (makenodelike node))
(entries (cons new (children node))))
(let ((axis (choosesplitaxis entries tree)))
(multiplevaluebind (one two)
(choosesplitindex entries axis tree)
(let* ((bone (minimumboundof one tree))
(btwo (minimumboundof two tree))
(intersection (intersection bone btwo))
(mb (minimumbound bone btwo)))
(cond
((or (null intersection)
(< (area intersection)
(* (area mb) (maxoverlap tree))))
(setf (children node) one
(slotvalue node 'mbr) bone)
(when (> (length one) (maxpernode tree))
(check (typep node 'xtreesupernode) "AARGH"))
(setf (children newnode) two
(slotvalue newnode 'mbr) btwo)
(when (> (length two) (maxpernode tree))
(changeclass newnode
(if (typep node 'spatialtreeleafnode)
'xtreeleafsupernode
'xtreesupernode)))
(when (< (length two) (maxpernode tree))
(changeclass newnode
(if (typep node 'spatialtreeleafnode)
'spatialtreeleafnode
'xtreenode)))
(unless (typep node 'spatialtreeleafnode)
(let ((splittree (splittree node)))
(setf (splittree node) (splittreefromset one splittree)
(splittree newnode) (splittreefromset two splittree))))
newnode)
((and (not (typep node 'spatialtreeleafnode))
(let ((splittree (splittree node)))
(destructuringbind (one . two) splittree
(let ((l1 (leavesofsplittree one))
(l2 (leavesofsplittree two)))
(if (find *split* l1)
(push new l1)
(progn
(check (find *split* l2) "Missing node!!")
(push new l2)))
(and (>= (minpernode tree) (length l1))
(>= (minpernode tree) (length l2))
(progn
(setf (children node) l1
(slotvalue node 'mbr) (minimumboundof l1 tree)
(splittree node) (if (find new l1)
(let ((cons (findconswithleaf *split* one)))
(if (eq (car cons) *split*)
(rplaca cons (cons *split* new))
(rplacd cons (cons *split* new)))
one)
one))
(setf (children newnode) l2
(slotvalue newnode 'mbr) (minimumboundof l2 tree)
(splittree node) (if (find new l2)
(let ((cons (findconswithleaf *split* two)))
(if (eq (car cons) *split*)
(rplaca cons (cons *split* new))
(rplacd cons (cons *split* new)))
two)
two))
newnode)))))))
(t (changeclass node
(etypecase node
(spatialtreeleafnode 'xtreeleafsupernode)
(spatialtreenode 'xtreesupernode)))
(push new (children node))
(when (not (typep node 'spatialtreeleafnode))
(let ((cons (findconswithleaf *split* (splittree node))))
(if (eq *split* (car cons))
(rplaca cons (cons *split* new))
(progn
(check (eq *split* (cdr cons)) "Aargh2")
(rplacd cons (cons *split* new))))))
nil)))))))
(defmethod checkconsistency progn ((tree xtree))
(labels ((%check (node)
(assert
(or (typep node 'spatialtreeleafnode)
(null (setdifference (children node)
(leavesofsplittree
(splittree node))))))
(unless (typep node 'spatialtreeleafnode)
(dolist (child (children node))
(%check child)))))
(%check (rootnode tree))))
