4 let (|-) g f x = f (g x)
13 val string_with_color : string -> color -> string
15 val clear : unit -> unit
17 val reset : unit -> unit
24 let ansi_code_clear = "\027[2J" (* Clear screen *)
25 let ansi_code_reset = "\027[1;1H" (* Reset cursor position *)
27 let string_of_color = function
28 | `green -> "\027[0;32m"
29 | `red -> "\027[1;31m"
30 | `white -> "\027[1;37m"
32 let string_with_color s c =
33 sprintf "%s%s\027[0m" (string_of_color c) s
36 print_string ansi_code_clear
39 print_string ansi_code_reset
43 module type MATRIX = sig
45 type t = {r : int; k : int}
50 val create : rs:int -> ks:int -> 'a -> 'a t
52 val get_neighbors : 'a t -> Point.t -> 'a list
54 val map : 'a t -> f:('a -> 'b) -> 'b t
56 val mapi : 'a t -> f:(Point.t -> 'a -> 'b) -> 'b t
58 val iter : 'a t -> f:(Point.t -> 'a -> unit) -> unit
60 val print : 'a t -> to_string:('a -> string) -> unit
63 module Matrix : MATRIX = struct
65 type t = {r : int; k : int}
73 module Direction = struct
78 let all = [ NW ; N ; NE
86 | NW -> {r = -1; k = -1}
87 | N -> {r = -1; k = 0}
88 | NE -> {r = -1; k = 1}
89 | W -> {r = 0; k = -1}
91 | SW -> {r = 1; k = -1}
93 | SE -> {r = 1; k = 1}
96 type 'a t = 'a array array
98 let create ~rs ~ks x =
99 Array.make_matrix ~dimx:rs ~dimy:ks x
106 f {Point.r; Point.k} x
110 let print t ~to_string =
113 Array.iter r ~f:(fun x -> printf "%s" (to_string x));
118 Array.map t ~f:(Array.map ~f:(fun x -> f x))
125 f {Point.r; Point.k} x
129 let get t {Point.r; Point.k} =
132 let is_within_bounds t {Point.r; Point.k} =
134 | [||] -> assert false
136 r >= 0 && r < Array.length t &&
137 k >= 0 && k < Array.length t.(0)
139 let neighborhood t point =
140 List.map Direction.all ~f:Direction.to_offset
141 |> List.map ~f:(fun offset_point -> Point.(point + offset_point))
142 |> List.filter ~f:(is_within_bounds t)
144 let get_neighbors t point =
145 List.map (neighborhood t point) ~f:(get t)
149 module PhenoType : sig
152 val create : char -> Terminal.color option -> t
154 val to_string : t -> string
156 type t = { color : Terminal.color option
160 let create character color =
163 let to_string = function
164 | {color=None; character} ->
165 String.of_char character
166 | {color=Some c; character} ->
167 Terminal.string_with_color (String.of_char character) c
172 module State = struct
173 type intention = Friendly
177 type t = Alive of intention
181 type t = { state : State.t
182 ; pheno : PhenoType.t
187 module type RULE = sig
188 val create : unit -> Cell.t
190 val transition : self:Cell.State.t
191 -> neighbors:Cell.State.t list
196 module Life : RULE = struct
200 val of_int : int -> t
202 val to_int : t -> int
204 val to_cell : t -> Cell.t
206 val of_cell_state : Cell.State.t -> t
210 let of_int = function
215 let to_int = function
219 let to_pheno = function
220 | D -> PhenoType.create ' ' None
221 | A -> PhenoType.create 'o' (Some `white)
223 let of_cell_state = function
224 | Cell.State.Dead -> D
225 | Cell.State.Alive Cell.State.Friendly -> A
226 | Cell.State.Alive Cell.State.Neutral -> A
227 | Cell.State.Alive Cell.State.Hostile -> D
229 let to_cell_state = function
230 | D -> Cell.State.Dead
231 | A -> Cell.State.Alive Cell.State.Neutral
234 { Cell.state = t |> to_cell_state
235 ; Cell.pheno = t |> to_pheno
239 let next state ~live_neighbors =
241 | State.A when live_neighbors < 2 -> State.D
242 | State.A when live_neighbors < 4 -> State.A
243 | State.A when live_neighbors > 3 -> State.D
244 | State.D when live_neighbors = 3 -> State.A
249 Random.int 2 |> State.of_int |> State.to_cell
251 let live_neighbors neighbors =
252 neighbors |> List.map ~f:(State.of_cell_state |- State.to_int)
253 |> List.fold_left ~init:0 ~f:(+)
255 let transition ~self ~neighbors =
256 self |> State.of_cell_state
257 |> next ~live_neighbors:(live_neighbors neighbors)
262 module ForestFire : RULE = struct
266 val is_burning : t -> bool
268 val of_int : int -> t
270 val to_int : t -> int
272 val to_cell : t -> Cell.t
274 val of_cell_state : Cell.State.t -> t
278 let is_burning = function
283 let of_int = function
289 let to_int = function
294 let to_pheno = function
295 | E -> PhenoType.create ' ' None
296 | T -> PhenoType.create 'T' (Some `green)
297 | B -> PhenoType.create '#' (Some `red)
299 let of_cell_state = function
300 | Cell.State.Dead -> E
301 | Cell.State.Alive Cell.State.Friendly -> T
302 | Cell.State.Alive Cell.State.Neutral -> E
303 | Cell.State.Alive Cell.State.Hostile -> B
305 let to_cell_state = function
306 | E -> Cell.State.Dead
307 | T -> Cell.State.Alive Cell.State.Friendly
308 | B -> Cell.State.Alive Cell.State.Hostile
311 { Cell.state = t |> to_cell_state
312 ; Cell.pheno = t |> to_pheno
317 Random.int 3 |> State.of_int |> State.to_cell
319 let f = 0.000001 (* Probability of spontaneous ignition *)
320 let p = 0.1 (* Probability of spontaneous growth *)
323 (Random.float 1.0) <= p
325 let next state ~burning_neighbors =
326 match state, burning_neighbors with
327 | State.E, _ when is_probable p -> State.T
328 | State.E, _ -> State.E
329 | State.T, 0 when is_probable f -> State.B
330 | State.T, _ when burning_neighbors > 0 -> State.B
331 | State.T, _ -> State.T
332 | State.B, _ -> State.E
334 let burning_neighbors neighbors =
335 neighbors |> List.map ~f:State.of_cell_state
336 |> List.filter ~f:State.is_burning
337 |> List.map ~f:State.to_int
338 |> List.fold_left ~init:0 ~f:(+)
340 let transition ~self ~neighbors =
341 self |> State.of_cell_state
342 |> next ~burning_neighbors:(burning_neighbors neighbors)
347 module Automaton : sig
350 val create : rows:int
353 -> rules: (module RULE) list
358 type cell = { data : Cell.t
359 ; rule : (module RULE)
362 type t = { grid : cell Matrix.t
363 ; interval : Time.Span.t
367 let create ~rows:rs ~columns:ks ~interval ~rules =
368 let n = List.length rules in
370 let rule = List.nth_exn rules (Random.int n) in
371 let module Rule = (val rule : RULE) in
373 ; data = Rule.create ()
377 { grid = Matrix.map ~f:init (Matrix.create ~rs ~ks ())
378 ; interval = Time.Span.of_float interval
379 ; bar = String.make ks '-'
382 let cell_to_string cell =
383 PhenoType.to_string cell.data.Cell.pheno
388 Matrix.print t.grid ~to_string:cell_to_string;
393 Matrix.mapi t.grid ~f:(
394 fun point {rule; data} ->
395 let module Rule = (val rule : RULE) in
396 let neighbors = Matrix.get_neighbors t.grid point in
399 ~self:data.Cell.state
400 ~neighbors:(List.map neighbors ~f:(fun c -> c.data.Cell.state))
409 Time.pause t.interval;
414 let main interval () =
416 let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in
418 [ (module Life : RULE)
419 ; (module ForestFire : RULE)
422 Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
426 let summary = "Polymorphic Cellular Automata" in
427 let spec = Command.Spec.(empty
428 +> flag "-i" (optional_with_default 0.1 float)
429 ~doc:" Induced interval between generations."
432 Command.basic ~summary spec main
435 let () = Command.run spec