Correct monstruous error.

3 files changed, 251 insertions, 0 deletions

diff --git a/judge/_tags b/judge/_tags
new file mode 100644
index 0000000..eb13bea
--- /dev/null
+++ b/judge/_tags
@@ -0,0 +1 @@
+true: use_unix
diff --git a/judge/core.ml b/judge/core.ml
new file mode 100644
index 0000000..e7c44e8
--- /dev/null
+++ b/judge/core.ml
@@ -0,0 +1,209 @@
+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
+
+	type player = {
+		name: string;
+		binary: string;
+		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: juge <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;
+						Hashtbl.add players	s
+							{ name = s;
+								binary = b;
+								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 (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;
+					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) *)
+		()
+	
+end
diff --git a/judge/protocol.ml b/judge/protocol.ml
new file mode 100644
index 0000000..3f6d548
--- /dev/null
+++ b/judge/protocol.ml
@@ -0,0 +1,41 @@
+
+exception Invalid_message of string
+
+type msg =
+	| Hello of string		(* nom du jeu *)
+	| YourTurn of float		(* nombre secondes pour jouer *)
+	| Play of string		(* description textuelle du coup *)
+	| OK					(* coup accepté *)
+	| YouWin
+	| YouLose
+	| Tie
+	| Eliminated
+	| FairEnough
+
+let decode = function
+	| "OK" -> OK
+	| "You win" -> YouWin
+	| "You lose" -> YouLose
+	| "Tie" -> Tie
+	| "Eliminated" -> Eliminated
+	| "Fair enough" -> FairEnough
+	| s when String.sub s 0 6 = "Hello " ->
+		Hello (String.sub s 6 (String.length s - 6))
+	| s when String.sub s 0 10 = "Your turn " ->
+		YourTurn (float_of_string (String.sub s 10 (String.length s - 10)))
+	| s when String.sub s 0 5 = "Play " ->
+		Play (String.sub s 5 (String.length s - 5))
+	| s -> raise (Invalid_message s)
+
+let encode = function
+	| Hello x -> "Hello " ^ x
+	| YourTurn n -> "Your turn " ^ (string_of_float n)
+	| Play x -> "Play " ^ x
+	| OK -> "OK"
+	| YouWin -> "You win"
+	| YouLose -> "You lose"
+	| Tie -> "Tie"
+	| Eliminated -> "Eliminated"
+	| FairEnough -> "Fair enough"
+
+