X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=polymorphism%2F001%2Fsrc%2Fpolymorphism.ml;h=62730e4457959cf013f49f52427f9952d252f10c;hb=77d0f9e1ea0f4e1ea131c0bde987ea25ad57d023;hp=7b48faf681d45a53c63166c21f8f1c4dd06cce4f;hpb=a0d860e45b892ba0bd5aff132c24b23bd9ebeff1;p=cellular-automata.git diff --git a/polymorphism/001/src/polymorphism.ml b/polymorphism/001/src/polymorphism.ml index 7b48faf..62730e4 100644 --- a/polymorphism/001/src/polymorphism.ml +++ b/polymorphism/001/src/polymorphism.ml @@ -4,7 +4,8 @@ open Core.Std let (|-) g f x = f (g x) -module Terminal : sig +module Terminal : +sig type color = [ `green | `red | `white @@ -15,7 +16,8 @@ module Terminal : sig val clear : unit -> unit val reset : unit -> unit -end = struct +end = +struct type color = [ `green | `red | `white @@ -40,8 +42,10 @@ end = struct end -module type MATRIX = sig - module Point : sig +module Matrix : +sig + module Point : + sig type t = {r : int; k : int} end @@ -58,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' = @@ -70,7 +74,8 @@ module Matrix : MATRIX = struct } end - module Direction = struct + module Direction = + struct type t = NW | N | NE | W | E | SW | S | SE @@ -146,13 +151,15 @@ module Matrix : MATRIX = struct end -module PhenoType : sig +module PhenoType : +sig type t val create : char -> Terminal.color option -> t val to_string : t -> string -end = struct +end = +struct type t = { color : Terminal.color option ; character : char } @@ -168,9 +175,15 @@ end = struct end -module Cell = struct - module State = struct - type t = Alive of char +module Cell = +struct + module State = + struct + type intention = Friendly + | Neutral + | Hostile + + type t = Alive of intention | Dead end @@ -180,7 +193,8 @@ module Cell = struct end -module type RULE = sig +module type RULE = +sig val create : unit -> Cell.t val transition : self:Cell.State.t @@ -189,8 +203,10 @@ module type RULE = sig end -module Life : RULE = struct - module State : sig +module Life : RULE = +struct + module State : + sig type t = D | A val of_int : int -> t @@ -200,7 +216,10 @@ module Life : RULE = struct val to_cell : t -> Cell.t val of_cell_state : Cell.State.t -> t - end = struct + + val next : t -> live_neighbors:int -> t + end = + struct type t = D | A let of_int = function @@ -217,28 +236,29 @@ module Life : RULE = struct | A -> PhenoType.create 'o' (Some `white) let of_cell_state = function - | Cell.State.Dead -> D - | Cell.State.Alive 'A' -> A - | Cell.State.Alive _ -> D (* Foreign cell *) + | 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 'A' + | A -> Cell.State.Alive Cell.State.Neutral let to_cell t = { Cell.state = t |> to_cell_state ; Cell.pheno = t |> to_pheno } - end - let next state ~live_neighbors = - match state with - | 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 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 @@ -249,13 +269,15 @@ module Life : RULE = struct let transition ~self ~neighbors = self |> State.of_cell_state - |> next ~live_neighbors:(live_neighbors neighbors) + |> State.next ~live_neighbors:(live_neighbors neighbors) |> State.to_cell end -module ForestFire : RULE = struct - module State : sig +module ForestFire : RULE = +struct + module State : + sig type t = E | T | B val is_burning : t -> bool @@ -267,7 +289,10 @@ module ForestFire : RULE = struct val to_cell : t -> Cell.t val of_cell_state : Cell.State.t -> t - end = struct + + val next : t -> burning_neighbors:int -> t + end = + struct type t = E | T | B let is_burning = function @@ -292,39 +317,39 @@ module ForestFire : RULE = struct | 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 *) + | 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 'T' - | B -> Cell.State.Alive 'B' + | 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 } - end - let create () = - 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 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 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 next state ~burning_neighbors = - match state, burning_neighbors with - | 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 create () = + Random.int 3 |> State.of_int |> State.to_cell let burning_neighbors neighbors = neighbors |> List.map ~f:State.of_cell_state @@ -334,12 +359,13 @@ module ForestFire : RULE = struct let transition ~self ~neighbors = self |> State.of_cell_state - |> next ~burning_neighbors:(burning_neighbors neighbors) + |> State.next ~burning_neighbors:(burning_neighbors neighbors) |> State.to_cell end -module Automaton : sig +module Automaton : +sig type t val create : rows:int @@ -349,7 +375,8 @@ module Automaton : sig -> t val loop : t -> unit -end = struct +end = +struct type cell = { data : Cell.t ; rule : (module RULE) } @@ -406,10 +433,9 @@ 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 Life : RULE) ; (module ForestFire : RULE) @@ -420,7 +446,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