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.