Working on judge system

4 files changed, 228 insertions, 39 deletions

diff --git a/README.md b/README.md
index f6045d5..2cab40e 100644
--- a/README.md
+++ b/README.md
@@ -12,8 +12,7 @@ Organisation des fichiers
 judge/                 le code du juge
   protocol.ml          encodeur et décodeur pour le protocole décrit plus bas
   core.ml              la partie principale
-  main.ml              la synchro
-  gui.ml               l'interface de visualisation
+  main.ml              la synchro et l'UI
   morpionrec.ml        la partie spécifique à un jeu
 
 morpionrec/            dossier pour un jeu
diff --git a/judge/_tags b/judge/_tags
index eb13bea..6c0a352 100644
--- a/judge/_tags
+++ b/judge/_tags
@@ -1 +1 @@
-true: use_unix
+true: use_unix, use_graphics
diff --git a/judge/core.ml b/judge/core.ml
index 34d5dc9..70e2bd4 100644
--- a/judge/core.ml
+++ b/judge/core.ml
@@ -25,14 +25,14 @@ type player_proc_status =
 	| Dead
 
 module type GAME = sig
-	type game		(* mutable structure *)
+	type game		(* immutable structure *)
 
 	val name : string	(* ex: Morpion récursif *)
 	val id : string		(* ex: morpion_rec *)
 
-	val new_game : unit -> (game * game_status)
+	val new_game : game * game_status
 
-	val turn : game -> player -> string -> game_status
+	val turn : game -> player -> string -> (game * game_status)
 end
 
 module type CORE = sig
@@ -43,8 +43,10 @@ module type CORE = sig
 	val p2 : game -> player_proc_status
 	val s : game -> game_proc_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 ? *)
 
@@ -62,7 +64,7 @@ end
 module C (G: GAME) : CORE = struct
 	module G : GAME = G
 
-	exception Eliminated_ex
+	exception Eliminated_ex of string
 
 	type player = {
 		name: string;
@@ -84,7 +86,7 @@ module C (G: GAME) : CORE = struct
 		flush pp.o
 
 	type game = {
-		g: G.game;
+		mutable hist: G.game list;
 		p1: player_proc;
 		p2: player_proc;
 		mutable s: game_proc_status;
@@ -92,7 +94,8 @@ module C (G: GAME) : CORE = struct
 	let p1 g = g.p1.s
 	let p2 g = g.p2.s
 	let s g = g.s
-	let g g = g.g
+	let g g = List.hd g.hist
+	let hist g = g.hist
 
 	let players = Hashtbl.create 12
 	let planned_games = Queue.create ()
@@ -101,6 +104,10 @@ module C (G: GAME) : CORE = struct
 	(* 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 []
@@ -110,9 +117,13 @@ module C (G: GAME) : CORE = struct
 		(* 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."
+			"-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)
@@ -172,7 +183,14 @@ module C (G: GAME) : CORE = struct
 				rd()
 			with End_of_file -> ()
 		in rd ()
-
+	
+	let finish () =
+		(* TODO :
+			- save scores
+			- kill all child processes and wait for them
+		*)
+		()
+	
 	let add_rounds () =
 		Hashtbl.iter
 			(fun p _ -> Hashtbl.iter
@@ -213,8 +231,8 @@ module C (G: GAME) : CORE = struct
 			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
+			let g, s = G.new_game in
+			let g = { p1; p2; hist = [g]; s = Initializing s } in
 			r_games := g::(!r_games)
 		done;
 
@@ -245,39 +263,38 @@ module C (G: GAME) : CORE = struct
 			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());
+				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 ->
+						send_m p (YourTurn t);
+						p.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;
+				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.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;
-					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;
+					p.p.score <- p.p.score + !pt_tie;
+					op.p.score <- op.p.score + !pt_tie;
 					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;
+					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 x -> assert false
@@ -298,17 +315,19 @@ module C (G: GAME) : CORE = struct
 			| FairEnough, Saving ->
 				kill p.pid 15;		(* 15 : sigterm *)
 				p.s <- Dead
-			| _ -> raise Eliminated_ex
-			| exception _ -> raise Eliminated_ex
+			| 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 ->
+			| 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 15;
-				Format.printf "%s vs. %s: %s eliminated!@." g.p1.p.name g.p2.p.name p.p.name;
+				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.score <- p.p.score + !pt_elim;
 				op.s <- Saving;
 				g.s <- Finished (Eliminated pi)
 			end;
diff --git a/judge/main.ml b/judge/main.ml
new file mode 100644
index 0000000..5155e02
--- /dev/null
+++ b/judge/main.ml
@@ -0,0 +1,171 @@
+open Core
+open Graphics
+
+(* ****************** *)
+(* The user interface *)
+(* ****************** *)
+
+exception Exit_judge
+
+module UI (C : CORE) : sig
+
+  val init : unit -> unit
+  val close : unit -> unit
+  val handle_events : unit -> unit
+  val display : unit -> unit
+
+end = struct
+
+  module G = C.G
+
+  (* Graphic helpers *)
+  let grey = rgb 64 64 64
+
+  let center () = size_x () / 2, size_y () / 2
+
+  let fullscreen_msg m =
+    clear_graph();
+    let tx, ty = text_size m in
+    let cx, cy = center () in
+    let w, h = tx/2, ty/2 in
+    set_color black;
+    let cr d =
+      draw_rect (cx - w - d) (cy - h - d)
+                (cx + w + d) (cy + h + d)
+    in cr 20; cr 22;
+    moveto (cx - w) (cy - h);
+    draw_string m
+
+  let tw m = fst (text_size m)
+
+  let text_l l x c m =
+    set_color c;
+    moveto x (size_y() - ((l+1) * 20));
+    draw_string m
+
+  let text1 l c m =
+    text_l l 20 c m
+  let text2 l c m =
+    text_l l (size_x()/2 - 20 - tw m) c m
+  let text3 l c m =
+    text_l l (size_x()/2 + 20) c m
+  let text4 l c m =
+    text_l l (size_x() - 20 - tw m) c m
+
+  let hl () =
+    draw_poly_line
+      [| 10, size_y() - 50;
+         size_x() - 10, size_y() - 50 |]
+
+  (* Init/Close *)
+  let init () =
+    open_graph " 800x600";
+    fullscreen_msg "Starting up..."
+
+  let close () =
+    close_graph ()
+
+  (* View types *)
+  type view =
+    | ScoreBoard
+    | MatchList of bool
+    | ViewGame of C.game
+    | Question of string * (unit -> unit) * view
+
+  let rec handle_events () =
+    while key_pressed () do
+      match !curr_view, read_key() with
+      | ScoreBoard, '\t' -> curr_view := MatchList false
+      | MatchList _, '\t' -> curr_view := ScoreBoard
+      | MatchList e, 'f' -> curr_view := MatchList (not e)
+      | Question(_, y, n), 'y' -> y()
+      | Question(_, y, n), 'n' -> curr_view := n
+      | v, 'q' ->
+        curr_view := Question(
+          "Really quit?",
+          (fun () ->
+            fullscreen_msg "Exiting...";
+            raise Exit_judge),
+          v)
+      | _ -> ()
+    done
+
+  and display () =
+    clear_graph ();
+    match !curr_view with
+    | ScoreBoard -> scoreboard_disp ()
+    | MatchList f -> matchlist_disp f
+    | ViewGame g -> game_disp g
+    | Question (q, _, _) -> fullscreen_msg (q ^ " (y/n)")
+
+  and curr_view = ref ScoreBoard
+
+  (* Scoreboard view *)
+  and scoreboard_disp () =
+    text1 2 black "score board";
+    text4 2 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)
+    in
+    List.iteri show_sc scores
+
+  (* Match list view *)
+  and matchlist_disp show_only_running =
+    (* TODO *)
+    ()
+
+  (* Game view *)
+  and game_disp g =
+    (* TODO *)
+    ()
+
+end
+
+(* ************* *)
+(* The main loop *)
+(* ************* *)
+
+module Juge (C : CORE) : sig
+
+  val run : unit -> unit
+
+end = struct
+
+  module UI = UI(C)
+
+  let run () =
+    C.init();
+    UI.init();
+    begin try while true do
+      C.handle_events ();
+      UI.handle_events ()
+    done with
+      Exit_judge ->
+        C.finish ();
+        UI.close ()
+    end
+
+end