10 val string_with_color : string -> color -> string
12 val clear : unit -> unit
14 val reset : unit -> unit
21 let ansi_code_clear = "\027[2J" (* Clear screen *)
22 let ansi_code_reset = "\027[1;1H" (* Reset cursor position *)
24 let string_of_color = function
25 | `green -> "\027[0;32m"
26 | `red -> "\027[1;31m"
27 | `white -> "\027[1;37m"
29 let string_with_color s c =
30 sprintf "%s%s\027[0m" (string_of_color c) s
33 print_string ansi_code_clear
36 print_string ansi_code_reset
40 module type MATRIX = sig
42 type t = {r : int; k : int}
47 val create : rs:int -> ks:int -> 'a -> 'a t
49 val get_neighbors : 'a t -> Point.t -> 'a list
51 val map : 'a t -> f:('a -> 'b) -> 'b t
53 val mapi : 'a t -> f:(Point.t -> 'a -> 'b) -> 'b t
55 val iter : 'a t -> f:(Point.t -> 'a -> unit) -> unit
57 val print : 'a t -> to_string:('a -> string) -> unit
60 module Matrix : MATRIX = struct
62 type t = {r : int; k : int}
70 module Direction = struct
75 let all = [ NW ; N ; NE
83 | NW -> {r = -1; k = -1}
84 | N -> {r = -1; k = 0}
85 | NE -> {r = -1; k = 1}
86 | W -> {r = 0; k = -1}
88 | SW -> {r = 1; k = -1}
90 | SE -> {r = 1; k = 1}
93 type 'a t = 'a array array
95 let create ~rs ~ks x =
96 Array.make_matrix ~dimx:rs ~dimy:ks x
103 f {Point.r; Point.k} x
107 let print t ~to_string =
110 Array.iter r ~f:(fun x -> printf "%s" (to_string x));
115 Array.map t ~f:(Array.map ~f:(fun x -> f x))
122 f {Point.r; Point.k} x
126 let get t {Point.r; Point.k} =
129 let is_within_bounds t {Point.r; Point.k} =
131 | [||] -> assert false
133 r >= 0 && r < Array.length t &&
134 k >= 0 && k < Array.length t.(0)
136 let neighborhood t point =
137 List.map Direction.all ~f:Direction.to_offset
138 |> List.map ~f:(fun offset_point -> Point.(point + offset_point))
139 |> List.filter ~f:(is_within_bounds t)
141 let get_neighbors t point =
142 List.map (neighborhood t point) ~f:(get t)
151 module State = struct
156 module PhenoType : sig
159 val create : char -> Terminal.color option -> t
161 val to_string : t -> string
163 type t = { color : Terminal.color option
167 let create character color =
170 let to_string = function
171 | {color=None; character} ->
172 String.of_char character
173 | {color=Some c; character} ->
174 Terminal.string_with_color (String.of_char character) c
179 type t = { msg : Msg.t
180 ; pheno : PhenoType.t
186 module type RULE = sig
187 val create : unit -> Cell.t
189 val transition : state:State.t -> inputs:Msg.t list -> Cell.t
193 module Life : RULE = struct
196 let state_of_string : (string -> state) = function
201 let state_of_int : (int -> state) = function
206 let int_of_state : (state -> int) = function
210 let string_of_state : (state -> string) = function
214 let msg_of_state : (state -> Msg.t) =
217 let pheno_of_state : (state -> PhenoType.t) = function
218 | D -> PhenoType.create ' ' None
219 | A -> PhenoType.create 'o' (Some `white)
222 msg |> state_of_string |> int_of_state
224 let next state ~live_neighbors =
226 | A when live_neighbors < 2 -> D
227 | A when live_neighbors < 4 -> A
228 | A when live_neighbors > 3 -> D
229 | D when live_neighbors = 3 -> A
233 let cell_of_state s =
234 { Cell.msg = s |> msg_of_state
235 ; Cell.pheno = s |> pheno_of_state
236 ; Cell.state = s |> string_of_state
240 Random.int 2 |> state_of_int |> cell_of_state
242 let live_neighbors inputs =
244 |> List.filter ~f:(function "D" | "A" -> true | _ -> false)
245 |> List.map ~f:int_of_msg
246 |> List.fold_left ~init:0 ~f:(+)
248 let transition ~state ~inputs =
251 |> next ~live_neighbors:(live_neighbors inputs)
256 module ForestFire : RULE = struct
257 type state = E | T | B
259 let string_of_state : (state -> string) = function
264 let msg_of_state : (state -> Msg.t) =
267 let pheno_of_state : (state -> PhenoType.t) = function
268 | E -> PhenoType.create ' ' None
269 | T -> PhenoType.create 'T' (Some `green)
270 | B -> PhenoType.create '#' (Some `red)
272 let cell_of_state s =
273 { Cell.msg = s |> msg_of_state
274 ; Cell.pheno = s |> pheno_of_state
275 ; Cell.state = s |> string_of_state
278 let state_of_string : (string -> state) = function
284 let state_of_int : (int -> state) = function
291 Random.int 3 |> state_of_int |> cell_of_state
293 let f = 0.000001 (* Probability of spontaneous ignition *)
294 let p = 0.1 (* Probability of spontaneous growth *)
297 (Random.float 1.0) <= p
299 let next state ~burning_neighbors =
300 match state, burning_neighbors with
301 | E, _ when is_probable p -> T
303 | T, 0 when is_probable f -> B
304 | T, _ when burning_neighbors > 0 -> B
308 let burning_neighbors inputs =
310 |> List.filter_map ~f:(function "B" -> Some 1 | _ -> None)
311 |> List.fold_left ~init:0 ~f:(+)
313 let transition ~state ~inputs =
316 |> next ~burning_neighbors:(burning_neighbors inputs)
321 module Automaton : sig
324 val create : rows:int
327 -> rules: (module RULE) list
332 type cell = { data : Cell.t
333 ; rule : (module RULE)
336 type t = { grid : cell Matrix.t
337 ; interval : Time.Span.t
341 let create ~rows:rs ~columns:ks ~interval ~rules =
342 let n = List.length rules in
344 let rule = List.nth_exn rules (Random.int n) in
345 let module Rule = (val rule : RULE) in
347 ; data = Rule.create ()
351 { grid = Matrix.map ~f:init (Matrix.create ~rs ~ks ())
352 ; interval = Time.Span.of_float interval
353 ; bar = String.make ks '-'
356 let cell_to_string cell =
357 PhenoType.to_string cell.data.Cell.pheno
362 Matrix.print t.grid ~to_string:cell_to_string;
367 Matrix.mapi t.grid ~f:(
368 fun point {rule; data} ->
369 let module Rule = (val rule : RULE) in
370 let neighbors = Matrix.get_neighbors t.grid point in
373 ~state:data.Cell.state
374 ~inputs:(List.map neighbors ~f:(fun cell -> cell.data.Cell.msg))
383 Time.pause t.interval;
390 let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in
391 let interval = 0.1 in
393 [ (module Life : RULE)
394 ; (module ForestFire : RULE)
397 Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules)
401 let summary = "Polymorphic Cellular Automata" in
402 let spec = Command.Spec.empty in
403 Command.basic ~summary spec main
406 let () = Command.run spec