polymorphism/001/src/polymorphism.ml

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