
    <<StdPairCollections3.Mesa>>
        <<Last tweaked by Mike Spreitzer on October 19, 1987 1:50:59 pm PDT>>

    DIRECTORY Basics, Collections, PairCollections, List, Rope;

    StdPairCollections3: CEDAR PROGRAM
        IMPORTS Collections, PairCollections, List, Rope
        EXPORTS PairCollections
        =

    BEGIN OPEN Colls:Collections, Collections, PairCollections;

    CreatePairSpace: PROC [sp: SpacePair] RETURNS [s: Space] ~ {
        name: ROPE ~ Rope.Cat["pairs in [", SpaceName[sp[left]], ", ", SpaceName[sp[right]], "]"];
        s _ NEW [SpacePrivate _ [
            Equal: PairEqual,
            Hash: HashPair,
            Compare: ComparePair,
            other: List.PutAssoc[$Name, name, NIL],
            data: NEW [SpacePair _ sp]
            ]];
        RETURN};

    SpaceName: PROC [s: Space] RETURNS [ROPE] ~ {
        WITH List.Assoc[$Name, s.other] SELECT FROM
            x: ROPE => RETURN [x];
            x: REF READONLY TEXT => RETURN [Rope.FromRefText[x]];
            ENDCASE => RETURN ["??"];
        };

    PairEqual: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [b: BOOL] ~ {
        sp: REF SpacePair ~ NARROW[data];
        pair1: REF Pair ~ NARROW[elt1];
        pair2: REF Pair ~ NARROW[elt2];
        b _ sp[left].SpaceEqual[pair1[left], pair2[left]] AND sp[right].SpaceEqual[pair1[right], pair2[right]];
        RETURN};

    HashPair: PROC [data: REF ANY, elt: Value] RETURNS [hash: CARDINAL] ~ {
        sp: REF SpacePair ~ NARROW[data];
        pair: REF Pair ~ NARROW[elt];
        hash _ sp[left].SpaceHash[pair[left]]*17 + sp[right].SpaceHash[pair[right]];
        RETURN};

    ComparePair: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [c: Basics.Comparison] ~ {
        sp: REF SpacePair ~ NARROW[data];
        pair1: REF Pair ~ NARROW[elt1];
        pair2: REF Pair ~ NARROW[elt2];
        c _ sp[left].SpaceCompare[pair1[left], pair2[left]];
        IF c=equal THEN c _ sp[right].SpaceCompare[pair1[right], pair2[right]];
        RETURN};

    refPairSpace: Space ~ CreatePairSpace[[refs, refs]];
    pairToSpace: Function--REF SpacePair 

    WidenSpacePair: PUBLIC PROC [sp: SpacePair] RETURNS [s: Space] ~ {
        IF sp = [refs, refs] THEN RETURN [refPairSpace];
        {rsp: REF Pair ~ NEW [Pair _ [left: sp[left], right: sp[right]]];
        mv: MaybeValue ~ pairToSpace.Apply[rsp];
        IF mv.found THEN RETURN [NARROW[mv.val]];
        s _ CreatePairSpace[sp];
        [] _ pairToSpace.AddPair[[rsp, s]];
        RETURN}};

    IsPairSpace: PUBLIC PROC [s: Space] RETURNS [BOOL] ~ {
        RETURN [s.Equal=PairEqual AND s.Hash=HashPair AND s.Compare=ComparePair AND ISTYPE[s.data, REF SpacePair]]};

    NarrowSpace: PUBLIC PROC [s: Space] RETURNS [sp: SpacePair] ~ {
        IF NOT IsPairSpace[s] THEN ERROR;
        {rsp: REF SpacePair ~ NARROW[s.data];
        RETURN [rsp^]}};

    orderSpace: Colls.Space ~ NEW [Colls.SpacePrivate _ [
        Equal: EqualOrderings,
        Hash: HashOrdering,
        Compare: CompareOrderings,
        other: List.PutAssoc[$Name, "pair orderings", NIL]
        ]];

    EqualOrderings: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [BOOL] ~ {
        o1: REF Ordering ~ NARROW[elt1];
        o2: REF Ordering ~ NARROW[elt2];
        RETURN [o1^ = o2^]};

    HashOrdering: PROC [data: REF ANY, elt: Value] RETURNS [hash: CARDINAL] ~ {
        o: REF Ordering ~ NARROW[elt];
        hash _ Colls.HashIntI[INT[LOOPHOLE[o.Compare, CARDINAL]]*19] + Colls.HashRefI[o.data];
        RETURN};

    CompareOrderings: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [c: Basics.Comparison] ~ {
        o1: REF Ordering ~ NARROW[elt1];
        o2: REF Ordering ~ NARROW[elt2];
        IF (c _ Colls.CompareIntI[LOOPHOLE[o1.Compare, CARDINAL], LOOPHOLE[o2.Compare, CARDINAL]])#equal THEN RETURN;
        c _ Colls.CompareRefI[o1.data, o2.data];
        RETURN};

    pairifyOrdering: Function--REF Ordering 

    WidenOrdering: PUBLIC PROC [o: Ordering] RETURNS [wo: Colls.Ordering] ~ {
        IF o.Compare=NarrowCompare AND ISTYPE[o.data, REF Colls.Ordering] THEN RETURN [NARROW[o.data, REF Colls.Ordering]^];
        {ref: REF Ordering ~ NEW [Ordering _ o];
        rwo: REF Colls.Ordering ~ NARROW[pairifyOrdering.Apply[ref].DVal];
        IF rwo#NIL THEN RETURN [rwo^];
        wo _ [WideCompare, ref];
        [] _ pairifyOrdering.AddPair[[ref, NEW [Colls.Ordering _ wo]]];
        RETURN}};

    WideCompare: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [Basics.Comparison] ~ {
        ref: REF Ordering ~ NARROW[data];
        pair1: REF Pair ~ NARROW[elt1];
        pair2: REF Pair ~ NARROW[elt2];
        RETURN ref.Compare[ref.data, pair1^, pair2^]};

    NarrowOrdering: PUBLIC PROC [wo: Colls.Ordering] RETURNS [o: Ordering] ~ {
        IF wo=Colls.unordered THEN RETURN [unordered];
        IF wo.Compare=WideCompare AND ISTYPE[wo.data, REF Ordering]
            THEN RETURN [NARROW[wo.data, REF Ordering]^]
            ELSE RETURN [[NarrowCompare, NEW [Colls.Ordering _ wo], both]];
        };

    NarrowCompare: PROC [data: REF ANY, elt1, elt2: Pair] RETURNS [Basics.Comparison] ~ {
        rwo: REF Colls.Ordering ~ NARROW[data];
        rp1: REF Pair ~ NEW [Pair _ elt1];
        rp2: REF Pair ~ NEW [Pair _ elt2];
        RETURN rwo.Compare[rwo.data, rp1, rp2]};

    CreateIDSubset: PUBLIC PROC [sub: Collection] RETURNS [PairColl] ~ {
        RETURN [[idClasses[sub.MayDuplicate[]][sub.OrderStyleOf][sub.MutabilityOf[]], sub.Refify]]};

    IDClasses: TYPE ~ ARRAY --mayDuplicate--BOOL OF ARRAY OrderStyle OF ARRAY Mutability OF PairCollClass;
    idClasses: REF IDClasses ~ NEW [IDClasses];

    IDPrimitive: PROC [pc: PairColl, op: ATOM, args: ArgList _ NIL] RETURNS [PrimitiveAnswer] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        SELECT op FROM
            $Scan => RETURN [IF sub.QualityOf[op, args]>=goodDefault THEN yes ELSE no];
            ENDCASE => RETURN [pass];
        };

    IDHasPair: PROC [pc: PairColl, pair: Pair] RETURNS [BOOL] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        RETURN [sub.SpaceOf.SpaceEqual[pair[left], pair[right]] AND sub.HasMember[pair[left]]]};

    IDApply: PROC [pc: PairColl, v: Value, dir: Direction] RETURNS [MaybeValue] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        IF sub.HasMember[v] THEN RETURN [[TRUE, v]] ELSE RETURN [noMaybe];
        };

    IDScan: PROC [pc: PairColl, Test: Tester, bkwd: BOOL] RETURNS [mp: MaybePair] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        PerElt: PROC [v: Value] RETURNS [pass: BOOL] ~ {
            IF (pass _ Test[[v, v]]) THEN mp _ [TRUE, [v, v]];
            RETURN};
        mp _ noMaybePair;
        [] _ sub.Scan[PerElt, bkwd];
        RETURN};

    IDSize: PROC [pc: PairColl, limit: LNAT] RETURNS [LNAT] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        RETURN sub.Size[limit]};

    IDCollectionOn: PROC [pc: PairColl, side: Side] RETURNS [UWColl] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        RETURN [sub.Insulate]};

    IDCurSetOn: PROC [pc: PairColl, side: Side] RETURNS [ConstSet] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        RETURN [sub.ValueOf]};

    IDAddColl: PROC [pc, other: PairColl, if: IfNewsPair, where: Where] RETURNS [some: NewsSetPair] ~ TRUSTED {
        sub: Collection ~ Colls.DeRef[pc.data];
        space: Space ~ sub.SpaceOf[];
        cWhere: Colls.Where ~ WITH where SELECT FROM
            any => [any[]],
            end => [end[end]],
            rel => [rel[elt: pair[left], reln: reln]],
            ENDCASE => ERROR;
        PerPair: PROC [pair: Pair] ~ CHECKED {
            v: Value ~ pair[left];
            IF NOT space.SpaceEqual[v, pair[right]] THEN Complain[pc, "Can't add pair of non-equal values [%g, %g]", LIST[v, pair[right]]];
            IF sub.AddElt[v, cWhere]
                THEN some[leftToRight][new] _ some[rightToLeft][new] _ TRUE
                ELSE some[leftToRight][same] _ some[rightToLeft][same] _ TRUE;
            RETURN};
        WITH where SELECT FROM
            any, end => NULL;
            rel => IF NOT space.SpaceEqual[pair[left], pair[right]] THEN Complain[pc, "Can't add relative to pair of non-equal values [%g, 
            %g]", LIST[pair[left], pair[right]]];
            ENDCASE => NULL;
        some _ ALL[ALL[FALSE]];
        other.Enumerate[PerPair];
        RETURN};

    IDRemColl: PROC [pc, other: PairColl, style: RemoveStyle] RETURNS [hadSome, hadAll: BoolPair] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        space: Space ~ sub.SpaceOf[];
        PerPair: PROC [pair: Pair] ~ {
            v: Value ~ pair[left];
            IF space.SpaceEqual[v, pair[right]] AND sub.RemoveElt[v, style] THEN hadSome _ ALL[TRUE] ELSE hadAll _ ALL[FALSE]; 
            RETURN};
        hadAll _ ALL[TRUE];
        hadSome _ ALL[FALSE];
        other.Enumerate[PerPair];
        RETURN};

    IDDeleteColl: PROC [pc: PairColl, coll: Collection, side: Side, style: RemoveStyle] RETURNS [hadSome, hadAll: BOOL] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        RETURN sub.RemoveColl[coll, style]};

    IDSpaces: PROC [pc: PairColl] RETURNS [SpacePair] ~ {
        sub: Collection ~ Colls.DeRef[pc.data];
        space: Space ~ sub.SpaceOf[];
        RETURN [[space, space]]};

    CreateProduct: PUBLIC PROC [cp: CollPair] RETURNS [PairColl] ~ {
        rcp: REF CollPair ~ NEW [CollPair _ cp];
        mut: UnwriteableMutability ~ IF cp[left].MutabilityOf[]=constant AND cp[right].MutabilityOf[]=constant THEN constant ELSE readonly;
        mayDup: BOOL ~ cp[left].MayDuplicate[] OR cp[right].MayDuplicate[];
        RETURN [[prodClasses[mut][mayDup], rcp]]};

    ProdClasses: TYPE ~ ARRAY UnwriteableMutability OF ARRAY --mayDuplicate--BOOL OF PairCollClass;
    prodClasses: REF ProdClasses ~ NEW [ProdClasses];

    ProdPrimitive: PROC [pc: PairColl, op: ATOM, args: ArgList _ NIL] RETURNS [PrimitiveAnswer] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        SELECT op FROM
            $HasPair => RETURN [IF rcp[left].QualityOf[$HasMember]>=goodDefault AND rcp[right].QualityOf[$HasMember]>=goodDefault THEN yes ELSE 
            no];
            $ScanHalfRestriction => RETURN [IF rcp[left].QualityOf[$Scan, LIST[FromBool[GetBool[args, 2]]]]>=goodDefault AND 
            rcp[right].QualityOf[$HasMember, LIST[FromBool[GetBool[args, 2]]]]>=goodDefault THEN yes ELSE no];
            $Size => RETURN [IF rcp[left].QualityOf[op, args]>=goodDefault AND rcp[right].QualityOf[op, args]>=goodDefault THEN yes ELSE no];
            ENDCASE => RETURN [pass];
        };

    ProdHasPair: PROC [pc: PairColl, pair: Pair] RETURNS [BOOL] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        RETURN [rcp[left].HasMember[pair[left]] AND rcp[right].HasMember[pair[right]]]};

    ProdImage: PROC [pc: PairColl, coll: Collection, dir: Direction] RETURNS [UWColl] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        pt: ProdTest ~ NEW [ProdTestPrivate _ [rcp[Source[dir]], coll]];
        cond: Condition ~ NEW [ConditionPrivate _ [TestProd, pt]];
        RETURN CreateConditional[cond, rcp[Dest[dir]]]};

    ProdTest: TYPE ~ REF ProdTestPrivate;
    ProdTestPrivate: TYPE ~ RECORD [dom, coll: Collection];

    TestProd: PROC [data: REF ANY] RETURNS [BOOL] ~ {
        pt: ProdTest ~ NARROW[data];
        RETURN [pt.coll.Intersection[pt.dom].Size[1] # 0]};

    ProdScanHalfRestriction: PROC [pc: PairColl, side: Side, coll: Collection, Test: Tester, bkwd: BOOL] RETURNS [mp: MaybePair _ 
    noMaybePair] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        interesection: Collection ~ rcp[side].Intersection[coll];
        Pass1: PROC [v: Value] RETURNS [pass: BOOL] ~ {
            pair: Pair _ ALL[v];
            other: Side ~ OtherSide[side];
            Pass2: PROC [v: Value] RETURNS [pass: BOOL] ~ {
                pair[other] _ v;
                IF (pass _ Test[pair]) THEN mp _ [TRUE, pair];
                RETURN};
            pass _ rcp[other].Scan[Pass2, bkwd].found;
            RETURN};
        [] _ interesection.Scan[Pass1, bkwd];
        RETURN};

    ProdSize: PROC [pc: PairColl, limit: LNAT] RETURNS [LNAT] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        s1: LNAT ~ rcp[left].Size[limit];
        IF s1=0 THEN RETURN [0];
        RETURN [s1 * rcp[right].Size[(limit+s1-1)/s1]]};

    ProdValueOf: PROC [pc: PairColl] RETURNS [ConstPairColl] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        RETURN [CreateProduct[[rcp[left].ValueOf[], rcp[right].ValueOf[]]].AsConst]};

    ProdCollectionOn: PROC [pc: PairColl, side: Side] RETURNS [UWColl] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        RETURN [rcp[side].Insulate]};

    ProdCurSetOn: PROC [pc: PairColl, side: Side] RETURNS [ConstSet] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        RETURN [rcp[side].ValueOf]};

    ProdSpaces: PROC [pc: PairColl] RETURNS [SpacePair] ~ {
        rcp: REF CollPair ~ NARROW[pc.data];
        RETURN [[rcp[left].SpaceOf[], rcp[right].SpaceOf[]]]};

    Start: PROC ~ {
        FOR mutability: Mutability IN Mutability DO FOR mayDup: BOOL IN BOOL DO
            IF mutability#variable THEN prodClasses[mutability][mayDup] _ CreateClass[
                cp: [
                    Primitive: ProdPrimitive,
                    HasPair: ProdHasPair,
                    Image: ProdImage,
                    ScanHalfRestriction: ProdScanHalfRestriction,
                    Size: ProdSize,
                    ValueOf: ProdValueOf,
                    CollectionOn: ProdCollectionOn,
                    CurSetOn: IF NOT mayDup THEN ProdCurSetOn ELSE NIL,
                    Spaces: ProdSpaces,
                    functional: ALL[FALSE],
                    mayDuplicate: mayDup,
                    orderStyle: none,
                    mutability: mutability,
                    data: NIL],
                dirable: ALL[TRUE]];
            FOR orderStyle: OrderStyle IN OrderStyle DO
                idClasses[mayDup][orderStyle][mutability] _ CreateClass[
                    cp: [
                        Primitive: IDPrimitive,
                        HasPair: IDHasPair,
                        Apply: IDApply,
                        Scan: IDScan,
                        Size: IDSize,
                        CollectionOn: IDCollectionOn,
                        CurSetOn: IF NOT mayDup THEN IDCurSetOn ELSE NIL,
                        AddColl: IF mutability=variable THEN IDAddColl ELSE NIL,
                        RemColl: IF mutability=variable THEN IDRemColl ELSE NIL,
                        DeleteColl: IF mutability=variable THEN IDDeleteColl ELSE NIL,
                        Spaces: IDSpaces,
                        functional: ALL[TRUE],
                        mayDuplicate: mayDup,
                        orderStyle: orderStyle,
                        mutability: mutability,
                        data: NIL],
                    dirable: ALL[TRUE]];
                ENDLOOP
            ENDLOOP ENDLOOP;
        };

    Start[];

    END.