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
|
(*kitlife35u.sml*)
(*based on kitlifeopt.sml, but with copying
to avoid many generations in the same region*)
local
fun eq_integer (x: int, y: int): bool = x = y
fun eq_string (x: string, y: string): bool = x = y
fun eq_integer_curry(x)(y:int) =eq_integer(x,y)
fun eq_int_pair_curry (x,x')(y,y'): bool =
eq_integer(x,y) andalso eq_integer(x',y')
fun app f [] = ()
| app f (x::xs) = (f x; app f xs)
fun map f [] = []
| map f (a::x) = f a :: map f x
fun map_rec(f, []) = []
| map_rec(f, x::xs) = f x:: map_rec(f, xs)
exception ex_undefined of string
fun error str = raise ex_undefined str
fun accumulate f a [] = a (* this now has no escaping regions, although still an escaping arrow effect*)
| accumulate f a (b::x) = accumulate f (f a b) x
fun accumulate' (f, a, []) = a
| accumulate' (f, a, b::x) = accumulate'(f, f(a,b), x)
fun filter p l=
rev (accumulate (fn x => fn a => if p a then a::x else x) [] l)
(*builds an intermediate list; the regions of this list
are now made local (unlike in escape.sml) *)
fun equal a b = a=b
fun exists p [] = false
| exists p (a::x) = if p a then true else exists p x
fun exists' (p, []) = false
| exists' (p, (a::x)) = p a orelse exists'(p,x)
fun member eq x a = exists' (eq a, x)
fun C f x y = f y x
fun cons a x = a::x
fun revonto x y = accumulate' ((fn (x,y) => y::x), x, y)
fun copy_int n = n+0
fun length x = copy_int(let fun count (n, a) = n+1 in accumulate'(count, 0, x) end)
(* eta expanded*)
fun repeat f = let (* rptf moved into inner let *)
fun check n = if n<0 then error "repeat<0" else n
in fn x => fn y => let fun rptf n x = if n=0 then x else rptf(n-1)(f x)
in rptf (check x) y
end
end
fun copy n x = repeat (cons x) n []
fun spaces n = implode (copy n #" ")
fun copy_list[] = []
| copy_list((x,y)::rest) = (x+0,y+0):: copy_list rest
fun lexless(a2,b2)(a1:int,b1:int) =
if a2<a1 then true else if a2=a1 then b2<b1 else false
fun length l = case l of
[] => 0
| x::xs => 1 + length xs
fun copy [] = []
| copy (x::xs) = x :: copy xs
fun take(i,l) =
case l of [] => []
| x::xs=> if i>0 then x::take(i-1,xs) else nil
fun drop(i,l) = case l of [] => []
| x::xs => if i>0 then drop(i-1,xs) else l
fun merge(lp as (left, right)) =
case left of [] => right
| x::xs => (case right of
[] => left
| y::ys => if lexless x y then x::merge(xs, right)
else if lexless y x then y:: merge(left,ys)
else (*x=y*) merge(xs, right)
)
fun tmergesort l =
case l of [] => []
| x::xs => (case xs of []=> l
| _ => let val k = length l div 2
in merge(copy (tmergesort(take(k,l))),
copy (tmergesort(drop(k,l))))
end
)
fun lexordset x = tmergesort x
fun collect f list =
let fun accumf sofar [] = sofar
| accumf sofar (a::x) = accumf (revonto sofar (f a)) x
in accumf [] list (* note: this worked without changes!*)
end
fun occurs3 x =
(* finds coords which occur exactly 3 times in coordlist x *)
let fun f (q) =
case q of (_,_,_,_,[]) => q
| ( xover, x3, x2, x1, (a::x)) =>
if member eq_int_pair_curry xover a then f( xover, x3, x2, x1, x) else
if member eq_int_pair_curry x3 a then f ((a::xover), x3, x2, x1, x) else
if member eq_int_pair_curry x2 a then f (xover, (a::x3), x2, x1, x) else
if member eq_int_pair_curry x1 a then f (xover, x3, (a::x2), x1, x) else
f (xover, x3, x2, (a::x1), x)
fun diff x y = filter (fn x => not(member eq_int_pair_curry y x)) x (* unfolded o *)
val (xover, x3, _, _, _) = f ([],[],[],[],x)
in diff x3 xover end
fun copy_string s= implode(explode s)
fun copy_bool true = true
| copy_bool false = false
fun neighbours (i,j) = [(i-1,j-1),(i-1,j),(i-1,j+1),
(i,j-1),(i,j+1),
(i+1,j-1),(i+1,j),(i+1,j+1)]
abstype generation = GEN of (int*int) list
with
fun copy (GEN l) = GEN( copy_list l)
fun alive (GEN livecoords) = livecoords
and mkgen coordlist = GEN (lexordset coordlist)
and mk_nextgen_fn gen =
if true then
let val living = alive gen
fun isalive x = copy_bool(member eq_int_pair_curry living x) (* eta *)
fun liveneighbours x = length( filter isalive ( neighbours x)) (*eta*)
fun twoorthree n = eq_integer(n,2) orelse eq_integer(n,3)
val survivors = copy_list(filter (twoorthree o liveneighbours) living)
val newnbrlist = copy_list(collect (fn z => filter (fn x => not( isalive x)) ( neighbours z)) living) (* unfolded o twice*)
val newborn = copy_list(occurs3 newnbrlist)
in mkgen (survivors @ newborn) end
else gen
end
local val xstart = 0 and ystart = 0
fun markafter n string = string ^ spaces n ^ "0"
fun plotfrom (x,y) (* current position *)
str (* current line being prepared -- a string *)
((x1,y1)::more) (* coordinates to be plotted *)
= if eq_integer(x,x1)
then (* same line so extend str and continue from y1+1 *)
plotfrom(x,y1+1)(markafter(y1-y)str)more
else (* flush current line and start a new line *)
str :: plotfrom(x+1,ystart)""((x1,y1)::more)
| plotfrom (x,y) str [] = [str]
fun good (x,y) = x>=xstart andalso y>=ystart
in fun plot coordlist = map_rec(copy_string,(plotfrom(xstart,ystart) ""
(copy_list(filter good coordlist))))
end
infix 6 at
fun coordlist at (x:int,y:int) = let fun move(a,b) = (a+x,b+y)
in map move coordlist end
fun rotate x = map (fn (x:int,y:int) => (y,~x)) x (* eta converted*)
val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)]
val bail = [(0,0),(0,1),(1,0),(1,1)]
fun barberpole n =
let fun f i = if eq_integer(i,n) then (n+n-1,n+n)::(n+n,n+n)::nil
else (i+i,i+i+1)::(i+i+2,i+i+1)::f(i+1)
in (0,0)::(1,0):: f 0
end
val genB = mkgen(glider at (2,2) @ bail at (2,12)
@ rotate (barberpole 4) at (5,20))
fun copy_whole_arg (p, g) = (copy_int p, copy g)
fun nthgen'(p as(0,g)) = p
| nthgen'(p as(i,g)) = (print ".\n";
nthgen' (copy_whole_arg(let val arg = (i-1,mk_nextgen_fn g)
val arg' = copy_whole_arg arg
in (*resetRegions arg; *)
arg'
end)))
fun gun() = mkgen (* turned into function *)
[(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18),
(5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18),
(6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28),
(7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41),
(9,29),(9,30),(9,31),(9,32)]
fun iter n = #2(nthgen'(n+0,gun()))
fun pr x = print x
fun show(x) = (pr "starting printing\n";
app (fn s => (pr s; pr "\n"))(plot(alive x));
()
) (* had to uncurry show, as iter 50 gave attop
also made it return a different unit *)
fun testit _ = show(iter 250) (* inserted call of iter *)
val _ = testit ()
in
val done = "done";
end
|
