
    <<LichenStructuringImpl.Mesa>>
        <<Last tweaked by Mike Spreitzer on September 1, 1987 5:08:46 pm PDT>>

    DIRECTORY Basics, Convert, IO, LichenCollections, LichenDataStructure, LichenIntFunctions, LichenPairCollections, 
    LichenStructuring, List, Rope, StructuredStreams, UnparserBuffer;

    LichenStructuringImpl: CEDAR PROGRAM
        IMPORTS Convert, IO, LichenCollections, LichenDataStructure, LichenPairCollections, LichenStructuring, List, Rope, 
        StructuredStreams, UnparserBuffer
        EXPORTS LichenStructuring
        =

    BEGIN OPEN LichenDataStructure, Colls:LichenCollections, PairColls:LichenPairCollections, IntFns:LichenIntFunctions, 
    SS:StructuredStreams, UB:UnparserBuffer, LichenStructuring;

    CreateDAG: PUBLIC PROC [root: StepNode, ups: BOOL] RETURNS [dag: StepDAG] ~ {
        dag _ NEW [StepDAGPrivate];
        dag.down _ PairColls.CreateHashFn[];
        IF ups THEN dag.up _ PairColls.CreateHashOTO[];
        dag.cands _ Colls.CreateHashSet[];
        dag.root _ root;
        };

    VerifyDAG: PUBLIC PROC [dag: StepDAG, mayBeLone: StepNode, midThings: BOOL] ~ {
        parents: Set--of StepNode-- ~ Colls.CreateHashSet[];
        children: Set--of StepNode-- ~ Colls.CreateHashSet[];
        ExploreDown: PROC [parent: StepNode] ~ {
            dec: Decomp ~ GetDecomp[dag, parent, FALSE];
            leaf: BOOL ~ parent#dag.root AND (WITH parent SELECT FROM
                x: Port => TRUE,
                x: Wire => TRUE,
                x: Fake => FALSE,
                ENDCASE => ERROR);
            cand: BOOL ~ dag.cands.HasMember[parent];
            CheckDecomp: PROC [pair: PairColls.Pair] ~ {
                step: NameStep ~ pair[left];
                child: StepNode ~ pair[right];
                ups: Ups ~ GetUps[dag, child, FALSE];
                [] _ children.AddElt[child];
                IF NOT ups^.HasPair[[parent, step]] THEN ERROR;
                ExploreDown[child];
                };
            IF (leaf OR parent=mayBeLone)#(dec=NIL) THEN IF NOT (leaf AND midThings) THEN ERROR;
            IF leaf AND cand THEN ERROR;
            IF cand AND dec=NIL THEN ERROR;
            IF dec=NIL THEN RETURN;
            IF NOT parents.AddElt[parent] THEN RETURN;
            dec^.Enumerate[CheckDecomp];
            RETURN};
        CheckUp: PROC [pair: PairColls.Pair] ~ {
            child: StepNode ~ pair[left];
            ups: Ups ~ NARROW[pair[right]];
            PerUp: PROC [pair: PairColls.Pair] ~ {
                parent: StepNode ~ pair[left];
                step: NameStep ~ pair[right];
                dec: Decomp ~ GetDecomp[dag, parent, FALSE];
                IF NOT dec^.HasPair[[step, child]] THEN ERROR;
                RETURN};
            ups^.Enumerate[PerUp];
            RETURN};
        IF dag.down.Size[]#0 THEN ExploreDown[dag.root];
        dag.cands.Enumerate[ExploreDown];
        IF dag.down.CollectionOn[left].Intersection[parents.Negate].Size[1]#0 THEN ERROR;
        IF dag.up.CollectionOn[left].Intersection[children.Negate].Size[1]#0 THEN ERROR;
        dag.up.Enumerate[CheckUp];
        RETURN};

    PrintDAG: PROC [to: IO.STREAM, dag: StepDAG] ~ {
        ss: IO.STREAM ~ SS.Create[UB.NewInittedHandle[[output: [stream[to]], margin: 69]]];
        PrintSubDAG[ss, dag, dag.root];
        ss.Close[]};

    PrintSubDAG: PROC [to: IO.STREAM, dag: StepDAG, parent: StepNode] ~ {
        dec: Decomp ~ GetDecomp[dag, parent, FALSE];
        first: BOOL _ TRUE;
        PerDec: PROC [pair: PairColls.Pair] ~ {
            step: NameStep ~ pair[left];
            child: StepNode ~ pair[right];
            IF first THEN {first _ FALSE; SS.Bp[to, width, 3]}
            ELSE {to.PutRope[","]; SS.Bp[to, lookLeft, 3, " "]};
            SS.Begin[to];
            to.PutRope[FmtStep[step]];
            to.PutRope[": "];
            PrintSubDAG[to, dag, child];
            SS.End[to];
            RETURN};
        to.PutRope[Descr[parent]];
        IF IsThing[parent] THEN to.PutRope["!"];
        IF dag.cands.HasMember[parent] THEN to.PutRope["?"];
        IF dec=NIL THEN RETURN;
        to.PutRope["["];
        dec^.Enumerate[PerDec];
        to.PutRope["]"];
        RETURN};

    PrintDown: PROC [to: IO.STREAM, dag: StepDAG] ~ {
        ss: IO.STREAM ~ SS.Create[UB.NewInittedHandle[[output: [stream[to]], margin: 69]]];
        PerDown: PROC [pair: PairColls.Pair] ~ {
            parent: StepNode ~ pair[left];
            dec: Decomp ~ NARROW[pair[right]];
            first: BOOL _ TRUE;
            PerDec: PROC [pair: PairColls.Pair] ~ {
                step: NameStep ~ pair[left];
                child: StepNode ~ pair[right];
                IF first THEN first _ FALSE ELSE {ss.PutRope[","]; SS.Bp[ss, width, 3, " "]};
                ss.PutF["%g: %g", [rope[FmtStep[step]]], [rope[Descr[child]]]];
                RETURN};
            SS.Begin[ss];
            ss.PutRope[Descr[parent]];
            ss.PutRope[": ["];
            dec^.Enumerate[PerDec];
            ss.PutRope["]\n"];
            RETURN};
        dag.down.Enumerate[PerDown];
        ss.Close[]};

    PrintUp: PROC [to: IO.STREAM, dag: StepDAG] ~ {
        ss: IO.STREAM ~ SS.Create[UB.NewInittedHandle[[output: [stream[to]], margin: 69]]];
        PerUp: PROC [pair: PairColls.Pair] ~ {
            child: StepNode ~ pair[left];
            ups: Ups ~ NARROW[pair[right]];
            first: BOOL _ TRUE;
            PerTuple: PROC [pair: PairColls.Pair] ~ {
                step: NameStep ~ pair[right];
                parent: StepNode ~ pair[left];
                IF first THEN first _ FALSE ELSE {ss.PutRope[","]; SS.Bp[ss, width, 3, " "]};
                ss.PutF["%g.%g", [rope[Descr[parent]]], [rope[FmtStep[step]]]];
                RETURN};
            SS.Begin[ss];
            ss.PutRope[Descr[child]];
            ss.PutRope[": ["];
            ups^.Enumerate[PerTuple];
            ss.PutRope["]\n"];
            RETURN};
        dag.up.Enumerate[PerUp];
        ss.Close[];
        };

    Descr: PROC [ra: REF ANY] RETURNS [ROPE] ~ TRUSTED {
        addr: INT ~ LOOPHOLE[ra];
        RETURN [Convert.RopeFromInt[addr, 8]]};

    FmtStep: PROC [step: NameStep] RETURNS [ROPE] ~ {
        WITH step SELECT FROM
            x: ROPE => RETURN [x];
            x: REF INT => RETURN [Convert.RopeFromInt[x^]];
            ENDCASE => ERROR};

    InsertInDAG: PUBLIC PROC [dag: StepDAG, parent: StepNode, parts: SteppyName, thing: Thing] ~ {
        IF parts.rest=NIL THEN AddLink[dag, parent, parts.first, thing, FALSE]
        ELSE {
            fake: Fake ~ GetDown[dag, parent, parts.first, TRUE];
            InsertInDAG[dag, fake, parts.rest, thing];
            RETURN};
        RETURN};

    AddLink: PUBLIC PROC [dag: StepDAG, parent: StepNode, step: NameStep, child: StepNode, downRed: BOOL] ~ {
        dec: Decomp ~ GetDecomp[dag, parent, TRUE];
        Store[dec^, [step, child], downRed];
        IF dag.up#PairColls.nilPairColl THEN {
            ups: Ups ~ GetUps[dag, child, TRUE];
            Store[ups^, [parent, step], FALSE];
            };
        RETURN};

    GetDown: PUBLIC PROC [dag: StepDAG, parent: StepNode, step: NameStep, mayAdd: BOOL] RETURNS [child: StepNode] ~ {
        pdec: Decomp ~ GetDecomp[dag, parent, TRUE];
        child _ pdec^.Apply[step].DVal;
        IF child#NIL OR NOT mayAdd THEN RETURN;
        child _ CreateDecomp[];
        Store[pdec^, [step, child], FALSE];
        Store[dag.down, [child, child], FALSE];
        IF dag.up#PairColls.nilPairColl THEN {
            ups: Ups ~ CreateUps[];
            Store[ups^, [parent, step], FALSE];
            Store[dag.up, [child, ups], FALSE];
            RETURN};
        RETURN};

    GetDecomp: PUBLIC PROC [dag: StepDAG, parent: StepNode, mayAdd: BOOL] RETURNS [dec: Decomp] ~ {
        dec _ NARROW[dag.down.Apply[parent].DVal];
        IF dec#NIL OR NOT mayAdd THEN RETURN;
        dec _ CreateDecomp[];
        Store[dag.down, [parent, dec], FALSE];
        RETURN};

    GetUps: PUBLIC PROC [dag: StepDAG, child: StepNode, mayAdd: BOOL] RETURNS [ups: Ups] ~ {
        ups _ NARROW[dag.up.Apply[child].DVal];
        IF ups#NIL OR NOT mayAdd THEN RETURN;
        ups _ CreateUps[];
        Store[dag.up, [child, ups], FALSE];
        RETURN};

    CreateDecomp: PROC RETURNS [dec: Decomp]
        ~ INLINE {dec _ NARROW[PairColls.CreateHashFn[spaces: [nameStepSpace, Colls.refs], invable: FALSE].Refify]};

    CreateUps: PROC RETURNS [ups: Ups]
        ~ INLINE {ups _ NARROW[PairColls.CreateHashReln[spaces: [Colls.refs, nameStepSpace], mappable: [TRUE, FALSE]].Refify]};

    RemoveLink: PUBLIC PROC [dag: StepDAG, parent: StepNode, step: NameStep, child: StepNode, cleanup: CleanOption] ~ {
        dec: Decomp ~ GetDecomp[dag, parent, FALSE];
        trace: PairColls.BoolPair;
        IF dag.up#PairColls.nilPairColl THEN {
            ups: Ups ~ GetUps[dag, child, FALSE];
            IF ups=NIL THEN ERROR;
            [] _ ups^.RemPair[[parent, step]];
            IF ups^.Size[limit: 1]=0 THEN IF NOT dag.up.Delete[child] THEN ERROR;
            };
        IF dec=NIL THEN ERROR;
        IF NOT (trace _ dec^.RemPair[[step, child]])[leftToRight] THEN ERROR;
        IF dec^.Size[limit: 1]=0 THEN {
            clean: BOOL ~ SELECT cleanup FROM
                ignore => FALSE,
                wontBeNeeded => ERROR,
                ifFake => NOT IsThing[parent],
                do => TRUE,
                ENDCASE => ERROR;
            IF dag.cands.HasMember[parent] THEN ERROR;
            IF NOT dag.down.Delete[parent] THEN ERROR;
            [] _ dag.cands.RemoveElt[parent];
            IF clean THEN {
                pups: Ups ~ GetUps[dag, parent, FALSE];
                RemoveUp: PROC [pair: PairColls.Pair] ~ {
                    RemoveLink[dag, pair[left], pair[right], parent, cleanup];
                    RETURN};
                IF pups#NIL THEN pups^.Enumerate[RemoveUp];
                RETURN};
            RETURN};
        RETURN};

    ReplaceNode: PUBLIC PROC [dag: StepDAG, doomed, survivor: StepNode] ~ {
        ups: Ups ~ GetUps[dag, doomed, FALSE];
        dec: Decomp ~ GetDecomp[dag, doomed, FALSE];
        MoveUplink: PROC [pair: PairColls.Pair] ~ {
            RemoveLink[dag, pair[left], pair[right], doomed, ignore];
            AddLink[dag, pair[left], pair[right], survivor, FALSE];
            RETURN};
        MoveDownlink: PROC [pair: PairColls.Pair] ~ {
            RemoveLink[dag, doomed, pair[left], pair[right], ignore];
            RETURN};
        IF ups#NIL THEN ups^.Enumerate[MoveUplink];
        IF dec=NIL THEN ERROR;
        dec^.Enumerate[MoveDownlink];
        RETURN};

    RemoveLeaf: PUBLIC PROC [dag: StepDAG, leaf: StepNode] ~ {
        ups: Ups ~ GetUps[dag, leaf, FALSE];
        RemoveUplink: PROC [pair: PairColls.Pair] ~ {
            RemoveLink[dag, pair[left], pair[right], leaf, ifFake];
            RETURN};
        IF ups#NIL THEN ups^.Enumerate[RemoveUplink];
        RETURN};

    CreateTreeSpace: PUBLIC PROC [dag: StepDAG] RETURNS [treeSpace: Colls.Space] ~ {
        treeSpace _ NEW [Colls.SpacePrivate _ [
            Equal: TreesEqual,
            Hash: HashTree,
            Compare: CompareTrees,
            other: List.PutAssoc[$Name, Rope.Cat["name step tree rooted at ", Describe[dag.root]], NIL],
            data: dag]];
        RETURN};

    TreesEqual: PROC [data: REF ANY, elt1, elt2: REF ANY] RETURNS [BOOL] ~ {
        RETURN [CompareTrees[data, elt1, elt2]=equal]};

    HashTree: PROC [data: REF ANY, elt: REF ANY] RETURNS [CARDINAL] ~ {
        dag: StepDAG ~ NARROW[data];
        IF IsThing[elt] THEN RETURN Colls.HashRefI[elt];
        {dec: Decomp ~ NARROW[elt];
        hash: CARD _ 0;
        HashPair: PROC [pair: PairColls.Pair] ~ {
            step: CARD _ nameStepSpace.SpaceHash[pair[left]];
            IF step=0 THEN step _ CARDINAL.LAST.LONG.SUCC;
            hash _ hash + step * HashTree[data, pair[right]];
            RETURN};
        dec^.Enumerate[HashPair];
        RETURN Colls.HashIntI[LOOPHOLE[hash]]}};

    CompareTrees: PROC [data: REF ANY, elt1, elt2: REF ANY] RETURNS [c: Basics.Comparison] ~ {
        dag: StepDAG ~ NARROW[data];
        leaf1: BOOL ~ IsThing[elt1];
        leaf2: BOOL ~ IsThing[elt2];
        Test: PROC [a, b: PairColls.MaybePair] RETURNS [pass: BOOL _ FALSE] ~ {
            IF a.found#b.found THEN {
                c _ IF a.found THEN greater ELSE less;
                RETURN [TRUE]};
            IF NOT a.found THEN ERROR;
            c _ nameStepSpace.SpaceCompare[a.pair[left], b.pair[left]];
            IF c=equal THEN c _ CompareTrees[data, a.pair[right], b.pair[right]];
            pass _ c#equal;
            RETURN};
    SELECT TRUE FROM
    leaf1 > leaf2 => RETURN [less];
    leaf1 < leaf2 => RETURN [greater];
    leaf1 => RETURN Colls.CompareRefI[elt1, elt2];
    ENDCASE => {
        dec1: Decomp ~ NARROW[elt1];
        dec2: Decomp ~ NARROW[elt2];
        c _ equal;
        [] _ dec1^.ParallelScan[dec2^, Test];
        RETURN};
        };

    Store: PROC [pc: PairColls.PairColl, pair: PairColls.Pair, mayBeRedundant: BOOL] ~ {
        lr: BOOL ~ pc.Functional[][leftToRight];
        rl: BOOL ~ pc.Functional[][rightToLeft];
        news: PairColls.NewsPair ~ pc.AddPair[pair, [[NOT lr, TRUE], [NOT rl, TRUE]]];
        IF lr AND news[leftToRight]#new AND NOT (mayBeRedundant AND news[leftToRight]=same) THEN ERROR;
        IF rl AND news[rightToLeft]#new AND NOT (mayBeRedundant AND news[rightToLeft]=same) THEN ERROR;
        };

    END.