Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (*klife_eq.sml*) |
2 | ||
3 | (*based on kitlifeopt.sml, but with copying | |
4 | to avoid many generations in the same region*) | |
5 | val _ = | |
6 | let | |
7 | ||
8 | (* | |
9 | structure Main : BMARK = | |
10 | struct | |
11 | *) | |
12 | ||
13 | fun map f [] = [] | |
14 | | map f (a::x) = f a :: map f x | |
15 | ||
16 | fun map_rec(f, []) = [] | |
17 | | map_rec(f, x::xs) = f x:: map_rec(f, xs) | |
18 | ||
19 | exception ex_undefined of string | |
20 | fun error str = raise ex_undefined str | |
21 | ||
22 | fun accumulate f a [] = a (* this now has no escaping regions, although still an escaping arrow effect*) | |
23 | | accumulate f a (b::x) = accumulate f (f a b) x | |
24 | ||
25 | fun filter p l= | |
26 | rev (accumulate (fn x => fn a => if p a then a::x else x) [] l) | |
27 | (*builds an intermediate list; the regions of this list | |
28 | are now made local (unlike in escape.sml) *) | |
29 | ||
30 | fun member x [] = false | |
31 | | member x (y::ys) = x =y orelse member x ys | |
32 | ||
33 | fun C f x y = f y x | |
34 | ||
35 | fun cons a x = a::x | |
36 | ||
37 | fun revonto x y = accumulate (C cons) x y (* eta expanded*) | |
38 | ||
39 | fun length x = (let fun count n a = n+1 in accumulate count 0 end) x | |
40 | (* eta expanded*) | |
41 | ||
42 | fun repeat f = let (* rptf moved into inner let *) | |
43 | fun check n = if n<0 then error "repeat<0" else n | |
44 | in fn x => fn y => let fun rptf n x = if n=0 then x else rptf(n-1)(f x) | |
45 | in rptf (check x) y | |
46 | end | |
47 | end | |
48 | ||
49 | fun copy n x = repeat (cons x) n [] | |
50 | ||
51 | fun spaces n = implode (copy n #" ") | |
52 | (*mads | |
53 | local | |
54 | mads*) | |
55 | fun copy_list[] = [] | |
56 | | copy_list((x,y)::rest) = (x,y):: copy_list rest | |
57 | ||
58 | fun lexordset [] = [] | |
59 | | lexordset (a::x) = lexordset (filter (lexless a) x) @ [a] @ | |
60 | lexordset (filter (lexgreater a) x) | |
61 | and lexless(a1:int,b1:int)(a2,b2) = | |
62 | if a2<a1 then true else if a2=a1 then b2<b1 else false | |
63 | and lexgreater pr1 pr2 = lexless pr2 pr1 | |
64 | ||
65 | fun collect f list = | |
66 | let fun accumf sofar [] = sofar | |
67 | | accumf sofar (a::x) = accumf (revonto sofar (f a)) x | |
68 | in accumf [] list (* note: this worked without changes!*) | |
69 | end | |
70 | ||
71 | fun occurs3 x = | |
72 | (* finds coords which occur exactly 3 times in coordlist x *) | |
73 | let | |
74 | fun diff x y = filter (fn x => not(member x y)) x (* unfolded o *) | |
75 | fun f xover x3 x2 x1 [] = diff x3 xover | |
76 | | f xover x3 x2 x1 (a::x) = | |
77 | if member a xover then f xover x3 x2 x1 x else | |
78 | if member a x3 then f (a::xover) x3 x2 x1 x else | |
79 | if member a x2 then f xover (a::x3) x2 x1 x else | |
80 | if member a x1 then f xover x3 (a::x2) x1 x else | |
81 | f xover x3 x2 (a::x1) x | |
82 | in f [] [] [] [] x end | |
83 | (* in | |
84 | *) | |
85 | ||
86 | ||
87 | fun copy_string s= implode(explode s) | |
88 | fun copy_bool true = true | |
89 | | copy_bool false = false | |
90 | ||
91 | ||
92 | abstype generation = GEN of (int*int) list | |
93 | with | |
94 | fun copy (GEN l) = GEN( copy_list l) | |
95 | fun alive (GEN livecoords) = livecoords | |
96 | and mkgen coordlist = GEN (lexordset coordlist) | |
97 | and mk_nextgen_fn neighbours gen = | |
98 | if true then | |
99 | let val living = alive gen | |
100 | fun isalive x = copy_bool(member x living) (* eta *) | |
101 | fun liveneighbours x = length( filter isalive ( neighbours x)) (*eta*) | |
102 | fun twoorthree n = n = 2 orelse n = 3 | |
103 | val survivors = copy_list(filter (twoorthree o liveneighbours) living) | |
104 | val newnbrlist = copy_list(collect (fn z => filter (fn x => not( isalive x)) ( neighbours z)) living) (* unfolded o twice*) | |
105 | val newborn = copy_list(occurs3 newnbrlist) | |
106 | in mkgen (survivors @ newborn) end | |
107 | else gen | |
108 | end | |
109 | (* end*) | |
110 | ||
111 | fun neighbours (i,j) = [(i-1,j-1),(i-1,j),(i-1,j+1), | |
112 | (i,j-1),(i,j+1), | |
113 | (i+1,j-1),(i+1,j),(i+1,j+1)] | |
114 | ||
115 | local val xstart = 0 and ystart = 0 | |
116 | fun markafter n string = string ^ spaces n ^ "0" | |
117 | fun plotfrom (x,y) (* current position *) | |
118 | str (* current line being prepared -- a string *) | |
119 | ((x1,y1)::more) (* coordinates to be plotted *) | |
120 | = if x = x1 | |
121 | then (* same line so extend str and continue from y1+1 *) | |
122 | plotfrom(x,y1+1)(markafter(y1-y)str)more | |
123 | else (* flush current line and start a new line *) | |
124 | str :: plotfrom(x+1,ystart)""((x1,y1)::more) | |
125 | | plotfrom (x,y) str [] = [str] | |
126 | fun good (x,y) = x>=xstart andalso y>=ystart | |
127 | in fun plot coordlist = map_rec(copy_string,(plotfrom(xstart,ystart) "" | |
128 | (copy_list(filter good coordlist)))) | |
129 | end | |
130 | ||
131 | ||
132 | infix 6 at | |
133 | fun coordlist at (x:int,y:int) = let fun move(a,b) = (a+x,b+y) | |
134 | in map move coordlist end | |
135 | fun rotate x = map (fn (x:int,y:int) => (y,~x)) x (* eta converted*) | |
136 | ||
137 | val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)] | |
138 | val bail = [(0,0),(0,1),(1,0),(1,1)] | |
139 | fun barberpole n = | |
140 | let fun f i = if i = n then (n+n-1,n+n)::(n+n,n+n)::nil | |
141 | else (i+i,i+i+1)::(i+i+2,i+i+1)::f(i+1) | |
142 | in (0,0)::(1,0):: f 0 | |
143 | end | |
144 | ||
145 | val genB = mkgen(glider at (2,2) @ bail at (2,12) | |
146 | @ rotate (barberpole 4) at (5,20)) | |
147 | ||
148 | fun copy_whole_arg (p, g) = (p, copy g) | |
149 | ||
150 | fun nthgen'(p as(0,g)) = p | |
151 | | nthgen'(p as(i,g)) = (print ".\n"; | |
152 | nthgen' (copy_whole_arg(copy_whole_arg(i-1,mk_nextgen_fn neighbours g)))) | |
153 | ||
154 | fun gun() = mkgen (* turned into function *) | |
155 | [(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18), | |
156 | (5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18), | |
157 | (6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28), | |
158 | (7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41), | |
159 | (9,29),(9,30),(9,31),(9,32)] | |
160 | ||
161 | ||
162 | fun iter n = #2(nthgen'(n,gun())) | |
163 | ||
164 | fun pr x = print x | |
165 | ||
166 | fun show(x) = (pr "starting printing\n"; | |
167 | app (fn s => (pr s; pr "\n"))(plot(alive x)); | |
168 | () | |
169 | ) (* had to uncurry show, as iter 50 gave attop | |
170 | also made it return a different unit *) | |
171 | ||
172 | (* fun doit () = show((fn _ => ()), (iter 50)) (* inserted call of iter *)*) | |
173 | ||
174 | ||
175 | fun testit _ = show(iter 50) (* inserted call of iter *) | |
176 | ||
177 | (* | |
178 | end (* Life *) | |
179 | *) | |
180 | ||
181 | ||
182 | (* val _ = (doit (); doit(); doit()); *) | |
183 | ||
184 | in | |
185 | testit (); testit (); testit () | |
186 | end |