Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* From the SML/NJ benchmark suite. *) |
2 | signature BMARK = | |
3 | sig | |
4 | val doit : int -> unit | |
5 | val testit : TextIO.outstream -> unit | |
6 | end; | |
7 | structure Main : BMARK = | |
8 | struct | |
9 | ||
10 | fun map f [] = [] | |
11 | | map f (a::x) = f a :: map f x | |
12 | ||
13 | exception ex_undefined of string | |
14 | fun error str = raise ex_undefined str | |
15 | ||
16 | fun accumulate f = let | |
17 | fun foldf a [] = a | |
18 | | foldf a (b::x) = foldf (f a b) x | |
19 | in | |
20 | foldf | |
21 | end | |
22 | ||
23 | fun filter p = let | |
24 | fun consifp x a = if p a then a::x else x | |
25 | in | |
26 | rev o accumulate consifp [] | |
27 | end | |
28 | ||
29 | ||
30 | fun exists p = let fun existsp [] = false | |
31 | | existsp (a::x) = if p a then true else existsp x | |
32 | in existsp end | |
33 | ||
34 | fun equal a b = (a = b) | |
35 | ||
36 | fun member x a = exists (equal a) x | |
37 | ||
38 | fun C f x y = f y x | |
39 | ||
40 | fun cons a x = a::x | |
41 | ||
42 | fun revonto x = accumulate (C cons) x | |
43 | ||
44 | fun length x = let fun count n a = n+1 in accumulate count 0 x end | |
45 | ||
46 | fun repeat f = let fun rptf n x = if n=0 then x else rptf(n-1)(f x) | |
47 | fun check n = if n<0 then error "repeat<0" else n | |
48 | in rptf o check end | |
49 | ||
50 | fun copy n x = repeat (cons x) n [] | |
51 | ||
52 | fun spaces n = concat (copy n " ") | |
53 | ||
54 | local | |
55 | fun lexordset [] = [] | |
56 | | lexordset (a::x) = lexordset (filter (lexless a) x) @ [a] @ | |
57 | lexordset (filter (lexgreater a) x) | |
58 | and lexless(a1:int,b1:int)(a2,b2) = | |
59 | if a2<a1 then true else if a2=a1 then b2<b1 else false | |
60 | and lexgreater pr1 pr2 = lexless pr2 pr1 | |
61 | fun collect f list = | |
62 | let fun accumf sofar [] = sofar | |
63 | | accumf sofar (a::x) = accumf (revonto sofar (f a)) x | |
64 | in accumf [] list | |
65 | end | |
66 | fun occurs3 x = | |
67 | (* finds coords which occur exactly 3 times in coordlist x *) | |
68 | let fun f xover x3 x2 x1 [] = diff x3 xover | |
69 | | f xover x3 x2 x1 (a::x) = | |
70 | if member xover a then f xover x3 x2 x1 x else | |
71 | if member x3 a then f (a::xover) x3 x2 x1 x else | |
72 | if member x2 a then f xover (a::x3) x2 x1 x else | |
73 | if member x1 a then f xover x3 (a::x2) x1 x else | |
74 | f xover x3 x2 (a::x1) x | |
75 | and diff x y = filter (not o member y) x | |
76 | in f [] [] [] [] x end | |
77 | in | |
78 | abstype generation = GEN of (int*int) list | |
79 | with | |
80 | fun alive (GEN livecoords) = livecoords | |
81 | and mkgen coordlist = GEN (lexordset coordlist) | |
82 | and mk_nextgen_fn neighbours gen = | |
83 | let val living = alive gen | |
84 | val isalive = member living | |
85 | val liveneighbours = length o filter isalive o neighbours | |
86 | fun twoorthree n = n=2 orelse n=3 | |
87 | val survivors = filter (twoorthree o liveneighbours) living | |
88 | val newnbrlist = collect (filter (not o isalive) o neighbours) living | |
89 | val newborn = occurs3 newnbrlist | |
90 | in mkgen (survivors @ newborn) end | |
91 | end | |
92 | end | |
93 | ||
94 | fun neighbours (i,j) = [(i-1,j-1),(i-1,j),(i-1,j+1), | |
95 | (i,j-1),(i,j+1), | |
96 | (i+1,j-1),(i+1,j),(i+1,j+1)] | |
97 | ||
98 | local val xstart = 0 and ystart = 0 | |
99 | fun markafter n string = string ^ spaces n ^ "0" | |
100 | fun plotfrom (x,y) (* current position *) | |
101 | str (* current line being prepared -- a string *) | |
102 | ((x1,y1)::more) (* coordinates to be plotted *) | |
103 | = if x=x1 | |
104 | then (* same line so extend str and continue from y1+1 *) | |
105 | plotfrom(x,y1+1)(markafter(y1-y)str)more | |
106 | else (* flush current line and start a new line *) | |
107 | str :: plotfrom(x+1,ystart)""((x1,y1)::more) | |
108 | | plotfrom (x,y) str [] = [str] | |
109 | fun good (x,y) = x>=xstart andalso y>=ystart | |
110 | in fun plot coordlist = plotfrom(xstart,ystart) "" | |
111 | (filter good coordlist) | |
112 | end | |
113 | ||
114 | ||
115 | infix 6 at | |
116 | fun coordlist at (x:int,y:int) = let fun move(a,b) = (a+x,b+y) | |
117 | in map move coordlist end | |
118 | val rotate = map (fn (x:int,y:int) => (y,~x)) | |
119 | ||
120 | val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)] | |
121 | val bail = [(0,0),(0,1),(1,0),(1,1)] | |
122 | fun barberpole n = | |
123 | let fun f i = if i=n then (n+n-1,n+n)::(n+n,n+n)::nil | |
124 | else (i+i,i+i+1)::(i+i+2,i+i+1)::f(i+1) | |
125 | in (0,0)::(1,0):: f 0 | |
126 | end | |
127 | ||
128 | val genB = mkgen(glider at (2,2) @ bail at (2,12) | |
129 | @ rotate (barberpole 4) at (5,20)) | |
130 | ||
131 | fun nthgen g 0 = g | nthgen g i = nthgen (mk_nextgen_fn neighbours g) (i-1) | |
132 | ||
133 | val gun = mkgen | |
134 | [(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18), | |
135 | (5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18), | |
136 | (6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28), | |
137 | (7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41), | |
138 | (9,29),(9,30),(9,31),(9,32)] | |
139 | ||
140 | fun show pr = (app (fn s => (pr s; pr "\n"))) o plot o alive | |
141 | ||
142 | fun doit () = show (fn _ => ()) (nthgen gun 25000) | |
143 | ||
144 | val doit = | |
145 | fn size => | |
146 | let | |
147 | fun loop n = | |
148 | if n = 0 | |
149 | then () | |
150 | else (doit(); | |
151 | loop(n-1)) | |
152 | in loop size | |
153 | end | |
154 | ||
155 | fun testit strm = show (fn c => TextIO.output (strm, c)) (nthgen gun 50) | |
156 | ||
157 | end (* Life *) |