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
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' =
}
end
- module Direction = struct
+ module Direction =
+ struct
type t = NW | N | NE
| W | E
| SW | S | SE
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
-> t
val loop : t -> unit
-end = struct
+end =
+struct
type cell = { data : Cell.t
; rule : (module RULE)
}
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
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}
)
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.create ~rows:(rows - 3) ~columns ~interval ~rules |> Automaton.loop
+ Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
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
home / code / cellular-automata.git / blobdiff