polymorphic-life/001/src/polymorphic_life.ml

   1 open Core.Std
   2
   3
   4 module type MATRIX = sig
   5   module Point : sig
   6     type t = {r : int; k : int}
   7   end
   8
   9   type 'a t
  10
  11   val create : rs:int -> ks:int -> data:'a -> 'a t
  12
  13   val get_neighbors : 'a t -> Point.t -> 'a list
  14
  15   val map : 'a t -> f:('a -> 'b) -> 'b t
  16
  17   val mapi : 'a t -> f:(Point.t -> data:'a -> 'b) -> 'b t
  18
  19   val iter : 'a t -> f:(Point.t -> data:'a -> unit) -> unit
  20
  21   val print : 'a t -> to_string:('a -> string) -> unit
  22 end
  23
  24 module Matrix : MATRIX = struct
  25   module Point = struct
  26     type t = {r : int; k : int}
  27
  28     let (+) p p' =
  29       { r = p.r + p'.r
  30       ; k = p.k + p'.k
  31       }
  32   end
  33
  34   module Direction = struct
  35     type t = NW | N | NE
  36            | W  |     E
  37            | SW | S | SE
  38
  39     let all = [ NW ; N ; NE
  40               ; W  ;     E
  41               ; SW ; S ; SE
  42               ]
  43
  44     let to_offset =
  45       let open Point in
  46       function
  47       | NW -> {r = -1; k = -1}
  48       | N  -> {r = -1; k =  0}
  49       | NE -> {r = -1; k =  1}
  50       | W  -> {r =  0; k = -1}
  51       | E  -> {r =  0; k =  1}
  52       | SW -> {r =  1; k = -1}
  53       | S  -> {r =  1; k =  0}
  54       | SE -> {r =  1; k =  1}
  55   end
  56
  57   type 'a t = 'a array array
  58
  59   let create ~rs ~ks ~data =
  60     Array.make_matrix ~dimx:rs ~dimy:ks data
  61
  62   let iter t ~f =
  63     Array.iteri t ~f:(
  64       fun r ks ->
  65         Array.iteri ks ~f:(
  66           fun k data ->
  67             f {Point.r; Point.k} ~data
  68         )
  69     )
  70
  71   let print t ~to_string =
  72     Array.iter t ~f:(
  73       fun r ->
  74         Array.iter r ~f:(fun x -> printf "%s" (to_string x));
  75         print_newline ()
  76     )
  77
  78   let map t ~f =
  79     Array.map t ~f:(Array.map ~f:(fun x -> f x))
  80
  81   let mapi t ~f =
  82     Array.mapi t ~f:(
  83       fun r ks ->
  84         Array.mapi ks ~f:(
  85           fun k data ->
  86             f {Point.r; Point.k} ~data
  87         )
  88     )
  89
  90   let get t {Point.r; Point.k} =
  91     t.(r).(k)
  92
  93   let is_within_bounds t {Point.r; Point.k} =
  94     match t with
  95     | [||] -> assert false
  96     | t ->
  97       r >= 0 && r < Array.length t &&
  98       k >= 0 && k < Array.length t.(0)
  99
 100   let neighborhood t point =
 101     List.map Direction.all ~f:Direction.to_offset
 102     |> List.map ~f:(fun offset_point -> Point.(point + offset_point))
 103     |> List.filter ~f:(is_within_bounds t)
 104
 105   let get_neighbors t point =
 106     List.map (neighborhood t point) ~f:(get t)
 107 end
 108
 109
 110 module type CELL = sig
 111   type t
 112
 113   val create : unit -> t
 114
 115   val to_string : t -> string
 116
 117   val state : t -> int
 118
 119   val react : t -> states:int list -> t
 120 end
 121
 122
 123 module Conway : CELL = struct
 124   type t = D | A
 125
 126   let of_int = function
 127     | 0 -> D
 128     | 1 -> A
 129     | _ -> assert false
 130
 131   let to_int = function
 132     | D -> 0
 133     | A -> 1
 134
 135   let to_string = function
 136     | D -> " "
 137     | A -> "o"
 138
 139   let create () =
 140     Random.int 2 |> of_int
 141
 142   let state = to_int
 143
 144   let react t ~states =
 145     let live_neighbors = List.fold_left states ~init:0 ~f:(+) in
 146     match t with
 147     | A when live_neighbors < 2 -> D
 148     | A when live_neighbors < 4 -> A
 149     | A when live_neighbors > 3 -> D
 150     | D when live_neighbors = 3 -> A
 151     | A -> A
 152     | D -> D
 153 end
 154
 155
 156 let rec loop bar pause_span grid =
 157   print_endline bar;
 158   Matrix.print grid ~to_string:Conway.to_string;
 159   print_endline bar;
 160   let grid =
 161     Matrix.mapi grid ~f:(fun point ~data:cell ->
 162       let neighbors = Matrix.get_neighbors grid point in
 163       Conway.react cell ~states:(List.map neighbors ~f:Conway.state)
 164     )
 165   in
 166   Time.pause pause_span;
 167   loop bar pause_span grid
 168
 169
 170 let main () =
 171   Random.self_init ();
 172   let rs, ks = Or_error.ok_exn Linux_ext.get_terminal_size () in
 173   Matrix.create ~rs:(rs - 3) ~ks ~data:()
 174   |> Matrix.map ~f:Conway.create
 175   |> loop (String.make ks '-') (Time.Span.of_float 0.1)
 176
 177
 178 let spec =
 179   let summary = "Polymorphic Cellular Automata" in
 180   let spec = Command.Spec.empty in
 181   Command.basic ~summary spec main
 182
 183
 184 let () = Command.run spec