LichenStructuringImpl.Mesa
Last tweaked by Mike Spreitzer on May 4, 1988 5:16:16 pm PDT
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 [description:
ROPE, rootNode: StepNode, from: StepDAG]
RETURNS [dag: StepDAG] ~ {
dag ←
NEW [StepDAGPrivate ← [
down: BiRels.CreateHashFn[invable: FALSE],
up: BiRels.CreateHashOTO[],
toThing: BiRels.nilBiRel,
cands: Sets.CreateHashSet[],
rootNode: IF rootNode#NIL THEN rootNode ELSE CreateStepNode[],
description: IF description#NIL THEN description ELSE Rope.Cat["a subpart of ", from.description] ]];
IF from=
NIL
THEN dag.toThing ← BiRels.CreateHashFn[]
ELSE {
dag.toThing ← from.toThing;
dag.prefixd ← from.prefixd;
dag.leavesCommonized ← from.leavesCommonized};
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: BOOL ← TRUE;
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: BOOL ← TRUE;
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: BOOL ← TRUE;
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 [d: Design, 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, rightSpace: d.eSpace];
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: BOOL ← FALSE;
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: BOOL ← FALSE;
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,
AHash: HashTree,
ACompare: CompareTrees,
name: dag.description,
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: SetBasics.TotalComparison] ~ {
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:
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.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[Sets.fwd]], [ALL[Sets.fwd]]];
RETURN};
};
END.