LichenStructuringImpl.Mesa
Last tweaked by Mike Spreitzer on February 2, 1988 1:13:38 pm PST
DIRECTORY AbSets, Basics, BiRels, Convert, IntStuff, IO, LichenDataStructure, LichenStructuring, Rope, SetBasics, StructuredStreams, UnparserBuffer;
LichenStructuringImpl: CEDAR PROGRAM
IMPORTS AbSets, BiRels, Convert, IntStuff, IO, LichenDataStructure, Rope, SetBasics, StructuredStreams, UnparserBuffer
EXPORTS LichenStructuring
=
BEGIN OPEN LichenDataStructure, Sets:AbSets, IS:IntStuff, SS:StructuredStreams, UB:UnparserBuffer, LichenStructuring;
CreateDAG: PUBLIC PROC [root: REF ANY--UNION[Thing, StepNode]--, from: StepDAG] RETURNS [dag: StepDAG] ~ {
dag ← NEW [StepDAGPrivate ← [
down: BiRels.CreateHashFn[invable: FALSE],
up: BiRels.CreateHashOTO[],
toThing: BiRels.nilBiRel,
cands: Sets.CreateHashSet[],
rootThing: root,
rootNode: NIL
]];
IF from=NIL THEN dag.toThing ← BiRels.CreateHashFn[] ELSE {
dag.toThing ← from.toThing;
dag.prefixd ← from.prefixd;
dag.leavesCommonized ← from.leavesCommonized};
WITH root SELECT FROM
x: Port => dag.rootNode ← CreateStepNode[];
x: Wire => dag.rootNode ← CreateStepNode[];
x: StepNode => {dag.rootNode ← x; dag.rootThing ← NIL};
ENDCASE => ERROR;
RETURN};
VerifyDAG: PUBLIC PROC [dag: StepDAG] ~ {
CheckDown: PROC [parenta, deca: REF ANY] ~ {
parent: StepNode ~ NARROW[parenta];
dec: Decomp ~ NARROW[deca];
PerDown: PROC [step: NameStep, childa: REF ANY] ~ {
child: StepNode ~ NARROW[childa];
ups: Ups ~ GetUps[dag, child, FALSE];
IF NOT ups^.HasAA[parent, step] THEN ERROR;
RETURN};
IF parent#dag.rootNode AND GetUps[dag, parent, FALSE]=NIL THEN ERROR;
dec^.EnumAA[PerDown];
RETURN};
CheckUp: PROC [childa, upsa: REF ANY] ~ {
child: StepNode ~ NARROW[childa];
ups: Ups ~ NARROW[upsa];
leaf: BOOL ~ GetDecomp[dag, child, FALSE]=NIL;
mt: Sets.MaybeValue ~ dag.toThing.ApplyA[child];
thingy: BOOL ~ mt.found;
PerUp: PROC [parenta: REF ANY, step: NameStep] ~ {
parent: StepNode ~ NARROW[parenta];
dec: Decomp ~ GetDecomp[dag, parent, FALSE];
IF NOT dec^.HasAA[step, child] THEN ERROR;
RETURN};
IF NOT (leaf=thingy OR (thingy AND NOT dag.prefixd)) THEN ERROR;
IF dag.leavesCommonized AND thingy AND dag.toThing.MappingSize[mt.it, rightToLeft, IS.two]#IS.one THEN ERROR;
ups^.EnumAA[PerUp];
RETURN};
dag.down.EnumAA[CheckDown];
dag.up.EnumAA[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.rootNode];
ss.Close[]};
PrintSubDAG: PROC [to: IO.STREAM, dag: StepDAG, parent: StepNode] ~ {
dec: Decomp ~ GetDecomp[dag, parent, FALSE];
first: BOOLTRUE;
PerDec: PROC [step: NameStep, childa: REF ANY] ~ {
child: StepNode ~ NARROW[childa];
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[dag, parent]];
IF dag.cands.HasMemA[parent] THEN to.PutRope["?"];
IF dec=NIL THEN RETURN;
to.PutRope["["];
dec^.EnumAA[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 [parenta, rdec: REF ANY] ~ {
parent: StepNode ~ NARROW[parenta];
dec: Decomp ~ NARROW[rdec];
first: BOOLTRUE;
PerDec: PROC [step: NameStep, childa: REF ANY] ~ {
child: StepNode ~ NARROW[childa];
IF first THEN first ← FALSE ELSE {ss.PutRope[","]; SS.Bp[ss, width, 3, " "]};
ss.PutF["%g: %g", [rope[FmtStep[step]]], [rope[Descr[dag, child]]]];
RETURN};
SS.Begin[ss];
ss.PutRope[Descr[dag, parent]];
ss.PutRope[": ["];
dec^.EnumAA[PerDec];
ss.PutRope["]\n"];
RETURN};
dag.down.EnumAA[PerDown];
ss.Close[]};
PrintUp: PROC [to: IO.STREAM, dag: StepDAG] ~ {
ss: IO.STREAM ~ SS.Create[UB.NewInittedHandle[[output: [stream[to]], margin: 69]]];
PerUp: PROC [childa: REF ANY, upsa: REF ANY] ~ {
child: StepNode ~ NARROW[childa];
ups: Ups ~ NARROW[upsa];
first: BOOLTRUE;
PerTuple: PROC [parenta: REF ANY, step: NameStep] ~ {
parent: StepNode ~ NARROW[parenta];
IF first THEN first ← FALSE ELSE {ss.PutRope[","]; SS.Bp[ss, width, 3, " "]};
ss.PutF["%g.%g", [rope[Descr[dag, parent]]], [rope[FmtStep[step]]]];
RETURN};
SS.Begin[ss];
ss.PutRope[Descr[dag, child]];
ss.PutRope[": ["];
ups^.EnumAA[PerTuple];
ss.PutRope["]\n"];
RETURN};
dag.up.EnumAA[PerUp];
ss.Close[];
};
Descr: PROC [dag: StepDAG, node: StepNode] RETURNS [ans: ROPE] ~ {
mv: Sets.MaybeValue ~ dag.toThing.ApplyA[node];
ans ← Convert.RopeFromInt[node^];
IF mv.found THEN ans ← ans.Cat["(", Convert.RopeFromInt[LOOPHOLE[mv.MA], 8], ")"];
RETURN};
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, steps: NameStepList, thing: Thing] ~ {
WHILE steps#NIL DO
parent ← GetDown[dag, parent, steps.first, TRUE];
steps ← steps.rest;
ENDLOOP;
dag.toThing.AddNewAA[parent, thing];
RETURN};
GetDown: PUBLIC PROC [dag: StepDAG, parent: StepNode, step: NameStep, mayAdd: BOOL] RETURNS [child: StepNode] ~ {
pdec: Decomp ~ GetDecomp[dag, parent, TRUE];
child ← NARROW[pdec^.ApplyA[step].MDA];
IF child#NIL OR NOT mayAdd THEN RETURN;
child ← CreateStepNode[];
AddLink[dag, parent, step, child];
RETURN};
AddLink: PUBLIC PROC [dag: StepDAG, parent: StepNode, step: NameStep, child: StepNode] ~ {
dec: Decomp ~ GetDecomp[dag, parent, TRUE];
dec^.AddNewAA[step, child];
IF dag.up#BiRels.nilBiRel THEN {
ups: Ups ~ GetUps[dag, child, TRUE];
ups^.AddNewAA[parent, step];
};
RETURN};
GetDecomp: PUBLIC PROC [dag: StepDAG, parent: StepNode, mayAdd: BOOL] RETURNS [dec: Decomp] ~ {
dec ← NARROW[dag.down.ApplyA[parent].MDA];
IF dec#NIL OR NOT mayAdd THEN RETURN;
dec ← CreateDecomp[];
dag.down.AddNewAA[parent, dec];
RETURN};
GetUps: PUBLIC PROC [dag: StepDAG, child: StepNode, mayAdd: BOOL] RETURNS [ups: Ups] ~ {
ups ← NARROW[dag.up.ApplyA[child].MDA];
IF ups#NIL OR NOT mayAdd THEN RETURN;
ups ← CreateUps[];
dag.up.AddNewAA[child, ups];
RETURN};
CreateDecomp: PROC RETURNS [dec: Decomp]
~ INLINE {dec ← NARROW[BiRels.CreateHashFn[spaces: [nameStepSpace, SetBasics.refs], invable: FALSE].Refify]};
CreateUps: PROC RETURNS [ups: Ups]
~ INLINE {ups ← NARROW[BiRels.CreateHashReln[spaces: [SetBasics.refs, nameStepSpace], mappable: [TRUE, FALSE]].Refify]};
CreateStepNode: PROC RETURNS [StepNode]
~ {RETURN [NEW [INT ← nStepNodes ← nStepNodes+1]]};
nStepNodes: INT ← 0;
RemoveLink: PUBLIC PROC [dag: StepDAG, parent: StepNode, step: NameStep, child: StepNode, cleanup: CleanUpOption] ~ {
dec: Decomp ~ GetDecomp[dag, parent, FALSE];
trace: BiRels.HadPair;
IF dag.up#BiRels.nilBiRel THEN {
ups: Ups ~ GetUps[dag, child, FALSE];
IF ups=NIL THEN ERROR;
[] ← ups^.RemAA[parent, step];
IF ups^.Empty THEN IF NOT dag.up.DeleteA[child] THEN ERROR;
};
IF dec=NIL THEN ERROR;
IF (trace ← dec^.RemAA[step, child])[leftToRight]#same THEN ERROR;
IF dec^.Empty THEN {
clean: BOOL ~ SELECT cleanup FROM
ignore => FALSE,
wontBeNeeded => ERROR,
ifNotThinged => NOT dag.toThing.HasMapA[parent],
do => TRUE,
ENDCASE => ERROR;
IF dag.cands.HasMemA[parent] THEN ERROR;
IF NOT dag.down.DeleteA[parent] THEN ERROR;
IF clean THEN {
pups: Ups ~ GetUps[dag, parent, FALSE];
RemoveUp: PROC [grandparenta, pstep: REF ANY] ~ {
grandparent: StepNode ~ NARROW[grandparenta];
RemoveLink[dag, grandparent, pstep, parent, cleanup];
RETURN};
IF pups#NIL THEN pups^.EnumAA[RemoveUp];
RETURN};
RETURN};
RETURN};
ReplaceNode: PUBLIC PROC [dag: StepDAG, doomed, survivor: StepNode, cleanDown: CleanDownOption] ~ {
ups: Ups ~ GetUps[dag, doomed, FALSE];
dec: Decomp ~ GetDecomp[dag, doomed, FALSE];
MoveUplink: PROC [parenta: REF ANY, step: NameStep] ~ {
parent: StepNode ~ NARROW[parenta];
RemoveLink[dag, parent, step, doomed, ignore];
AddLink[dag, parent, step, survivor];
RETURN};
MoveDownlink: PROC [step: NameStep, childa: REF ANY] ~ {
child: StepNode ~ NARROW[childa];
RemoveLink[dag, doomed, step, child, ignore];
IF cleanDown=keep THEN AddLink[dag, survivor, step, child];
RETURN};
IF ups#NIL THEN ups^.EnumAA[MoveUplink];
IF (dec=NIL) # (cleanDown=none) THEN ERROR;
IF cleanDown#none THEN dec^.EnumAA[MoveDownlink];
RETURN};
RemoveLeaf: PUBLIC PROC [dag: StepDAG, leaf: StepNode] ~ {
ups: Ups ~ GetUps[dag, leaf, FALSE];
RemoveUplink: PROC [parenta: REF ANY, step: NameStep] ~ {
parent: StepNode ~ NARROW[parenta];
RemoveLink[dag, parent, step, leaf, ifNotThinged];
RETURN};
ups^.EnumAA[RemoveUplink];
RETURN};
PruneCand: PUBLIC PROC [dag: StepDAG, cand: StepNode] ~ {
dec: Decomp ~ GetDecomp[dag, cand, FALSE];
RemoveDownlink: PROC [step, childa: REF ANY] ~ {
RemoveLink[dag, cand, step, NARROW[childa], do];
RETURN};
IF NOT dag.cands.RemA[cand] THEN ERROR;
IF dec=NIL THEN ERROR;
dec^.EnumAA[RemoveDownlink];
RETURN};
Sequify: PUBLIC PROC [oto: OneToOne] RETURNS [seq: Seq] ~ {
PerPair: PROC [step: NameStep, thing: Thing] ~ {
WITH thing SELECT FROM
x: Port => NULL;
w: Wire => NULL;
ENDCASE => ERROR;
WITH step SELECT FROM
x: REF INT => seq.AddNewIA[x^, thing];
x: ROPE => ERROR;
ENDCASE => ERROR;
RETURN};
seq ← CreateSeq[len: oto.Size.EN, oneToOne: TRUE];
oto.EnumAA[PerPair];
RETURN};
GradeCand: PUBLIC PROC [dag: StepDAG, cand: StepNode] RETURNS [grade: CandGrade ← [FALSE, 0]] ~ {
dec: Decomp ~ GetDecomp[dag, cand, FALSE];
bounds: IS.Interval ← IS.anEmptyInterval;
subSize: INT ← 1;
subArrayed: BOOLFALSE;
PerPair: PROC [pair: BiRels.Pair] RETURNS [BOOL] ~ {
child: StepNode ~ NARROW[pair[right].VA];
subDec: Decomp ~ GetDecomp[dag, child, FALSE];
subGrade: CandGrade;
WITH pair[left].VA SELECT FROM
x: REF INT => bounds ← bounds.MBI[[x^, x^]];
x: ROPE => ERROR;
ENDCASE => ERROR;
IF subDec=NIL THEN {subGrade ← [FALSE, 0]} ELSE {
subGrade ← IF dag.cands.HasMemA[child] THEN GradeCand[dag, child] ELSE [FALSE, 0];
IF NOT subGrade.good THEN RETURN [TRUE]};
IF grade.size=0 THEN [subArrayed, subSize] ← subGrade
ELSE IF subGrade # [subArrayed, subSize] THEN RETURN [TRUE];
grade.size ← grade.size+1;
RETURN [FALSE]};
grade.good ← (NOT dec^.Scan[PerPair].found) AND bounds.min IN [0 .. 1] AND bounds.Length.EI=grade.size AND grade.size>1;
IF subArrayed THEN grade.size ← grade.size * subSize;
RETURN};
CommonizeLeaves: PUBLIC PROC [dag: StepDAG] ~ {
CommonizeThing: PROC [thing: Thing] ~ {
nLeaves: INT ~ dag.toThing.MappingSize[AV[thing], rightToLeft].EI;
IF nLeaves=0 THEN ERROR;
IF nLeaves=1 THEN RETURN;
{theOne: StepNode ← NIL;
Replace: PROC [val: Sets.Value] ~ {
leaf: StepNode ~ NARROW[val.VA];
IF leaf=NIL THEN ERROR;
IF theOne=NIL THEN {theOne ← leaf; RETURN};
ReplaceNode[dag, leaf, theOne, none];
dag.toThing.RemOldAA[leaf, thing];
RETURN};
dag.toThing.EnumerateMapping[AV[thing], Replace, rightToLeft];
IF theOne=NIL THEN ERROR;
RETURN}};
dag.toThing.SetOn[right].EnumA[CommonizeThing];
RETURN};
refStepNodeSets: SetBasics.Space ~ Sets.CreateSetSpace[SetBasics.refs];
CommonizeDecomps: PUBLIC PROC [dag: StepDAG] ~ {
treeSpace: Sets.Space ~ CreateTreeSpace[dag];
indexed: Function--parent StepNode b StepTree-- ~ BiRels.CreateHashFn[spaces: [SetBasics.refs, treeSpace], invable: TRUE];
collapsars: Set--of Set of parent StepNode-- ~ Sets.CreateHashSet[refStepNodeSets];
PerDown: PROC [tree: REF ANY] ~ {
parents: Set--of parent StepNode-- ~ indexed.MappingA[tree, rightToLeft];
nParents: NATURAL ~ parents.Size.EN;
IF nParents>1 THEN IF NOT collapsars.AddA[parents.CreateHashCopy.Refify] THEN ERROR;
RETURN};
Collapsit: PROC [val: REF ANY] ~ {
parents: Set--of parent StepNode-- ~ Sets.DeRef[val];
nParents: NATURAL ~ parents.Size.EN;
survivor: StepNode ~ NARROW[parents.First.MA];
foundSurvivor: BOOLFALSE;
Replace: PROC [parenta: REF ANY] ~ {
parent: StepNode ~ NARROW[parenta];
IF parent=survivor THEN {foundSurvivor ← TRUE; RETURN};
[] ← dag.cands.RemA[parent];
ReplaceNode[dag, parent, survivor, unlink];
RETURN};
IF nParents<2 THEN ERROR;
parents.EnumA[Replace];
IF NOT foundSurvivor THEN ERROR;
RETURN};
[] ← indexed.AddSet[BiRels.CreateIDSubset[dag.down.SetOn[left]]];
indexed.SetOn[right].EnumA[PerDown];
collapsars.EnumA[Collapsit];
RETURN};
CreateTreeSpace: PUBLIC PROC [dag: StepDAG] RETURNS [treeSpace: Sets.Space] ~ {
treeSpace ← NEW [SetBasics.SpacePrivate ← [
Contains: TreesContains,
Equal: TreesEqual,
Hash: HashTree,
Compare: CompareTrees,
name: Rope.Cat["name step tree rooted at ", Describe[dag.rootThing]],
data: dag]];
RETURN};
TreesContains: PROC [data: REF ANY, v: Sets.Value] RETURNS [BOOL] ~ {
RETURN [v.ra#NIL AND ISTYPE[v.ra, StepNode]]};
TreesEqual: PROC [data: REF ANY, v1, v2: Sets.Value] RETURNS [BOOL] ~ {
dag: StepDAG ~ NARROW[data];
elt1: StepNode ~ NARROW[v1.VA];
elt2: StepNode ~ NARROW[v2.VA];
dec1: Decomp ~ GetDecomp[dag, elt1, FALSE];
dec2: Decomp ~ GetDecomp[dag, elt2, FALSE];
leaf1: BOOL ~ dec1=NIL;
leaf2: BOOL ~ dec2=NIL;
IF leaf1 OR leaf2 THEN RETURN [dag.toThing.ApplyA[elt1] = dag.toThing.ApplyA[elt2]];
{
LookForMissing: PROC [p1: BiRels.Pair] RETURNS [BOOL] ~ {
t2: Sets.MaybeValue ~ dec2^.Apply[p1[left]];
IF NOT t2.found THEN RETURN [TRUE];
RETURN [NOT TreesEqual[data, p1[right], t2.it]]};
IF dec1^.Size # dec2^.Size THEN RETURN [FALSE];
RETURN [NOT dec1^.Scan[LookForMissing].found]}};
HashTree: PROC [data: REF ANY, v: Sets.Value] RETURNS [CARDINAL] ~ {
dag: StepDAG ~ NARROW[data];
elt: StepNode ~ NARROW[v.VA];
dec: Decomp ~ GetDecomp[dag, elt, FALSE];
IF dec=NIL THEN RETURN SetBasics.HashRefI[dag.toThing.ApplyA[elt].MA];
{hash: CARD ← 0;
HashPair: PROC [pair: BiRels.Pair] ~ {
step: CARD ← nameStepSpace.SHash[pair[left]];
IF step=0 THEN step ← CARDINAL.LAST.LONG.SUCC;
hash ← hash + step * HashTree[data, pair[right]];
RETURN};
dec^.Enumerate[HashPair];
RETURN SetBasics.HashIntI[LOOPHOLE[hash]]}};
CompareTrees: PROC [data: REF ANY, v1, v2: Sets.Value] RETURNS [c: Basics.Comparison] ~ {
dag: StepDAG ~ NARROW[data];
elt1: StepNode ~ NARROW[v1.VA];
elt2: StepNode ~ NARROW[v2.VA];
dec1: Decomp ~ GetDecomp[dag, elt1, FALSE];
dec2: Decomp ~ GetDecomp[dag, elt2, FALSE];
leaf1: BOOL ~ dec1=NIL;
leaf2: BOOL ~ dec2=NIL;
Test: PROC [a, b: BiRels.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.SCompare[a.it[left], b.it[left]];
IF c=equal THEN c ← CompareTrees[data, a.it[right], b.it[right]];
pass ← c#equal;
RETURN};
SELECT TRUE FROM
leaf1 > leaf2 => RETURN [less];
leaf1 < leaf2 => RETURN [greater];
leaf1 => RETURN SetBasics.CompareRefI[dag.toThing.ApplyA[elt1].MA, dag.toThing.ApplyA[elt2].MA];
ENDCASE => {
c ← equal;
[] ← dec1^.ParallelScan[dec2^, Test, [ALL[fwd]], [ALL[fwd]]];
RETURN};
};
END.