
    <<BiRelsIndirect.Mesa>>
        <<Last tweaked by Mike Spreitzer on December 14, 1987 1:15:37 pm PST>>

    DIRECTORY AbSets, BiRelBasics, BiRels, IntStuff, List, SetBasics;

    BiRelsIndirect: CEDAR PROGRAM
        IMPORTS AbSets, BiRels, IntStuff, List, SetBasics
        EXPORTS BiRels
        =

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

    classes1: Function--spaces[left] 

    Classes: TYPE ~ ARRAY --constant--BOOL OF ARRAY --oneToOne--BOOL OF BiRelClass;

    FnFromProc: PUBLIC PROC
        [
            Apply: PROC [data: REF ANY, v: Value] RETURNS [mv: MaybeValue],
            spaces: SpacePair _ [basic, basic],
            data: REF ANY _ NIL,
            constant, oneToOne: BOOL _ FALSE,
            ScanInverse: PROC [data: REF ANY, v: Value, Test: Tester] RETURNS [MaybePair] _ NIL
            ]
        RETURNS [Function] ~ {
        classes2: Function--spaces[right] 
        IF classes2 = nilBiRel THEN {
            classes2 _ BiRels.CreateHashFn[spaces: [spaceSpace, refs], invable: FALSE];
            classes1.AddNewAA[spaces[left], classes2.Refify]};
        {classes3: REF Classes _ NARROW[classes2.ApplyA[spaces[right]].MDA];
        IF classes3=NIL THEN {
            classes3 _ NEW [Classes];
            FOR constant: BOOL IN BOOL DO FOR oneToOne: BOOL IN BOOL DO
                classes3[constant][oneToOne] _ CreateClass[[Apply: PFApply, Spaces: PFSpaces, functional: [TRUE, FALSE], mutability: readonly]];
                ENDLOOP ENDLOOP;
            classes2.AddNewAA[spaces[right], classes3]};
        RETURN [[
            classes3[constant][oneToOne],
            NEW [ProcFnPrivate _ [spaces, Apply, ScanInverse, data]]
            ]]}};

    ProcFn: TYPE ~ REF ProcFnPrivate;
    ProcFnPrivate: TYPE ~ RECORD [
        spaces: SpacePair,
        Apply: PROC [data: REF ANY, v: Value] RETURNS [mv: MaybeValue],
        ScanInverse: PROC [data: REF ANY, v: Value, Test: Tester] RETURNS [MaybePair],
        data: REF ANY
        ];

    PFApply: PROC [br: BiRel, v: Value, dir: Direction] RETURNS [MaybeValue] ~ {
        pf: ProcFn ~ NARROW[br.data];
        IF dir#leftToRight THEN RETURN DefaultApply[br, v, dir];
        RETURN pf.Apply[pf.data, v]};

    PFSpaces: PROC [br: BiRel] RETURNS [SpacePair] ~ {
        pf: ProcFn ~ NARROW[br.data];
        RETURN [pf.spaces]};

    EnumSeqOfSet: PUBLIC PROC [set: Set, ro: Sets.RelOrder _ no] RETURNS [Sequence] ~ {
        es: EnumSeq ~ NEW [EnumSeqPrivate _ [set, ro]];
        RETURN [[esClasses[set.MutabilityOf[]=constant], es]]};

    esClasses: REF ESClasses ~ NEW [ESClasses];
    ESClasses:  TYPE ~ ARRAY --const--BOOL OF BiRelClass;

    EnumSeq: TYPE ~ REF EnumSeqPrivate;
    EnumSeqPrivate: TYPE ~ RECORD [set: Set, ro: Sets.RelOrder];

    ESPrimitive: PROC [br: BiRel, op: ATOM, arg1, arg2: REF ANY] RETURNS [PrimitiveAnswer] ~ {
        es: EnumSeq ~ NARROW[br.data];
        SELECT op FROM
            $ScanRestriction => {sets: RefSetPair ~ ToSets[arg1];
                IF sets^#ALL[nilSet] THEN RETURN [no];
                {ro: RelOrder ~ ToRO[arg2];
                roc: ROChoice ~ ChooseRO[ro, es.ro];
                RETURN [IF roc.ok AND es.set.GoodImpl[$Scan] THEN yes ELSE no]}};
            $GetBounds => RETURN [IF es.ro#no AND es.set.GoodImpl[$Scan] THEN yes ELSE no];
            $ValueOf => RETURN [IF es.set.GoodImpl[op] THEN yes ELSE no];
            $SetOn => RETURN [IF es.set.Can[$Size] THEN yes ELSE no];
            ENDCASE => RETURN [pass]};

    ROChoice: TYPE ~ RECORD [sro: Sets.RelOrder, ok, rev: BOOL];

    ChooseRO: PROC [ro: RelOrder, esro: Sets.RelOrder] RETURNS [ROChoice] ~ {
        SELECT ro.first FROM
            left => SELECT ro.sub[left] FROM
                fwd => RETURN [[esro, TRUE, FALSE]];
                bwd => RETURN [[esro.ReverseRO, esro#no, TRUE]];
                no => RETURN [[esro, TRUE, FALSE]];
                ENDCASE => ERROR;
            right => SELECT ro.sub[right] FROM
                fwd => RETURN [[fwd, esro#no, esro#fwd]];
                bwd => RETURN [[bwd, esro#no, esro#bwd]];
                no => RETURN [[esro, TRUE, FALSE]];
                ENDCASE => ERROR;
            ENDCASE => ERROR};

    ESScanRestriction: PROC [br: BiRel, sets: SetPair, Test: Tester, ro: RelOrder] RETURNS [mp: MaybePair _ noMaybePair] ~ {
        IF sets#ALL[nilSet] THEN RETURN br.DefaultScanRestriction[sets, Test, ro];
        {es: EnumSeq ~ NARROW[br.data];
        roc: ROChoice ~ ChooseRO[ro, es.ro];
        i: LNAT _ 0;
        Pass: PROC [right: Value] RETURNS [BOOL] ~ {
            IF Test[[[i[i]], right]] THEN RETURN [(mp _ [TRUE, [[i[i]], right]]).found];
            i _ IF roc.rev THEN i-1 ELSE i+1;
            RETURN [FALSE]};
        IF NOT roc.ok THEN RETURN DefaultScanRestriction[br, sets, Test, ro];
        IF roc.rev THEN i _ es.set.Size.Pred.EN;
        [] _ es.set.Scan[Pass, roc.sro];
        RETURN}};

    ESGetBounds: PROC [br: BiRel, want: EndBools, ro: RelOrder] RETURNS [MaybePairInterval] ~ {
        es: EnumSeq ~ NARROW[br.data];
        IF es.set.Empty THEN RETURN [[FALSE, []]];
        IF es.ro=no THEN RETURN DefaultGetBounds[br, want, ro];
        RETURN [[TRUE, [
            min: [[i[0]], es.set.AnElt[es.ro].it],
            max: [[i[es.set.Size.Pred.EN]], es.set.AnElt[es.ro.ReverseRO].it]
            ]]];
        };

    ESValueOf: PROC [br: BiRel] RETURNS [ConstBiRel] ~ {
        es: EnumSeq ~ NARROW[br.data];
        RETURN EnumSeqOfSet[es.set.ValueOf, es.ro].AsConst};

    ESSetOn: PROC [br: BiRel, side: Side] RETURNS [UWSet] ~ {
        es: EnumSeq ~ NARROW[br.data];
        SELECT side FROM
            left => RETURN [IIAsSet[[0, es.set.Size.Pred.EN]]];
            right => RETURN [es.set.Insulate];
            ENDCASE => ERROR};

    ESSpaces: PROC [br: BiRel] RETURNS [SpacePair] ~ {
        es: EnumSeq ~ NARROW[br.data];
        RETURN [[ints, es.set.SpaceOf]]};

    GradeUp: PUBLIC PROC [a: IntFn, o: SetBasics.Order] RETURNS [p: Permutation] ~ {
        indices: LORA _ NIL;
        i: INT _ 0;
        AddIndex: PROC [pair: Pair] ~ {indices _ CONS[NEW[INT _ pair[left].VI], indices]};
        Compare: PROC[ref1, ref2: REF ANY] RETURNS [c: Basics.Comparison] ~ {
            i1: REF INT ~ NARROW[ref1];
            i2: REF INT ~ NARROW[ref2];
            RETURN o.Compare[o.data, a.ApplyI[i1^].Val, a.ApplyI[i2^].Val]};
        a.Enumerate[AddIndex];
        indices _ List.Sort[indices, Compare];
        p _ CreateSimple[oneToOne: TRUE, dense: TRUE, rightSpace: ints];
        FOR inds: LORA _ indices, inds.rest WHILE inds#NIL DO
            p.AddNewPair[[[i[i]], [i[NARROW[inds.first, REF INT]^]]]];
            i _ i + 1;
            ENDLOOP;
        p _ p.Freeze;
        RETURN};

    TransPermute: PUBLIC PROC [from, to: IntFn, p: Permutation] ~ {
        PerPair: PROC [pair: Pair] ~ {
            old: INT ~ pair[right].VI;
            mv: MaybeValue ~ from.ApplyI[old];
            IF mv.found THEN [] _ to.AddPair[[pair[left], mv.it]] ELSE [] _ to.Delete[pair[left]];
            RETURN};
        p.Enumerate[PerPair];
        RETURN};

    PermuteInPlace: PUBLIC PROC [a: Sequence, p: Permutation] ~ {
        done: Set--INT-- ~ CreateHashSet[ints];
        PerPair: PROC [pair: Pair] ~ {
            startToI: INT ~ pair[left].VI;
            fromI: INT _ pair[right].VI;
            IF fromI = startToI THEN RETURN;
            IF done.HasMemI[fromI] THEN RETURN;
            {startMV: MaybeValue ~ a.ApplyI[startToI];
            toI: INT _ startToI;
            UNTIL fromI = startToI DO
                moveMV: MaybeValue ~ a.ApplyI[fromI];
                IF NOT done.AddI[fromI] THEN ERROR;
                IF moveMV.found THEN [] _ a.AddPair[[[i[toI]], moveMV.it]] ELSE [] _ a.DeleteI[toI];
                toI _ fromI;
                fromI _ p.ApplyI[toI].MI;
                ENDLOOP;
            IF NOT done.AddI[fromI] THEN ERROR;
            IF startMV.found THEN [] _ a.AddPair[[[i[toI]], startMV.it]] ELSE [] _ a.DeleteI[toI];
            RETURN}};
        p.Enumerate[PerPair];
        RETURN};

    Start: PROC ~ {
        FOR const: BOOL IN BOOL DO
            esClasses[const] _ CreateClass[[
                Primitive: ESPrimitive,
                ScanRestriction: ESScanRestriction,
                GetBounds: ESGetBounds,
                ValueOf: ESValueOf,
                SetOn: ESSetOn,
                Spaces: ESSpaces,
                functional: ALL[TRUE],
                mutability: IF const THEN constant ELSE readonly]];
            ENDLOOP;
        };

    Start[];

    END.