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