Coin-flipping game in OCaml with timeouts on players

forkex.ml

open Unix

type player_moves = Heads | Tails

type server_moves = Right | Wrong | Timeout

type player = {
  name : string;
  brain : out_channel -> unit;
  pipe : in_channel * out_channel;
  fds : file_descr * file_descr;
  pid : int;
}

type victory = Guesses of player | Default of player | Draw | BothTimeout

let guaranteed_random ch =
  while true do
    output_value ch Heads; (* chosen by fair coin flip *)
    flush ch;
  done

let hard_thinker ch =
  while true do
    Unix.sleepf (Random.float 600. /. 1000.);
    let choice = if Random.bool() then Heads else Tails in
    output_value ch choice;
    flush ch;
  done

let check_guess ch =
  (* let's hope the players _never communicate_ *)
  let answer = if Random.bool() then Heads else Tails in
  if input_value ch = answer then Right else Wrong

let next_moves {fds = (fd1, _); pipe = (ch1, _)} {fds = (fd2, _); pipe = (ch2, _)} =
  Unix.sleepf 0.5; (* give players an amount of time to think.
                      use it or lose it!
                      no points for answering early *)
  let (ready, _, _) = select [fd1; fd2] [] [] 0. in
  match ready with
  | [_; _] -> (check_guess ch1, check_guess ch2)
  | [a] when a = fd1 -> (check_guess ch1, Timeout)
  | [a] when a = fd2 -> (Timeout, check_guess ch2)
  | [] -> (Timeout, Timeout)
  | _ -> failwith "Inexplicable select() result"

let spawn f name =
  let (fdr, fdw) = pipe () in
  let (chr, chw) = (in_channel_of_descr fdr, out_channel_of_descr fdw) in
  let child = fork () in
  if child = 0 then (f chw; exit 1) else
    { name = name; brain = f; pipe = (chr, chw); fds = (fdr, fdw); pid = child }

let play_games_to goal p1 p2 =
  let rec round n a b =
    if n > goal && a > b then (Guesses p1, n) else
    if n > goal && b > a then (Guesses p2, n) else
    if n > goal then (Draw, n) else
      begin
        Printf.printf "Round %2d: %s (%d) -- %s (%d)\n"
          n p1.name a p2.name b;
        flush_all ();
        match next_moves p1 p2 with
        | (Timeout, Timeout) -> (BothTimeout, n)
        | (Timeout, _) -> (Default p2, n)
        | (_, Timeout) -> (Default p1, n)
        | (Right, Right) -> round (n + 1) (a + 1) (b + 1)
        | (Right, Wrong) -> round (n + 1) (a + 1) b
        | (Wrong, Right) -> round (n + 1) a (b + 1)
        | (Wrong, Wrong) -> round (n + 1) a b
      end
  in round 1 0 0

let punish {name; pipe = (r, w); pid} =
  close_in r;
  close_out w;
  kill pid Sys.sigkill;
  Printf.printf "[!] Player ``%s'' (pid: %d) has been ejected due to tardiness.\n"
    name pid

let rec competition players =
  match players with
  | [] -> print_endline "[_] The competition ended with no victors."
  | [winner] -> Printf.printf "[=] The final victor is... %s!\n" winner.name
  | p1 :: p2 :: rest ->
    match play_games_to 10 p1 p2 with
    | (Guesses winner, _) ->
      let loser = if winner.name = p1.name then p2 else p1 in
      Printf.printf "[*] ``%s'' beat ``%s'' through superior play.\n"
        winner.name loser.name;
      competition (winner :: rest)
    | (Default winner, n) ->
      let loser = if winner.name = p1.name then p2 else p1 in
      punish loser;
      Printf.printf "[*] ``%s'' beat ``%s'' through superior responsiveness after %d rounds.\n"
        winner.name loser.name n;
      competition (winner :: rest)
    | (Draw, _) ->
      Printf.printf "[*] ``%s'' and ``%s'' managed to BOTH LOSE.\n" p1.name p2.name;
      competition rest
    | (BothTimeout, n) ->
      punish p1; punish p2;
      Printf.printf "[*] Neither ``%s'' nor ``%s'' could KEEP UP through %d rounds.\n"
        p1.name p2.name n;
      competition rest

let () =
  Random.self_init ();
  let alice = spawn guaranteed_random "Alice" in
  let bob = spawn hard_thinker "Bob" in
  let eve = spawn hard_thinker "Eve" in
  competition [alice; bob; eve];
  (* clean up -- could use kill 0 here to check for aliveness
     and do something with unejected players.
     it would be safer though to remember ejects *)
  kill alice.pid Sys.sigkill;
  kill bob.pid Sys.sigkill;
  kill eve.pid Sys.sigkill;
  try
    while true do
      ignore (Unix.waitpid [] 0)
    done
  with Unix.Unix_error _ -> ()

$ ocaml unix.cma forkex.ml
Round  1: Alice (0) -- Bob (0)
Round  2: Alice (1) -- Bob (0)
[!] Player ``Bob'' (pid: 8204) has been ejected due to tardiness.
[*] ``Alice'' beat ``Bob'' through superior responsiveness after 2 rounds.
Round  1: Alice (0) -- Eve (0)
Round  2: Alice (1) -- Eve (0)
Round  3: Alice (2) -- Eve (1)
Round  4: Alice (2) -- Eve (2)
Round  5: Alice (3) -- Eve (2)
Round  6: Alice (4) -- Eve (2)
Round  7: Alice (4) -- Eve (2)
Round  8: Alice (5) -- Eve (3)
Round  9: Alice (6) -- Eve (4)
Round 10: Alice (6) -- Eve (4)
[*] ``Alice'' beat ``Eve'' through superior play.
[=] The final victor is... Alice!