Commit | Line | Data |
---|---|---|
8c93b722 SK |
1 | open Core.Std |
2 | ||
3 | ||
ce139f1f SK |
4 | module Terminal : sig |
5 | type color = [ `green | |
6 | | `red | |
39971ff4 | 7 | | `white |
ce139f1f SK |
8 | ] |
9 | ||
10 | val string_with_color : string -> color -> string | |
11 | ||
12 | val clear : unit -> unit | |
13 | ||
14 | val reset : unit -> unit | |
15 | end = struct | |
16 | type color = [ `green | |
17 | | `red | |
39971ff4 | 18 | | `white |
ce139f1f SK |
19 | ] |
20 | ||
21 | let ansi_code_clear = "\027[2J" (* Clear screen *) | |
22 | let ansi_code_reset = "\027[1;1H" (* Reset cursor position *) | |
23 | ||
24 | let string_of_color = function | |
25 | | `green -> "\027[0;32m" | |
26 | | `red -> "\027[1;31m" | |
39971ff4 | 27 | | `white -> "\027[1;37m" |
ce139f1f SK |
28 | |
29 | let string_with_color s c = | |
30 | sprintf "%s%s\027[0m" (string_of_color c) s | |
31 | ||
32 | let clear () = | |
33 | print_string ansi_code_clear | |
34 | ||
35 | let reset () = | |
36 | print_string ansi_code_reset | |
37 | end | |
38 | ||
39 | ||
4d49c95e | 40 | module type MATRIX = sig |
7c363dd8 SK |
41 | module Point : sig |
42 | type t = {r : int; k : int} | |
43 | end | |
44 | ||
4d49c95e SK |
45 | type 'a t |
46 | ||
a1665c92 | 47 | val create : rs:int -> ks:int -> 'a -> 'a t |
4d49c95e | 48 | |
7c363dd8 | 49 | val get_neighbors : 'a t -> Point.t -> 'a list |
4d49c95e | 50 | |
65dbef41 SK |
51 | val map : 'a t -> f:('a -> 'b) -> 'b t |
52 | ||
a1665c92 | 53 | val mapi : 'a t -> f:(Point.t -> 'a -> 'b) -> 'b t |
4d49c95e | 54 | |
a1665c92 | 55 | val iter : 'a t -> f:(Point.t -> 'a -> unit) -> unit |
0ce0e798 SK |
56 | |
57 | val print : 'a t -> to_string:('a -> string) -> unit | |
4d49c95e SK |
58 | end |
59 | ||
60 | module Matrix : MATRIX = struct | |
7c363dd8 SK |
61 | module Point = struct |
62 | type t = {r : int; k : int} | |
63 | ||
64 | let (+) p p' = | |
65 | { r = p.r + p'.r | |
66 | ; k = p.k + p'.k | |
67 | } | |
68 | end | |
69 | ||
394125ca SK |
70 | module Direction = struct |
71 | type t = NW | N | NE | |
72 | | W | E | |
73 | | SW | S | SE | |
74 | ||
75 | let all = [ NW ; N ; NE | |
76 | ; W ; E | |
77 | ; SW ; S ; SE | |
78 | ] | |
79 | ||
7c363dd8 SK |
80 | let to_offset = |
81 | let open Point in | |
82 | function | |
83 | | NW -> {r = -1; k = -1} | |
84 | | N -> {r = -1; k = 0} | |
85 | | NE -> {r = -1; k = 1} | |
86 | | W -> {r = 0; k = -1} | |
87 | | E -> {r = 0; k = 1} | |
88 | | SW -> {r = 1; k = -1} | |
89 | | S -> {r = 1; k = 0} | |
90 | | SE -> {r = 1; k = 1} | |
394125ca SK |
91 | end |
92 | ||
4d49c95e SK |
93 | type 'a t = 'a array array |
94 | ||
a1665c92 SK |
95 | let create ~rs ~ks x = |
96 | Array.make_matrix ~dimx:rs ~dimy:ks x | |
4d49c95e SK |
97 | |
98 | let iter t ~f = | |
99 | Array.iteri t ~f:( | |
63fe855d SK |
100 | fun r ks -> |
101 | Array.iteri ks ~f:( | |
a1665c92 SK |
102 | fun k x -> |
103 | f {Point.r; Point.k} x | |
4d49c95e SK |
104 | ) |
105 | ) | |
106 | ||
0ce0e798 SK |
107 | let print t ~to_string = |
108 | Array.iter t ~f:( | |
63fe855d SK |
109 | fun r -> |
110 | Array.iter r ~f:(fun x -> printf "%s" (to_string x)); | |
0ce0e798 SK |
111 | print_newline () |
112 | ) | |
113 | ||
4d49c95e | 114 | let map t ~f = |
65dbef41 SK |
115 | Array.map t ~f:(Array.map ~f:(fun x -> f x)) |
116 | ||
117 | let mapi t ~f = | |
4d49c95e | 118 | Array.mapi t ~f:( |
63fe855d SK |
119 | fun r ks -> |
120 | Array.mapi ks ~f:( | |
a1665c92 SK |
121 | fun k x -> |
122 | f {Point.r; Point.k} x | |
4d49c95e SK |
123 | ) |
124 | ) | |
125 | ||
7c363dd8 | 126 | let get t {Point.r; Point.k} = |
63fe855d | 127 | t.(r).(k) |
394125ca | 128 | |
7c363dd8 | 129 | let is_within_bounds t {Point.r; Point.k} = |
394125ca SK |
130 | match t with |
131 | | [||] -> assert false | |
132 | | t -> | |
133 | r >= 0 && r < Array.length t && | |
134 | k >= 0 && k < Array.length t.(0) | |
135 | ||
7c363dd8 | 136 | let neighborhood t point = |
394125ca | 137 | List.map Direction.all ~f:Direction.to_offset |
7c363dd8 SK |
138 | |> List.map ~f:(fun offset_point -> Point.(point + offset_point)) |
139 | |> List.filter ~f:(is_within_bounds t) | |
394125ca | 140 | |
7c363dd8 SK |
141 | let get_neighbors t point = |
142 | List.map (neighborhood t point) ~f:(get t) | |
4d49c95e SK |
143 | end |
144 | ||
145 | ||
a96702d3 SK |
146 | module Msg = struct |
147 | type t = string | |
148 | end | |
149 | ||
150 | ||
151 | module State = struct | |
152 | type t = string | |
153 | end | |
154 | ||
155 | ||
4b18b7df SK |
156 | module PhenoType : sig |
157 | type t | |
158 | ||
159 | val create : char -> Terminal.color option -> t | |
160 | ||
161 | val to_string : t -> string | |
162 | end = struct | |
163 | type t = { color : Terminal.color option | |
164 | ; character : char | |
165 | } | |
166 | ||
167 | let create character color = | |
168 | {color; character} | |
169 | ||
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 | |
a96702d3 SK |
175 | end |
176 | ||
da8f1674 | 177 | |
a96702d3 SK |
178 | module Cell = struct |
179 | type t = { msg : Msg.t | |
180 | ; pheno : PhenoType.t | |
181 | ; state : State.t | |
182 | } | |
183 | end | |
0ce0e798 | 184 | |
0ce0e798 | 185 | |
a96702d3 SK |
186 | module type RULE = sig |
187 | val create : unit -> Cell.t | |
da8f1674 | 188 | |
a96702d3 | 189 | val transition : state:State.t -> inputs:Msg.t list -> Cell.t |
da8f1674 SK |
190 | end |
191 | ||
192 | ||
029c4a1f | 193 | module Life : RULE = struct |
a96702d3 | 194 | type state = D | A |
0d6f7833 | 195 | |
a96702d3 SK |
196 | let state_of_string : (string -> state) = function |
197 | | "D" -> D | |
198 | | "A" -> A | |
199 | | _ -> assert false | |
200 | ||
201 | let state_of_int : (int -> state) = function | |
0ce0e798 SK |
202 | | 0 -> D |
203 | | 1 -> A | |
204 | | _ -> assert false | |
205 | ||
a96702d3 | 206 | let int_of_state : (state -> int) = function |
0d6f7833 SK |
207 | | D -> 0 |
208 | | A -> 1 | |
209 | ||
a96702d3 SK |
210 | let string_of_state : (state -> string) = function |
211 | | D -> "D" | |
212 | | A -> "A" | |
213 | ||
214 | let msg_of_state : (state -> Msg.t) = | |
215 | string_of_state | |
216 | ||
217 | let pheno_of_state : (state -> PhenoType.t) = function | |
4b18b7df | 218 | | D -> PhenoType.create ' ' None |
39971ff4 | 219 | | A -> PhenoType.create 'o' (Some `white) |
0ce0e798 | 220 | |
a96702d3 SK |
221 | let int_of_msg msg = |
222 | msg |> state_of_string |> int_of_state | |
0ce0e798 | 223 | |
a96702d3 SK |
224 | let next state ~live_neighbors = |
225 | match state with | |
0d6f7833 SK |
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 | |
b36c0aef SK |
230 | | A -> A |
231 | | D -> D | |
a96702d3 SK |
232 | |
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 | |
237 | } | |
238 | ||
239 | let create () = | |
240 | Random.int 2 |> state_of_int |> cell_of_state | |
241 | ||
242 | let live_neighbors inputs = | |
fd51b8fa SK |
243 | inputs |
244 | |> List.filter ~f:(function "D" | "A" -> true | _ -> false) | |
245 | |> List.map ~f:int_of_msg | |
246 | |> List.fold_left ~init:0 ~f:(+) | |
a96702d3 SK |
247 | |
248 | let transition ~state ~inputs = | |
249 | state | |
250 | |> state_of_string | |
251 | |> next ~live_neighbors:(live_neighbors inputs) | |
252 | |> cell_of_state | |
0d6f7833 SK |
253 | end |
254 | ||
255 | ||
fd51b8fa SK |
256 | module ForestFire : RULE = struct |
257 | type state = E | T | B | |
258 | ||
259 | let string_of_state : (state -> string) = function | |
260 | | E -> "E" | |
261 | | T -> "T" | |
262 | | B -> "B" | |
263 | ||
264 | let msg_of_state : (state -> Msg.t) = | |
265 | string_of_state | |
266 | ||
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) | |
271 | ||
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 | |
276 | } | |
277 | ||
278 | let state_of_string : (string -> state) = function | |
279 | | "E" -> E | |
280 | | "T" -> T | |
281 | | "B" -> B | |
282 | | _ -> assert false | |
283 | ||
284 | let state_of_int : (int -> state) = function | |
285 | | 0 -> E | |
286 | | 1 -> T | |
287 | | 2 -> B | |
288 | | _ -> assert false | |
289 | ||
290 | let create () = | |
291 | Random.int 3 |> state_of_int |> cell_of_state | |
292 | ||
293 | let f = 0.000001 (* Probability of spontaneous ignition *) | |
3ac904c0 | 294 | let p = 0.1 (* Probability of spontaneous growth *) |
fd51b8fa | 295 | |
c30cad07 SK |
296 | let is_probable p = |
297 | (Random.float 1.0) <= p | |
fd51b8fa SK |
298 | |
299 | let next state ~burning_neighbors = | |
300 | match state, burning_neighbors with | |
301 | | E, _ when is_probable p -> T | |
302 | | E, _ -> E | |
303 | | T, 0 when is_probable f -> B | |
304 | | T, _ when burning_neighbors > 0 -> B | |
305 | | T, _ -> T | |
306 | | B, _ -> E | |
307 | ||
308 | let burning_neighbors inputs = | |
309 | inputs | |
310 | |> List.filter_map ~f:(function "B" -> Some 1 | _ -> None) | |
311 | |> List.fold_left ~init:0 ~f:(+) | |
312 | ||
313 | let transition ~state ~inputs = | |
314 | state | |
315 | |> state_of_string | |
316 | |> next ~burning_neighbors:(burning_neighbors inputs) | |
317 | |> cell_of_state | |
318 | end | |
319 | ||
320 | ||
d9fa5d46 SK |
321 | module Automaton : sig |
322 | type t | |
aed335e3 | 323 | |
a96702d3 SK |
324 | val create : rows:int |
325 | -> columns:int | |
326 | -> interval:float | |
327 | -> rules: (module RULE) list | |
328 | -> t | |
aed335e3 | 329 | |
d9fa5d46 SK |
330 | val loop : t -> unit |
331 | end = struct | |
a96702d3 SK |
332 | type cell = { data : Cell.t |
333 | ; rule : (module RULE) | |
334 | } | |
335 | ||
336 | type t = { grid : cell Matrix.t | |
d9fa5d46 SK |
337 | ; interval : Time.Span.t |
338 | ; bar : string | |
339 | } | |
aed335e3 | 340 | |
a96702d3 SK |
341 | let create ~rows:rs ~columns:ks ~interval ~rules = |
342 | let n = List.length rules in | |
a96702d3 | 343 | let init () = |
fd51b8fa | 344 | let rule = List.nth_exn rules (Random.int n) in |
a96702d3 SK |
345 | let module Rule = (val rule : RULE) in |
346 | { rule | |
347 | ; data = Rule.create () | |
348 | } | |
349 | in | |
21c4909c | 350 | Terminal.clear (); |
a96702d3 | 351 | { grid = Matrix.map ~f:init (Matrix.create ~rs ~ks ()) |
d9fa5d46 SK |
352 | ; interval = Time.Span.of_float interval |
353 | ; bar = String.make ks '-' | |
354 | } | |
355 | ||
a96702d3 | 356 | let cell_to_string cell = |
4b18b7df | 357 | PhenoType.to_string cell.data.Cell.pheno |
a96702d3 | 358 | |
d9fa5d46 | 359 | let print t = |
21c4909c | 360 | Terminal.reset (); |
d9fa5d46 | 361 | print_endline t.bar; |
a96702d3 | 362 | Matrix.print t.grid ~to_string:cell_to_string; |
d9fa5d46 SK |
363 | print_endline t.bar |
364 | ||
365 | let next t = | |
366 | let grid = | |
367 | Matrix.mapi t.grid ~f:( | |
a96702d3 SK |
368 | fun point {rule; data} -> |
369 | let module Rule = (val rule : RULE) in | |
d9fa5d46 | 370 | let neighbors = Matrix.get_neighbors t.grid point in |
a96702d3 SK |
371 | let data = |
372 | Rule.transition | |
373 | ~state:data.Cell.state | |
374 | ~inputs:(List.map neighbors ~f:(fun cell -> cell.data.Cell.msg)) | |
375 | in | |
376 | {rule; data} | |
d9fa5d46 SK |
377 | ) |
378 | in | |
379 | {t with grid} | |
380 | ||
381 | let rec loop t = | |
382 | print t; | |
383 | Time.pause t.interval; | |
384 | loop (next t) | |
385 | end | |
7707ff62 SK |
386 | |
387 | ||
388 | let main () = | |
389 | Random.self_init (); | |
d9fa5d46 | 390 | let rows, columns = Or_error.ok_exn Linux_ext.get_terminal_size () in |
a96702d3 SK |
391 | let interval = 0.1 in |
392 | let rules = | |
029c4a1f | 393 | [ (module Life : RULE) |
fd51b8fa | 394 | ; (module ForestFire : RULE) |
a96702d3 SK |
395 | ] |
396 | in | |
8526e3e1 | 397 | Automaton.loop (Automaton.create ~rows:(rows - 3) ~columns ~interval ~rules) |
8c93b722 SK |
398 | |
399 | ||
7d89c037 SK |
400 | let spec = |
401 | let summary = "Polymorphic Cellular Automata" in | |
7707ff62 | 402 | let spec = Command.Spec.empty in |
7d89c037 SK |
403 | Command.basic ~summary spec main |
404 | ||
405 | ||
406 | let () = Command.run spec |