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 is_alive : t -> bool
 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 is_alive = function
 231       | D -> false
 232       | A -> true
 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 count_of_live =
 267        List.map       ~f:State.of_cell_state
 268     |- List.filter    ~f:State.is_alive
 269     |- List.length
 270
 271   let transition ~self ~neighbors =
 272     self |> State.of_cell_state
 273          |> State.next ~live_neighbors:(count_of_live neighbors)
 274          |> State.to_cell
 275 end
 276
 277
 278 module ForestFire : RULE =
 279 struct
 280   module State :
 281   sig
 282     type t = E | T | B
 283
 284     val is_burning : t -> bool
 285
 286     val of_int : int -> t
 287
 288     val to_cell : t -> Cell.t
 289
 290     val of_cell_state : Cell.State.t -> t
 291
 292     val next : t -> burning_neighbors:int -> t
 293   end =
 294   struct
 295     type t = E | T | B
 296
 297     let is_burning = function
 298       | E -> false
 299       | T -> false
 300       | B -> true
 301
 302     let of_int = function
 303       | 0 -> E
 304       | 1 -> T
 305       | 2 -> B
 306       | _ -> assert false
 307
 308     let to_pheno = function
 309       | E -> PhenoType.create ' ' None
 310       | T -> PhenoType.create 'T' (Some `green)
 311       | B -> PhenoType.create '#' (Some `red)
 312
 313     let of_cell_state = function
 314       | Cell.State.Dead                      -> E
 315       | Cell.State.Alive Cell.State.Friendly -> T
 316       | Cell.State.Alive Cell.State.Neutral  -> E
 317       | Cell.State.Alive Cell.State.Hostile  -> B
 318
 319     let to_cell_state = function
 320       | E -> Cell.State.Dead
 321       | T -> Cell.State.Alive Cell.State.Friendly
 322       | B -> Cell.State.Alive Cell.State.Hostile
 323
 324     let to_cell t =
 325       { Cell.state = t |> to_cell_state
 326       ; Cell.pheno = t |> to_pheno
 327       }
 328
 329     let f = 0.000001  (* Probability of spontaneous ignition *)
 330     let p = 0.1       (* Probability of spontaneous growth *)
 331
 332     let is_probable p =
 333       (Random.float 1.0) <= p
 334
 335     let next t ~burning_neighbors =
 336       match t, burning_neighbors with
 337       | E, _ when is_probable p         -> T
 338       | E, _                            -> E
 339       | T, 0 when is_probable f         -> B
 340       | T, _ when burning_neighbors > 0 -> B
 341       | T, _                            -> T
 342       | B, _                            -> E
 343   end
 344
 345   let create () =
 346     Random.int 3 |> State.of_int |> State.to_cell
 347
 348   let count_of_burning =
 349        List.map       ~f:State.of_cell_state
 350     |- List.filter    ~f:State.is_burning
 351     |- List.length
 352
 353   let transition ~self ~neighbors =
 354     self |> State.of_cell_state
 355          |> State.next ~burning_neighbors:(count_of_burning neighbors)
 356          |> State.to_cell
 357 end
 358
 359
 360 module Automaton :
 361 sig
 362   type t
 363
 364   val create  : rows:int
 365              -> columns:int
 366              -> interval:float
 367              -> rules: (module RULE) list
 368              -> t
 369
 370   val loop : t -> unit
 371 end =
 372 struct
 373   type cell = { data : Cell.t
 374               ; rule : (module RULE)
 375               }
 376
 377   type t = { grid     : cell Matrix.t
 378            ; interval : Time.Span.t
 379            ; bar      : string
 380            }
 381
 382   let create ~rows:rs ~columns:ks ~interval ~rules =
 383     let n = List.length rules in
 384     let init () =
 385       let rule = List.nth_exn rules (Random.int n) in
 386       let module Rule = (val rule : RULE) in
 387       { rule
 388       ; data = Rule.create ()
 389       }
 390     in
 391     Terminal.clear ();
 392     { grid     = Matrix.map ~f:init (Matrix.create ~rs ~ks ())
 393     ; interval = Time.Span.of_float interval
 394     ; bar      = String.make ks '-'
 395     }
 396
 397   let cell_to_string cell =
 398     PhenoType.to_string cell.data.Cell.pheno
 399
 400   let print t =
 401     Terminal.reset ();
 402     print_endline t.bar;
 403     Matrix.print t.grid ~to_string:cell_to_string;
 404     print_endline t.bar
 405
 406   let next t =
 407     let grid =
 408       Matrix.mapi t.grid ~f:(
 409         fun point {rule; data} ->
 410           let module Rule = (val rule : RULE) in
 411           let neighbors = Matrix.get_neighbors t.grid point in
 412           let data =
 413             Rule.transition
 414               ~self:data.Cell.state
 415               ~neighbors:(List.map neighbors ~f:(fun c -> c.data.Cell.state))
 416           in
 417           {rule; data}
 418       )
 419     in
 420     {t with grid}
 421
 422   let rec loop t =
 423     print t;
 424     Time.pause t.interval;
 425     loop (next t)
 426 end
 427
 428
 429 let main interval () =
 430   Random.self_init ();
 431   let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in
 432   let rules =
 433     [ (module Life : RULE)
 434     ; (module ForestFire : RULE)
 435     ]
 436   in
 437   Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
 438
 439
 440 let spec =
 441   let summary = "Polymorphic Cellular Automata" in
 442   let spec = Command.Spec.(empty
 443     +> flag "-i" (optional_with_default 0.1 float)
 444              ~doc:" Induced interval between generations."
 445     )
 446   in
 447   Command.basic ~summary spec main
 448
 449
 450 let () = Command.run spec