-- 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