Commit 0ae161cb authored by Vincent Zweije's avatar Vincent Zweije
Browse files

Translate canosisation module from Miranda to Clean

parent 3bc4f58b
definition module canon definition module canon
// $Id$
from rule import Rule,Rgraph
from graph import Node
from StdOverloaded import ==
// Canonises area into task expression
// so equivalent ones can be detected through '==' comparison.
canonise ::
(sym -> Rule tsym tvar) // Get type rule of a symbol (for eta expansion)
[var2] // Heap (nodespace) for consistent relabeling
(Rgraph sym var1) // Input rooted graph
-> Rgraph sym var2 // Canonised rooted graph
| == var1
// Fold an area in a subject graph
foldarea ::
((Rgraph sym var) -> sym) // Labeling function, assigning names to areas
(Rgraph sym var) // Area to fold
-> Node sym var // Resulting function application
| == var
labelarea ::
[Rgraph sym var] // List of areas to be labeled
[sym] // List of symbols to assign to them
(Rgraph sym var) // Rooted graph to label
-> sym // Assigned symbol
| == sym
& == var
...@@ -2,6 +2,11 @@ implementation module canon ...@@ -2,6 +2,11 @@ implementation module canon
// $Id$ // $Id$
import rule
import graph
import basic
import StdEnv
/* /*
canon.lit - Area canonicalization canon.lit - Area canonicalization
...@@ -49,13 +54,29 @@ steps: ...@@ -49,13 +54,29 @@ steps:
(3) Relabeling the nodes in a standard way. (3) Relabeling the nodes in a standard way.
> canonise :: (*->rule **** *****) -> [***] -> rgraph * ** -> rgraph * *** > canonise :: (*->rule **** *****) -> [***] -> rgraph * ** -> rgraph * ***
> canonise typerule heap = relabel heap.uncurry typerule.split.relabel localheap > canonise typerule heap = relabel heap.etaexpand typerule.splitrg.relabel localheap
*/
canonise :: (sym -> Rule tsym tvar) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise typerule heap rg
= (relabel heap o etaexpand typerule o splitrg o relabel localheap) rg
/*
> split :: rgraph * num -> rgraph * num > split :: rgraph * num -> rgraph * num
> split rgraph > split rgraph
> = foldsingleton single rgraph rgraph > = foldsingleton single rgraph rgraph
> where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (localheap--[root]))) emptygraph) > where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (localheap--[root]))) emptygraph)
*/
splitrg :: (Rgraph sym Int) -> Rgraph sym Int
splitrg rgraph
= foldsingleton single rgraph rgraph
where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (removeMembers localheap [root]))) emptygraph)
/*
> uncurry :: (*->rule **** *****) -> rgraph * num -> rgraph * num > uncurry :: (*->rule **** *****) -> rgraph * num -> rgraph * num
> uncurry typerule rgraph > uncurry typerule rgraph
> = f (nc root) > = f (nc root)
...@@ -65,17 +86,38 @@ steps: ...@@ -65,17 +86,38 @@ steps:
> f cont = rgraph > f cont = rgraph
> nc = nodecontents graph > nc = nodecontents graph
> root = rgraphroot rgraph; graph = rgraphgraph rgraph > root = rgraphroot rgraph; graph = rgraphgraph rgraph
*/
etaexpand :: (sym->Rule tsym tvar) (Rgraph sym Int) -> Rgraph sym Int
etaexpand typerule rgraph
= f (nc root)
where f (True,(sym,args))
= mkrgraph root (updategraph root (sym,fst (claim targs (args++(removeMembers localheap (varlist graph [root]))))) graph)
where targs = arguments (typerule sym)
f cont = rgraph
nc = varcontents graph
root = rgraphroot rgraph; graph = rgraphgraph rgraph
> localheap = [0..] localheap :: [Int]
localheap =: [0..]
/*
------------------------------------------------------------------------ ------------------------------------------------------------------------
> foldarea :: (rgraph * **->*) -> rgraph * ** -> (*,[**]) > foldarea :: (rgraph * **->*) -> rgraph * ** -> (*,[**])
> foldarea label rgraph > foldarea label rgraph
> = (label rgraph,foldsingleton single nosingle rgraph) > = (label rgraph,foldsingleton single nosingle rgraph)
> where single root sym args = args > where single root sym args = args
> nosingle = snd (nodeset (rgraphgraph rgraph) [rgraphroot rgraph]) > nosingle = snd (varset (rgraphgraph rgraph) [rgraphroot rgraph])
*/
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label rgraph
= (label rgraph,foldsingleton single nosingle rgraph)
where single root sym args = args
nosingle = snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph])
/*
------------------------------------------------------------------------ ------------------------------------------------------------------------
> labelarea :: [rgraph * **] -> [*] -> rgraph * ** -> * > labelarea :: [rgraph * **] -> [*] -> rgraph * ** -> *
...@@ -91,9 +133,31 @@ steps: ...@@ -91,9 +133,31 @@ steps:
> getlabel (True,(asym,aargs)) labels = (asym,labels), if ~or (map (fst.nc) aargs) > getlabel (True,(asym,aargs)) labels = (asym,labels), if ~or (map (fst.nc) aargs)
> getlabel acont (label:labels) = (label,labels) > getlabel acont (label:labels) = (label,labels)
> getlabel = error "maketable: out of labels" > getlabel = error "maketable: out of labels"
> nc = nodecontents agraph > nc = varcontents agraph
> aroot = rgraphroot area; agraph = rgraphgraph area > aroot = rgraphroot area; agraph = rgraphgraph area
*/
labelarea :: [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea areas labels rg
= foldmap id nolabel (maketable areas labels) rg
where nolabel = abort "canon: labelarea: no label assigned to area"
maketable :: [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable [] _ = []
maketable [area:areas] labels
= [(area,label):maketable areas labels`]
where (label,labels`) = getlabel (nc aroot) labels
getlabel (True,(asym,aargs)) labels
| not (or (map (fst o nc) aargs))
= (asym,labels)
getlabel acont [label:labels]
= (label,labels)
getlabel _ _
= abort "canon: maketable: out of labels"
nc = varcontents agraph
aroot = rgraphroot area; agraph = rgraphgraph area
/*
------------------------------------------------------------------------ ------------------------------------------------------------------------
> relabel :: [***] -> rgraph * ** -> rgraph * *** > relabel :: [***] -> rgraph * ** -> rgraph * ***
...@@ -111,7 +175,25 @@ steps: ...@@ -111,7 +175,25 @@ steps:
> = id, otherwise > = id, otherwise
> where (def,(sym,args)) = nc node > where (def,(sym,args)) = nc node
> nc = nodecontents graph > nc = nodecontents graph
*/
relabel :: [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
relabel heap rgraph
= mkrgraph (move root) graph`
where root = rgraphroot rgraph; graph = rgraphgraph rgraph
nodes = varlist graph [root]
table = zip2 nodes heap
move = foldmap id nonew table
nonew = abort "relabel: no new node assigned to node"
graph` = foldr addnode emptygraph table
addnode (node,node`)
| def
= updategraph node` (sym,map move args)
= id
where (def,(sym,args)) = nc node
nc = varcontents graph
/*
> foldsingleton > foldsingleton
> :: (**->*->[**]->***) -> > :: (**->*->[**]->***) ->
> *** -> > *** ->
...@@ -124,5 +206,21 @@ steps: ...@@ -124,5 +206,21 @@ steps:
> f cont = nosingle > f cont = nosingle
> nc = nodecontents graph > nc = nodecontents graph
> root = rgraphroot rgraph; graph = rgraphgraph rgraph > root = rgraphroot rgraph; graph = rgraphgraph rgraph
*/ */
foldsingleton ::
(var sym [var] -> pvar)
pvar
(Rgraph sym var)
-> pvar
| == var
foldsingleton single nosingle rgraph
= case nc root
of (True,(sym,args))
| not (or (map (fst o nc) args))
-> single root sym args
_
-> nosingle
where nc = varcontents graph
root = rgraphroot rgraph; graph = rgraphgraph rgraph
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment