<> <> 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=0 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 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.