open Unix
open Protocol
(* Description of data structures *)
type player = P1 | P2
type game_status =
| TurnOf of player
| Won of player
| Tie
| Eliminated of player
type game_proc_status =
| Initializing of game_status
| Running of game_status
| Finished of game_status
type player_proc_status =
| Loading
| StandBy of float (* temps restant sur toute la partie *)
| Thinking of (float * float) (* temps restant ; heure de début de réflexion *)
| Saving
| Dead
module type GAME = sig
type game (* mutable structure *)
val name : string (* ex: Morpion récursif *)
val id : string (* ex: morpion_rec *)
val new_game : unit -> (game * game_status)
val turn : game -> player -> string -> game_status
end
module type CORE = sig
module G : GAME
type game
val p1 : game -> player_proc_status
val p2 : game -> player_proc_status
val s : game -> game_proc_status
val g : game -> G.game
val init : unit -> unit
val handle_events : unit -> unit (* is anything happening ? *)
val add_rounds : unit -> unit (* adds one game of everyone against everyone *)
val scores : unit -> (string * int) list
val games : unit -> game list
end
(* ****************************************** *)
(* BEGIN IMPLEMENTATION *)
(* ****************************************** *)
module C (G: GAME) : CORE = struct
module G : GAME = G
exception Eliminated_ex
type player = {
name: string;
binary: string;
log_out: file_descr;
mutable score: int;
}
type player_proc = {
pid: int;
p: player;
i: in_channel;
o: out_channel;
mutable s: player_proc_status;
}
let send_m pp m =
output_string pp.o (encode m ^ "\n");
flush pp.o
type game = {
g: G.game;
p1: player_proc;
p2: player_proc;
mutable s: game_proc_status;
}
let p1 g = g.p1.s
let p2 g = g.p2.s
let s g = g.s
let g g = g.g
let players = Hashtbl.create 12
let planned_games = Queue.create ()
let r_games = ref []
(* program paremeters *)
let par_games = ref 2 (* default: launch two simultaneous games *)
let game_time = ref 30.0 (* default: 30 sec for each player *)
let scores () =
Hashtbl.fold (fun _ p l -> (p.name, p.score)::l) players []
let games () = !r_games
let init () =
(* 1. PARSE ARGUMENTS *)
let game_dir = ref "" in
let args = [
"-p", Arg.Set_int par_games, "How many games to run in parallel.";
"-t", Arg.Set_float game_time,
"Time (seconds) allotted to each player for a game."
] in
Arg.parse args (fun s -> game_dir := s)
"Usage: judge <game_directory>";
if !game_dir = "" then begin
Format.eprintf "Error: no game directory specified.@.";
exit 1
end;
let date =
let d = Unix.gmtime (Unix.time ()) in
Format.sprintf "%04d%02d%02d%02d%02d" d.tm_year d.tm_mon d.tm_mday d.tm_hour d.tm_min
in
(* 2. REDIRECT STDOUT TO LOG FILE *)
let log_file = Filename.concat !game_dir (date^".log") in
Format.printf "Juge for '%s' starting up...@." G.name;
Format.printf "Redirecting standard output to '%s'.@." log_file;
flush Pervasives.stdout;
begin try
let log_out = Unix.openfile log_file [O_APPEND; O_CREAT; O_WRONLY] 0o644 in
dup2 log_out Unix.stdout
with _ ->
Format.eprintf "Could not open log output file.@.";
exit 1
end;
Format.printf "Juge for '%s' starting up...@." G.name;
Format.printf "Session: %s@." date;
(* 3. LOAD PLAYER LIST *)
Format.printf "Loading player list...@.";
let fd = try opendir !game_dir with _ ->
Format.printf "Could not open directory %s for listing.@." !game_dir;
exit 1
in
let rec rd () =
try let s = readdir fd in
try
let b = Filename.concat (Filename.concat !game_dir s) "player" in
let st = Unix.stat b in
if (st.st_kind = S_REG || st.st_kind = S_LNK)
&& (st.st_perm land 0o100 <> 0) then begin
Format.printf "- %s@." s;
(* open log output for player *)
let p_log_file = Filename.concat (Filename.concat !game_dir s) "stderr.log" in
let p_log_out = Unix.openfile p_log_file [O_APPEND; O_CREAT; O_WRONLY] 0o644 in
let f = Format.formatter_of_out_channel (out_channel_of_descr p_log_out) in
Format.fprintf f "---- Begin session %s@." date;
Hashtbl.add players s
{ name = s;
binary = b;
log_out = p_log_out;
score = 0; }
end
with _ -> ();
rd()
with End_of_file -> ()
in rd ()
let add_rounds () =
Hashtbl.iter
(fun p _ -> Hashtbl.iter
(fun q _ -> if p <> q then Queue.push (p, q) planned_games)
players)
players
let handle_events () =
(* 1. IF NOT ENOUGH MATCHES ARE RUNING, LAUNCH ONE *)
while (List.length
(List.filter (fun g -> match g.s with Finished _ -> false | _ -> true)
!r_games)) < !par_games
&& Queue.length planned_games > 0
do
let p1, p2 = Queue.pop planned_games in
Format.printf "Launching match: %s vs. %s@." p1 p2;
let open_c p =
let f =Format.formatter_of_out_channel (out_channel_of_descr p.log_out) in
Format.fprintf f "--- Begin game (%s vs. %s)@." p1 p2;
let (j2p_i, j2p_o) = pipe () in
let (p2j_i, p2j_o) = pipe () in
let pid = fork() in
if pid = 0 then begin
dup2 j2p_i stdin;
dup2 p2j_o stdout;
dup2 p.log_out stderr;
execv p.binary [| p.binary |];
end;
Format.printf "- %s: pid %d@." p.name pid;
let pl = { pid; p;
i = in_channel_of_descr p2j_i;
o = out_channel_of_descr j2p_o;
s = Loading } in
send_m pl (Hello G.id);
pl
in
let p1 = open_c (Hashtbl.find players p1) in
let p2 = open_c (Hashtbl.find players p2) in
let g, s = G.new_game () in
let g = { p1; p2; g; s = Initializing s } in
r_games := g::(!r_games)
done;
(* 2. LOOK IF ANYBODY IS TELLING US SOMETHING - IF SO, REACT
(wait max. 0.01 sec) *)
let in_fd = List.fold_left
(fun l g -> match g.s with
| Finished _ -> l
| _ ->
let l = match g.p1.s with
| Dead -> l
| _ -> (Unix.descr_of_in_channel g.p1.i)::l
in match g.p2.s with
| Dead -> l
| _ -> (Unix.descr_of_in_channel g.p2.i)::l)
[] !r_games
in
let in_fd, _, _ = select in_fd [] [] 0.01 in
let do_fd fd =
let g = List.find
(fun g -> fd = Unix.descr_of_in_channel g.p1.i
|| fd = Unix.descr_of_in_channel g.p2.i)
!r_games
in
let pi = if Unix.descr_of_in_channel g.p1.i = fd then P1 else P2 in
let p = match pi with P1 -> g.p1 | P2 -> g.p2 in
let op = match pi with P1 -> g.p2 | P2 -> g.p1 in
begin try match decode (input_line p.i), p.s with
| Hello x, Loading when x = G.id ->
p.s <- StandBy !game_time;
if op.s <> Loading then begin
match g.s, g.p1.s, g.p2.s with
| Initializing (TurnOf P1), StandBy t, _ ->
send_m g.p1 (YourTurn t);
g.p1.s <- Thinking (t, Unix.time());
g.s <- Running (TurnOf P1)
| Initializing (TurnOf P2), _, StandBy t ->
send_m g.p2 (YourTurn t);
g.p2.s <- Thinking (t, Unix.time());
g.s <- Running (TurnOf P2)
| _ -> assert false
end
| Play act, Thinking (time, beg_r) ->
let end_r = Unix.time () in
let new_s = G.turn g.g pi act in
begin match new_s with | Eliminated _ -> raise Eliminated_ex | _ -> () end;
send_m p OK;
send_m op (Play act);
let finished = match new_s with
| Tie ->
send_m p Tie;
send_m op Tie;
Format.printf "%s vs. %s: tie!@." g.p1.p.name g.p2.p.name;
true
| Won x when x = pi ->
send_m p YouWin;
send_m op YouLose;
Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name p.p.name;
true
| Won x ->
send_m op YouWin;
send_m p YouLose;
Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name op.p.name;
true
| TurnOf _ -> false
| Eliminated x -> assert false
in
if finished then begin
p.s <- Saving;
op.s <- Saving;
g.s <- Finished new_s
end else begin
p.s <- StandBy (time -. (end_r -. beg_r));
g.s <- Running new_s;
match op.s with
| StandBy t ->
send_m op (YourTurn t);
op.s <- Thinking (t, Unix.time())
| _ -> assert false
end
| FairEnough, Saving ->
kill p.pid 15; (* 15 : sigterm *)
p.s <- Dead
| _ -> raise Eliminated_ex
| exception _ -> raise Eliminated_ex
with
| Eliminated_ex ->
send_m p Eliminated;
send_m op YouWin;
(* since process is not respecting the protocol, we cannot assume
it is doing anything reasonable, so we kill it... *)
kill p.pid 15;
Format.printf "%s vs. %s: %s eliminated!@." g.p1.p.name g.p2.p.name p.p.name;
p.s <- Dead;
op.s <- Saving;
g.s <- Finished (Eliminated pi)
end;
in List.iter do_fd in_fd
end
