Implement GUI interface for playingHEADmaster

4 files changed, 178 insertions, 7 deletions

diff --git a/judge/core.ml b/judge/core.ml
index e08ce17..cb5df75 100644
--- a/judge/core.ml
+++ b/judge/core.ml
@@ -36,6 +36,7 @@ module type GAME = sig
   val s    : game -> game_status
 
   val display_game : game -> (string * string) -> unit
+  val gui_act_at : game -> (int * int) -> string
 end
 
 module type CORE = sig
@@ -121,7 +122,7 @@ module Core (G: GAME) : CORE = struct
 
   let init () =
     (* 1. PARSE ARGUMENTS *)
-    let game_dir = ref "" in
+    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,
@@ -134,11 +135,7 @@ module Core (G: GAME) : CORE = struct
 
     ] in
     Arg.parse args (fun s -> game_dir := s)
-      "Usage: judge [<option> ...] <game_directory>";
-    if !game_dir = "" then begin
-      Format.eprintf "Error: no game directory specified.@.";
-      exit 1
-    end;
+      "Usage: judge [<option> ...] [<game_directory>]";
     if Filename.is_relative !game_dir then
       game_dir := Filename.concat (Unix.getcwd()) !game_dir;
     let date =
diff --git a/judge/guiplay.ml b/judge/guiplay.ml
new file mode 100644
index 0000000..50add3c
--- /dev/null
+++ b/judge/guiplay.ml
@@ -0,0 +1,155 @@
+open Core
+open Graphics
+open Unix
+open Protocol
+
+module A (G : GAME) : sig
+
+  val run : unit -> unit
+
+end = struct
+
+  exception Unexpected of msg
+
+  open G_util
+
+  (* Init/Close *)
+  let gui_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 gui_close () =
+    close_graph ()
+
+  (* The functions *)
+
+  let dg t g pnx =
+    clear_graph();
+    text3 1 black t;
+    hl();
+    G.display_game g pnx;
+    synchronize()
+
+  let display_result r (p1n, p2n) = 
+    let s = match r with
+      | Won P1 -> p1n ^ " won"
+      | Won P2 -> p2n ^ " won"
+      | Tie -> "Tie"
+      | Eliminated P1 -> p1n ^ " eliminated"
+      | Eliminated P2 -> p2n ^ " eliminated"
+      | _ -> assert false
+    in
+    fullscreen_msg (s ^ ". Press a key to exit.");
+    ignore @@ read_key()
+
+  let fwd ff g (send, recv) (p1n, p2n) =
+    match G.s g with
+    | TurnOf _ -> ff g (send, recv) (p1n, p2n)
+    | s ->
+      display_result s (p1n, p2n);
+      send (match s with
+        | Tie -> Tie
+        | Won P1 when p1n = "AI" -> YouWin
+        | Won P2 when p2n = "AI" -> YouWin
+        | Won _ ->  YouLose
+        | _ -> Eliminated);
+      match (recv ()) with
+        | FairEnough -> ()
+        | x -> raise (Unexpected x)
+
+  let rec human_turn g (send, recv) pnx =
+    dg "Your turn !" g pnx;
+    let rec x pmc =
+      let st = wait_next_event [Button_down; Button_up; Mouse_motion; Key_pressed] in
+      let act = G.gui_act_at g (st.mouse_x, st.mouse_y) in
+      let g', ok = try G.play g act, true with _ -> g, false in
+      let ok = ok && (match G.s g' with Eliminated _ -> false | _ -> true) in
+      dg "Your turn !" (if ok then g' else g) pnx;
+      if st.keypressed && st.key = 'q' then begin
+        send (YouWin);
+        fullscreen_msg "You abandon! Coward!"
+      end else
+        if pmc && not st.button && ok then begin
+          send (Play act);
+          fwd ai_turn g' (send, recv) pnx
+        end else
+          x st.button
+    in x false
+    
+  and ai_turn g (send, recv) pnx =
+    dg "AI's turn..." g pnx;
+    send (YourTurn 30.0);
+    match recv() with
+      | Play x ->
+        let g' = G.play g x in
+        send OK;
+        fwd human_turn g' (send, recv) pnx
+      | x -> raise (Unexpected x)
+
+  (* Arg parsing && Initialization *)
+
+  let human_begin = ref false
+
+  let start_proc player_dir =
+    let b = Filename.concat player_dir "player" in
+    let st = Unix.stat b in
+    if not ((st.st_kind = S_REG || st.st_kind = S_LNK)
+            && (st.st_perm land 0o100 <> 0)) then
+    begin
+      Format.eprintf "Could not find player binary in %s@." player_dir;
+      exit 1
+    end;
+    let (ff_i, o) = pipe () in
+    let (i, ff_o) = pipe () in
+    let pid = fork() in
+    if pid = 0 then begin
+      chdir player_dir;
+      dup2 ff_i stdin;
+      dup2 ff_o stdout;
+      execvp b [| b |];
+    end;
+    Format.eprintf "Started IA process, pid %d@." pid;
+    i, o, pid
+
+
+  let run () =
+    let player_dir = ref "." in
+    let args = [
+      "-h", Arg.Set human_begin, "Human begins (default: AI begins";
+    ] in
+    Arg.parse args (fun s -> player_dir := s)
+      "Usage: xx_guiplay [<option> ...] [<player directory>]";
+    let player_dir =
+      if Filename.is_relative !player_dir
+        then Filename.concat (Unix.getcwd()) !player_dir
+        else !player_dir
+    in
+    gui_init();
+    let i, o, pid = start_proc player_dir in
+    let ic = in_channel_of_descr i in
+    let oc = out_channel_of_descr o in
+    let send m = output_string oc (encode m ^ "\n"); flush oc in
+    let recv () = decode (input_line ic) in
+    send (Hello G.id);
+    let pnc = if !human_begin then ("human", "AI") else ("AI", "human") in
+    begin try
+        match recv () with
+        | Hello x when x = G.id ->
+          if !human_begin
+            then human_turn G.new_game (send, recv) pnc
+            else ai_turn G.new_game (send, recv) pnc
+        | x -> raise (Unexpected x)
+      with
+        | Unexpected x ->
+          Format.eprintf "Unexpected message: %s@." (encode x)
+    end;
+    Unix.kill pid Sys.sigterm;
+    gui_close()
+
+end
+
+
diff --git a/judge/morpion_rec.ml b/judge/morpion_rec.ml
index a46b7f9..49e6544 100644
--- a/judge/morpion_rec.ml
+++ b/judge/morpion_rec.ml
@@ -195,9 +195,13 @@ module G = struct
     List.iter (fun p -> sdf (margin (subpos box p) 6) (getp1 mor p)) all_p1;
     disp_l 2 box (reduct mor)
 
-  let display_game (s, mor, q) (pn1, pn2) =
+  let gbox () =
     let cx, cy = center() in
     let box = cx - 200, cy - 200, cx + 200, cy + 200 in
+    box
+
+  let display_game (s, mor, q) (pn1, pn2) =
+    let box = gbox () in
     disp_r (disp_r (disp_l 1)) box mor;
     begin match q, s with
     | Some p, TurnOf player ->
@@ -207,6 +211,18 @@ module G = struct
     | _ -> ()
     end
 
+  let in_box (x1, y1, x2, y2) (x, y) =
+    (x >= x1 && x <= x2 && y >= y1 && y <= y2)
+
+  let gui_act_at g xy =
+    let box = gbox () in
+    try
+      let pg = List.find (fun p -> in_box (subpos box p) xy) all_p1 in
+      let sbox = subpos box pg in
+      let pp = List.find (fun p -> in_box (subpos sbox p) xy) all_p1 in
+      encode (pg, pp)
+    with Not_found -> ""
+
 
 end
 
diff --git a/judge/morpion_rec_guiplay.ml b/judge/morpion_rec_guiplay.ml
new file mode 100644
index 0000000..ed44a14
--- /dev/null
+++ b/judge/morpion_rec_guiplay.ml
@@ -0,0 +1,3 @@
+module Main = Guiplay.A(Morpion_rec.G)
+
+let () = Main.run ()