path: root/judge/core.ml

open Unix

open Protocol

(* Description of data structures *)

type player = P1 | P2
let other_player = function P1 -> P2 | P2 -> P1

type game_status =
	| TurnOf of player
	| Won of player
	| Tie
	| Eliminated of player

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		(* immutable structure *)

	val name : string	(* ex: Morpion récursif *)
	val id : string		(* ex: morpion_rec *)

	val new_game : game * game_status

	val turn : game -> player -> string -> (game * 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 pn : game -> string * string
	val s : game -> game_status
	val g : game -> G.game
	val hist : game -> G.game list	(* head: same as g g *)

	val init : unit -> unit
	val finish : unit -> unit

	val handle_events : unit -> unit   (* is anything happening ? *)

	val add_rounds : unit -> unit      (* adds one game of everyone against everyone *)

	val ql : unit -> int
	val scores : unit -> (string * int) list
	val games : unit -> game list

end

(* ****************************************** *)
(*           BEGIN IMPLEMENTATION             *)
(* ****************************************** *)

module Core (G: GAME) : CORE = struct
	module G : GAME = G

	exception Eliminated_ex of string

	type player = {
		name: string;
		binary: string;
		dir: string;
		log_out: file_descr;
		mutable score: int;
		mutable running: player_proc option;
	}

	and 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 = {
		mutable hist: G.game list;
		p1: player_proc;
		p2: player_proc;
		mutable s: game_status;
	}
	let p1 g = g.p1.s
	let p2 g = g.p2.s
	let pn g = (g.p1.p.name, g.p2.p.name)
	let s g = g.s
	let g g = List.hd g.hist
	let hist g = g.hist

	let players = Hashtbl.create 12
	let planned_games = ref []
	let r_games = ref []

	let ql () = List.length !planned_games

	(* 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 pt_win = ref 3					(* default: on win, score += 3 *)
	let pt_tie = ref 1					(* default: on tie, score += 1 *)
	let pt_lose = ref 0			    (* default: on lose, score does not change *)
	let pt_elim = ref (-1)			(* default: on eliminated, score -= 1 *)

	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 (2)";
			"-s", Arg.Set_float game_time,
				"Time (seconds) allotted to each player for a game (30)";
			"-w", Arg.Set_int pt_win, "Points granted on win (+3)";
			"-t", Arg.Set_int pt_tie, "Points granted on tie (+1)";
			"-l", Arg.Set_int pt_lose, "Points granted on lose (0)";
			"-e", Arg.Set_int pt_elim, "Points granted on eliminated (-1)";

		] 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;
		if Filename.is_relative !game_dir then
			game_dir := Filename.concat (Unix.getcwd()) !game_dir;
		let date =
			let d = Unix.gmtime (Unix.gettimeofday ()) in
			Format.sprintf "%04d%02d%02d%02d%02d" (d.tm_year+1900) (d.tm_mon+1) 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
				begin try
					let dir = Filename.concat !game_dir s in
					let b = Filename.concat dir "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 dir "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;
								dir;
								log_out = p_log_out;
								score = 0;
								running = None; }
					end
				with _ -> () end;
				rd()
			with End_of_file -> ()
		in rd (); closedir fd
	
	let finish () =
		(* TODO :
			- save scores
			- kill all child processes and wait for them
		*)
		()
	
	let add_rounds () =
		Hashtbl.iter
			(fun p _ -> Hashtbl.iter
				(fun q _ -> if p <> q then planned_games := (p, q)::!planned_games)
				players)
			players

	let handle_events () =
		(* 1. IF NOT ENOUGH MATCHES ARE RUNING, LAUNCH ONE *)
		let matches_in_progress = List.length
					(List.filter
						(fun g -> match g.p1.s, g.p2.s with Dead, Dead -> false | _ -> true)
						!r_games)
		in
		let launch_match p1 p2 =
			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
					chdir p.dir;
					dup2 j2p_i stdin;
					dup2 p2j_o stdout;
					dup2 p.log_out stderr;
					execvp 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
				p.running <- Some pl;
				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; hist = [g]; s } in
			r_games := g::(!r_games)
		in
		let can_launch, cannot_launch = List.partition
			(fun (p1, p2) ->
				(Hashtbl.find players p1).running = None
					&& (Hashtbl.find players p2).running = None)
			!planned_games
		in
		begin match can_launch with
			| (p1, p2)::q when matches_in_progress < !par_games ->
				launch_match p1 p2;
				planned_games := q @ cannot_launch
			| _ -> ()
		end;
		(* 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 ->
				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, _, _ =
			try select in_fd [] [] 0.01
			with 
				Unix_error (EINTR, _, _) -> [], [], []
		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;
				| Play act, Thinking (time, beg_r) ->
					let end_r = Unix.gettimeofday () in
					let new_g, new_s = G.turn (List.hd g.hist) pi act in
					send_m p OK;
					send_m op (Play act);
					g.s <- new_s;
					g.hist <- new_g::g.hist;
					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;
							p.p.score <- p.p.score + !pt_tie;
							op.p.score <- op.p.score + !pt_tie;
							true
						| Won x ->
							let (w, l) = if x = P1 then (g.p1, g.p2) else (g.p2, g.p1) in
							send_m w YouWin;
							send_m l YouLose;
							Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name w.p.name;
							w.p.score <- w.p.score + !pt_win;
							l.p.score <- l.p.score + !pt_lose;
							true
						| TurnOf _ -> false
						| Eliminated _ -> raise (Eliminated_ex ("invalid move: " ^ act))
					in
					if finished then begin
						p.s <- Saving;
						op.s <- Saving;
					end else begin
						p.s <- StandBy (time -. (end_r -. beg_r));
					end
				| FairEnough, Saving ->
					kill p.pid Sys.sigterm;
					p.s <- Dead;
					p.p.running <- None;
				| bad_m, _ -> raise (Eliminated_ex ("unexpected message: '" ^ encode bad_m ^ "'"))
				| exception Invalid_message m -> raise (Eliminated_ex ("invalid message: '" ^ m ^"'"))
				| exception _ -> raise (Eliminated_ex "exception when reading message")
			with
				| Eliminated_ex r ->
					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 Sys.sigterm;
					Format.printf "%s vs. %s: %s eliminated (%s)!@." g.p1.p.name g.p2.p.name p.p.name r;
					p.s <- Dead;
					p.p.running <- None;
					p.p.score <- p.p.score + !pt_elim;
					op.s <- Saving;
					g.s <- Eliminated pi
			end;
			begin match g.s, g.p1.s, g.p2.s, g.p1, g.p2 with
				| TurnOf P1, StandBy t, StandBy _, p, _
				| TurnOf P2, StandBy _, StandBy t, _, p ->
					send_m p (YourTurn t);
					p.s <- Thinking (t, Unix.gettimeofday());
				| _ -> ()
			end
		in List.iter do_fd in_fd
	
end