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