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