aboutsummaryrefslogtreecommitdiff
path: root/sucl/extract.icl
diff options
context:
space:
mode:
Diffstat (limited to 'sucl/extract.icl')
-rw-r--r--sucl/extract.icl216
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