| 1 | (*kitlife35u.sml*) |
| 2 | |
| 3 | (*based on kitlifeopt.sml, but with copying |
| 4 | to avoid many generations in the same region*) |
| 5 | |
| 6 | local |
| 7 | |
| 8 | fun eq_integer (x: int, y: int): bool = x = y |
| 9 | fun eq_string (x: string, y: string): bool = x = y |
| 10 | |
| 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') |
| 14 | |
| 15 | fun app f [] = () |
| 16 | | app f (x::xs) = (f x; app f xs) |
| 17 | |
| 18 | |
| 19 | fun map f [] = [] |
| 20 | | map f (a::x) = f a :: map f x |
| 21 | |
| 22 | fun map_rec(f, []) = [] |
| 23 | | map_rec(f, x::xs) = f x:: map_rec(f, xs) |
| 24 | |
| 25 | exception ex_undefined of string |
| 26 | fun error str = raise ex_undefined str |
| 27 | |
| 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 |
| 30 | |
| 31 | fun accumulate' (f, a, []) = a |
| 32 | | accumulate' (f, a, b::x) = accumulate'(f, f(a,b), x) |
| 33 | |
| 34 | fun filter p l= |
| 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) *) |
| 38 | |
| 39 | |
| 40 | fun equal a b = a=b |
| 41 | |
| 42 | fun exists p [] = false |
| 43 | | exists p (a::x) = if p a then true else exists p x |
| 44 | |
| 45 | fun exists' (p, []) = false |
| 46 | | exists' (p, (a::x)) = p a orelse exists'(p,x) |
| 47 | |
| 48 | |
| 49 | fun member eq x a = exists' (eq a, x) |
| 50 | |
| 51 | fun C f x y = f y x |
| 52 | |
| 53 | fun cons a x = a::x |
| 54 | |
| 55 | |
| 56 | fun revonto x y = accumulate' ((fn (x,y) => y::x), x, y) |
| 57 | |
| 58 | fun copy_int n = n+0 |
| 59 | |
| 60 | fun length x = copy_int(let fun count (n, a) = n+1 in accumulate'(count, 0, x) end) |
| 61 | (* eta expanded*) |
| 62 | |
| 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) |
| 66 | in rptf (check x) y |
| 67 | end |
| 68 | end |
| 69 | |
| 70 | fun copy n x = repeat (cons x) n [] |
| 71 | |
| 72 | fun spaces n = implode (copy n #" ") |
| 73 | |
| 74 | fun copy_list[] = [] |
| 75 | | copy_list((x,y)::rest) = (x+0,y+0):: copy_list rest |
| 76 | |
| 77 | |
| 78 | fun lexless(a2,b2)(a1:int,b1:int) = |
| 79 | if a2<a1 then true else if a2=a1 then b2<b1 else false |
| 80 | |
| 81 | |
| 82 | |
| 83 | fun length l = case l of |
| 84 | [] => 0 |
| 85 | | x::xs => 1 + length xs |
| 86 | fun copy [] = [] |
| 87 | | copy (x::xs) = x :: copy xs |
| 88 | fun take(i,l) = |
| 89 | case l of [] => [] |
| 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 |
| 96 | [] => left |
| 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) |
| 100 | ) |
| 101 | |
| 102 | fun tmergesort l = |
| 103 | case l of [] => [] |
| 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)))) |
| 108 | end |
| 109 | ) |
| 110 | fun lexordset x = tmergesort x |
| 111 | |
| 112 | |
| 113 | |
| 114 | |
| 115 | fun collect f list = |
| 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!*) |
| 119 | end |
| 120 | |
| 121 | fun occurs3 x = |
| 122 | (* finds coords which occur exactly 3 times in coordlist x *) |
| 123 | let fun f (q) = |
| 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) |
| 133 | in diff x3 xover end |
| 134 | |
| 135 | fun copy_string s= implode(explode s) |
| 136 | fun copy_bool true = true |
| 137 | | copy_bool false = false |
| 138 | |
| 139 | fun neighbours (i,j) = [(i-1,j-1),(i-1,j),(i-1,j+1), |
| 140 | (i,j-1),(i,j+1), |
| 141 | (i+1,j-1),(i+1,j),(i+1,j+1)] |
| 142 | |
| 143 | |
| 144 | abstype generation = GEN of (int*int) list |
| 145 | with |
| 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 = |
| 150 | if true then |
| 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 |
| 159 | else gen |
| 160 | end |
| 161 | |
| 162 | |
| 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)))) |
| 177 | end |
| 178 | |
| 179 | |
| 180 | infix 6 at |
| 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*) |
| 184 | |
| 185 | val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)] |
| 186 | val bail = [(0,0),(0,1),(1,0),(1,1)] |
| 187 | fun barberpole n = |
| 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 |
| 191 | end |
| 192 | |
| 193 | val genB = mkgen(glider at (2,2) @ bail at (2,12) |
| 194 | @ rotate (barberpole 4) at (5,20)) |
| 195 | |
| 196 | fun copy_whole_arg (p, g) = (copy_int p, copy g) |
| 197 | |
| 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; *) |
| 203 | arg' |
| 204 | end))) |
| 205 | |
| 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)] |
| 212 | |
| 213 | |
| 214 | fun iter n = #2(nthgen'(n+0,gun())) |
| 215 | |
| 216 | fun pr x = print x |
| 217 | |
| 218 | fun show(x) = (pr "starting printing\n"; |
| 219 | app (fn s => (pr s; pr "\n"))(plot(alive x)); |
| 220 | () |
| 221 | ) (* had to uncurry show, as iter 50 gave attop |
| 222 | also made it return a different unit *) |
| 223 | |
| 224 | fun testit _ = show(iter 250) (* inserted call of iter *) |
| 225 | |
| 226 | val _ = testit () |
| 227 | in |
| 228 | val done = "done"; |
| 229 | end |
| 230 | |