Improved handling of the dead ; correct bug in Amane.

1 files changed, 51 insertions, 15 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