1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
implementation module rule
// $Id$
import graph
import basic
import StdEnv
:: Rule sym var
= RuleAlias [var] var (Graph sym var)
:: Rgraph sym var
= RgraphAlias var (Graph sym var)
/*
rule.lit - Rooted graphs and rules
==================================
Description
-----------
This module implements abstract types for rooted graphs and rules,
together with some useful functions on them. Though very simple
definitions, it greatly helps the readability of error messages if
rooted graphs or rules occur in them.
A rooted graph is a tuple consisting of a root and an unrooted graph
(how obvious).
The implementation of a rule is less obvious. Instead of simply using a
graph with two roots, the root of the pattern and its associated
function symbol have been taken out. Hence the pattern is only
accessibly by its arguments. The root of the replacement is still
accessible. The reason for this is twofold: the root must be defined
anyway, and if the rule is a type rule, we are now able to use two
different domains for (normal) symbols and type symbols.
------------------------------------------------------------
Interface
---------
Exported identifiers:
> %export
> compilerule || Compile a rule from all loose parts
> emptyrgraph || Creates an empty rooted graph
> lhs || Determines the left root of a rule
> mkrgraph || Composes a rooted graph from a root and a graph
> mkrule || Composes a rule from left and right roots and a graph
> printrgraph || Makes a readable representation of a rooted graph
> printrule || Makes a readable representation of a rule
> prunergraph || Undefines the contents of a node of a rooted graph
> rgraph || Type of rooted graph over functorspace * and nodespace **
> rgraphgraph || Determines the (unrooted) graph of a rooted graph
> rgraphroot || Determines the root of a rooted graph
> rhs || Determines the right root of a rule
> rule || Type of rules over functorspace * and nodespace **
> rulegraph || Determines the graph of a rule
> showrgraph || Make a representation of a rooted graph
> showrule || Make a representation of a rule
> updatergraph || Updates the contents of a node of a rooted graph
Required types:
mkrgraph - graph@graph.lit
mkrule - graph@graph.lit
rgraphgraph - graph@graph.lit
rulegraph - graph@graph.lit
------------------------------------------------------------
Includes
--------
> %include "basic.lit"
> %include "graph.lit" -extgraph
------------------------------------------------------------
Implementation
--------------
> abstype rgraph * **
> with emptyrgraph :: ** -> rgraph * **
> updatergraph :: ** -> (*,[**]) -> rgraph * ** -> rgraph * **
> prunergraph :: ** -> rgraph * ** -> rgraph * **
> rgraphroot :: rgraph * ** -> **
> rgraphgraph :: rgraph * ** -> graph * **
> mkrgraph :: ** -> graph * ** -> rgraph * **
> showrgraph :: (*->[char]) -> (**->[char]) -> rgraph * ** -> [char]
> printrgraph :: (*->[char]) -> (**->[char]) -> rgraph * ** -> [char]
> abstype rule * **
> with mkrule :: [**] -> ** -> graph * ** -> rule * **
> lhs :: rule * ** -> [**]
> rhs :: rule * ** -> **
> rulegraph :: rule * ** -> graph * **
> showrule :: (*->[char]) -> (**->[char]) -> rule * ** -> [char]
> printrule :: (*->[char]) -> (**->[char]) -> rule * ** -> [char]
Rooted graphs
> emptyrgraph root = (root,emptygraph)
> updatergraph node contents (root,graph) = (root,updategraph node contents graph)
> prunergraph node (root,graph) = (root,prunegraph node graph)
> rgraphroot (root,graph) = root
> rgraphgraph (root,graph) = graph
> mkrgraph root graph = (root,graph)
*/
emptyrgraph :: var -> .Rgraph sym var
emptyrgraph root = RgraphAlias root emptygraph
updatergraph :: var .(Node sym var) !.(Rgraph sym var) -> .Rgraph sym var
updatergraph var node rgraph = maprgraph (mapsnd (updategraph var node)) rgraph
prunergraph :: var !.(Rgraph sym var) -> .Rgraph sym var
prunergraph var rgraph = maprgraph (mapsnd (prunegraph var)) rgraph
rgraphroot :: !.(Rgraph sym var) -> var
rgraphroot (RgraphAlias root _) = root
rgraphgraph :: !.(Rgraph sym var) -> Graph sym var
rgraphgraph (RgraphAlias _ graph) = graph
mkrgraph :: var (Graph sym var) -> .Rgraph sym var
mkrgraph root graph = RgraphAlias root graph
maprgraph :: (.(var1,Graph sym1 var1) -> .(var2,Graph sym2 var2)) !.(Rgraph sym1 var1) -> .Rgraph sym2 var2
maprgraph f (RgraphAlias root1 graph1) = RgraphAlias root2 graph2
where (root2,graph2) = f (root1,graph1)
instance toString (Rgraph sym var) | toString sym & toString var & Eq var
where toString rgraph = showrgraph toString toString rgraph
showrgraph ::
(sym->String)
(var->String)
(Rgraph sym var)
-> String
| == var
showrgraph showsym showvar (RgraphAlias root graph)
= "("+++snd (showsubgraph root ([],"emptyrgraph) "))+++showvar root
where showsubgraph node (seen,repr)
| not def || isMember node seen
= (seen,repr)
= (seen``,repr``)
where (def,(f,args)) = varcontents graph node
(seen``,repr`) = foldlr showsubgraph (seen`,repr) args
seen` = [node:seen]
repr`` = "updatergraph "+++showvar node+++" ("+++showsym f+++","+++showlist showvar args+++") o "+++repr`
/*
> printrgraph showfunc shownode (root,graph)
> = hd (printgraph showfunc shownode graph [root])
*/
instance <<< (Rgraph sym var) | toString sym & toString var & == var
where (<<<) file (RgraphAlias root graph)
= file <<< hd (printgraph graph [root])
/*
Rules
> mkrule lroots rroot graph = (lroots,rroot,graph)
> lhs (lroots,rroot,graph) = lroots
> rhs (lroots,rroot,graph) = rroot
> rulegraph (lroots,rroot,graph) = graph
*/
mkrule :: .[var] var (Graph sym var) -> .Rule sym var
mkrule args root graph = RuleAlias args root graph
arguments :: !.(Rule sym var) -> [var]
arguments (RuleAlias args _ _) = args
ruleroot :: !.(Rule sym var) -> var
ruleroot (RuleAlias _ root _) = root
rulegraph :: !.(Rule sym var) -> Graph sym var
rulegraph (RuleAlias _ _ graph) = graph
/*
> printrule showfunc shownode (lroots,rroot,graph)
> = (concat.map (++" ").init) reprs++"-> "++last reprs
> where reprs = printgraph showfunc shownode graph (lroots++[rroot])
> compilerule :: [**] -> ** -> [(**,(*,[**]))] -> rule * **
> compilerule args root = mkrule args root.compilegraph
*/
instance == (Rgraph sym var) | == sym & == var
where (==) (RgraphAlias root1 graph1) (RgraphAlias root2 graph2)
= root1==root2 && graph1==graph2
instance toString (Rule sym var) | toString sym & toString var & == var
where toString rule = showrule toString toString rule
showrule ::
(sym->String)
(var->String)
(Rule sym var)
-> String
| == var
showrule showsym showvar (RuleAlias lroots rroot graph)
= "((mkrule "+++showlist showvar lroots+++" "+++showvar rroot+++repr`+++") emptygraph)"
where (seen,repr`) = foldlr showsubgraph ([],repr) lroots
(seen`,repr) = showsubgraph rroot (seen,"")
showsubgraph node (seen,repr)
| not def || isMember node seen
= (seen,repr)
= (seen``,repr``)
where (def,(f,args)) = varcontents graph node
(seen``,repr`) = foldlr showsubgraph (seen`,repr) args
seen` = [node:seen]
repr`` = " o updategraph "+++showvar node+++" ("+++showsym f+++","+++showlist showvar args+++")"+++repr`
ruleToString :: (sym->.String) .(Rule sym var) -> String | Eq,toString var
ruleToString symToString (RuleAlias lroots rroot graph)
/*
= if def ("<rule with root "+++symToString sym+++">") "<rule with no root>"
where (def,(sym,args)) = varcontents graph rroot
*/
= "((mkrule "+++showlist toString lroots+++" "+++toString rroot+++repr`+++") emptygraph)"
where (seen,repr`) = foldlr showsubgraph ([],repr) lroots
(seen`,repr) = showsubgraph rroot (seen,"")
showsubgraph node (seen,repr)
| not def || isMember node seen
= (seen,repr)
= (seen``,repr``)
where (def,(f,args)) = varcontents graph node
(seen``,repr`) = foldlr showsubgraph (seen`,repr) args
seen` = [node:seen]
repr`` = " o updategraph "+++toString node+++" ("+++symToString f+++","+++showlist toString args+++")"+++repr`
instance <<< (Rule sym var) | toString sym & toString,== var
where (<<<) file rule = file <<< toString rule
(writergraph) infixl :: *File .(Rgraph sym var) -> .File | toString sym & ==,toString var
(writergraph) file rgraph = file <<< rgraph
(writerule) infixl :: *File .(Rule sym var) -> .File | toString sym & ==,toString var
(writerule) file rule = file <<< rule
showruleanch ::
(sym->String)
(var->String)
[Bool]
(Rule sym var)
[var]
-> String
| == var
showruleanch showsym showvar stricts rule anchors
= foldr (+++) "" (map2 annot stricts argreprs)+++"-> "+++rootrepr
where graph = rulegraph rule; args = arguments rule; root = ruleroot rule
(argreprs,[rootrepr:anchorreprs]) = claim args reprs
reprs = printgraphBy showsym showvar graph (args++[root:anchors])
annot strict repr = (if strict ((+++) "!") id) (repr+++" ")
|
