3 (*based on kitlifeopt
.sml
, but
with copying
4 to avoid many generations
in the same region
*)
8 fun eq_integer (x
: int, y
: int): bool = x
= y
9 fun eq_string (x
: string, y
: string): bool = x
= y
11 fun eq_integer_curry(x
)(y
:int) =eq_integer(x
,y
)
12 fun eq_int_pair_curry (x
,x
')(y
,y
'): bool =
13 eq_integer(x
,y
) andalso eq_integer(x
',y
')
16 | app
f (x
::xs
) = (f x
; app f xs
)
20 | map
f (a
::x
) = f a
:: map f x
22 fun map_rec(f
, []) = []
23 |
map_rec(f
, x
::xs
) = f x
:: map_rec(f
, xs
)
25 exception ex_undefined
of string
26 fun error str
= raise ex_undefined str
28 fun accumulate f a
[] = a (* this now has no escaping regions
, although still an escaping arrow effect
*)
29 | accumulate f
a (b
::x
) = accumulate
f (f a b
) x
31 fun accumulate
' (f
, a
, []) = a
32 | accumulate
' (f
, a
, b
::x
) = accumulate
'(f
, f(a
,b
), x
)
35 rev (accumulate (fn x
=> fn a
=> if p a
then a
::x
else x
) [] l
)
36 (*builds an intermediate list
; the regions
of this list
37 are now made
local (unlike
in escape
.sml
) *)
42 fun exists p
[] = false
43 | exists
p (a
::x
) = if p a
then true else exists p x
45 fun exists
' (p
, []) = false
46 | exists
' (p
, (a
::x
)) = p a
orelse exists
'(p
,x
)
49 fun member eq x a
= exists
' (eq a
, x
)
56 fun revonto x y
= accumulate
' ((fn (x
,y
) => y
::x
), x
, y
)
60 fun length x
= copy_int(let fun count (n
, a
) = n
+1 in accumulate
'(count
, 0, x
) end)
63 fun repeat f
= let (* rptf moved into inner
let *)
64 fun check n
= if n
<0 then error
"repeat<0" else n
65 in fn x
=> fn y
=> let fun rptf n x
= if n
=0 then x
else rptf(n
-1)(f x
)
70 fun copy n x
= repeat (cons x
) n
[]
72 fun spaces n
= implode (copy n #
" ")
75 |
copy_list((x
,y
)::rest
) = (x
+0,y
+0):: copy_list rest
78 fun lexless(a2
,b2
)(a1
:int,b1
:int) =
79 if a2
<a1
then true else if a2
=a1
then b2
<b1
else false
83 fun length l
= case l
of
85 | x
::xs
=> 1 + length xs
87 |
copy (x
::xs
) = x
:: copy xs
90 | x
::xs
=> if i
>0 then x
::take(i
-1,xs
) else nil
91 fun drop(i
,l
) = case l
of [] => []
92 | x
::xs
=> if i
>0 then drop(i
-1,xs
) else l
93 fun merge(lp
as (left
, right
)) =
94 case left
of [] => right
95 | x
::xs
=> (case right
of
97 | y
::ys
=> if lexless x y
then x
::merge(xs
, right
)
98 else if lexless y x
then y
:: merge(left
,ys
)
99 else (*x
=y
*) merge(xs
, right
)
104 | x
::xs
=> (case xs
of []=> l
105 | _
=> let val k
= length l
div 2
106 in merge(copy (tmergesort(take(k
,l
))),
107 copy (tmergesort(drop(k
,l
))))
110 fun lexordset x
= tmergesort x
116 let fun accumf sofar
[] = sofar
117 | accumf
sofar (a
::x
) = accumf (revonto
sofar (f a
)) x
118 in accumf
[] list (* note
: this worked without changes
!*)
122 (* finds coords which occur exactly
3 times
in coordlist x
*)
124 case q
of (_
,_
,_
,_
,[]) => q
125 |
( xover
, x3
, x2
, x1
, (a
::x
)) =>
126 if member eq_int_pair_curry xover a
then f( xover
, x3
, x2
, x1
, x
) else
127 if member eq_int_pair_curry x3 a
then f ((a
::xover
), x3
, x2
, x1
, x
) else
128 if member eq_int_pair_curry x2 a
then f (xover
, (a
::x3
), x2
, x1
, x
) else
129 if member eq_int_pair_curry x1 a
then f (xover
, x3
, (a
::x2
), x1
, x
) else
130 f (xover
, x3
, x2
, (a
::x1
), x
)
131 fun diff x y
= filter (fn x
=> not(member eq_int_pair_curry y x
)) x (* unfolded
o *)
132 val (xover
, x3
, _
, _
, _
) = f ([],[],[],[],x
)
135 fun copy_string s
= implode(explode s
)
136 fun copy_bool
true = true
137 | copy_bool
false = false
139 fun neighbours (i
,j
) = [(i
-1,j
-1),(i
-1,j
),(i
-1,j
+1),
141 (i
+1,j
-1),(i
+1,j
),(i
+1,j
+1)]
144 abstype generation
= GEN
of (int*int) list
146 fun copy (GEN l
) = GEN( copy_list l
)
147 fun alive (GEN livecoords
) = livecoords
148 and mkgen coordlist
= GEN (lexordset coordlist
)
149 and mk_nextgen_fn gen
=
151 let val living
= alive gen
152 fun isalive x
= copy_bool(member eq_int_pair_curry living x
) (* eta
*)
153 fun liveneighbours x
= length( filter
isalive ( neighbours x
)) (*eta
*)
154 fun twoorthree n
= eq_integer(n
,2) orelse eq_integer(n
,3)
155 val survivors
= copy_list(filter (twoorthree
o liveneighbours
) living
)
156 val newnbrlist
= copy_list(collect (fn z
=> filter (fn x
=> not( isalive x
)) ( neighbours z
)) living
) (* unfolded
o twice
*)
157 val newborn
= copy_list(occurs3 newnbrlist
)
158 in mkgen (survivors @ newborn
) end
163 local val xstart
= 0 and ystart
= 0
164 fun markafter n
string = string ^ spaces n ^
"0"
165 fun plotfrom (x
,y
) (* current position
*)
166 str (* current line being prepared
-- a
string *)
167 ((x1
,y1
)::more
) (* coordinates to be plotted
*)
168 = if eq_integer(x
,x1
)
169 then (* same line so extend str
and continue from y1
+1 *)
170 plotfrom(x
,y1
+1)(markafter(y1
-y
)str
)more
171 else (* flush current line
and start a new line
*)
172 str
:: plotfrom(x
+1,ystart
)""((x1
,y1
)::more
)
173 |
plotfrom (x
,y
) str
[] = [str
]
174 fun good (x
,y
) = x
>=xstart
andalso y
>=ystart
175 in fun plot coordlist
= map_rec(copy_string
,(plotfrom(xstart
,ystart
) ""
176 (copy_list(filter good coordlist
))))
181 fun coordlist
at (x
:int,y
:int) = let fun move(a
,b
) = (a
+x
,b
+y
)
182 in map move coordlist
end
183 fun rotate x
= map (fn (x
:int,y
:int) => (y
,~x
)) x (* eta converted
*)
185 val glider
= [(0,0),(0,2),(1,1),(1,2),(2,1)]
186 val bail
= [(0,0),(0,1),(1,0),(1,1)]
188 let fun f i
= if eq_integer(i
,n
) then (n
+n
-1,n
+n
)::(n
+n
,n
+n
)::nil
189 else (i
+i
,i
+i
+1)::(i
+i
+2,i
+i
+1)::f(i
+1)
190 in (0,0)::(1,0):: f
0
193 val genB
= mkgen(glider
at (2,2) @ bail
at (2,12)
194 @
rotate (barberpole
4) at (5,20))
196 fun copy_whole_arg (p
, g
) = (copy_int p
, copy g
)
198 fun nthgen
'(p
as(0,g
)) = p
199 | nthgen
'(p
as(i
,g
)) = (print
".\n";
200 nthgen
' (copy_whole_arg(let val arg
= (i
-1,mk_nextgen_fn g
)
201 val arg
' = copy_whole_arg arg
202 in (*resetRegions arg
; *)
206 fun gun() = mkgen (* turned into function
*)
207 [(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18),
208 (5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18),
209 (6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28),
210 (7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41),
211 (9,29),(9,30),(9,31),(9,32)]
214 fun iter n
= #
2(nthgen
'(n
+0,gun()))
218 fun show(x
) = (pr
"starting printing\n";
219 app (fn s
=> (pr s
; pr
"\n"))(plot(alive x
));
221 ) (* had to uncurry show
, as iter
50 gave attop
222 also made it return a different unit
*)
224 fun testit _
= show(iter
250) (* inserted call
of iter
*)