+module ForestFire : RULE = struct
+ module State : sig
+ type t = E | T | B
+
+ val is_burning : t -> bool
+
+ val of_int : int -> t
+
+ val to_int : t -> int
+
+ val to_cell : t -> Cell.t
+
+ val of_cell_state : Cell.State.t -> 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_int = function
+ | E -> 0
+ | T -> 1
+ | B -> 2
+
+ 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 'T' -> T
+ | Cell.State.Alive 'B' -> B
+ | Cell.State.Alive _ -> E (* Foreign cell *)
+
+ let to_cell_state = function
+ | E -> Cell.State.Dead
+ | T -> Cell.State.Alive 'T'
+ | B -> Cell.State.Alive 'B'
+
+ let to_cell t =
+ { Cell.state = t |> to_cell_state
+ ; Cell.pheno = t |> to_pheno
+ }
+ end
+
+ let create () =
+ Random.int 3 |> State.of_int |> State.to_cell
+
+ 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 state ~burning_neighbors =
+ match state, burning_neighbors with
+ | State.E, _ when is_probable p -> State.T
+ | State.E, _ -> State.E
+ | State.T, 0 when is_probable f -> State.B
+ | State.T, _ when burning_neighbors > 0 -> State.B
+ | State.T, _ -> State.T
+ | State.B, _ -> State.E
+
+ let burning_neighbors neighbors =
+ neighbors |> List.map ~f:State.of_cell_state
+ |> List.filter ~f:State.is_burning
+ |> List.map ~f:State.to_int
+ |> List.fold_left ~init:0 ~f:(+)
+
+ let transition ~self ~neighbors =
+ self |> State.of_cell_state
+ |> next ~burning_neighbors:(burning_neighbors neighbors)
+ |> State.to_cell