
DIRECTORY
Basics,
QuadTree,
Real,
Vector,
IO,
FS,
Rope;

QuadTreeImpl: CEDAR MONITOR LOCKS tree USING tree: QT
 IMPORTS Basics, Real, IO, FS EXPORTS QuadTree =

BEGIN OPEN Basics, QuadTree;

testing: BOOLEAN = FALSE;

QT: TYPE = REF QTRec;
QTRec: PUBLIC TYPE = MONITORED RECORD [
structure: QTNode м NIL,
universe: BoundingBox
];

QTNode:  TYPE = REF QTNodeRec;
QTNodeRec: TYPE = RECORD [
count: INTEGER м 0,  --set to -1 once the node is split
level: CARDINAL,
area: InternalBoundingBox,
items: LIST OF QTItem м NIL,
scan: LIST OF QTItem м NIL,  --used to scan items during enumerate
quadrants: ARRAY[0..3] OF QTNode м ALL[NIL]
];

splitThreshold: INTEGER = 18;
maxLevels: CARDINAL = 15;

Create: PUBLIC PROC [universe: BoundingBox] RETURNS [tree:QT] ~ {
structure: QTNode м  NEW[QTNodeRec м [
area: [ [FIRST[CARDINAL], FIRST[CARDINAL]], [LAST[CARDINAL], LAST[CARDINAL]] ],
level: 0
]];
RETURN[ NEW[QTRec м [structure: structure, universe: universe]] ];
};

Insert: PUBLIC PROC [tree: QT, itemSize: BoundingBox, itemData: REF ANY, locked: BOOL м FALSE] ~ {
item: QTItem м NEW[QTItemRec м [size: IntFromExt[itemSize, tree.universe], data: itemData]];
root: QTNode м tree.structure;
IF locked THEN LockedInsert[tree, item] ELSE InsertItemInNode[item, root];
};

LockedInsert: PROC [tree: QT, item: QTItem] ~ {
root: QTNode м tree.structure;
InsertItemInNode[item, root];
};

IntFromExt: PROC [ext, universe: BoundingBox] RETURNS [int: InternalBoundingBox] ~ {
int.lowerLeft м ScaleVec[ext.lowerLeft, universe];
int.upperRight м ScaleVec[ext.upperRight, universe];
};

ScaleVec: PROC [v: Vector.VEC, u: BoundingBox] RETURNS [iv: InternalVEC] ~ {
iv.x м ScaleInRange[v.x, u.lowerLeft.x, u.upperRight.x];
iv.y м ScaleInRange[v.y, u.lowerLeft.y, u.upperRight.y]; 
};

ScaleInRange: PROC [r, l, u: REAL] RETURNS [i: CARDINAL] ~  INLINE{
IF (r <= l) THEN RETURN[0];
IF (r >= u) THEN RETURN[65535];
RETURN[Real.Fix[( (r - l) * 65535.0 ) / (u - l)]];
};

InsertItemInNode: PROC [item: QTItem, node: QTNode] ~ {
IF node.level = maxLevels THEN node.items м CONS[item, node.items]
ELSE IF node.count >= 0 THEN {
node.items м CONS[item, node.items];
node.count м node.count + 1;
IF node.count > splitThreshold THEN {
node.count м -1;
node.scan м node.items;
node.items м NIL;
UNTIL node.scan = NIL DO
InsertItemInNode[node.scan.first, node];
node.scan м node.scan.rest;
ENDLOOP;
};
}
ELSE {  -- node.count = -1 means node is split already
quad: INTEGER м LocateQuadrant[item, node.level];
IF quad = -1 THEN node.items м CONS[item, node.items]  --belongs here
ELSE  {
IF node.quadrants[quad] = NIL THEN node.quadrants[quad] м NewNode[node, quad];
InsertItemInNode[item, node.quadrants[quad]];
};
};
};

LocateQuadrant: PROC [item: QTItem, level: CARDINAL] RETURNS [quad: INTEGER] ~ {
xBit: CARDINAL м ExtractBit[item.size.lowerLeft.x, 15 - level];
yBit: CARDINAL м ExtractBit[item.size.lowerLeft.y, 15 - level];
quadLL: CARDINAL м xBit + 2*yBit;
quadUR: CARDINAL;
xBit м ExtractBit[item.size.upperRight.x, 15 - level];
yBit м ExtractBit[item.size.upperRight.y, 15 - level];
quadUR м xBit + 2*yBit;
IF quadLL = quadUR THEN RETURN[quadLL] ELSE RETURN[-1];
};

ExtractBit: PROC [w: CARDINAL, loc: CARDINAL] RETURNS [b: CARDINAL] ~ INLINE {
RETURN[BITAND[BITSHIFT[LOOPHOLE[w], -loc], 1]]; 
};

NewNode: PROC [parent: QTNode, quad: INTEGER] RETURNS [son: QTNode] ~ {
son м NEW[QTNodeRec м [
level: parent.level + 1,
area:  SubArea[parent.area, parent.level, quad]
]];
};

SubArea: PROC [org: InternalBoundingBox, level: CARDINAL, quad: INTEGER] RETURNS [sub: InternalBoundingBox] ~ {
yBit: CARDINAL м quad/2;
xBit: CARDINAL м quad - 2*yBit;
sub.lowerLeft.x м ComputeCorner[org.lowerLeft.x, xBit, level, 0];
sub.lowerLeft.y м ComputeCorner[org.lowerLeft.y, yBit, level, 0];
sub.upperRight.x м ComputeCorner[org.lowerLeft.x, xBit, level, 1];
sub.upperRight.y м ComputeCorner[org.lowerLeft.y, yBit, level, 1];
};

ComputeCorner: PROC [base: CARDINAL, bit: CARDINAL, level: CARDINAL, pad: CARDINAL] RETURNS [result: CARDINAL] ~ {
scratch: WORD м bit + pad;
result м BITOR[
LOOPHOLE[base],
BITSHIFT[scratch, 15 - level] - pad
];
};

Enumerate: PUBLIC PROC [tree: QT, region: BoundingBox, PerItem: PerItemProc, quanta: CARD м LAST[CARD], locked: BOOL м FALSE ] ~ {
IF quanta < LAST[CARD] AND NOT locked THEN ERROR;
IF locked THEN LockedEnumerate[tree, region, PerItem, quanta]
ELSE InnerEnumerate[tree, region, PerItem, quanta];
};

LockedEnumerate: ENTRY PROC [tree: QT, region: BoundingBox, PerItem: PerItemProc, quanta: CARD м LAST[CARD] ] ~ {
ENABLE UNWIND => NULL;
InnerEnumerate[tree, region, PerItem, quanta];
};


InnerEnumerate: PROC [tree: QT, region: BoundingBox, PerItem: PerItemProc, quanta: CARD м LAST[CARD] ] ~ {
intRegion: InternalBoundingBox м IntFromExt[region, tree.universe];

ResetScans: PerNodeProc ~ {
node.scan м node.items;
};

extraPassNeeded: BOOL м TRUE;

ProcessAQuanta: PerNodeProc ~ {
quantaCount: CARD м 0;
UNTIL node.scan = NIL DO
IF quantaCount >= quanta THEN {
extraPassNeeded м TRUE;
RETURN[FALSE];   --this node finished for now
};
IF Intersect[region, node.scan.first.size].overlap THEN {
IF PerItem[node.scan.first] THEN RETURN[TRUE];  --quit requested
quantaCount м quantaCount + 1;
};
node.scan м node.scan.rest;
ENDLOOP;
RETURN[FALSE];   --this node finished
};

ProcessAll: PerNodeProc ~ {
scan: LIST OF QTItem м node.items;
UNTIL scan = NIL DO
IF Intersect[region, scan.first.size].overlap THEN
IF PerItem[scan.first] THEN RETURN[TRUE];  --quit requested
scan м scan.rest;
ENDLOOP;
};

IF quanta < LAST[CARD] THEN TreeWalk[tree.structure, intRegion, ResetScans];
UNTIL extraPassNeeded = FALSE DO
extraPassNeeded м FALSE;
TreeWalk[tree.structure, intRegion, IF quanta < LAST[CARD] THEN ProcessAQuanta ELSE ProcessAll];
ENDLOOP;

};

PerNodeProc: TYPE = PROC [node: QTNode, region: InternalBoundingBox] RETURNS [quit: BOOLEAN м FALSE];

TreeWalk: PROC [node: QTNode, region: InternalBoundingBox, PerNode: PerNodeProc] ~ {
IF PerNode[node, region] THEN RETURN;
FOR quad: CARDINAL IN [0..3] DO
nextNode: QTNode м node.quadrants[quad];
nextRegion: InternalBoundingBox; lap: BOOLEAN;
IF nextNode = NIL THEN LOOP;
[nextRegion, lap] м Intersect[region, nextNode.area];
IF lap THEN TreeWalk[nextNode, nextRegion, PerNode];
ENDLOOP; 
};

Intersect: PROC [b1, b2: InternalBoundingBox] RETURNS [common: InternalBoundingBox, overlap: BOOLEAN] ~ {
common.lowerLeft.x м MAX[b1.lowerLeft.x, b2.lowerLeft.x];
common.lowerLeft.y м MAX[b1.lowerLeft.y, b2.lowerLeft.y];
common.upperRight.x м MIN[b1.upperRight.x, b2.upperRight.x];
common.upperRight.y м MIN[b1.upperRight.y, b2.upperRight.y];
overlap м (common.lowerLeft.x <= common.upperRight.x) AND (common.lowerLeft.y <= common.upperRight.y);
};


Destroy: PUBLIC ENTRY PROC [tree: QT, PerItem: PerItemProc м NIL] ~ {
ENABLE UNWIND => NULL;

TreeDestroyWalk: PROC [node: QTNode] ~ {
scan, temp: LIST OF QTItem;

IF node = NIL THEN RETURN;
scan м node.items;

UNTIL scan = NIL DO
IF PerItem # NIL THEN [] м  PerItem[scan.first];
temp м scan; scan м scan.rest;
temp.first м NIL; temp.rest м NIL;
ENDLOOP;

FOR quad: CARDINAL IN [0..3] DO
nextNode: QTNode м node.quadrants[quad];
[] м TreeDestroyWalk[nextNode];
node.quadrants[quad] м NIL;
ENDLOOP; 
};

TreeDestroyWalk[tree.structure];
};


qt: QT;
s: IO.STREAM;

PrintItems: PerItemProc ~ {
s.PutF1["QT item number %g\n", IO.int[NARROW[item.data, REF INT]н] ]
};

IF testing THEN {
s м FS.StreamOpen["QuadTreeImpl.testlog", $create];
qt м Create[[[0.0, 0.0], [10.0, 10.0]]];
Insert[qt, [[4.0, 4.0], [6.0, 6.0]], NEW[INT м 1]];
Insert[qt, [[5.0, 2.0], [6.0, 3.0]], NEW[INT м 2]];
Insert[qt, [[7.0, 7.0], [8.0, 8.0]], NEW[INT м 3]];
Enumerate[qt,  [[6.0, 6.0], [6.0, 6.0]], PrintItems];
Destroy[qt];
s.Close[];
};
 

END.


    в  
QuadTree.mesa
Copyright ╙ 1992 by Xerox Corporation.  All rights reserved.
Greene, June 14, 1990 5:40 pm PDT
Chauser, June 2, 1992 2:23 pm PDT
For testing
Э╩
w  ХNewlineDelimiter
Ц(cedarcode) styleЩ ЪЬЩJЪЬ
╧eЬ1Щ<JЪЬ!Щ!JЩ!ЧIcodeШ KЪ╧k	Ь!ЮЬЮЬШ7KШ KЪ╧nЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬШfKШ KЪЮЬЮЬШKШ KЪЬ	ЮЬЮЬШKШ KЪЮЬЮЬЮЬШЪ	ЬЮЬЮЬЮ	ЬЮЬШ'KЪЬЮЬШKЪЬШKЪЬШKШ ЧKЪЬ	ЮЬЮЬШЪЬЮЬЮЬШKЪЬЮЬ╧c"Ш7KЪЬЮЬШKЪЬШKЪЬЮЬЮЬ
ЮЬШKЪЬЮЬЮЬ
ЮЬа%ШBKЪ	ЬЮЬЮЬ
ЮЬЮЬШ+KШЧKШ KЪЬЮЬШKЪЬЮЬШKШ Ъ
ЯЬЮЬЮЬЮЬЮЬШAЪЬЮЬШ&KЪЬ	ЮЬЮЬЮЬЮЬЮЬЮЬЮЬЮЬШOKЪЬШKЪЬШЧKЪЮЬЮЬ7ШBKШЧKШ ЪЯЬЮЬЮЬЮЬ#ЮЬЮЬ
ЮЬЮЬШbKЪЬЮЬJШ\KШKЪЮЬЮЬЮЬШJKШЧKШ ЪЯЬЮЬЮЬШ/KШKЪЬШKШЧKШ ЪЯ
ЬЮЬЮЬШTKШ2KШ4KШЧKШ ЪЯЬЮЬЮЬЮЬШLKШ8KШ9KШЧKШ ЪЯЬЮЬЮЬЮЬЮЬЮЬШCKЪЮЬ
ЮЬЮЬШKЪЮЬ
ЮЬЮЬШKЪЮЬ,Ш2KШЧKШ ЪЯЬЮЬ!Ш7KЪЮЬЮЬЮЬШBЪЮЬЮЬЮЬШKЪЬЮЬШ$KШЪЮЬЮЬШ%KШKШKЪЬЮЬШЪЮЬЮЬЮШKЪЬ(Ш(KШKЪЮЬШЧKШЧKШЧЪЮЬа.Ш6KЪЬЮЬ$Ш1KЪЮЬЮЬЮЬаШEЪЮЬШKЪЮЬЮЬЮЬ,ШNKЪЬ-Ш-KШЧKШЧKШЧKШ Ъ
ЯЬЮЬЮЬЮЬЮЬШPKЪЬЮЬ1Ш?KЪЬЮЬ1Ш?KЪЬЮЬШ!KЪЬЮЬШKШ6KШ6KШKЪ
ЮЬЮЬЮЬ	ЮЬЮЬШ7KШЧKШ ЪЯ
ЬЮЬЮЬЮЬЮЬЮЬЮЬШNKЪЮЬЮЬЮЬЮЬШ0KШЧKШ ЪЯЬЮЬЮЬЮЬШGЪЬЮЬШKШKШ/KШЧKШЧKШ Ъ
ЯЬЮЬ#ЮЬЮЬЮЬШoKЪЬЮЬ
ШKЪЬЮЬШKШAKШAKШBKШBKШЧKШ ЪЯЬЮЬЮЬЮЬ	ЮЬЮЬЮЬ
ЮЬШrKЪЬ	ЮЬШЪЬ	ЮЬШKЪЮЬШKЪЮЬШ#KШЧKШKШ ЧЪЯ	ЬЮЬЮЬЮЬЯЬЮЬЮЬЮЬЮЬЮЬШВKЪЮЬ
ЮЬЮЬЮЬЮЬЮЬЮЬШ1KЪЮЬЮЬ/Ш=KЪЮЬ/Ш3KШЧKШ ЪЯЬЮЬЮЬЮЬЯЬЮЬЮЬЮЬШqKЪЮЬЮЬЮЬШKЪЬ.Ш.KШЧKШ KШ ЪЯЬЮЬЮЬЯЬЮЬЮЬЮЬШjKШCKШ ЪЯ
ЬШKШKШЧKШ KЪЬЮЬЮЬШKШ ЪЯЬШKЪЬЮЬШЪЮЬЮЬЮШЪЮЬЮЬШKЪЬЮЬШKЪЮЬЮЬаШ-KШЧЪЮЬ1ЮЬШ9KЪ	ЮЬЮЬЮЬЮЬаШ@KШKШЧKШKЪЮЬШЧKЪЮЬЮЬаШ%KШЧKШ ЪЯ
ЬШKЪЬЮЬЮЬШ"ЪЮЬЮЬЮШЪЮЬ,ЮШ2KЪ	ЮЬЮЬЮЬЮЬаШ;ЧKШKЪЮЬШЧKШЧKШ KЪЮЬ
ЮЬЮЬЮЬ1ШLЪЮЬЮЬЮШ KЪЬЮЬШKЪЬ$ЮЬ
ЮЬЮЬЮЬЮЬШ`KЪЮЬШЧKШ KШЧKШ KЪЬЮЬЮЬ-ЮЬЮЬЮЬШeKШ ЪЯЬЮЬ-ЯЬШTKЪЮЬЮЬЮЬШ%ЪЮЬЮЬЮЬЮШKШ(KЪЬ&ЮЬШ.KЪЮЬЮЬЮЬЮЬШKШ5KЪЮЬЮЬ)Ш4KЪЮЬШ	ЧKШЧKШ ЪЯ	ЬЮЬЮЬ(ЮЬШiKЪЬЮЬ!Ш9KЪЬЮЬ!Ш9KЪЬЮЬ#Ш<KЪЬЮЬ#Ш<KЪЬ6ЮЬ-ШfKШЧKШ KШ ЪЯЬЮЬЮЬЮЬЮЬЯЬЮЬШEKЪЮЬЮЬЮЬШKШ ЪЯЬЮЬШ(KЪЬЮЬЮЬШKШ KЪЮЬЮЬЮЬЮЬШKШKШ ЪЮЬЮЬЮШKЪЮЬЮЬЮЬШ0KШKЪЬЮЬЮЬШ"KЪЮЬШKШ ЧЪЮЬЮЬЮЬЮШKШ(KШKЪЬЮЬШKЪЮЬШ	ЧKШЧKШ KЪЬ Ш KШЧKШ KШ KЪЬЩKШ KЪЬЮЬШKЪЬЮЬЮЬШKШ ЪЯ
ЬШKЪ	ЬЮЬЮЬЮЬЮЬШDKШЧKШ ЪЮЬ	ЮЬШKЪЬЮЬ-Ш3KШ(KЪЬ%ЮЬЮЬШ3KЪЬ%ЮЬЮЬШ3KЪЬ%ЮЬЮЬШ3KШ5KШKШ
KШKЪЬШЧKШ ЪЮЬШKШ KШ KШ KШ KШ KШ KШ KШ ЧЧ ЕЧ    4  )M  