benchmark/tests/life.sml

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