-- FeaturePSTImpl.mesa
-- A generic package to organize list elements
-- in a priority search tree by the intervals they cover,
-- and to search by interval.
-- last modified by E. McCreight, November 8, 1982 2:34 PM
-- written by E. McCreight, November 3, 1981 11:08 AM
DIRECTORY
InlineDefs,
MiscDefs,
FeaturePST;
FeaturePSTImpl: PROGRAM
IMPORTS InlineDefs, MiscDefs, FeaturePST
EXPORTS FeaturePST SHARES FeaturePST =
BEGIN OPEN FeaturePST;
-- Note: An Interval is [min..max).
NewFeaturePST: PUBLIC PROCEDURE[zone: UNCOUNTED ZONE]
RETURNS[PSTHandle] =
{RETURN[zone.NEW[PSTObject ← [
zone: zone, root: zone.NEW[PSTNode ← [nil[]]]]]]};
DestroyFeaturePST: PUBLIC PROCEDURE[p: PSTHandle]
RETURNS[PSTHandle] =
BEGIN
InternalDestroyPST: PROCEDURE[p: PSTNodePtr] =
BEGIN
WITH d: p SELECT FROM
nil => NULL;
leaf => p↑ ← [nil[]];
internal =>
BEGIN
pst: PSTBinNodePtr ← d.pst;
InternalDestroyPST[@pst.halves[lower]];
InternalDestroyPST[@pst.halves[upper]];
zone.FREE[@pst]; p↑ ← [nil[]];
END;
ENDCASE;
END;
zone: UNCOUNTED ZONE ← p.zone;
pi: PSTNodePtr ← p.root;
InternalDestroyPST[pi];
zone.FREE[@p.root];
WHILE p.freeNodes#NIL DO
node: PSTBinNodePtr ← NewNode[p];
zone.FREE[@node];
ENDLOOP;
zone.FREE[@p];
RETURN[NIL];
END; -- of DestroyPST
InsertFeaturePST: PUBLIC PROCEDURE[p: PSTHandle,
item: Item] =
BEGIN
-- There can be many items with the same
-- .y value. For now we shall simply let these
-- form degenerate trees upward, so as not to
-- overflow our stacks.
pi: PSTNodePtr ← p.root;
-- IF checkTree THEN CheckPST[p];
DO WITH f: pi SELECT FROM
nil => {pi↑ ← [leaf[item: item]]; EXIT};
leaf => pi↑ ← [internal[pst: NewNode[p: p,
init: [vMin: f.item,
uLen: CommonLen[f.item, item, pt]]]]];
internal =>
BEGIN OPEN InlineDefs;
son: PSTBinNodePtr ← f.pst;
newULen: RadixIndex ← CommonLen[item, son.vMin, pt];
IF newULen<son.uLen THEN
BEGIN -- a new node for lp must be put
-- between father and son;
new: PSTBinNodePtr ← NewNode[p: p,
init:
(IF TreeHalf[item, newULen]=lower THEN
[uLen: newULen, halves:
[lower: [leaf[item]], upper: [internal[son]]]]
ELSE
[uLen: newULen, halves:
[lower: [internal[son]], upper: [leaf[item]]]])];
pi↑ ← [internal[new]];
ExtractVMin[pi, p]; -- sets the vMin field
EXIT;
END
ELSE -- item.lp and son.vMin.lp match in first son.uLen bits
BEGIN
IF Shallower[item, son.vMin] THEN
BEGIN -- exchange item with son.vMin
t: Item ← son.vMin; son.vMin ← item; item ← t;
END;
pi ← @son.halves[TreeHalf[item, son.uLen]];
END;
END; -- internal
ENDCASE;
ENDLOOP;
-- IF checkTree THEN CheckPST[p];
END; -- of InsertFeaturePST
CouldntDeleteFeaturePST: PUBLIC SIGNAL = CODE;
DeleteFeaturePST: PUBLIC PROCEDURE[p: PSTHandle, item: Item] =
BEGIN
pi: PSTNodePtr ← p.root;
-- IF checkTree THEN CheckPST[p];
DO WITH f: pi SELECT FROM
nil => SIGNAL CouldntDeleteFeaturePST;
leaf => IF item=f.item THEN {pi↑ ← [nil[]]; EXIT} ELSE
SIGNAL CouldntDeleteFeaturePST;
internal =>
BEGIN
son: PSTBinNodePtr ← f.pst;
IF item=son.vMin THEN {ExtractVMin[pi, p]; EXIT}
ELSE
pi ← @son.halves[TreeHalf[item, son.uLen]];
END;
ENDCASE;
ENDLOOP;
-- IF checkTree THEN CheckPST[p];
END; -- of DeleteFeaturePST
ExtractVMin: PROCEDURE[pi: PSTNodePtr, p: PSTHandle] =
BEGIN
DO WITH f: pi SELECT FROM
nil => MiscDefs.CallDebugger[NIL];
leaf => {pi↑ ← [nil[]]; RETURN};
internal =>
BEGIN
t: PSTBinNodePtr ← f.pst;
WITH l: t.halves[lower] SELECT FROM
nil =>
WITH u: t.halves[upper] SELECT FROM
nil =>
{FreeNode[p, t]; pi↑ ←[nil[]]; RETURN};
leaf =>
BEGIN
pi↑ ← [leaf[item: u.item]];
FreeNode[p, t];
RETURN;
END;
internal => {t.vMin ← u.pst.vMin; pi ← @u};
ENDCASE; -- u
leaf =>
WITH u: t.halves[upper] SELECT FROM
nil =>
BEGIN
pi↑ ← [leaf[item: l.item]];
FreeNode[p, t];
RETURN;
END;
leaf =>
IF Shallower[l.item, u.item] THEN
{t.vMin ← l.item; pi ← @l}
ELSE {t.vMin ← u.item; pi ← @u};
internal =>
IF Shallower[l.item, u.pst.vMin] THEN
{t.vMin ← l.item; pi ← @l}
ELSE {t.vMin ← u.pst.vMin; pi ← @u};
ENDCASE; -- u
internal =>
WITH u: t.halves[upper] SELECT FROM
nil => {t.vMin ← l.pst.vMin; pi ← @l};
leaf =>
IF Shallower[l.pst.vMin, u.item] THEN
{t.vMin ← l.pst.vMin; pi ← @l}
ELSE {t.vMin ← u.item; pi ← @u};
internal =>
IF Shallower[l.pst.vMin, u.pst.vMin] THEN
{t.vMin ← l.pst.vMin; pi ← @l}
ELSE {t.vMin ← u.pst.vMin; pi ← @u};
ENDCASE; -- u
ENDCASE; -- l
END;
ENDCASE; -- f
ENDLOOP;
END; -- of ExtractVMin
NewNode: PROCEDURE[p: PSTHandle,
init: PSTBinNode ← [uLen: 0]]
RETURNS[new: PSTBinNodePtr] = INLINE
BEGIN
IF (new ← p.freeNodes)#NIL THEN
BEGIN
WITH n: new.halves[lower] SELECT FROM
internal => p.freeNodes ← n.pst;
nil => p.freeNodes ← NIL;
ENDCASE => ERROR; -- bad free list linkage
new↑ ← init;
END
ELSE
new ← p.zone.NEW[PSTBinNode ← init];
END; -- of NewNode
FreeNode: PROCEDURE[p: PSTHandle,
old: PSTBinNodePtr] = INLINE
BEGIN
old.halves[lower] ← [internal[pst: p.freeNodes]];
p.freeNodes ← old;
END; -- of FreeNode
pqLim: INTEGER = 200;
PSTPQEnt: TYPE = RECORD[min: Domain, p: PSTNodePtr];
PSTPQArray: TYPE = ARRAY [1..pqLim) OF PSTPQEnt;
PSTPQPtr: TYPE = LONG POINTER TO PSTPQArray ← NIL;
PSTPQs: ARRAY [0..10) OF PSTPQPtr;
recursionDepth: [0..10) ← 0;
SearchFeaturePST: PUBLIC PROCEDURE[p: PSTHandle,
int: Interval, touch: PROCEDURE[item: Item]] =
BEGIN -- enumerates in increasing order by Min[item]
MakePSTPQEnt: PROCEDURE[p: PSTNodePtr]
RETURNS[PSTPQEnt] = INLINE
BEGIN
WITH dp: p SELECT FROM
internal => RETURN[[min: Min[dp.pst.vMin], p: p]];
leaf => RETURN[[min: Min[dp.item], p: p]];
ENDCASE => RETURN[[min: FIRST[Domain], p: p]];
END;
yMin: Domain ← int.min;
yMax: Domain ← int.max; -- yMax not in interval
pqSize: [0..pqLim) ← 1;
PSTPQ: PSTPQPtr ← IF PSTPQs[recursionDepth]#NIL
THEN PSTPQs[recursionDepth]
ELSE (PSTPQs[recursionDepth] ← p.zone.NEW[PSTPQArray]);
recursionDepth ← recursionDepth+1;
PSTPQ[1] ← MakePSTPQEnt[p.root];
WHILE 1<=pqSize DO
RippleUp: PROCEDURE[] = INLINE
BEGIN
p: PSTPQEnt ← PSTPQ[hole];
FOR nextHole ← hole/2, hole/2
WHILE 1<=nextHole AND p.min<PSTPQ[nextHole].min DO
PSTPQ[hole] ← PSTPQ[nextHole];
hole ← nextHole;
ENDLOOP;
PSTPQ[hole] ← p;
END; -- of RippleUp
FillHole: PROCEDURE[] = INLINE
BEGIN
IF hole<pqSize THEN
{PSTPQ[hole] ← PSTPQ[pqSize]; RippleUp[]};
pqSize ← pqSize-1;
END; -- of FillHole
NewPSTPQ: PROCEDURE[p: PSTNodePtr] = INLINE
BEGIN
hole ← pqSize ← pqSize+1;
PSTPQ[pqSize] ← MakePSTPQEnt[p];
RippleUp[];
END; -- of NewPSTPQ
next: PSTPQEnt ← PSTPQ[1];
hole: [1..pqLim) ← 1;
nextHole: [0..2*pqLim);
FOR nextHole ← 2, 2*hole WHILE nextHole<=pqSize DO
IF nextHole<pqSize AND
PSTPQ[nextHole+1].min<PSTPQ[nextHole].min THEN
nextHole ← nextHole+1;
PSTPQ[hole] ← PSTPQ[nextHole];
hole ← nextHole;
ENDLOOP;
WITH f: next.p SELECT FROM
nil => FillHole[];
leaf =>
BEGIN OPEN f;
IF next.min<yMax AND yMin<Max[item] THEN
touch[item
! UNWIND => recursionDepth ← recursionDepth-1];
FillHole[];
END;
internal =>
BEGIN OPEN InlineDefs;
son: PSTBinNodePtr ← f.pst;
IF next.min<=yMax THEN
-- interval could touch this subtree
BEGIN OPEN son;
IF next.min<yMax AND yMin<Max[vMin] THEN
touch[vMin
! UNWIND => recursionDepth ← recursionDepth-1];
PSTPQ[hole] ← MakePSTPQEnt[@halves[upper]];
RippleUp[];
WITH fLower: halves[lower] SELECT FROM
nil => NULL;
leaf => NewPSTPQ[@fLower];
internal =>
IF NOT Above[yMin, fLower.pst] THEN
-- interval could touch lower subtree as well
NewPSTPQ[@fLower];
ENDCASE;
END
ELSE FillHole[];
END;
ENDCASE;
ENDLOOP;
recursionDepth ← recursionDepth-1;
END; -- of SearchFeaturePST
ClassifyFeaturePSTInterval: PUBLIC PROCEDURE[p: PSTHandle,
int: Interval,
covered: PROCEDURE[int: Interval, repItem: Item],
gap: PROCEDURE[int: Interval]] =
BEGIN OPEN MiscDefs;
DoGap: PROCEDURE[int: Interval] = INLINE
{IF gap#NullFeatureGap THEN gap[int]};
DoCovered: PROCEDURE[int: Interval, repItem: Item] = INLINE
{IF covered#NullFeatureCovered THEN covered[int, repItem]};
Classify: PROCEDURE[pi: PSTNodePtr, w: Interval]
RETURNS[r: Interval, minItem, maxItem: Item ← nullItem] =
BEGIN
-- The window w is not empty, so w.min<w.max.
-- w is always surrounded by a pair of
-- covered intervals. Classify is responsible for
-- finding the largest sub-interval r of w which does not
-- intersect a cover contained in the subtree pi
-- containing either endpoint of v. Thus
-- if r is non-empty, it starts and ends with a gap.
-- If r is empty, then r.min>w.min and r.max<w.max.
-- Classify is
-- also responsible for calling "covered" and "gap" on
-- a collection of sub-intervals of w that exhaust r,
-- and for providing two Items, minItem and maxItem,
-- that are part of the covers of w.min and w.max,
-- respectively, if these points are not part of r.
item, item1, item2, rtItem: Item;
i, i2, w2, r2: Interval;
lSon, rSon: PSTNodePtr;
WITH f: pi SELECT FROM
nil =>
BEGIN
DoGap[w];
r ← w;
RETURN
END;
leaf =>
BEGIN
item ← f.item;
i ← [min: Min[item], max: Max[item]];
IF i.max<=w.min OR w.max<=i.min THEN
{DoGap[w]; r ← w; RETURN}; -- no coverage
i2 ← [w.max, w.max]; -- empty above w
lSon ← NIL;
END; -- leaf
internal =>
BEGIN
fint: PSTBinNodePtr ← f.pst;
item ← fint.vMin;
i ← [min: Min[item], max: Max[item]];
IF w.max<=i.min OR Above[w.min, fint] THEN
{DoGap[w]; r ← w; RETURN};
-- no coverage possible
lSon ← @fint.halves[lower];
rSon ← @fint.halves[upper];
WITH s: fint.halves[upper] SELECT FROM
nil =>
BEGIN
i2 ← [w.max, w.max]; -- empty above w
END;
leaf =>
BEGIN
rtItem ← s.item;
i2 ← [min: Min[rtItem], max: Max[rtItem]];
END;
internal =>
BEGIN
rtItem ← s.pst.vMin;
i2 ← [min: Min[rtItem], max: Max[rtItem]];
END;
ENDCASE;
END; -- internal
ENDCASE;
-- Here i.min<w.max.
SELECT w.min FROM
IN [i.min..i.max) => minItem ← item;
IN [i2.min..i2.max) => minItem ← rtItem;
ENDCASE => NULL;
SELECT w.max FROM
<=i.max => maxItem ← item; -- greatest element of w IN i
IN (i2.min..i2.max] => maxItem ← rtItem;
-- greatest element of w IN i2
ENDCASE => NULL;
-- If i and i2 touch, we can extend i and i2 to
-- cover each other's upper endpoints
-- without altering their joint coverage.
IF i2.min<=i.max THEN -- i.min<=i2.min by PST invariant
BEGIN
i.max ← i2.max ← MAX[i.max, i2.max];
END;
IF -- i.max<= -- i2.max<=w.min THEN
{[r, minItem, maxItem] ← Classify[rSon, w]; RETURN}
-- w is beyond the effects of i, i2, and lSon
ELSE IF -- i.max<= -- i2.max<w.max THEN
BEGIN -- Classify the gap between i2 and the top of w
w2 ← [min: i2.max, max: w.max]; -- w.min<i2.max
[r2, , maxItem] ← Classify[rSon, w2];
IF r2.max<=r2.min THEN -- rSon covers w2
i2.max ← w.max
ELSE
{i2.max ← r2.min; r.max ← r2.max};
END;
-- We have now reported [i2.max..w.max) clipped to w.
IF i.max<i2.min THEN
BEGIN -- i<<i2
IF w.min<i2.min AND i.max<w.max THEN
BEGIN -- at least some of the gap between i and i2 is in w
w2 ← [min: MAX[w.min, i.max],
max: MIN[w.max, i2.min]];
IF lSon#NIL THEN
[r2, item1, item2] ← Classify[lSon, w2]
ELSE {DoGap[w2]; r2 ← w2};
IF w2.min=w.min THEN
BEGIN
r.min ← r2.min;
IF w2.min<r2.min THEN minItem ← item1;
END;
IF w.max=w2.max THEN
BEGIN
r.max ← r2.max;
IF r2.max<w2.max THEN maxItem ← item2;
END;
IF r2.max<=r2.min THEN
i.max ← i2.max -- extend i to cover i2
ELSE {i.max ← r2.min; i2.min ← r2.max};
-- If i<<i2 still, and i2 is properly contained in w, then
-- we must call covered on i2.
IF i.max<i2.min AND i2.max<w.max THEN
DoCovered[i2, rtItem];
END;
END
ELSE i.max ← i2.max; -- i2 may have grown in the step above
-- We have now reported [i.max..w.max) clipped to w.
IF w.min<i.min THEN
BEGIN
r.min ← w.min;
DoGap[[w.min, i.min]];
IF i.max<w.max THEN DoCovered[i,item]
END;
-- We have now explained all of w.
-- We must now compute r in
-- those cases where i or i2 contain the endpoints of w.
SELECT w.min FROM
IN [i.min..i.max) => r.min ← MIN[w.max, i.max];
IN [i2.min..i2.max) => r.min ← MIN[w.max, i2.max];
ENDCASE => NULL;
SELECT w.max FROM
<=i.max => r.max ← MAX[w.min, i.min];
-- greatest element of w IN i
IN (i2.min..i2.max] => r.max ← MAX[w.min, i2.min];
-- greatest element of w IN i2
ENDCASE => NULL;
END; -- of Classify
pi: PSTNodePtr ← p.root;
IF int.min<int.max THEN
BEGIN -- test interval is non-empty
r: Interval;
minItem, maxItem: Item;
[r, minItem, maxItem] ← Classify[pi, int];
IF r.max<=r.min THEN
DoCovered[int, minItem] -- the whole interval is covered
ELSE
BEGIN
IF int.min<r.min THEN
DoCovered[[int.min, r.min], minItem];
-- a prefix is covered
IF r.max<int.max THEN
DoCovered[[r.max, int.max], maxItem];
-- a suffix is covered
END;
END;
END; -- of ClassifyPSTInterval
NullFeatureCovered: PUBLIC PROCEDURE[int: Interval,
repItem: Item] =
{NULL};
NullFeatureGap: PUBLIC PROCEDURE[int: Interval] =
{NULL};
prefixTable: PrefixTable;
pt: PrefixTablePtr ← @prefixTable;
InitPrefixTable: PROCEDURE[] =
BEGIN
i: [0..8] ← 0;
k: [0..256) ← 255;
FOR j: [0..256) ← 128, j/2 WHILE j>0 DO
FOR k ← k, k-1 WHILE j<=k DO
prefixTable[k] ← i;
ENDLOOP;
i ← i+1;
ENDLOOP;
prefixTable[0] ← 8; -- nobody should use this entry...
END;
InitPrefixTable[];
END. -- of FeaturePSTImpl