LichenStructuringImpl.Mesa
Last tweaked by Mike Spreitzer on September 1, 1987 5:08:46 pm PDT
DIRECTORY Basics, Convert, IO, Collections, LichenDataStructure, IntFunctions, PairCollections, LichenStructuring, List, Rope, StructuredStreams, UnparserBuffer;
LichenStructuringImpl: CEDAR PROGRAM
IMPORTS Convert, IO, Collections, LichenDataStructure, PairCollections, LichenStructuring, List, Rope, StructuredStreams, UnparserBuffer
EXPORTS LichenStructuring
=
BEGIN OPEN LichenDataStructure, Colls:Collections, PairColls:PairCollections, IntFns:IntFunctions, 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: BOOLTRUE;
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: BOOLTRUE;
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: BOOLTRUE;
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: BOOLFALSE] ~ {
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.