polymorphic-life/001/src/polymorphic_life.ml

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