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;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!};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: Rect] 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: Rect] 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: Rect] RETURNS [Rect] = 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: Rect] RETURNS [BOOL] = INLINE {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;};Size: PROC [table: Table] RETURNS [size: INT _ 0] = {Count: PROC [Instance, 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 5, 1988 6:54:12 pm 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!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 empty [contains more points than the border]For debugging!Э╩Ы  Ц"cedar" styleШ codeЪЬЩKЪЬBЩBKЪЬI╧kЩLKЪЬ-Щ-KЪЬ/ЭЩ2KШ ЧЪЭ	Ш	KЪ	ЬЭЬЭЬЭЬЭЬШ3KЪЭЬШ
KЪЬШKШ ЧЪ╧nЬЭЬЭШ%KЪЭЬШKЪЭЬШKЪЭЬЭЬШKШ ЧЪЬЭЬЭЬЭЬШ0KЩ&KЩ ЧKЪЬЭЬЩ%ЪЮЬЭЬЭЬЭЬЭЬЭЬЭЬЭЬШlKЪЭЬЭЬЭЬЭЬЭЬ╧cШQKЪ	ЭЬЭЬЭЬЭЬЯШQKЪЬiШiKШKШ ЧKЪЬ Щ KЪЬ#Щ#ЪЮЬЭЬЭЬЭЬЭЬЭЬЭЬЭЬШ]KЪЬ$ЭЬ>ШeKЪ	ЭЬЭЬЭЬЭЬЯШQKШKШ ЧЪЮЬЭЬЭЬЭЬЭЬЭЬШ-KЪЬEЭЬЩJJЪЬШJЪЬ
Ш
JЪЬЭЬЭЬЭЬШMJЪЬЭЬЭЬЭЬШOKЪЭЬ	ШKШKШ ЧЪ
Ю	ЬЭЬЭЬЭЬЭЬШ8JЪЬRЩRJЪЬЭЬ"Щ'JЪЭЬЭЬЭЬЭЬШHJЪЬШJШ ЧЪ
ЮЬЭЬЭЬЭЬЭЬШ3JЪЬ*Щ*JЪЭЬЭЬЭЬЭЬШ?JЪЬШJШ ЧЪЮЬЭЬЭЬ
ЭЬШ;JЪЬ!Щ!JЪ
ЭЬЭЬЭЬЭЬЭЬШeJЪЬШJШ ЧЪ
ЮЬЭЬЭЬЭЬЭЬШ2JЪЬ=Щ=JЪЭЬЭЬШ JЪЬШJШ ЧЪЮ
ЬЭЬЭЬЭЬШEKЪЬ4Ш4KЪЬ$Ш$KШKШ ЧЪЮЬЭЬЭЬЭЬШGJЪЬШЪЭЬ*Ш,JЪЭЬЭЬDШRJЪЭЬЭЬEШSЧKШKШ ЧЪЮЬЭЬЭЬЭЬ	ШEJЪЬШJЪЭЬЭЬЭЬЭЬШ'ЪЭЬЭШ#JЪЬШJЪЬ$Ш$ЪЭЬЭЬЭШJЪЬ>Ш>JЪЬAШAJЪЭЬ
ЭЬШЧJЪЭЬШЧKШKШ ЧЪ
ЮЬЭЬ$ЭЬЭЬЭЬШTJЪЬ-Ш-KШKШ ЧЪ
ЮЬЭЬЭЬЭЬЭЬШGKЪЬЭЬЭЬЭЬШQKЪЭЬЭЬ:ШEKШKШ ЧЪЮЬЭЬШKЪЬ	ЭЬШ$KЪЬ	ЭЬЭЬШ9KЪЬШKЪЬШЪЭЬЭЬЭЬЭШ$KЪЬЭЬЭЬШ+ЪЭЬЭЬЭШKЪЬЭЬ.Ш7KЪЭЬЭЬЭЬ)ШBKЪЬ2Ш2KЪЬШKЪЭЬШЧKЪЭЬШЧKШKШ ЧЪЮЬЭЬЭЬЭЬ5ШNKЪЭЬЭЬЭЬШKЪЬЭЬ!Ш*KЪЭЬЭЬЭЬ)ШEKЪЬ=Ш=KЪЭЬ)ЭЬШ>KШKШ ЧЪЮ	ЬЭЬЭЬЭЬ.Ш`ЪЮЬЭЬЭЬШ%ЪЭЬЭЬЭЬ&ЭЬЭЬЭШFЪЭЬ4Ш6KЪЭЬ-Ш1ЧKЪЭЬШЧKШЧKЪЬЭЬЯ@ШbKЪЬ0Ш0KЪЬЭЬШKЪ	ЭЬЭЬЭЬЭЬЯШ3KЪЬ0Ш0KЪЭЬЭЬ&ЭЬШ=ЪЭШKЪЬ)Ш)KЪЭЬЭЬЭЬШ KЪЭЬЭЬЭЬЭЬШ>KЪЭЬШЧKШKШ ЧЪЮЬЭЬЭЬЭЬШ?ЪЭЬЭЬЭЬЭШ'ЪЭЬЭЬЭЬШKЪЬ	ЭЬЭЬШ/KЪЬ
ЭЬЭЬЭЬЯ(ШOKЪЬЭЬЭЬШЪЭЬЭЬЭШЪЭЬЭЬЭШЪЬ8Ш8KЪЬЭЬ-Ш?KШЧKЪЬЭЬ/Ш=KЪЭЬ/Ш6ЧKЪЭЬШЧKЪЭЬЭЬ)Ш;KШЧKЪЭЬШЧKШKШ ЧKЪЬЩЪЮЬЭЬЭЬЭЬ	Ш5KЪЮЬЭЬ'Ш2KЪЬШKШKШ ЧЪЭЬШKШ KШ KШ ЧЧ ЕЧ    .  ╧  