Implement a part of the judge UI; add dummy game & player for testing purposes.

4 files changed, 211 insertions, 81 deletions

diff --git a/judge/core.ml b/judge/core.ml
index 70e2bd4..4411937 100644
--- a/judge/core.ml
+++ b/judge/core.ml
@@ -5,6 +5,7 @@ open Protocol
 (* Description of data structures *)
 
 type player = P1 | P2
+let other_player = function P1 -> P2 | P2 -> P1
 
 type game_status =
 	| TurnOf of player
@@ -12,11 +13,6 @@ type game_status =
 	| 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 *)
@@ -41,7 +37,8 @@ module type CORE = sig
 	type game
 	val p1 : game -> player_proc_status
 	val p2 : game -> player_proc_status
-	val s : game -> game_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 *)
 
@@ -52,6 +49,7 @@ module type CORE = sig
 
 	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
 
@@ -61,7 +59,7 @@ end
 (*           BEGIN IMPLEMENTATION             *)
 (* ****************************************** *)
 
-module C (G: GAME) : CORE = struct
+module Core (G: GAME) : CORE = struct
 	module G : GAME = G
 
 	exception Eliminated_ex of string
@@ -72,9 +70,10 @@ module C (G: GAME) : CORE = struct
 		dir: string;
 		log_out: file_descr;
 		mutable score: int;
+		mutable running: player_proc option;
 	}
 
-	type player_proc = {
+	and player_proc = {
 		pid: int;
 		p: player;
 		i: in_channel;
@@ -89,18 +88,21 @@ module C (G: GAME) : CORE = struct
 		mutable hist: G.game list;
 		p1: player_proc;
 		p2: player_proc;
-		mutable s: game_proc_status;
+		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 = Queue.create ()
+	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 *)
@@ -132,9 +134,11 @@ module C (G: GAME) : CORE = struct
 			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.time ()) in
-			Format.sprintf "%04d%02d%02d%02d%02d" d.tm_year d.tm_mon d.tm_mday d.tm_hour d.tm_min
+			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 *)
@@ -160,7 +164,7 @@ module C (G: GAME) : CORE = struct
 		in
 		let rec rd () =
 			try let s = readdir fd in
-				try
+				begin try
 					let dir = Filename.concat !game_dir s in
 					let b = Filename.concat dir "player" in
 					let st =  Unix.stat b in
@@ -177,12 +181,13 @@ module C (G: GAME) : CORE = struct
 								binary = b;
 								dir;
 								log_out = p_log_out;
-								score = 0; }
+								score = 0;
+								running = None; }
 					end
-				with _ -> ();	
+				with _ -> () end;
 				rd()
 			with End_of_file -> ()
-		in rd ()
+		in rd (); closedir fd
 	
 	let finish () =
 		(* TODO :
@@ -194,18 +199,18 @@ module C (G: GAME) : CORE = struct
 	let add_rounds () =
 		Hashtbl.iter
 			(fun p _ -> Hashtbl.iter
-				(fun q _ -> if p <> q then Queue.push (p, q) planned_games)
+				(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 *)
-		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
+		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 =
@@ -219,38 +224,52 @@ module C (G: GAME) : CORE = struct
 					dup2 j2p_i stdin;
 					dup2 p2j_o stdout;
 					dup2 p.log_out stderr;
-					execv p.binary [| p.binary |];
+					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 = Initializing s } in
+			let g = { p1; p2; hist = [g]; s } in
 			r_games := g::(!r_games)
-		done;
-
+		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 -> 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)
+			(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, _, _ = select in_fd [] [] 0.01 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
@@ -264,21 +283,21 @@ module C (G: GAME) : CORE = struct
 			| Hello x, Loading when x = G.id ->
 				p.s <- StandBy !game_time;
 				begin match g.s, g.p1.s, g.p2.s, g.p1, g.p2 with
-					| Initializing (TurnOf P1), StandBy t, StandBy _, p, _
-					| Initializing (TurnOf P2), StandBy _, StandBy t, _, p ->
+					| TurnOf P1, StandBy t, StandBy _, p, _
+					| TurnOf P2, StandBy _, StandBy t, _, p ->
 						send_m p (YourTurn t);
-						p.s <- Thinking (t, Unix.time());
-						g.s <- Running (TurnOf P1)
+						p.s <- Thinking (t, Unix.gettimeofday());
 					| _ -> ()
 				end
 			| Play act, Thinking (time, beg_r) ->
-				let end_r = Unix.time () in
+				let end_r = Unix.gettimeofday () in
 				let new_g, new_s = G.turn (List.hd g.hist) pi act in
 				begin match new_s with 
 					| Eliminated _ -> raise (Eliminated_ex ("invalid move: " ^ act)) | _ -> ()
 				end;
 				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 ->
@@ -302,19 +321,18 @@ module C (G: GAME) : CORE = struct
 				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())
+							op.s <- Thinking (t, Unix.gettimeofday ())
 						| _ -> assert false
 				end
 			| FairEnough, Saving ->
-				kill p.pid 15;		(* 15 : sigterm *)
-				p.s <- Dead
+				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")
@@ -324,12 +342,13 @@ module C (G: GAME) : CORE = struct
 				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;
+				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 <- Finished (Eliminated pi)
+				g.s <- Eliminated pi
 			end;
 		in List.iter do_fd in_fd
 	
diff --git a/judge/dummy_game.ml b/judge/dummy_game.ml
new file mode 100644
index 0000000..869513a
--- /dev/null
+++ b/judge/dummy_game.ml
@@ -0,0 +1,35 @@
+open Core
+open Main
+
+module Dummy : GAME = struct
+
+  type game = player * int
+
+  let new_game = (P1, 10), TurnOf P1
+
+  let turn (p0, g) p _ =
+    if p <> p0 || g <= 0 then
+      (p0, g), Eliminated p
+    else
+      let op = other_player p in
+      (op, g-1), (
+        if g - 1 = 0 then
+          if Random.int 100 = 0 then Eliminated p
+          else if Random.int 2 = 0 then Won p
+          else if Random.int 2 = 0 then Won op
+          else Tie
+        else
+          TurnOf op
+      )
+
+  let id = "dummy_game"
+  let name = "Dumm game for testing purposes"
+
+end
+
+module C = Core(Dummy)
+module Main = Juge(C)
+
+let () =
+  Random.self_init ();
+  Main.run ()
diff --git a/judge/dummy_player.ml b/judge/dummy_player.ml
new file mode 100644
index 0000000..fe19b48
--- /dev/null
+++ b/judge/dummy_player.ml
@@ -0,0 +1,42 @@
+
+
+let expect mgs =
+  let l = read_line () in
+  begin try
+    let (s, f) = List.find
+      (fun (s, _) ->
+           String.length l >= String.length s
+        && String.sub l 0 (String.length s) = s)
+      mgs
+    in f (String.sub l (String.length s)
+          (String.length l - String.length s))
+  with
+    Not_found ->
+      Format.eprintf "Unexpected '%s'.@." l;
+      exit 1
+  end
+
+let finished _ =
+  print_string "Fair enough\n"
+
+let rec turn _ =
+  expect [
+    "Your turn",
+      (fun _ ->
+        if Random.int 2 = 0 then Unix.sleep 1;
+        print_string "Play this_is_a_word\n";
+        expect [ "OK", turn ]);
+    "Play ", turn;
+    "Tie", finished;
+    "You win", finished;
+    "You lose", finished;
+    "Eliminated", finished
+  ]
+
+let () =
+  Random.self_init ();
+  expect [
+    "Hello dummy_game",
+    (fun _ -> print_string "Hello dummy_game\n";
+        turn "")
+  ];
diff --git a/judge/main.ml b/judge/main.ml
index 5155e02..6a42ff8 100644
--- a/judge/main.ml
+++ b/judge/main.ml
@@ -19,7 +19,9 @@ end = struct
   module G = C.G
 
   (* Graphic helpers *)
-  let grey = rgb 64 64 64
+  let grey = rgb 112 112 112
+  let red = rgb 200 0 0
+  let green = rgb 0 150 0
 
   let center () = size_x () / 2, size_y () / 2
 
@@ -31,10 +33,11 @@ end = struct
     set_color black;
     let cr d =
       draw_rect (cx - w - d) (cy - h - d)
-                (cx + w + d) (cy + h + d)
+                (2 * (w + d)) (2 * (h + d))
     in cr 20; cr 22;
     moveto (cx - w) (cy - h);
-    draw_string m
+    draw_string m;
+    synchronize ()
 
   let tw m = fst (text_size m)
 
@@ -44,13 +47,13 @@ end = struct
     draw_string m
 
   let text1 l c m =
-    text_l l 20 c m
+    text_l l 30 c m
   let text2 l c m =
-    text_l l (size_x()/2 - 20 - tw m) c m
+    text_l l (size_x()/2 - 30 - tw m) c m
   let text3 l c m =
-    text_l l (size_x()/2 + 20) c m
+    text_l l (size_x()/2 + 30) c m
   let text4 l c m =
-    text_l l (size_x() - 20 - tw m) c m
+    text_l l (size_x() - 30 - tw m) c m
 
   let hl () =
     draw_poly_line
@@ -60,6 +63,10 @@ end = struct
   (* Init/Close *)
   let init () =
     open_graph " 800x600";
+    set_font "-misc-fixed-bold-r-normal--15-120-90--c-90-iso8859-1";
+    auto_synchronize false;
+    display_mode false;
+    remember_mode true;
     fullscreen_msg "Starting up..."
 
   let close () =
@@ -78,6 +85,11 @@ end = struct
       | ScoreBoard, '\t' -> curr_view := MatchList false
       | MatchList _, '\t' -> curr_view := ScoreBoard
       | MatchList e, 'f' -> curr_view := MatchList (not e)
+      | MatchList _, 'r' -> curr_view := Question(
+          "Launch new round?",
+          (fun () -> C.add_rounds(); curr_view := MatchList false),
+          !curr_view
+        )
       | Question(_, y, n), 'y' -> y()
       | Question(_, y, n), 'n' -> curr_view := n
       | v, 'q' ->
@@ -92,50 +104,71 @@ end = struct
 
   and display () =
     clear_graph ();
-    match !curr_view with
+    begin match !curr_view with
     | ScoreBoard -> scoreboard_disp ()
     | MatchList f -> matchlist_disp f
     | ViewGame g -> game_disp g
     | Question (q, _, _) -> fullscreen_msg (q ^ " (y/n)")
+    end;
+    synchronize ()
 
   and curr_view = ref ScoreBoard
 
   (* Scoreboard view *)
   and scoreboard_disp () =
-    text1 2 black "score board";
-    text4 2 grey "match list >";
+    text1 1 black "score board";
+    text4 1 grey "match list >";
     hl();
     let scores = List.sort
       (fun (_, sc) (_, sc') -> sc' - sc)
       (C.scores())
     in
-    let xx l (n, s) t =
-      text1 l black t;
-      text1 (l+1) black ("  "^n);
-      text2 (l+1) black (string_of_int s)
-    in
-    let scores = match scores with
-    | first::q -> xx 4 first "first place"; q
-    | [] -> []
-    in
-    let scores = match scores with
-    | sec::q -> xx 7 sec "second place"; q
-    | [] -> []
-    in
-    let scores = match scores with
-    | thrd::q -> xx 10 thrd "third place"; q
-    | [] -> []
-    in
     let show_sc i (n, s) =
-      text3 (i+4) black ((string_of_int (i+3))^". "^n);
-      text4 (i+1) black (string_of_int s)
+      text2 (i+4) black (string_of_int (i+1)^". ");
+      text3 (i+4) black n;
+      text4 (i+4) black (string_of_int s)
     in
     List.iteri show_sc scores
 
   (* Match list view *)
   and matchlist_disp show_only_running =
-    (* TODO *)
-    ()
+    text1 1 black "match list";
+    text2 1 black "queued matches:";
+    text3 1 black (string_of_int (C.ql ()));
+    text4 1 grey "score board >";
+    hl();
+    let games =
+      if show_only_running then
+        List.filter
+          (fun g -> match C.p1 g, C.p2 g with Dead, Dead -> false | _ -> true)
+          (C.games())
+      else C.games()
+    in
+    let time = Unix.gettimeofday() in
+    let print_g i g =
+      let cp1, cp2 = match C.s g with
+      | TurnOf _ -> black, black
+      | Won P1 -> green, red
+      | Won P2 -> red, green
+      | Tie -> grey, grey
+      | Eliminated P1 -> red, grey
+      | Eliminated P2 -> grey, red
+      in
+      let mp = function
+        | Loading -> grey, ">>>"
+        | Saving -> grey, "<<<"
+        | Dead -> black, ""
+        | StandBy t -> grey, Format.sprintf "%.2f" t
+        | Thinking (t, tb) -> black,
+          Format.sprintf "[ %.2f ]" (t -. (time -. tb))
+      in
+      let p1n, p2n = C.pn g in
+      let c, m = mp (C.p1 g) in text1 (i+4) c m;
+      text2 (i+4) cp1 p1n;
+      text3 (i+4) cp2 p2n;
+      let c, m = mp (C.p2 g) in text4 (i+4) c m
+    in
+    List.iteri print_g games
 
   (* Game view *)
   and game_disp g =
@@ -161,7 +194,8 @@ end = struct
     UI.init();
     begin try while true do
       C.handle_events ();
-      UI.handle_events ()
+      UI.handle_events ();
+      UI.display ()
     done with
       Exit_judge ->
         C.finish ();