Improved handling of the dead ; correct bug in Amane.

3 files changed, 59 insertions, 21 deletions

diff --git a/judge/core.ml b/judge/core.ml
index dd6c31c..ce542dc 100644
--- a/judge/core.ml
+++ b/judge/core.ml
@@ -83,11 +83,6 @@ module Core (G: GAME) : CORE = struct
     o: out_channel;
     mutable s: player_proc_status;
   }
-  let send_m pp m =
-    let m = encode m in
-    Format.printf ">%s< %s@." pp.p.name m;
-    output_string pp.o (m ^ "\n");
-    flush pp.o
 
   type game = {
     mutable hist: G.game list;
@@ -115,6 +110,7 @@ module Core (G: GAME) : CORE = struct
   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 log_games = ref false   (* default: do not log games *)
 
   let scores () =
     Hashtbl.fold (fun _ p l -> (p.name, p.score)::l) players []
@@ -131,6 +127,7 @@ module Core (G: GAME) : CORE = struct
       "-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)";
+      "-l", Arg.Set log_games, "Log all games (false)";
 
     ] in
     Arg.parse args (fun s -> game_dir := s)
@@ -197,9 +194,20 @@ module Core (G: GAME) : CORE = struct
   let finish () =
     (* TODO :
       - save scores
-      - kill all child processes and wait for them
     *)
-    ()
+    let childs = ref [] in
+    List.iter
+      (fun g ->
+        if g.p1.s <> Dead then childs := g.p1.pid::!childs;
+        if g.p2.s <> Dead then childs := g.p2.pid::!childs)
+      !r_games;
+    List.iter (fun pid -> kill pid Sys.sigterm) !childs;
+    while !childs <> [] do
+      try
+        let pid, _ = waitpid [] (-1) in
+        childs := List.filter (( <> ) pid) !childs
+      with _ -> ()
+    done
   
   let add_rounds () =
     Hashtbl.iter
@@ -208,6 +216,12 @@ module Core (G: GAME) : CORE = struct
         players)
       players
 
+  let send_m pp m =
+    let m = encode m in
+    if !log_games then Format.printf ">%s< %s@." pp.p.name m;
+    output_string pp.o (m ^ "\n");
+    flush pp.o
+
   let handle_events () =
     (* 1. IF NOT ENOUGH MATCHES ARE RUNING, LAUNCH ONE *)
     let matches_in_progress = List.length
@@ -231,7 +245,7 @@ module Core (G: GAME) : CORE = struct
           dup2 p.log_out stderr;
           execvp p.binary [| p.binary |];
         end;
-        Format.printf "- %s: pid %d@." p.name pid;
+        Format.printf "[%s start, pid: %d]@." p.name pid;
         let pl = { pid; p;
           i = in_channel_of_descr p2j_i;
           o = out_channel_of_descr j2p_o;
@@ -286,7 +300,7 @@ module Core (G: GAME) : CORE = struct
       let op = match pi with P1 -> g.p2 | P2 -> g.p1 in
       begin try
         let l = input_line p.i in
-        Format.printf "<%s> %s@." p.p.name l;
+        if !log_games then Format.printf "<%s> %s@." p.p.name l;
         match decode l, p.s with
         | Hello x, Loading when x = G.id ->
           p.s <- StandBy !game_time;
@@ -327,8 +341,6 @@ module Core (G: GAME) : CORE = struct
           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")
@@ -337,13 +349,12 @@ module Core (G: GAME) : CORE = struct
           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... *)
+            it is doing anything reasonable, so we kill it now rather than later... *)
           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;
+          p.s <- Saving;
           g.s <- Eliminated pi
       end;
       begin match g.s, g.p1.s, g.p2.s, g.p1, g.p2 with
@@ -353,6 +364,31 @@ module Core (G: GAME) : CORE = struct
           p.s <- Thinking (t, Unix.gettimeofday());
         | _ -> ()
       end
-    in List.iter do_fd in_fd
+    in List.iter do_fd in_fd;
+    (* Check if somebody has died on us *)
+    begin try
+      let pid, _ = waitpid [WNOHANG] (-1) in
+      if pid <> 0 then begin
+          let g = List.find
+            (fun g ->
+              (g.p1.s <> Dead && g.p1.pid = pid)
+              || (g.p2.s <> Dead && g.p2.pid = pid))
+            !r_games
+          in
+          let pi = if g.p1.pid = pid then P1 else P2 in
+          let p, op = if g.p1.pid = pid then g.p1, g.p2 else g.p2, g.p1 in
+          Format.printf "[%s (%d) died.]@." p.p.name pid;
+          if p.s <> Saving then begin
+            (* YOU DIE -> ELIMINATED! *)
+            send_m op YouWin;
+            Format.printf "%s vs. %s: %s eliminated (died...)!@." g.p1.p.name g.p2.p.name p.p.name;
+            p.p.score <- p.p.score + !pt_elim;
+            op.s <- Saving;
+            g.s <- Eliminated pi
+          end;
+          p.s <- Dead;
+          p.p.running <- None;
+      end
+    with _ -> () end
   
 end
diff --git a/judge/g_util.ml b/judge/g_util.ml
index 95bfcba..3679280 100644
--- a/judge/g_util.ml
+++ b/judge/g_util.ml
@@ -5,6 +5,7 @@ open Core
 let grey = rgb 112 112 112
 let red = rgb 200 0 0
 let green = rgb 0 150 0
+let orange = rgb 200 140 0
 
 let p1c = blue
 let p2c = red
diff --git a/judge/main.ml b/judge/main.ml
index ea7c2ef..8c74be6 100644
--- a/judge/main.ml
+++ b/judge/main.ml
@@ -138,12 +138,12 @@ end = struct
       | Won P1 -> green, red
       | Won P2 -> red, green
       | Tie -> grey, grey
-      | Eliminated P1 -> red, grey
-      | Eliminated P2 -> grey, red
+      | Eliminated P1 -> orange, grey
+      | Eliminated P2 -> grey, orange
       in
       let mp = function
-        | Loading -> grey, ">>>"
-        | Saving -> grey, "<<<"
+        | Loading -> grey, "-> []"
+        | Saving -> grey, "[] ->"
         | Dead -> black, ""
         | StandBy t -> grey, Format.sprintf "%.2f" t
         | Thinking (t, tb) -> black,
@@ -176,8 +176,9 @@ end = struct
     hl();
     let n = if n = -1 then List.length (C.hist g) -1 else n in
     let put_st i g =
-      let cx = 10 * i + 30 in
-      let cy = size_y () - 60 in
+      let ni = (size_x() - 60) / 12 + 1 in
+      let cx = 12 * (i mod ni) + 30 in
+      let cy = size_y () - 60 - (20 * (i / ni)) in
       begin match G.s g with
         | TurnOf p ->
           set_color (pc p);