polymorphism/001/src/polymorphism.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 -> '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 -> 'a -> 'b) -> 'b t
  18
  19   val iter : 'a t -> f:(Point.t -> '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 x =
  60     Array.make_matrix ~dimx:rs ~dimy:ks x
  61
  62   let iter t ~f =
  63     Array.iteri t ~f:(
  64       fun r ks ->
  65         Array.iteri ks ~f:(
  66           fun k x ->
  67             f {Point.r; Point.k} x
  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 x ->
  86             f {Point.r; Point.k} x
  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 Msg = struct
 111   type t = string
 112 end
 113
 114
 115 module State = struct
 116   type t = string
 117 end
 118
 119
 120 module PhenoType = struct
 121   type t = string
 122 end
 123
 124
 125 module Cell = struct
 126   type t = { msg   : Msg.t
 127            ; pheno : PhenoType.t
 128            ; state : State.t
 129            }
 130 end
 131
 132
 133 module type RULE = sig
 134   val create : unit -> Cell.t
 135
 136   val transition : state:State.t -> inputs:Msg.t list -> Cell.t
 137 end
 138
 139
 140 module Conway : RULE = struct
 141   type state = D | A
 142
 143   let state_of_string : (string -> state) = function
 144     | "D" -> D
 145     | "A" -> A
 146     | _   -> assert false
 147
 148   let state_of_int : (int -> state) = function
 149     | 0 -> D
 150     | 1 -> A
 151     | _ -> assert false
 152
 153   let int_of_state : (state -> int) = function
 154     | D -> 0
 155     | A -> 1
 156
 157   let string_of_state : (state -> string) = function
 158     | D -> "D"
 159     | A -> "A"
 160
 161   let msg_of_state : (state -> Msg.t) =
 162     string_of_state
 163
 164   let pheno_of_state : (state -> PhenoType.t) = function
 165     | D -> " "
 166     | A -> "o"
 167
 168   let int_of_msg msg =
 169     msg |> state_of_string |> int_of_state
 170
 171   let next state ~live_neighbors =
 172     match state with
 173     | A when live_neighbors < 2 -> D
 174     | A when live_neighbors < 4 -> A
 175     | A when live_neighbors > 3 -> D
 176     | D when live_neighbors = 3 -> A
 177     | A -> A
 178     | D -> D
 179
 180   let cell_of_state s =
 181     { Cell.msg   = s |> msg_of_state
 182     ; Cell.pheno = s |> pheno_of_state
 183     ; Cell.state = s |> string_of_state
 184     }
 185
 186   let create () =
 187     Random.int 2 |> state_of_int |> cell_of_state
 188
 189   let live_neighbors inputs =
 190     inputs |> List.map ~f:int_of_msg |> List.fold_left ~init:0 ~f:(+)
 191
 192   let transition ~state ~inputs =
 193     state
 194     |> state_of_string
 195     |> next ~live_neighbors:(live_neighbors inputs)
 196     |> cell_of_state
 197 end
 198
 199
 200 module Terminal : sig
 201   val clear : unit -> unit
 202   val reset : unit -> unit
 203 end = struct
 204   let ansi_code_clear = "\027[2J"    (* Clear screen *)
 205   let ansi_code_reset = "\027[1;1H"  (* Reset cursor position *)
 206
 207   let clear () =
 208     print_string ansi_code_clear
 209
 210   let reset () =
 211     print_string ansi_code_reset
 212 end
 213
 214
 215 module Automaton : sig
 216   type t
 217
 218   val create  : rows:int
 219              -> columns:int
 220              -> interval:float
 221              -> rules: (module RULE) list
 222              -> t
 223
 224   val loop : t -> unit
 225 end = struct
 226   type cell = { data : Cell.t
 227               ; rule : (module RULE)
 228               }
 229
 230   type t = { grid     : cell Matrix.t
 231            ; interval : Time.Span.t
 232            ; bar      : string
 233            }
 234
 235   let create ~rows:rs ~columns:ks ~interval ~rules =
 236     let n = List.length rules in
 237     let i = Random.int n in
 238     let init () =
 239       let rule = List.nth_exn rules i in
 240       let module Rule = (val rule : RULE) in
 241       { rule
 242       ; data = Rule.create ()
 243       }
 244     in
 245     Terminal.clear ();
 246     { grid     = Matrix.map ~f:init (Matrix.create ~rs ~ks ())
 247     ; interval = Time.Span.of_float interval
 248     ; bar      = String.make ks '-'
 249     }
 250
 251   let cell_to_string cell =
 252     cell.data.Cell.pheno
 253
 254   let print t =
 255     Terminal.reset ();
 256     print_endline t.bar;
 257     Matrix.print t.grid ~to_string:cell_to_string;
 258     print_endline t.bar
 259
 260   let next t =
 261     let grid =
 262       Matrix.mapi t.grid ~f:(
 263         fun point {rule; data} ->
 264           let module Rule = (val rule : RULE) in
 265           let neighbors = Matrix.get_neighbors t.grid point in
 266           let data =
 267             Rule.transition
 268               ~state:data.Cell.state
 269               ~inputs:(List.map neighbors ~f:(fun cell -> cell.data.Cell.msg))
 270           in
 271           {rule; data}
 272       )
 273     in
 274     {t with grid}
 275
 276   let rec loop t =
 277     print t;
 278     Time.pause t.interval;
 279     loop (next t)
 280 end
 281
 282
 283 let main () =
 284   Random.self_init ();
 285   let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in
 286   let interval = 0.1 in
 287   let rules =
 288     [ (module Conway : RULE)
 289     ]
 290   in
 291   Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
 292
 293
 294 let spec =
 295   let summary = "Polymorphic Cellular Automata" in
 296   let spec = Command.Spec.empty in
 297   Command.basic ~summary spec main
 298
 299
 300 let () = Command.run spec