diff options
Diffstat (limited to 'judge')
| -rw-r--r-- | judge/core.ml | 66 | ||||
| -rw-r--r-- | judge/g_util.ml | 1 | ||||
| -rw-r--r-- | judge/main.ml | 13 |
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); |