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