PipalInstanceTableImpl.mesa
Copyright Ó 1987, 1988 by Xerox Corporation. All rights reversed.
From Intervals, created by Bertrand Serlet, November 16, 1985 7:22:05 pm PST
Bertrand Serlet, March 5, 1988 6:54:12 pm PST
Jean-Marc Frailong January 16, 1988 5:30:56 pm PST
DIRECTORY
Basics USING [LongNumber, BITSHIFT, BITOR, BITAND],
CD, Core,
PipalCore, PipalInstanceTable;
PipalInstanceTableImpl:
CEDAR
MONITOR
IMPORTS Basics, PipalCore
EXPORTS PipalInstanceTable =
BEGIN OPEN PipalInstanceTable;
freeInstanceValues:
LIST
OF InstanceValue ←
NIL;
Hand allocation for efficiency reasons
equivalent to: new ← CONS [iw, list];
Cons:
PRIVATE
PROC [iw: InstanceValue, list:
LIST
OF InstanceValue]
RETURNS [new:
LIST
OF InstanceValue] = {
IF freeInstanceValues=NIL THEN freeInstanceValues ← LIST [[[], NIL]]; -- too bad!
IF freeInstanceValues.first#[[], NIL] THEN ERROR; -- something real bad going on!
new ← freeInstanceValues; freeInstanceValues ← freeInstanceValues.rest; new.first ← iw; new.rest ← list;
};
equivalent to: rest ← list.rest;
only disposes of the first element!
Dispose:
PRIVATE
PROC [list:
LIST
OF InstanceValue]
RETURNS [rest:
LIST
OF InstanceValue] = {
rest ← list.rest; list.first ← [[], NIL]; list.rest ← freeInstanceValues; freeInstanceValues ← list;
IF freeInstanceValues.first#[[], NIL] THEN ERROR; -- something real bad going on!
};
Halve:
PROC [n:
INT]
RETURNS [
INT] ~
INLINE {
Because the compiler is brain-damaged and calls general division for INT/2
ln: Basics.LongNumber;
ln.li ← n;
ln.lo ← Basics.BITOR[Basics.BITSHIFT[ln.lo, -1], Basics.BITSHIFT[ln.hi, 15]];
ln.hi ← Basics.BITOR[Basics.BITSHIFT[ln.hi, -1], Basics.BITAND[ln.hi, 08000H]];
RETURN [ln.li];
};
Intersect:
PROC [r1, r2: Rect]
RETURNS [
BOOL] =
INLINE {
Returns r1 and r2 have some common points or border; [assumes r1, r2 normalized].
[TRUE if rects touch on a single point]
RETURN [r1.x1<=r2.x2 AND r2.x1<=r1.x2 AND r1.y1<=r2.y2 AND r2.y1<=r1.y2]
};
Inside:
PROC [a, b: Rect]
RETURNS [
BOOL] =
INLINE {
Returns a inside of b (b inclusive border)
RETURN[a.x1>=b.x1 AND a.x2<=b.x2 AND a.y1>=b.y1 AND a.y2<=b.y2]
};
Intersection:
PROC [r1, r2: Rect]
RETURNS [Rect] =
INLINE {
Returns intersection of r1 and r2
RETURN [[x1: MAX[r1.x1, r2.x1], y1: MAX[r1.y1, r2.y1], x2: MIN[r1.x2, r2.x2], y2: MIN[r1.y2, r2.y2]]]
};
NonEmpty:
PROC [r: Rect]
RETURNS [
BOOL] =
INLINE {
Returns r is not empty [contains more points than the border]
RETURN [r.x1<r.x2 AND r.y1<r.y2]
};
InlineBBox:
PROC [instance: Instance]
RETURNS [rect: Rect] =
INLINE {
rr: PipalCore.Rect ← PipalCore.InlineBBox[instance];
rect ← [rr.x1, rr.y1, rr.x2, rr.y2];
};
Divide:
PROC [bucket: Rect]
RETURNS [bucket1, bucket2: Rect] =
INLINE {
bucket1 ← bucket2 ← bucket;
IF bucket.x2-bucket.x1>=bucket.y2-bucket.y1
THEN {mid: INT ← Halve[bucket.x1+bucket.x2]; bucket1.x2 ← mid; bucket2.x1 ← mid+1}
ELSE {mid: INT ← Halve[bucket.y1+bucket.y2]; bucket1.y2 ← mid; bucket2.y1 ← mid+1};
};
HashRect:
PROC [table: Table, rect: Rect]
RETURNS [hash:
NAT ← 1] = {
bucket: Rect ← table.range;
IF NOT Inside[rect, bucket] THEN ERROR;
WHILE hash * 2 < table.data.size
DO
bucket1, bucket2: Rect;
[bucket1, bucket2] ← Divide[bucket];
SELECT
TRUE
FROM
Inside[rect, bucket1] => {hash ← hash * 2; bucket ← bucket1};
Inside[rect, bucket2] => {hash ← hash * 2 + 1; bucket ← bucket2};
ENDCASE => RETURN;
ENDLOOP;
};
HashInstance:
PROC [table: Table, instance: Instance]
RETURNS [hash:
NAT] =
INLINE {
hash ← HashRect[table, InlineBBox[instance]];
};
Create:
PUBLIC
PROC [range: Rect, logSize:
NAT ← 2]
RETURNS [Table] = {
data: REF TableData ← NEW [TableData[Basics.BITSHIFT[value: 1, count: logSize]]];
RETURN [NEW [TableRec ← [range: range, leafBuckets: 0, data: data]]];
};
ReHash:
PROC [table: Table] = {
oldData: REF TableData ← table.data;
newData: REF TableData ← NEW [TableData[oldData.size*2]];
table.data ← newData;
table.leafBuckets ← 0;
FOR i:
NAT
IN [1 .. oldData.size)
DO
values: LIST OF InstanceValue ← oldData[i];
WHILE values#
NIL
DO
hash: NAT ← HashInstance[table, values.first.instance];
IF newData[hash]=NIL THEN table.leafBuckets ← table.leafBuckets+1;
newData[hash] ← Cons[values.first, newData[hash]];
values ← Dispose[values];
ENDLOOP;
ENDLOOP;
};
Insert:
PUBLIC
ENTRY
PROC [table: Table, instance: Instance, value: Value] = {
ENABLE UNWIND => NULL;
hash: NAT ← HashInstance[table, instance];
IF table.data[hash]=NIL THEN table.leafBuckets ← table.leafBuckets+1;
table.data[hash] ← Cons[[instance, value], table.data[hash]];
IF table.leafBuckets * 2 > table.data.size THEN ReHash[table];
};
Enumerate:
PUBLIC
PROC [table: Table, action:
PROC [Instance, Value], rect: Rect ← universe] = {
EnumerateBucket:
PROC [hash:
NAT] = {
FOR ivs:
LIST
OF InstanceValue ← data[hash], ivs.rest
WHILE ivs#
NIL
DO
IF Intersect[InlineBBox[ivs.first.instance], clipped]
THEN action[ivs.first.instance, ivs.first.value];
ENDLOOP;
};
data: REF TableData ← table.data; -- stored in the local frame to avoid concurrent inconsistencies
clipped: Rect ← Intersection[rect, table.range];
hash1, hash2, hash: NAT;
IF NOT NonEmpty[clipped] THEN RETURN; -- empty rect
hash1 ← hash2 ← hash ← HashRect[table, clipped];
WHILE hash>0 DO EnumerateBucket[hash]; hash ← hash/2 ENDLOOP;
DO
hash1 ← 2 * hash1; hash2 ← 2 * hash2 + 1;
IF hash2>=data.size THEN RETURN;
FOR hash IN [hash1 .. hash2] DO EnumerateBucket[hash] ENDLOOP;
ENDLOOP;
};
DeleteOutside:
PUBLIC
ENTRY
PROC [table: Table, rect: Rect] = {
FOR i:
NAT
IN [1 .. table.data.size)
DO
IF table.data[i]#
NIL
THEN {
current: LIST OF InstanceValue ← table.data[i];
previous: LIST OF InstanceValue ← NIL; -- either NIL or the node before current
allDeleted: BOOL ← TRUE;
UNTIL current =
NIL
DO
SELECT
TRUE
FROM
Intersect[rect, InlineBBox[current.first.instance]] => {
allDeleted ← FALSE; previous ← current; current ← current.rest;
};
previous = NIL => current ← table.data[i] ← Dispose[current];
ENDCASE => current ← previous.rest ← Dispose[current];
ENDLOOP;
IF allDeleted THEN table.leafBuckets ← table.leafBuckets-1;
};
ENDLOOP;
};
For debugging!
Size:
PROC [table: Table]
RETURNS [size:
INT ← 0] = {
Count: PROC [Instance, Value] = {size ← size + 1};
Enumerate[table, Count];
};