
    <<BiRelShifting.Mesa>>
        <<Last tweaked by Mike Spreitzer on December 14, 1987 9:18:15 pm PST>>

    DIRECTORY Atom, BiRels, IntStuff, SetBasics, AbSets;

    BiRelShifting: CEDAR PROGRAM
        IMPORTS BiRels, IntStuff, SetBasics, AbSets
        EXPORTS BiRels
        =

    BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets, BiRels;

    ShiftClip: TYPE ~ REF ShiftClipPrivate;
    ShiftClipPrivate: TYPE ~ RECORD [
        es: ARRAY Direction OF EINT,
        cs: ARRAY Side OF IntInterval
        ];

    Restrict: PROC [sc: ShiftClip, sets: SetPair] RETURNS [left: IntInterval] ~ {
        RETURN [Intersect[
            IF sets[left]#nilSet THEN sets[left].AsIntInterval ELSE [],
            IF sets[right]#nilSet
                THEN sets[right].AsIntInterval.Intersect[sc.cs[right]] .ShiftInterval[sc.es[rightToLeft]]
                ELSE sc.cs[left]]]};

    ShiftAndClip: PUBLIC PROC [br: IntRel, shift: EINT _ zero, clip: IntInterval _ []] RETURNS [IntRel] ~ {
        IF shift = zero AND clip = [] THEN RETURN [br];
        {good: BOOL ~ br.GoodImpl[$GetIntDom];
        dom: IntInterval ~ IF good THEN br.GetIntDom ELSE [];
        li: IntInterval ~ clip.ClipShiftInterval[shift.Neg];
        ri: IntInterval ~ li.ShiftInterval[shift];
        scr: BiRel ~ CreateShiftAndClipper[shift.Neg, li];
        mbi: IntInterval ~ ri.MBI[dom];
        RETURN Compose[scr, br,
            IF NOT good THEN ALL[TRUE]
            ELSE IF mbi=ri THEN IF mbi=dom THEN ALL[FALSE] ELSE [FALSE, TRUE]
            ELSE IF mbi=dom THEN [TRUE, FALSE] ELSE ALL[TRUE]]}};

    CreateShiftAndClipper: PUBLIC PROC [shift: EINT _ zero, clip: IntInterval _ []] RETURNS [ConstOneToOne] ~ {
        e: EINT ~ shift;
        ne: EINT ~ e.Neg;
        cr: IntInterval ~ clip.ClipShiftInterval[e];
        IF cr.Empty[] THEN RETURN [CreateEmptyBiRel[ALL[ints]]];
        IF cr.min=cr.max THEN RETURN CreateSingleton[[IV[ne.AddI[cr.min].EI], IV[cr.min]], ALL[ints]];
        {sc: ShiftClip ~ NEW [ShiftClipPrivate _ [
            es: [e, ne],
            cs: [left: cr.ShiftInterval[ne], right: cr]
            ]];
        RETURN AsConst[[scClass, sc]]}};

    scClass: BiRelClass ~ CreateClass[
        cp: [
            Primitive: SCPrimitive,
            HasPair: SCHasPair,
            Image: SCImage,
            Apply: SCApply,
            ScanRestriction: SCScanRestriction,
            Get3: SCGet3,
            RestrictionSize: SCRestrictionSize,
            GetBounds: SCGetBounds,
            SetOn: SCSetOn,
            Spaces: SCSpaces,
            IsDense: SCIsDense,
            functional: ALL[TRUE],
            mutability: constant],
        dirable: ALL[TRUE]];

    SCPrimitive: PROC [br: BiRel, op: ATOM, arg1, arg2: REF ANY _ NIL] RETURNS [PrimitiveAnswer] ~ {
        SELECT op FROM
            $Image => {sc: ShiftClip ~ NARROW[br.data];
                rs: RefSet ~ ToSet[arg1];
                RETURN [IF (rs^.GoodImpl[$QuaIntInterval] AND rs^.QuaIntInterval[].found) THEN yes ELSE no]};
            ENDCASE => RETURN [pass]};

    SCHasPair: PROC [br: BiRel, pair: Pair] RETURNS [BOOL] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        li: INT ~ pair[left].VI;
        RETURN [
            li IN [sc.cs[left].min .. sc.cs[left].max]
            AND sc.es[leftToRight].AddI[li]=IE[pair[right].VI]]};

    SCImage: PROC [br: BiRel, set: Set, dir: Direction] RETURNS [Set] ~ {
        IF set.MutabilityOf[]#constant THEN GOTO GiveUp;
        IF NOT set.GoodImpl[$QuaIntInterval] THEN GOTO GiveUp;
        {sc: ShiftClip ~ NARROW[br.data];
        qi: MaybeIntInterval ~ set.QuaIntInterval[];
        IF NOT qi.found THEN GOTO GiveUp;
        RETURN [IIAsSet[qi.it.ClipShiftInterval[sc.es[dir]]]]};
        EXITS GiveUp => RETURN DefaultImage[br, set, dir]};

    SCApply: PROC [br: BiRel, v: Value, dir: Direction] RETURNS [MaybeValue] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        x: INT ~ v.VI;
        c: IntInterval ~ sc.cs[Source[dir]];
        RETURN [IF x IN [c.min .. c.max] THEN [TRUE, IV[sc.es[dir].AddI[x].EI]] ELSE noMaybe]};

    SCScanRestriction: PROC [br: BiRel, sets: SetPair, Test: Tester, ro: RelOrder] RETURNS [MaybePair] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        li: IntInterval ~ Restrict[sc, sets];
        IF NOT li.Empty THEN SELECT ro.sub[ro.first] FROM
            fwd, no => {
                i: INT _ li.min;
                j: INT _ sc.es[leftToRight].AddI[i].EI;
                DO
                    IF Test[[IV[i], IV[j]]] THEN RETURN [[TRUE, [IV[i], IV[j]]]];
                    IF i=li.max THEN EXIT;
                    i _ i + 1;
                    j _ j + 1;
                    ENDLOOP};
            bwd => {
                i: INT _ li.max;
                j: INT _ sc.es[leftToRight].AddI[i].EI;
                DO
                    IF Test[[IV[i], IV[j]]] THEN RETURN [[TRUE, [IV[i], IV[j]]]];
                    IF i=li.min THEN EXIT;
                    i _ i - 1;
                    j _ j - 1;
                    ENDLOOP};
            ENDCASE => ERROR;
        RETURN [noMaybePair]};

    MaybeInt: TYPE ~ RECORD [found: BOOL, it: INT];

    SCGet3: PROC [br: BiRel, pair: Pair, ro: RelOrder, want: TripleBool] RETURNS [TripleMaybePair] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        i: INT ~ pair[ro.first].VI;
        c: IntInterval ~ sc.cs[ro.first];
        Ex: PROC [mi: MaybeInt] RETURNS [MaybePair] ~ {
            RETURN [SELECT ro.first FROM
                left => IF mi.found THEN [TRUE, [IV[mi.it], IV[sc.es[leftToRight].AddI[mi.it].EI]]] ELSE noMaybePair,
                right => IF mi.found THEN [TRUE, [IV[sc.es[rightToLeft].AddI[mi.it].EI], IV[mi.it]]] ELSE noMaybePair,
                ENDCASE => ERROR]};
        Finish: PROC [l, e, g: MaybeInt] RETURNS [TripleMaybePair] ~ {
            SELECT ro.sub[ro.first] FROM
                fwd, no => RETURN [[Ex[l], Ex[e], Ex[g]]];
                bwd => RETURN [[Ex[g], Ex[e], Ex[l]]];
                ENDCASE => ERROR};
        SELECT TRUE FROM
            i < c.min => RETURN Finish[[FALSE, 0], [FALSE, 0], [TRUE, c.min]];
            i = c.min => RETURN Finish[[FALSE, 0], [TRUE, i], [TRUE, i+1]];
            i < c.max => RETURN Finish[[TRUE, i-1], [TRUE, i], [TRUE, i+1]];
            i = c.max => RETURN Finish[[TRUE, i-1], [TRUE, i], [FALSE, 0]];
            ENDCASE => RETURN Finish[[FALSE, c.max], [FALSE, 0], [TRUE, 0]]};

    SCRestrictionSize: PROC [br: BiRel, sets: SetPair, limit: EINT] RETURNS [EINT] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        li: IntInterval ~ Restrict[sc, sets];
        RETURN li.Length[]};

    SCGetBounds: PROC [br: BiRel, want: EndBools, ro: RelOrder] RETURNS [MaybePairInterval] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        RETURN [[TRUE, SELECT ro.sub[ro.first] FROM
            fwd, no => [
                min: [IV[sc.cs[left].min], IV[sc.cs[right].min] ],
                max: [IV[sc.cs[left].max], IV[sc.cs[right].max] ]],
            bwd => [
                max: [IV[sc.cs[left].min], IV[sc.cs[right].min] ],
                min: [IV[sc.cs[left].max], IV[sc.cs[right].max] ]],
            ENDCASE => ERROR]]};

    SCSetOn: PROC [br: BiRel, side: Side] RETURNS [UWSet] ~ {
        sc: ShiftClip ~ NARROW[br.data];
        RETURN [IIAsSet[sc.cs[side]]]};

    SCSpaces: PROC [br: BiRel] RETURNS [SpacePair] ~ {RETURN [ALL[ints]]};

    SCIsDense: PROC [br: BiRel, when: When, side: Side] RETURNS [BOOL]
        ~ {RETURN [TRUE]};

    Start: PROC ~ {
        RETURN};

    Start[];

    END.