DIRECTORY Basics USING [LongNumber, BITSHIFT, BITOR, BITAND], Pipal, PipalInt, PipalInstanceTable; PipalInstanceTableImpl: CEDAR MONITOR IMPORTS Basics, PipalInt EXPORTS PipalInstanceTable = BEGIN OPEN PipalInstanceTable; freeInstanceValues: LIST OF InstanceValue _ NIL; 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; }; 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! }; Range: TYPE = RECORD [x1, y1, x2, y2: INT]; Halve: PROC [n: INT] RETURNS [INT] ~ INLINE { 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: Range] RETURNS [BOOL] = INLINE { RETURN [r1.x1<=r2.x2 AND r2.x1<=r1.x2 AND r1.y1<=r2.y2 AND r2.y1<=r1.y2] }; Inside: PROC [a, b: Range] RETURNS [BOOL] = INLINE { RETURN[a.x1>=b.x1 AND a.x2<=b.x2 AND a.y1>=b.y1 AND a.y2<=b.y2] }; Intersection: PROC [r1, r2: Range] RETURNS [Range] = INLINE { 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: Range] RETURNS [BOOL] = INLINE { RETURN [r.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}; }; HashInstance: PROC [table: Table, trans: PipalInt.Transformation, object: Pipal.Object] RETURNS [hash: NAT] = INLINE { hash _ HashRect[table, InlineBBox[trans, object]]; }; RectToRange: PROC [rect: PipalInt.Rectangle] RETURNS [Range] = INLINE { RETURN [[x1: rect.base.x, y1: rect.base.y, x2: rect.base.x+rect.size.x, y2: rect.base.y+rect.size.y]]; }; HashRect: PROC [table: Table, range: Range] RETURNS [hash: NAT _ 1] = { bucket: Range _ RectToRange[table.rect]; IF NOT Inside[range, bucket] THEN ERROR; WHILE hash * 2 < table.data.size DO bucket1, bucket2: Range; [bucket1, bucket2] _ Divide[bucket]; SELECT TRUE FROM Inside[range, bucket1] => {hash _ hash * 2; bucket _ bucket1}; Inside[range, bucket2] => {hash _ hash * 2 + 1; bucket _ bucket2}; ENDCASE => RETURN; ENDLOOP; }; Create: PUBLIC PROC [rect: PipalInt.Rectangle, logSize: NAT _ 2] RETURNS [Table] = { data: REF TableData _ NEW [TableData[Basics.BITSHIFT[value: 1, count: logSize]]]; RETURN [NEW [TableRec _ [rect: rect, 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.trans, values.first.object]; 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, trans: PipalInt.Transformation, object: Pipal.Object, value: Value] = { ENABLE UNWIND => NULL; hash: NAT _ HashInstance[table, trans, object]; IF table.data[hash]=NIL THEN table.leafBuckets _ table.leafBuckets+1; table.data[hash] _ Cons[[trans, object, value], table.data[hash]]; IF table.leafBuckets * 2 > table.data.size THEN ReHash[table]; }; Enumerate: PUBLIC PROC [table: Table, action: PROC [PipalInt.Transformation, Pipal.Object, Value], rect: PipalInt.Rectangle _ PipalInt.fullRectangle] = { EnumerateBucket: PROC [hash: NAT] = { FOR ivs: LIST OF InstanceValue _ data[hash], ivs.rest WHILE ivs#NIL DO IF Intersect[InlineBBox[ivs.first.trans, ivs.first.object], clipped] THEN action[ivs.first.trans, ivs.first.object, ivs.first.value]; ENDLOOP; }; data: REF TableData _ table.data; -- stored in the local frame to avoid concurrent inconsistencies clipped: Range _ Intersection[RectToRange[rect], RectToRange[table.rect]]; hash1, hash2, hash: NAT; IF NOT NonEmpty[clipped] THEN RETURN; -- PipalInt.emptyRectangle range 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: PipalInt.Rectangle _ PipalInt.emptyRectangle] = { range: Range _ RectToRange[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[range, InlineBBox[current.first.trans, current.first.object]] => { 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; }; Size: PROC [table: Table] RETURNS [size: INT _ 0] = { Count: PROC [PipalInt.Transformation, Pipal.Object, Value] = {size _ size + 1}; Enumerate[table, Count]; }; END. :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 15, 1988 0:36:02 am PST Jean-Marc Frailong January 16, 1988 5:30:56 pm PST Hand allocation for efficiency reasons equivalent to: new _ CONS [iw, list]; equivalent to: rest _ list.rest; only disposes of the first element! For efficiency of intersection. Because the compiler is brain-damaged and calls general division for INT/2 Returns r1 and r2 have some common points or border; [assumes r1, r2 normalized]. [TRUE if rects touch on a single point] Returns a inside of b (b inclusive border) Returns intersection of r1 and r2 Returns r is not PipalInt.emptyRectangle [contains more points than the border] For debugging! Э╩╥Ц "cedar" styleШcodeЪЬЩKЪЬBЩBKЪЬI╧kЩLKЪЬ.Щ.KЪЬ/ЭЩ2KШЧЪЭ Ш KЪ ЬЭЬЭЬЭЬЭЬШ3KЪЬ$Ш$KШЧЪ╧nЬЭЬЭШ%KЪЭЬШKЪЭЬШKЪЭЬЭЬШKШЧЪЬЭЬЭЬЭЬШ0KЩ&KЩЧKЪЬЭЬЩ%ЪЮЬЭЬЭЬЭЬЭЬЭЬЭЬЭЬШlKЪЭЬЭЬЭЬЭЬЭЬ╧cШQKЪ ЭЬЭЬЭЬЭЬЯШQKЪЬiШiKШKШЧKЪЬ Щ KЪЬ#Щ#ЪЮЬЭЬЭЬЭЬЭЬЭЬЭЬЭЬШ]KЪЬ$ЭЬ>ШeKЪ ЭЬЭЬЭЬЭЬЯШQKШKШЧЪЬЭЬЭЬЭЬШ+KЩKЩЧЪЮЬЭЬЭЬЭЬЭЬЭЬШ-KЪЬEЭЬЩJJЪЬШJЪЬ Ш JЪЬЭЬЭЬЭЬ ШMJЪЬЭЬЭЬЭЬШOKЪЭЬ ШKШKШЧЪ Ю ЬЭЬЭЬЭЬЭЬШ9JЪЬRЩRJЪЬЭЬ"Щ'JЪЭЬЭЬЭЬЭЬШHJЪЬШJШЧЪ ЮЬЭЬЭЬЭЬЭЬШ4JЪЬ*Щ*JЪЭЬЭЬЭЬЭЬШ?JЪЬШJШЧЪЮЬЭЬЭЬЭЬШ=JЪЬ!Щ!JЪ ЭЬЭЬЭЬЭЬЭЬШeJЪЬШJШЧЪ ЮЬЭЬЭЬЭЬЭЬШ3JЪЬOЩOJЪЭЬЭЬШ JЪЬШJШЧЪЮ ЬЭЬ8ЭЬЭЬШiKЪЬ2Ш2KШKШЧЪЮЬЭЬЭЬЭЬШIJЪЬШЪЭЬ*Ш,JЪЭЬЭЬDШRJЪЭЬЭЬEШSЧKШKШЧЪ ЮЬЭЬFЭЬЭЬЭЬШvJЪЬ2Ш2KШKШЧЪЮЬЭЬЭЬЭЬШGKЪЭЬ`ШfKШKШЧЪЮЬЭЬЭЬЭЬ ШGJЪЬ(Ш(JЪЭЬЭЬЭЬЭЬШ(ЪЭЬЭШ#JЪЬШJЪЬ$Ш$ЪЭЬЭЬЭШJЪЬ?Ш?JЪЬBШBJЪЭЬ ЭЬШЧJЪЭЬШЧKШKШЧЪ ЮЬЭЬЭЬ%ЭЬЭЬШTKЪЬЭЬ ЭЬЭЬШQKЪЭЬЭЬ8ШCKШKШЧЪЮЬЭЬШKЪЬ ЭЬШ$KЪЬ ЭЬ ЭЬШ9KЪЬШKЪЬШЪЭЬЭЬЭЬЭШ$KЪЬЭЬЭЬШ+ЪЭЬЭЬЭШKЪЬЭЬ@ШIKЪЭЬЭЬЭЬ)ШBKЪЬ2Ш2KЪЬШKЪЭЬШЧKЪЭЬШЧKШKШЧЪЮЬЭЬЭЬЭЬWШpKЪЭЬЭЬЭЬШKЪЬЭЬ&Ш/KЪЭЬЭЬЭЬ)ШEKЪЬBШBKЪЭЬ)ЭЬШ>KШKШЧЪЮ ЬЭЬЭЬЭЬgШЩЪЮЬЭЬЭЬШ%ЪЭЬЭЬЭЬ&ЭЬЭЬЭШFЪЭЬCШEKЪЭЬ<Ш@ЧKЪЭЬШЧKШЧKЪЬЭЬЯ@ШbKЪЬJШJKЪЬЭЬШKЪ ЭЬЭЬЭЬЭЬЯ ШFKЪЬ0Ш0KЪЭЬЭЬ&ЭЬШ=ЪЭШKЪЬ)Ш)KЪЭЬЭЬЭЬШ KЪЭЬЭЬЭЬЭЬШ>KЪЭЬШЧKШKШЧЪЮ ЬЭЬЭЬЭЬGШgKЪЬ!Ш!ЪЭЬЭЬЭЬЭШ'ЪЭЬЭЬЭЬШKЪЬ ЭЬЭЬШ/KЪЬ ЭЬЭЬЭЬЯ(ШOKЪЬЭЬЭЬШЪЭЬЭЬЭШЪЭЬЭЬЭШЪЬLШLKЪЬ ЭЬ-Ш?KШЧKЪЬЭЬ/Ш=KЪЭЬ/Ш6ЧKЪЭЬШЧKЪЭЬЭЬ)Ш;KШЧKЪЭЬШЧKШKШЧKЪЬЩЪЮЬЭЬЭЬЭЬ Ш5KЪЮЬЭЬDШOKЪЬШKШKШЧЪЭЬШKШKШKШЧЧЕЧМ"Ш