| 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 |