polymorphism/001/src/polymorphism.ml

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