diff options
Diffstat (limited to 'sucl/extract.icl')
| -rw-r--r-- | sucl/extract.icl | 216 |
1 files changed, 128 insertions, 88 deletions
diff --git a/sucl/extract.icl b/sucl/extract.icl index 97b09f7..a7223d3 100644 --- a/sucl/extract.icl +++ b/sucl/extract.icl @@ -2,6 +2,13 @@ implementation module extract // $Id$ +import rule +import dnc +import graph +import basic +from general import Yes,No +import StdEnv + /* extract.lit - Folding of subject graphs @@ -52,38 +59,43 @@ areas for parts that aren't folded. `Self' determines whether an instance of a history graph is the history graph itself. We don't want to fold back something we unfolded earlier! +*/ -> actualfold :: -> [**] -> -> [**] -> -> (rgraph * **->(*,[**])) -> -> (***->**->bool) -> -> (*,[***]) -> -> [(***,graph * ***)] -> -> rule * ** -> -> optional (rule * **,[rgraph * **]) - -> actualfold deltanodes rnfnodes foldarea self foldcont hist rule -> = Absent, if list3=[] -> = Present (mkrule rargs rroot rgraph'',areas'), otherwise -> where rargs = lhs rule; rroot = rhs rule; rgraph = rulegraph rule - -> list2 = map (pairwith (findoccs hist rule)) (nodelist rgraph [rroot]--nodelist rgraph rargs) -> || list2: list combining every node with list of every instantiable history graph - -> list3 = [(rnode,hgraph,mapping)|(rnode,(((hroot,hgraph),mapping):rest))<-list2] -> || list3: list combining every instantiable node with first instantiable history graph - -> rgraph' -> = foldr foldrec rgraph list3 -> where foldrec (rnode,hgraph,mapping) = updategraph rnode (mapsnd (map (lookup mapping)) foldcont) - -> (rgraph'',areas') = finishfold foldarea fixednodes singlenodes rroot rgraph' -> fixednodes = intersect (mkset (argnodes++foldednodes++rnfnodes)) (nodelist rgraph' [rroot]) -> singlenodes = intersect deltanodes (nodelist rgraph' [rroot]) -> argnodes = nodelist rgraph' rargs -> foldednodes = map fst3 list3 +actualfold :: + [var] + [var] + ((Rgraph sym var)->Node sym var) + (pvar->var->bool) + (sym,[pvar]) + [(pvar,Graph sym pvar)] + (Rule sym var) + -> Optional (Rule sym var,[Rgraph sym var]) + | == var + & == pvar + +actualfold deltanodes rnfnodes foldarea self foldcont hist rule +| isEmpty list3 + = No += Yes (mkrule rargs rroot rgraph``,areas`) + where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule + + list2 = map (pairwith (findoccs hist rule)) (removeMembers (varlist rgraph [rroot]) (varlist rgraph rargs)) + // list2: list combining every node with list of every instantiable history graph + + list3 = [(rnode,hgraph,mapping) \\ (rnode,[((hroot,hgraph),mapping):_])<-list2] + // list3: list combining every instantiable node with first instantiable history graph + + rgraph` + = foldr foldrec rgraph list3 + where foldrec (rnode,hgraph,mapping) = updategraph rnode (mapsnd (map (lookup mapping)) foldcont) + + (rgraph``,areas`) = finishfold foldarea fixednodes singlenodes rroot rgraph` + fixednodes = intersect (removeDup (argnodes++foldednodes++rnfnodes)) (varlist rgraph` [rroot]) + singlenodes = intersect deltanodes (varlist rgraph` [rroot]) + argnodes = varlist rgraph` rargs + foldednodes = map fst3 list3 +/* > findoccs > :: [(***,graph * ***)] -> > rule * ** -> @@ -107,37 +119,67 @@ graph itself. We don't want to fold back something we unfolded earlier! > = disjoint inner outer > where inner = map (lookup mapping) (fst (nodeset hgraph [hroot])) > outer = nodelist (prunegraph rnode rgraph) (rroot:rargs)--[rnode] +*/ + +findoccs :: + [(pvar,Graph sym pvar)] + (Rule sym var) + var + -> [((pvar,Graph sym pvar),[(pvar,var)])] + | == var + & == pvar + +findoccs hist rule rnode += [ ((hroot,hgraph),mapping) + \\ ((hroot,hgraph),(seen,mapping,[]))<-list1 // Find instantiable history rgraphs... + | unshared rnode (hroot,hgraph) mapping // ...which don't have shared contents + ] + where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule + list1 + = [((hroot,hgraph),inst (hroot,hgraph))\\(hroot,hgraph)<-hist] + where inst (hroot,hgraph) + = instantiate (hgraph,rgraph) (hroot,rnode) ([],[],[]) + // list1: all instantiation attempts at rnode with the history rgraphs + + unshared rnode (hroot,hgraph) mapping + = disjoint inner outer + where inner = map (lookup mapping) (fst (graphvars hgraph [hroot])) + outer = removeMembers (varlist (prunegraph rnode rgraph) [rroot:rargs]) [rnode] + +instantiate = undef +/* ------------------------------------------------------------------------ Splitting a rule into areas to fold to a certain area +*/ -> splitrule -> :: (rgraph * **->(*,[**])) -> -> [**] -> -> [**] -> -> rule * ** -> -> rgraph * ** -> -> (rule * **,[rgraph * **]) - -> splitrule fold rnfnodes deltanodes rule area -> = (mkrule rargs rroot rgraph'',area':areas) -> where - -> rargs = lhs rule; rroot = rhs rule; rgraph = rulegraph rule -> aroot = rgraphroot area; agraph = rgraphgraph area - -> (rgraph'',areas) = finishfold fold fixednodes deltanodes rroot rgraph' -> fixednodes = intersect (mkset (aroot:nodelist rgraph' rargs++rnfnodes)) (nodelist rgraph' [rroot]) -> rgraph' = updategraph aroot (fold area') rgraph -> area' = mkrgraph aroot agraph' -> agraph' = foldr addnode emptygraph ins -> ins = nodelist agraph [aroot]--outs -> outs = nodelist (prunegraph aroot rgraph) (rroot:rargs++snd (nodeset agraph [aroot]))--[aroot] - -> addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node)) +splitrule :: + ((Rgraph sym var)->Node sym var) + [var] + [var] + (Rule sym var) + (Rgraph sym var) + -> (Rule sym var,[Rgraph sym var]) + | == var + +splitrule fold rnfnodes deltanodes rule area += (mkrule rargs rroot rgraph``,[area`:areas]) + where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule + aroot = rgraphroot area; agraph = rgraphgraph area + + (rgraph``,areas) = finishfold fold fixednodes deltanodes rroot rgraph` + fixednodes = intersect (removeDup [aroot:varlist rgraph` rargs++rnfnodes]) (varlist rgraph` [rroot]) + rgraph` = updategraph aroot (fold area`) rgraph + area` = mkrgraph aroot agraph` + agraph` = foldr addnode emptygraph ins + ins = removeMembers (varlist agraph [aroot]) outs + outs = removeMembers (varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]) [aroot] + + addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node)) +/* ------------------------------------------------------------ @@ -145,38 +187,36 @@ Splitting a rule into areas to fold to a certain area by introducing areas for parts of the graph that are not fixed in some way (e.g. when part of the pattern of the rule, already folded, or bearing a delta function symbol). - -> finishfold -> :: (rgraph * **->(*,[**])) -> -> [**] -> -> [**] -> -> ** -> -> graph * ** -> -> (graph * **,[rgraph * **]) - -> finishfold foldarea fixednodes singlenodes root graph -> = (graph',areas) -> where graph' = foldr foldarea' graph areas -> foldarea' area = updategraph (rgraphroot area) (foldarea area) -> areas = depthfirst generate process arearoots -> process aroot -> = mkrgraph aroot (foldr addnode emptygraph ins) -> where outs_and_aroot = nodelist (prunegraph aroot graph) arearoots++fixednodes -> ins = aroot:nodelist graph [aroot]--outs_and_aroot -> generate area -> = snd (nodeset agraph [aroot])--fixednodes -> where aroot = rgraphroot area; agraph = rgraphgraph area -> arearoots = mkset (root:singlenodes++singfixargs)--fixednodes -> singfixargs = concat (map arguments (singlenodes++fixednodes)) - -> arguments node -> = args, if def -> = [], otherwise -> where (def,(sym,args)) = dnc (const "in finishfold/1") graph node - -> addnode node -> = updategraph node cnt, if def -> = id, otherwise -> where (def,cnt) = dnc (const "in finishfold/2") graph node - */ + +finishfold :: + ((Rgraph sym var)->Node sym var) + [var] + [var] + var + (Graph sym var) + -> (Graph sym var,[Rgraph sym var]) + | == var + +finishfold foldarea fixednodes singlenodes root graph += (graph`,areas) + where graph` = foldr foldarea` graph areas + foldarea` area = updategraph (rgraphroot area) (foldarea area) + areas = depthfirst generate process arearoots + process aroot + = mkrgraph aroot (foldr addnode emptygraph ins) + where outs_and_aroot = varlist (prunegraph aroot graph) arearoots++fixednodes + ins = [aroot:removeMembers (varlist graph [aroot]) outs_and_aroot] + generate area + = removeMembers (snd (graphvars agraph [aroot])) fixednodes + where aroot = rgraphroot area; agraph = rgraphgraph area + arearoots = removeMembers (removeDup [root:singlenodes++singfixargs]) fixednodes + singfixargs = flatten (map arguments (singlenodes++fixednodes)) + + arguments node + = if def args [] + where (def,(_,args)) = dnc (const "in finishfold/1") graph node + + addnode node + = if def (updategraph node cnt) id + where (def,cnt) = dnc (const "in finishfold/2") graph node |