http://unriskinsight.blogspot.fi/2014/06/fast-functional-goats-lions-and-wolves.html

forest.ml

open Core.Std

module Forest = struct
  type t = {
    goats: int;
    wolves: int;
    lions: int;
  }

  let create ~goats ~wolves ~lions = { goats; wolves; lions }

  let string_of_t { goats; wolves; lions } =
    printf "[goats=%i, wolves=%i, lions=%i]\n" goats wolves lions

  let wolf_devours_goat { goats; wolves; lions } =
    if goats > 0 && wolves > 0 then
      Some { goats=goats - 1; wolves=wolves - 1; lions=lions + 1 }
    else
      None
	
  let lion_devours_goat { goats; wolves; lions } =
    if goats > 0 && lions > 0 then
      Some { goats=goats - 1; wolves=wolves + 1; lions=lions - 1 }
    else
      None

  let lion_devours_wolf { goats; wolves; lions } =
    if lions > 0 && wolves > 0 then
      Some { goats=goats + 1; wolves=wolves - 1; lions=lions - 1 }
    else
      None

  let meal t =
    List.filter_map [wolf_devours_goat; lion_devours_goat; lion_devours_wolf]
		    ~f:(fun f -> f t)

  let is_stable { goats; wolves; lions } =
    if goats = 0 then
      wolves = 0 || lions = 0
    else
      wolves = 0 && lions = 0

  let meals forests =
    List.map forests ~f:meal
    |> List.join
    |> List.dedup ~compare:compare
			
  let compare a b =
    let cmp1 = a.goats - b.goats in
    if cmp1 <> 0 then
      cmp1
    else
      let cmp2 = a.wolves - b.wolves in
      if cmp2 <> 0 then
	cmp2
      else
	a.lions - b.lions

  let devouring_possible forests =
    List.length forests > 0 && not (List.exists forests ~f:is_stable)

  let stable_forests forests =
    List.filter forests ~f:is_stable

  let find_stable_forests t =
    let rec f = (fun forests ->
		 if devouring_possible forests then f (meals forests)
		 else forests) in
    f [t]
end

let () =
  let forest = Forest.create 417 455 406 in
  List.iter (Forest.find_stable_forests forest) ~f:Forest.string_of_t