
    <<BiRelStds.Mesa>>
        <<Last tweaked by Mike Spreitzer on January 19, 1988 6:41:47 pm PST>>

    DIRECTORY AbSets, BiRelBasics, BiRels, IntStuff, SetBasics;

    BiRelStds: CEDAR PROGRAM
        IMPORTS AbSets, BiRelBasics, BiRels, IntStuff, SetBasics
        EXPORTS BiRels
        =

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

    Lyst: TYPE ~ REF LystPrivate;
    LystPrivate: TYPE ~ RECORD [
        spaces: SpacePair,
        vals: LOP _ NIL,
        ro: --Canonical--RelOrder,
        size, freezeCount: LNAT _ 0
        ];

    CreateList: PUBLIC PROC [vals: LOP, functional: BoolPair _ [FALSE, FALSE], spaces: SpacePair _ [refs, refs], mutability: Mutability 
    _ variable, order: RelOrder _ [], assumeSorted: BOOL _ FALSE] RETURNS [br: BiRel] ~ {
        cro: RelOrder ~ order.CanonizeRelOrder[functional];
        l: Lyst ~ NEW [LystPrivate _ [spaces, NIL, cro]];
        br _ [listClasses [functional[leftToRight]] [functional[rightToLeft]] [variable], l];
        IF order=[] THEN assumeSorted _ TRUE;
        IF assumeSorted THEN {
            l.vals _ vals;
            FOR vals _ vals, vals.rest WHILE vals#NIL DO l.size _ l.size+1 ENDLOOP;
            }
        ELSE {
            FOR vals _ vals, vals.rest WHILE vals#NIL DO
                [] _ br.AddPair[vals.first];
                ENDLOOP;
            };
        IF mutability#variable THEN br _ br.Freeze[];
        RETURN};

    ListClasses: TYPE ~ ARRAY --functional[leftToRight]--BOOL OF ARRAY --functional[rightToLeft]--BOOL OF ARRAY Mutability OF 
    BiRelClass;
    listClasses: REF ListClasses ~ NEW [ListClasses];

    LystPrimitive: PROC [br: BiRel, op: ATOM, arg1, arg2: REF ANY] RETURNS [PrimitiveAnswer] ~ {
        l: Lyst ~ NARROW[br.data];
        SELECT op FROM
            $ScanRestriction => {
                cro: RelOrder ~ ToRO[arg2].CanonizeRelOrder[br.Functional];
                RETURN [IF NOT cro.Coarser[l.ro] THEN no ELSE yes]};
            $RestrictionSize => {
                sets: RefSetPair ~ ToSets[arg1];
                RETURN [IF sets^#ALL[nilSet] THEN no ELSE yes]};
            $Update => {dir: Direction ~ ToDir[arg1];
                src: Side ~ Source[dir];
                RETURN [IF src#l.ro.first AND l.ro.sub[l.ro.first]#no THEN no ELSE yes]};
            ENDCASE => RETURN [pass]};

    LystScanRestriction: PROC [br: BiRel, sets: SetPair, Test: Tester, ro: RelOrder] RETURNS [MaybePair] ~ {
        l: Lyst ~ NARROW[br.data];
        nl: BOOL ~ sets[left]=nilSet;
        nr: BOOL ~ sets[right]=nilSet;
        cro: RelOrder ~ ro.CanonizeRelOrder[br.Functional];
        IF br.MutabilityOf=constant AND l.freezeCount=0 THEN br.Complain[unfrozen];
        IF NOT cro.Coarser[l.ro] THEN RETURN DefaultScanRestriction[br, sets, Test, cro];
        FOR vals: LOP _ l.vals, vals.rest WHILE vals#NIL DO
            IF
                (nl OR sets[left].HasMember[vals.first[left]]) AND
                (nr OR sets[right].HasMember[vals.first[right]]) AND
                Test[vals.first]
            THEN RETURN [[TRUE, vals.first]];
            ENDLOOP;
        RETURN [noMaybePair]};

    LystRestrictionSize: PROC [br: BiRel, sets: SetPair, limit: EINT] RETURNS [EINT] ~ {
        l: Lyst ~ NARROW[br.data];
        IF br.MutabilityOf=constant AND l.freezeCount=0 THEN br.Complain[unfrozen];
        IF sets#ALL[nilSet] THEN RETURN DefaultRestrictionSize[br, sets, limit];
        RETURN [IE[l.size]]};

    LystCopy: PROC [br: BiRel] RETURNS [copy: VarBiRel] ~ {
        l: Lyst ~ NARROW[br.data];
        IF br.MutabilityOf=constant AND l.freezeCount=0 THEN br.Complain[unfrozen];
        copy _ CreateList[NIL, br.Functional, br.Spaces, br.MutabilityOf, l.ro].AsVar;
        [] _ copy.AddSet[br];
        RETURN};

    LystInsulate: PROC [br: BiRel] RETURNS [UWBiRel] ~ {
        l: Lyst ~ NARROW[br.data];
        functional: BoolPair ~ br.Functional;
        RETURN AsUW[[listClasses [functional[leftToRight]] [functional[rightToLeft]] [readonly], l]]};

    LystFreeze: PROC [br: BiRel] RETURNS [ConstBiRel] ~ {
        l: Lyst ~ NARROW[br.data];
        functional: BoolPair ~ br.Functional;
        l.freezeCount _ l.freezeCount+1;
        RETURN AsConst[[listClasses [functional[leftToRight]] [functional[rightToLeft]] [constant], l]]};

    LystThaw: PROC [br: BiRel] ~ {
        l: Lyst ~ NARROW[br.data];
        SELECT l.freezeCount FROM
            >0 => l.freezeCount _ l.freezeCount-1;
            =0 => br.Complain["attempt to thaw a non-frozen variable collection %g"];
            ENDCASE => ERROR;
        RETURN};

    LystAddSet: PROC [br, other: BiRel, if: IfHadPair] RETURNS [some: HadSetPair _ ALL[ALL[FALSE]]] ~ {
        l: Lyst ~ NARROW[br.data];
        s1: Side ~ l.ro.first;
        s2: Side ~ OtherSide[s1];
        d1: Direction ~ From[s1];
        d2: Direction ~ From[s2];
        f1: BOOL ~ br.Functional[][d1];
        f2: BOOL ~ br.Functional[][d2];
        last: LOP _ NIL;
        cur: LOP _ l.vals;
        fromScratch: BOOL ~ f2 OR NOT other.GoodImpl[$Scan, FromRO[l.ro]];
        Addit: PROC [this: LOP] ~ INLINE {
            IF last=NIL THEN l.vals _ this ELSE last.rest _ this;
            l.size _ l.size+1;
            last _ this};
        AddPair: PROC [pair: Pair] RETURNS [BOOL] ~ {
            notin: BOOL _ TRUE;
            unseen1: BOOL _ f1;
            unseen2: BOOL _ f2;
            IF fromScratch THEN {cur _ l.vals; last _ NIL};
            WHILE cur#NIL DO
                cp: ComPair ~ Compair[l.spaces, pair, cur.first];
                rcp: PComPair ~ RelativizeComPair[l.ro.sub, cp];
                IF unseen1 THEN SELECT rcp[s1] FROM
                    greater, notrel => NULL;
                    equal => {
                        unseen1 _ FALSE;
                        IF cp[s2]=equal THEN some[d1][same] _ TRUE ELSE {
                            some[d1][different] _ TRUE;
                            cur.first[s2] _ pair[s2];
                            notin _ FALSE}};
                    less => {unseen1 _ FALSE; some[d1][none] _ TRUE};
                    ENDCASE => ERROR;
                IF unseen2 AND cp[s2]=equal THEN {
                    unseen2 _ FALSE;
                    IF cp[s1]=equal THEN some[d2][same] _ TRUE ELSE {
                        some[d2][different] _ TRUE;
                        cur.first[s1] _ pair[s1];
                        notin _ FALSE}};
                SELECT LexizePComPair[rcp, s1] FROM
                    greater, notrel => NULL;
                    equal => notin _ FALSE;
                    less => IF notin THEN {Addit[CONS[pair, cur]]; notin _ FALSE};
                    ENDCASE => ERROR;
                IF NOT (notin OR unseen1 OR unseen2) THEN EXIT;
                last _ cur;
                cur _ cur.rest;
                ENDLOOP;
            IF notin THEN Addit[LIST[pair]];
            IF unseen1 THEN some[d1][none] _ TRUE;
            IF unseen2 THEN some[d2][none] _ TRUE;
            RETURN [FALSE]};
        IF l.freezeCount#0 THEN br.Complain[frozen];
        IF other.Scan[AddPair, IF fromScratch THEN [] ELSE l.ro].found THEN ERROR;
        RETURN};

    LystRemSet: PROC [br, other: BiRel] RETURNS [some: HadSetPair _ []] ~ {
        l: Lyst ~ NARROW[br.data];
        s1: Side ~ l.ro.first;
        s2: Side ~ OtherSide[s1];
        d1: Direction ~ From[s1];
        d2: Direction ~ From[s2];
        f1: BOOL ~ br.Functional[][d1];
        f2: BOOL ~ br.Functional[][d2];
        last: LOP _ NIL;
        cur: LOP _ l.vals;
        fromScratch: BOOL ~ f2 OR NOT other.GoodImpl[$Scan, FromRO[l.ro]];
        Remit: PROC ~ INLINE {
            IF last=NIL THEN l.vals _ cur.rest ELSE last.rest _ cur.rest;
            l.size _ l.size-1;
            cur _ cur.rest};
        Advance: PROC ~ INLINE {last _ cur; cur _ cur.rest};
        RemPair: PROC [pair: Pair] RETURNS [BOOL] ~ {
            in: BOOL _ TRUE;
            unseen1: BOOL _ f1;
            unseen2: BOOL _ f2;
            IF fromScratch THEN {cur _ l.vals; last _ NIL};
            WHILE cur#NIL DO
                cp: ComPair ~ Compair[l.spaces, pair, cur.first];
                rcp: PComPair ~ RelativizeComPair[l.ro.sub, cp];
                IF unseen1 THEN SELECT rcp[s1] FROM
                    greater, notrel => NULL;
                    equal => {unseen1 _ FALSE; some[d1][IF cp[s2]=equal THEN same ELSE different] _ TRUE};
                    less => {unseen1 _ FALSE; some[d1][none] _ TRUE};
                    ENDCASE => ERROR;
                IF unseen2 AND cp[s2]=equal THEN {unseen2 _ FALSE; some[d2][IF cp[s1]=equal THEN same ELSE different] _ TRUE};
                SELECT LexizePComPair[rcp, s1] FROM
                    greater, notrel => Advance[];
                    equal => {Remit[]; in _ FALSE; IF NOT (in OR unseen1 OR unseen2) THEN EXIT};
                    less => {in _ FALSE; IF NOT (in OR unseen1 OR unseen2) THEN EXIT; Advance[]};
                    ENDCASE => ERROR;
                in _ in; ENDLOOP;
            IF unseen1 THEN some[d1][none] _ TRUE;
            IF unseen2 THEN some[d2][none] _ TRUE;
            RETURN [FALSE]};
        IF l.freezeCount#0 THEN br.Complain[frozen];
        IF other.Scan[RemPair, IF fromScratch THEN [] ELSE l.ro].found THEN ERROR;
        RETURN};

    LystDeleteSet: PROC [br: BiRel, set: Set, side: Side] RETURNS [had: SomeAll _ []] ~ {
        l: Lyst ~ NARROW[br.data];
        s1: Side ~ l.ro.first;
        s2: Side ~ OtherSide[s1];
        d1: Direction ~ From[s1];
        d2: Direction ~ From[s2];
        f1: BOOL ~ s1=side;
        f2: BOOL ~ s2=side;
        roa: Sets.RelOrder ~ l.ro.sub[side];
        spacea: Space ~ br.Spaces[][side];
        last: LOP _ NIL;
        cur: LOP _ l.vals;
        fromScratch: BOOL ~ f2 OR NOT set.GoodImpl[$Scan, Sets.FromRO[roa]];
        Remit: PROC ~ INLINE {
            IF last=NIL THEN l.vals _ cur.rest ELSE last.rest _ cur.rest;
            l.size _ l.size-1;
            cur _ cur.rest};
        Advance: PROC ~ INLINE {last _ cur; cur _ cur.rest};
        RemElt: PROC [val: Value] RETURNS [BOOL] ~ {
            unseen1: BOOL _ f1;
            unseen2: BOOL _ f2;
            IF fromScratch THEN {cur _ l.vals; last _ NIL};
            WHILE cur#NIL DO
                c: PartialComparison ~ roa.RelPCompare[spacea, val, cur.first[side]];
                rc: PartialComparison ~ IF f1 THEN c ELSE IF c=equal THEN c ELSE notrel;
                IF unseen1 THEN SELECT c FROM
                    greater, notrel => NULL;
                    equal => {unseen1 _ FALSE; had.some _ TRUE};
                    less => {unseen1 _ FALSE; had.all _ FALSE};
                    ENDCASE => ERROR;
                IF unseen2 AND c=equal THEN {unseen2 _ FALSE; had.some _ TRUE};
                SELECT rc FROM
                    greater, notrel => Advance[];
                    equal => Remit[];
                    less => EXIT;
                    ENDCASE => ERROR;
                side _ side; ENDLOOP;
            IF unseen1 OR unseen2 THEN had.all _ FALSE;
            RETURN [FALSE]};
        IF l.freezeCount#0 THEN br.Complain[frozen];
        IF set.Scan[RemElt, IF fromScratch THEN no ELSE roa].found THEN ERROR;
        RETURN};

    LystUpdate: PROC [br: BiRel, val: Value, dir: Direction, Decide: UpdateDecider] ~ {
        l: Lyst ~ NARROW[br.data];
        ro1: Sets.RelOrder ~ l.ro.sub[l.ro.first];
        s1: Space ~ l.spaces[l.ro.first];
        src: Side ~ Source[dir];
        dst: Side ~ Dest[dir];
        cur, last: LOP _ NIL;
        IF src#l.ro.first AND ro1#no THEN {DefaultUpdate[br, val, dir, Decide]; RETURN};
        IF br.MutabilityOf[]=constant AND l.freezeCount=0 THEN br.Complain[unfrozen];
        FOR cur _ l.vals, cur.rest WHILE cur#NIL DO
            SELECT ro1.RelPCompare[s1, val, cur.first[src]] FROM
                greater, notrel => last _ cur;
                equal => {new: MaybeValue ~ Decide[[TRUE, cur.first[dst]]];
                    IF new.found AND l.spaces[dst].SEqual[new.it, cur.first[dst]] THEN RETURN;
                    IF br.MutabilityOf[]#variable THEN br.Complain[notVariable];
                    IF l.freezeCount#0 THEN br.Complain[frozen];
                    IF new.found THEN cur.first[dst] _ new.it ELSE {
                        IF last#NIL THEN last.rest _ cur.rest ELSE l.vals _ cur.rest;
                        l.size _ l.size-1};
                    RETURN};
                less => EXIT;
                ENDCASE => ERROR;
            ENDLOOP;
        {new: MaybeValue ~ Decide[noMaybe];
        IF NOT new.found THEN RETURN;
        IF br.MutabilityOf[]#variable THEN br.Complain[notVariable];
        IF l.freezeCount#0 THEN br.Complain[frozen];
        cur _ CONS[Cons[src, val, new.it], cur];
        IF last#NIL THEN last.rest _ cur ELSE l.vals _ cur;
        l.size _ l.size+1;
        RETURN}};

    LystSpaces: PROC [br: BiRel] RETURNS [SpacePair] ~ {
        l: Lyst ~ NARROW[br.data];
        RETURN [l.spaces]};

    Start: PROC ~ {
        FOR l2r: BOOL IN BOOL DO FOR r2l: BOOL IN BOOL DO FOR mut: Mutability IN Mutability DO
            listClasses[l2r][r2l][mut] _ CreateClass[
                cp: [
                    Primitive: LystPrimitive,
                    ScanRestriction: LystScanRestriction,
                    RestrictionSize: LystRestrictionSize,
                    Copy: LystCopy,
                    Insulate: IF mut=variable THEN LystInsulate ELSE NIL,
                    Freeze: IF mut=variable THEN LystFreeze ELSE NIL,
                    Thaw: IF mut=variable THEN LystThaw ELSE NIL,
                    AddSet: IF mut=variable THEN LystAddSet ELSE NIL,
                    RemSet: IF mut=variable THEN LystRemSet ELSE NIL,
                    Update: LystUpdate,
                    DeleteSet: IF mut=variable THEN LystDeleteSet ELSE NIL,
                    Spaces: LystSpaces,
                    functional: [l2r, r2l],
                    mutability: mut],
                dirable: ALL[TRUE]
                ];
            ENDLOOP ENDLOOP ENDLOOP;
        };

    Start[];

    END.