X-Git-Url: https://git.xandkar.net/?p=cellular-automata.git;a=blobdiff_plain;f=polymorphism%2F001%2Fsrc%2Fpolymorphism.ml;h=ab2cbd5b89e744eaf8fda0b749e3477bbcce82b3;hp=c52df9338acb3fe610a43736212cc691502e784b;hb=fd22df899f4fb6b3499f89fdcfd84462d89f40de;hpb=8526e3e1220a86ff1d6fee238123611f89a4f242

diff --git a/polymorphism/001/src/polymorphism.ml b/polymorphism/001/src/polymorphism.ml
index c52df93..ab2cbd5 100644
--- a/polymorphism/001/src/polymorphism.ml
+++ b/polymorphism/001/src/polymorphism.ml
@@ -1,8 +1,51 @@
 open Core.Std
 
 
-module type MATRIX = sig
-  module Point : sig
+let (|-) g f x = f (g x)
+
+
+module Terminal :
+sig
+  type color = [ `green
+               | `red
+               | `white
+               ]
+
+  val string_with_color : string -> color -> string
+
+  val clear : unit -> unit
+
+  val reset : unit -> unit
+end =
+struct
+  type color = [ `green
+               | `red
+               | `white
+               ]
+
+  let ansi_code_clear = "\027[2J"    (* Clear screen *)
+  let ansi_code_reset = "\027[1;1H"  (* Reset cursor position *)
+
+  let string_of_color = function
+    | `green -> "\027[0;32m"
+    | `red   -> "\027[1;31m"
+    | `white -> "\027[1;37m"
+
+  let string_with_color s c =
+    sprintf "%s%s\027[0m" (string_of_color c) s
+
+  let clear () =
+    print_string ansi_code_clear
+
+  let reset () =
+    print_string ansi_code_reset
+end
+
+
+module Matrix :
+sig
+  module Point :
+  sig
     type t = {r : int; k : int}
   end
 
@@ -19,10 +62,10 @@ module type MATRIX = sig
   val iter : 'a t -> f:(Point.t -> 'a -> unit) -> unit
 
   val print : 'a t -> to_string:('a -> string) -> unit
-end
-
-module Matrix : MATRIX = struct
-  module Point = struct
+end =
+struct
+  module Point =
+  struct
     type t = {r : int; k : int}
 
     let (+) p p' =
@@ -31,7 +74,8 @@ module Matrix : MATRIX = struct
       }
   end
 
-  module Direction = struct
+  module Direction =
+  struct
     type t = NW | N | NE
            | W  |     E
            | SW | S | SE
@@ -107,97 +151,214 @@ module Matrix : MATRIX = struct
 end
 
 
-module Msg = struct
-  type t = string
-end
+module PhenoType :
+sig
+  type t
 
+  val create : char -> Terminal.color option -> t
 
-module State = struct
-  type t = string
-end
+  val to_string : t -> string
+end =
+struct
+  type t = { color     : Terminal.color option
+           ; character : char
+           }
 
+  let create character color =
+    {color; character}
 
-module PhenoType = struct
-  type t = string
+  let to_string = function
+    | {color=None; character} ->
+      String.of_char character
+    | {color=Some c; character} ->
+      Terminal.string_with_color (String.of_char character) c
 end
 
 
-module Cell = struct
-  type t = { msg   : Msg.t
+module Cell =
+struct
+  module State =
+  struct
+    type intention = Friendly
+                   | Neutral
+                   | Hostile
+
+    type t = Alive of intention
+           | Dead
+  end
+
+  type t = { state : State.t
            ; pheno : PhenoType.t
-           ; state : State.t
            }
 end
 
 
-module type RULE = sig
+module type RULE =
+sig
   val create : unit -> Cell.t
 
-  val transition : state:State.t -> inputs:Msg.t list -> Cell.t
+  val transition : self:Cell.State.t
+                -> neighbors:Cell.State.t list
+                -> Cell.t
 end
 
 
-module Conway : RULE = struct
-  type state = D | A
+module Life : RULE =
+struct
+  module State :
+  sig
+    type t = D | A
 
-  let state_of_string : (string -> state) = function
-    | "D" -> D
-    | "A" -> A
-    | _   -> assert false
+    val of_int : int -> t
 
-  let state_of_int : (int -> state) = function
-    | 0 -> D
-    | 1 -> A
-    | _ -> assert false
+    val is_alive : t -> bool
 
-  let int_of_state : (state -> int) = function
-    | D -> 0
-    | A -> 1
+    val to_cell : t -> Cell.t
 
-  let string_of_state : (state -> string) = function
-    | D -> "D"
-    | A -> "A"
+    val of_cell_state : Cell.State.t -> t
 
-  let msg_of_state : (state -> Msg.t) =
-    string_of_state
+    val next : t -> live_neighbors:int -> t
+  end =
+  struct
+    type t = D | A
 
-  let pheno_of_state : (state -> PhenoType.t) = function
-    | D -> " "
-    | A -> "o"
+    let of_int = function
+      | 0 -> D
+      | 1 -> A
+      | _ -> assert false
 
-  let int_of_msg msg =
-    msg |> state_of_string |> int_of_state
+    let is_alive = function
+      | D -> false
+      | A -> true
 
-  let next state ~live_neighbors =
-    match state with
-    | A when live_neighbors < 2 -> D
-    | A when live_neighbors < 4 -> A
-    | A when live_neighbors > 3 -> D
-    | D when live_neighbors = 3 -> A
-    | A -> A
-    | D -> D
+    let to_pheno = function
+      | D -> PhenoType.create ' ' None
+      | A -> PhenoType.create 'o' (Some `white)
 
-  let cell_of_state s =
-    { Cell.msg   = s |> msg_of_state
-    ; Cell.pheno = s |> pheno_of_state
-    ; Cell.state = s |> string_of_state
-    }
+    let of_cell_state = function
+      | Cell.State.Dead                      -> D
+      | Cell.State.Alive Cell.State.Friendly -> A
+      | Cell.State.Alive Cell.State.Neutral  -> A
+      | Cell.State.Alive Cell.State.Hostile  -> D
+
+    let to_cell_state = function
+      | D -> Cell.State.Dead
+      | A -> Cell.State.Alive Cell.State.Neutral
+
+    let to_cell t =
+      { Cell.state = t |> to_cell_state
+      ; Cell.pheno = t |> to_pheno
+      }
+
+    let next t ~live_neighbors =
+      match t with
+      | A when live_neighbors < 2 -> D
+      | A when live_neighbors < 4 -> A
+      | A when live_neighbors > 3 -> D
+      | D when live_neighbors = 3 -> A
+      | A -> A
+      | D -> D
+  end
+
+  let create () =
+    Random.int 2 |> State.of_int |> State.to_cell
+
+  let count_of_live =
+       List.map       ~f:State.of_cell_state
+    |- List.filter    ~f:State.is_alive
+    |- List.length
+
+  let transition ~self ~neighbors =
+    self |> State.of_cell_state
+         |> State.next ~live_neighbors:(count_of_live neighbors)
+         |> State.to_cell
+end
+
+
+module ForestFire : RULE =
+struct
+  module State :
+  sig
+    type t = E | T | B
+
+    val is_burning : t -> bool
+
+    val of_int : int -> t
+
+    val to_cell : t -> Cell.t
+
+    val of_cell_state : Cell.State.t -> t
+
+    val next : t -> burning_neighbors:int -> t
+  end =
+  struct
+    type t = E | T | B
+
+    let is_burning = function
+      | E -> false
+      | T -> false
+      | B -> true
+
+    let of_int = function
+      | 0 -> E
+      | 1 -> T
+      | 2 -> B
+      | _ -> assert false
+
+    let to_pheno = function
+      | E -> PhenoType.create ' ' None
+      | T -> PhenoType.create 'T' (Some `green)
+      | B -> PhenoType.create '#' (Some `red)
+
+    let of_cell_state = function
+      | Cell.State.Dead                      -> E
+      | Cell.State.Alive Cell.State.Friendly -> T
+      | Cell.State.Alive Cell.State.Neutral  -> E
+      | Cell.State.Alive Cell.State.Hostile  -> B
+
+    let to_cell_state = function
+      | E -> Cell.State.Dead
+      | T -> Cell.State.Alive Cell.State.Friendly
+      | B -> Cell.State.Alive Cell.State.Hostile
+
+    let to_cell t =
+      { Cell.state = t |> to_cell_state
+      ; Cell.pheno = t |> to_pheno
+      }
+
+    let f = 0.000001  (* Probability of spontaneous ignition *)
+    let p = 0.1       (* Probability of spontaneous growth *)
+
+    let is_probable p =
+      (Random.float 1.0) <= p
+
+    let next t ~burning_neighbors =
+      match t, burning_neighbors with
+      | E, _ when is_probable p         -> T
+      | E, _                            -> E
+      | T, 0 when is_probable f         -> B
+      | T, _ when burning_neighbors > 0 -> B
+      | T, _                            -> T
+      | B, _                            -> E
+  end
 
   let create () =
-    Random.int 2 |> state_of_int |> cell_of_state
+    Random.int 3 |> State.of_int |> State.to_cell
 
-  let live_neighbors inputs =
-    inputs |> List.map ~f:int_of_msg |> List.fold_left ~init:0 ~f:(+)
+  let count_of_burning =
+       List.map       ~f:State.of_cell_state
+    |- List.filter    ~f:State.is_burning
+    |- List.length
 
-  let transition ~state ~inputs =
-    state
-    |> state_of_string
-    |> next ~live_neighbors:(live_neighbors inputs)
-    |> cell_of_state
+  let transition ~self ~neighbors =
+    self |> State.of_cell_state
+         |> State.next ~burning_neighbors:(count_of_burning neighbors)
+         |> State.to_cell
 end
 
 
-module Automaton : sig
+module Automaton :
+sig
   type t
 
   val create  : rows:int
@@ -207,7 +368,8 @@ module Automaton : sig
              -> t
 
   val loop : t -> unit
-end = struct
+end =
+struct
   type cell = { data : Cell.t
               ; rule : (module RULE)
               }
@@ -219,23 +381,24 @@ end = struct
 
   let create ~rows:rs ~columns:ks ~interval ~rules =
     let n = List.length rules in
-    let i = Random.int n in
     let init () =
-      let rule = List.nth_exn rules i in
+      let rule = List.nth_exn rules (Random.int n) in
       let module Rule = (val rule : RULE) in
       { rule
       ; data = Rule.create ()
       }
     in
+    Terminal.clear ();
     { grid     = Matrix.map ~f:init (Matrix.create ~rs ~ks ())
     ; interval = Time.Span.of_float interval
     ; bar      = String.make ks '-'
     }
 
   let cell_to_string cell =
-    cell.data.Cell.pheno
+    PhenoType.to_string cell.data.Cell.pheno
 
   let print t =
+    Terminal.reset ();
     print_endline t.bar;
     Matrix.print t.grid ~to_string:cell_to_string;
     print_endline t.bar
@@ -248,8 +411,8 @@ end = struct
           let neighbors = Matrix.get_neighbors t.grid point in
           let data =
             Rule.transition
-              ~state:data.Cell.state
-              ~inputs:(List.map neighbors ~f:(fun cell -> cell.data.Cell.msg))
+              ~self:data.Cell.state
+              ~neighbors:(List.map neighbors ~f:(fun c -> c.data.Cell.state))
           in
           {rule; data}
       )
@@ -263,12 +426,12 @@ end = struct
 end
 
 
-let main () =
+let main interval () =
   Random.self_init ();
   let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in
-  let interval = 0.1 in
   let rules =
-    [ (module Conway : RULE)
+    [ (module Life : RULE)
+    ; (module ForestFire : RULE)
     ]
   in
   Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
@@ -276,7 +439,11 @@ let main () =
 
 let spec =
   let summary = "Polymorphic Cellular Automata" in
-  let spec = Command.Spec.empty in
+  let spec = Command.Spec.(empty
+    +> flag "-i" (optional_with_default 0.1 float)
+             ~doc:" Induced interval between generations."
+    )
+  in
   Command.basic ~summary spec main