X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=polymorphism%2F001%2Fsrc%2Fpolymorphism.ml;h=d63386ac19d4981db9d419ea6961bc43c17f0321;hb=5b98f452f5264cde8bc34b3ed85fe8781deb506b;hp=aae480b44315dc5f5462444244290a12eb99ab58;hpb=3ac904c025187fa279cb311a7fa0ce668c85fa4c;p=cellular-automata.git

diff --git a/polymorphism/001/src/polymorphism.ml b/polymorphism/001/src/polymorphism.ml
index aae480b..d63386a 100644
--- a/polymorphism/001/src/polymorphism.ml
+++ b/polymorphism/001/src/polymorphism.ml
@@ -1,9 +1,13 @@
 open Core.Std
 
 
+let (|-) g f x = f (g x)
+
+
 module Terminal : sig
   type color = [ `green
                | `red
+               | `white
                ]
 
   val string_with_color : string -> color -> string
@@ -14,6 +18,7 @@ module Terminal : sig
 end = struct
   type color = [ `green
                | `red
+               | `white
                ]
 
   let ansi_code_clear = "\027[2J"    (* Clear screen *)
@@ -22,6 +27,7 @@ end = struct
   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
@@ -140,16 +146,6 @@ module Matrix : MATRIX = struct
 end
 
 
-module Msg = struct
-  type t = string
-end
-
-
-module State = struct
-  type t = string
-end
-
-
 module PhenoType : sig
   type t
 
@@ -173,9 +169,13 @@ end
 
 
 module Cell = struct
-  type t = { msg   : Msg.t
+  module State = struct
+    type t = Alive of char
+           | Dead
+  end
+
+  type t = { state : State.t
            ; pheno : PhenoType.t
-           ; state : State.t
            }
 end
 
@@ -183,136 +183,159 @@ end
 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
+
+    val of_int : int -> t
+
+    val to_int : t -> int
 
-  let state_of_string : (string -> state) = function
-    | "D" -> D
-    | "A" -> A
-    | _   -> assert false
+    val to_cell : t -> Cell.t
 
-  let state_of_int : (int -> state) = function
-    | 0 -> D
-    | 1 -> A
-    | _ -> assert false
+    val of_cell_state : Cell.State.t -> t
+  end = struct
+    type t = D | A
 
-  let int_of_state : (state -> int) = function
-    | D -> 0
-    | A -> 1
+    let of_int = function
+      | 0 -> D
+      | 1 -> A
+      | _ -> assert false
 
-  let string_of_state : (state -> string) = function
-    | D -> "D"
-    | A -> "A"
+    let to_int = function
+      | D -> 0
+      | A -> 1
 
-  let msg_of_state : (state -> Msg.t) =
-    string_of_state
+    let to_pheno = function
+      | D -> PhenoType.create ' ' None
+      | A -> PhenoType.create 'o' (Some `white)
 
-  let pheno_of_state : (state -> PhenoType.t) = function
-    | D -> PhenoType.create ' ' None
-    | A -> PhenoType.create 'o' None
+    let of_cell_state = function
+      | Cell.State.Dead      -> D
+      | Cell.State.Alive 'A' -> A
+      | Cell.State.Alive _   -> D  (* Foreign cell *)
 
-  let int_of_msg msg =
-    msg |> state_of_string |> int_of_state
+    let to_cell_state = function
+      | D -> Cell.State.Dead
+      | A -> Cell.State.Alive 'A'
+
+    let to_cell t =
+      { Cell.state = t |> to_cell_state
+      ; Cell.pheno = t |> to_pheno
+      }
+  end
 
   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 cell_of_state s =
-    { Cell.msg   = s |> msg_of_state
-    ; Cell.pheno = s |> pheno_of_state
-    ; Cell.state = s |> string_of_state
-    }
+    | State.A when live_neighbors < 2 -> State.D
+    | State.A when live_neighbors < 4 -> State.A
+    | State.A when live_neighbors > 3 -> State.D
+    | State.D when live_neighbors = 3 -> State.A
+    | State.A -> State.A
+    | State.D -> State.D
 
   let create () =
-    Random.int 2 |> state_of_int |> cell_of_state
-
-  let live_neighbors inputs =
-    inputs
-    |> List.filter ~f:(function "D" | "A" -> true | _ -> false)
-    |> List.map ~f:int_of_msg
-    |> List.fold_left ~init:0 ~f:(+)
-
-  let transition ~state ~inputs =
-    state
-    |> state_of_string
-    |> next ~live_neighbors:(live_neighbors inputs)
-    |> cell_of_state
+    Random.int 2 |> State.of_int |> State.to_cell
+
+  let live_neighbors neighbors =
+    neighbors |> List.map ~f:(State.of_cell_state |- State.to_int)
+              |> List.fold_left ~init:0 ~f:(+)
+
+  let transition ~self ~neighbors =
+    self |> State.of_cell_state
+         |> next ~live_neighbors:(live_neighbors neighbors)
+         |> State.to_cell
 end
 
 
 module ForestFire : RULE = struct
-  type state = E | T | B
+  module State : sig
+    type t = E | T | B
 
-  let string_of_state : (state -> string) = function
-    | E -> "E"
-    | T -> "T"
-    | B -> "B"
+    val is_burning : t -> bool
 
-  let msg_of_state : (state -> Msg.t) =
-    string_of_state
+    val of_int : int -> t
 
-  let pheno_of_state : (state -> PhenoType.t) = function
-    | E -> PhenoType.create ' ' None
-    | T -> PhenoType.create 'T' (Some `green)
-    | B -> PhenoType.create '#' (Some `red)
+    val to_int : t -> int
 
-  let cell_of_state s =
-    { Cell.msg   = s |> msg_of_state
-    ; Cell.pheno = s |> pheno_of_state
-    ; Cell.state = s |> string_of_state
-    }
+    val to_cell : t -> Cell.t
+
+    val of_cell_state : Cell.State.t -> 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 state_of_string : (string -> state) = function
-    | "E" -> E
-    | "T" -> T
-    | "B" -> B
-    | _   -> assert false
+    let to_int = function
+      | E -> 0
+      | T -> 1
+      | B -> 2
 
-  let state_of_int : (int -> state) = 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 'T' -> T
+      | Cell.State.Alive 'B' -> B
+      | Cell.State.Alive _   -> E  (* Foreign cell *)
+
+    let to_cell_state = function
+      | E -> Cell.State.Dead
+      | T -> Cell.State.Alive 'T'
+      | B -> Cell.State.Alive 'B'
+
+    let to_cell t =
+      { Cell.state = t |> to_cell_state
+      ; Cell.pheno = t |> to_pheno
+      }
+  end
 
   let create () =
-    Random.int 3 |> state_of_int |> cell_of_state
+    Random.int 3 |> State.of_int |> State.to_cell
 
   let f = 0.000001  (* Probability of spontaneous ignition *)
   let p = 0.1       (* Probability of spontaneous growth *)
 
-  let is_probable = function
-    | probability when (Random.float 1.0) <= probability -> true
-    | _ -> false
+  let is_probable p =
+    (Random.float 1.0) <= p
 
   let next state ~burning_neighbors =
     match state, 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
-
-  let burning_neighbors inputs =
-    inputs
-    |> List.filter_map ~f:(function "B" -> Some 1 | _ -> None)
-    |> List.fold_left ~init:0 ~f:(+)
-
-  let transition ~state ~inputs =
-    state
-    |> state_of_string
-    |> next ~burning_neighbors:(burning_neighbors inputs)
-    |> cell_of_state
+    | State.E, _ when is_probable p         -> State.T
+    | State.E, _                            -> State.E
+    | State.T, 0 when is_probable f         -> State.B
+    | State.T, _ when burning_neighbors > 0 -> State.B
+    | State.T, _                            -> State.T
+    | State.B, _                            -> State.E
+
+  let burning_neighbors neighbors =
+    neighbors |> List.map ~f:State.of_cell_state
+              |> List.filter ~f:State.is_burning
+              |> List.map ~f:State.to_int
+              |> List.fold_left ~init:0 ~f:(+)
+
+  let transition ~self ~neighbors =
+    self |> State.of_cell_state
+         |> next ~burning_neighbors:(burning_neighbors neighbors)
+         |> State.to_cell
 end
 
 
@@ -368,8 +391,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}
       )
@@ -383,12 +406,11 @@ 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
@@ -397,7 +419,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