polymorphism/001/src/polymorphism.ml

   1 open Core.Std
   2
   3
   4 let (|-) g f x = f (g x)
   5
   6
   7 module Terminal : sig
   8   type color = [ `green
   9                | `red
  10                | `white
  11                ]
  12
  13   val string_with_color : string -> color -> string
  14
  15   val clear : unit -> unit
  16
  17   val reset : unit -> unit
  18 end = struct
  19   type color = [ `green
  20                | `red
  21                | `white
  22                ]
  23
  24   let ansi_code_clear = "\027[2J"    (* Clear screen *)
  25   let ansi_code_reset = "\027[1;1H"  (* Reset cursor position *)
  26
  27   let string_of_color = function
  28     | `green -> "\027[0;32m"
  29     | `red   -> "\027[1;31m"
  30     | `white -> "\027[1;37m"
  31
  32   let string_with_color s c =
  33     sprintf "%s%s\027[0m" (string_of_color c) s
  34
  35   let clear () =
  36     print_string ansi_code_clear
  37
  38   let reset () =
  39     print_string ansi_code_reset
  40 end
  41
  42
  43 module type MATRIX = sig
  44   module Point : sig
  45     type t = {r : int; k : int}
  46   end
  47
  48   type 'a t
  49
  50   val create : rs:int -> ks:int -> 'a -> 'a t
  51
  52   val get_neighbors : 'a t -> Point.t -> 'a list
  53
  54   val map : 'a t -> f:('a -> 'b) -> 'b t
  55
  56   val mapi : 'a t -> f:(Point.t -> 'a -> 'b) -> 'b t
  57
  58   val iter : 'a t -> f:(Point.t -> 'a -> unit) -> unit
  59
  60   val print : 'a t -> to_string:('a -> string) -> unit
  61 end
  62
  63 module Matrix : MATRIX = struct
  64   module Point = struct
  65     type t = {r : int; k : int}
  66
  67     let (+) p p' =
  68       { r = p.r + p'.r
  69       ; k = p.k + p'.k
  70       }
  71   end
  72
  73   module Direction = struct
  74     type t = NW | N | NE
  75            | W  |     E
  76            | SW | S | SE
  77
  78     let all = [ NW ; N ; NE
  79               ; W  ;     E
  80               ; SW ; S ; SE
  81               ]
  82
  83     let to_offset =
  84       let open Point in
  85       function
  86       | NW -> {r = -1; k = -1}
  87       | N  -> {r = -1; k =  0}
  88       | NE -> {r = -1; k =  1}
  89       | W  -> {r =  0; k = -1}
  90       | E  -> {r =  0; k =  1}
  91       | SW -> {r =  1; k = -1}
  92       | S  -> {r =  1; k =  0}
  93       | SE -> {r =  1; k =  1}
  94   end
  95
  96   type 'a t = 'a array array
  97
  98   let create ~rs ~ks x =
  99     Array.make_matrix ~dimx:rs ~dimy:ks x
 100
 101   let iter t ~f =
 102     Array.iteri t ~f:(
 103       fun r ks ->
 104         Array.iteri ks ~f:(
 105           fun k x ->
 106             f {Point.r; Point.k} x
 107         )
 108     )
 109
 110   let print t ~to_string =
 111     Array.iter t ~f:(
 112       fun r ->
 113         Array.iter r ~f:(fun x -> printf "%s" (to_string x));
 114         print_newline ()
 115     )
 116
 117   let map t ~f =
 118     Array.map t ~f:(Array.map ~f:(fun x -> f x))
 119
 120   let mapi t ~f =
 121     Array.mapi t ~f:(
 122       fun r ks ->
 123         Array.mapi ks ~f:(
 124           fun k x ->
 125             f {Point.r; Point.k} x
 126         )
 127     )
 128
 129   let get t {Point.r; Point.k} =
 130     t.(r).(k)
 131
 132   let is_within_bounds t {Point.r; Point.k} =
 133     match t with
 134     | [||] -> assert false
 135     | t ->
 136       r >= 0 && r < Array.length t &&
 137       k >= 0 && k < Array.length t.(0)
 138
 139   let neighborhood t point =
 140     List.map Direction.all ~f:Direction.to_offset
 141     |> List.map ~f:(fun offset_point -> Point.(point + offset_point))
 142     |> List.filter ~f:(is_within_bounds t)
 143
 144   let get_neighbors t point =
 145     List.map (neighborhood t point) ~f:(get t)
 146 end
 147
 148
 149 module PhenoType : sig
 150   type t
 151
 152   val create : char -> Terminal.color option -> t
 153
 154   val to_string : t -> string
 155 end = struct
 156   type t = { color     : Terminal.color option
 157            ; character : char
 158            }
 159
 160   let create character color =
 161     {color; character}
 162
 163   let to_string = function
 164     | {color=None; character} ->
 165       String.of_char character
 166     | {color=Some c; character} ->
 167       Terminal.string_with_color (String.of_char character) c
 168 end
 169
 170
 171 module Cell = struct
 172   module State = struct
 173     type intention = Friendly
 174                    | Neutral
 175                    | Hostile
 176
 177     type t = Alive of intention
 178            | Dead
 179   end
 180
 181   type t = { state : State.t
 182            ; pheno : PhenoType.t
 183            }
 184 end
 185
 186
 187 module type RULE = sig
 188   val create : unit -> Cell.t
 189
 190   val transition : self:Cell.State.t
 191                 -> neighbors:Cell.State.t list
 192                 -> Cell.t
 193 end
 194
 195
 196 module Life : RULE = struct
 197   module State : sig
 198     type t = D | A
 199
 200     val of_int : int -> t
 201
 202     val to_int : t -> int
 203
 204     val to_cell : t -> Cell.t
 205
 206     val of_cell_state : Cell.State.t -> t
 207   end = struct
 208     type t = D | A
 209
 210     let of_int = function
 211       | 0 -> D
 212       | 1 -> A
 213       | _ -> assert false
 214
 215     let to_int = function
 216       | D -> 0
 217       | A -> 1
 218
 219     let to_pheno = function
 220       | D -> PhenoType.create ' ' None
 221       | A -> PhenoType.create 'o' (Some `white)
 222
 223     let of_cell_state = function
 224       | Cell.State.Dead                      -> D
 225       | Cell.State.Alive Cell.State.Friendly -> A
 226       | Cell.State.Alive Cell.State.Neutral  -> A
 227       | Cell.State.Alive Cell.State.Hostile  -> D
 228
 229     let to_cell_state = function
 230       | D -> Cell.State.Dead
 231       | A -> Cell.State.Alive Cell.State.Neutral
 232
 233     let to_cell t =
 234       { Cell.state = t |> to_cell_state
 235       ; Cell.pheno = t |> to_pheno
 236       }
 237   end
 238
 239   let next state ~live_neighbors =
 240     match state with
 241     | State.A when live_neighbors < 2 -> State.D
 242     | State.A when live_neighbors < 4 -> State.A
 243     | State.A when live_neighbors > 3 -> State.D
 244     | State.D when live_neighbors = 3 -> State.A
 245     | State.A -> State.A
 246     | State.D -> State.D
 247
 248   let create () =
 249     Random.int 2 |> State.of_int |> State.to_cell
 250
 251   let live_neighbors neighbors =
 252     neighbors |> List.map ~f:(State.of_cell_state |- State.to_int)
 253               |> List.fold_left ~init:0 ~f:(+)
 254
 255   let transition ~self ~neighbors =
 256     self |> State.of_cell_state
 257          |> next ~live_neighbors:(live_neighbors neighbors)
 258          |> State.to_cell
 259 end
 260
 261
 262 module ForestFire : RULE = struct
 263   module State : sig
 264     type t = E | T | B
 265
 266     val is_burning : t -> bool
 267
 268     val of_int : int -> t
 269
 270     val to_int : t -> int
 271
 272     val to_cell : t -> Cell.t
 273
 274     val of_cell_state : Cell.State.t -> t
 275   end = struct
 276     type t = E | T | B
 277
 278     let is_burning = function
 279       | E -> false
 280       | T -> false
 281       | B -> true
 282
 283     let of_int = function
 284       | 0 -> E
 285       | 1 -> T
 286       | 2 -> B
 287       | _ -> assert false
 288
 289     let to_int = function
 290       | E -> 0
 291       | T -> 1
 292       | B -> 2
 293
 294     let to_pheno = function
 295       | E -> PhenoType.create ' ' None
 296       | T -> PhenoType.create 'T' (Some `green)
 297       | B -> PhenoType.create '#' (Some `red)
 298
 299     let of_cell_state = function
 300       | Cell.State.Dead                      -> E
 301       | Cell.State.Alive Cell.State.Friendly -> T
 302       | Cell.State.Alive Cell.State.Neutral  -> E
 303       | Cell.State.Alive Cell.State.Hostile  -> B
 304
 305     let to_cell_state = function
 306       | E -> Cell.State.Dead
 307       | T -> Cell.State.Alive Cell.State.Friendly
 308       | B -> Cell.State.Alive Cell.State.Hostile
 309
 310     let to_cell t =
 311       { Cell.state = t |> to_cell_state
 312       ; Cell.pheno = t |> to_pheno
 313       }
 314   end
 315
 316   let create () =
 317     Random.int 3 |> State.of_int |> State.to_cell
 318
 319   let f = 0.000001  (* Probability of spontaneous ignition *)
 320   let p = 0.1       (* Probability of spontaneous growth *)
 321
 322   let is_probable p =
 323     (Random.float 1.0) <= p
 324
 325   let next state ~burning_neighbors =
 326     match state, burning_neighbors with
 327     | State.E, _ when is_probable p         -> State.T
 328     | State.E, _                            -> State.E
 329     | State.T, 0 when is_probable f         -> State.B
 330     | State.T, _ when burning_neighbors > 0 -> State.B
 331     | State.T, _                            -> State.T
 332     | State.B, _                            -> State.E
 333
 334   let burning_neighbors neighbors =
 335     neighbors |> List.map ~f:State.of_cell_state
 336               |> List.filter ~f:State.is_burning
 337               |> List.map ~f:State.to_int
 338               |> List.fold_left ~init:0 ~f:(+)
 339
 340   let transition ~self ~neighbors =
 341     self |> State.of_cell_state
 342          |> next ~burning_neighbors:(burning_neighbors neighbors)
 343          |> State.to_cell
 344 end
 345
 346
 347 module Automaton : sig
 348   type t
 349
 350   val create  : rows:int
 351              -> columns:int
 352              -> interval:float
 353              -> rules: (module RULE) list
 354              -> t
 355
 356   val loop : t -> unit
 357 end = struct
 358   type cell = { data : Cell.t
 359               ; rule : (module RULE)
 360               }
 361
 362   type t = { grid     : cell Matrix.t
 363            ; interval : Time.Span.t
 364            ; bar      : string
 365            }
 366
 367   let create ~rows:rs ~columns:ks ~interval ~rules =
 368     let n = List.length rules in
 369     let init () =
 370       let rule = List.nth_exn rules (Random.int n) in
 371       let module Rule = (val rule : RULE) in
 372       { rule
 373       ; data = Rule.create ()
 374       }
 375     in
 376     Terminal.clear ();
 377     { grid     = Matrix.map ~f:init (Matrix.create ~rs ~ks ())
 378     ; interval = Time.Span.of_float interval
 379     ; bar      = String.make ks '-'
 380     }
 381
 382   let cell_to_string cell =
 383     PhenoType.to_string cell.data.Cell.pheno
 384
 385   let print t =
 386     Terminal.reset ();
 387     print_endline t.bar;
 388     Matrix.print t.grid ~to_string:cell_to_string;
 389     print_endline t.bar
 390
 391   let next t =
 392     let grid =
 393       Matrix.mapi t.grid ~f:(
 394         fun point {rule; data} ->
 395           let module Rule = (val rule : RULE) in
 396           let neighbors = Matrix.get_neighbors t.grid point in
 397           let data =
 398             Rule.transition
 399               ~self:data.Cell.state
 400               ~neighbors:(List.map neighbors ~f:(fun c -> c.data.Cell.state))
 401           in
 402           {rule; data}
 403       )
 404     in
 405     {t with grid}
 406
 407   let rec loop t =
 408     print t;
 409     Time.pause t.interval;
 410     loop (next t)
 411 end
 412
 413
 414 let main interval () =
 415   Random.self_init ();
 416   let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in
 417   let rules =
 418     [ (module Life : RULE)
 419     ; (module ForestFire : RULE)
 420     ]
 421   in
 422   Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
 423
 424
 425 let spec =
 426   let summary = "Polymorphic Cellular Automata" in
 427   let spec = Command.Spec.(empty
 428     +> flag "-i" (optional_with_default 0.1 float)
 429              ~doc:" Induced interval between generations."
 430     )
 431   in
 432   Command.basic ~summary spec main
 433
 434
 435 let () = Command.run spec