diff options
Diffstat (limited to 'judge/core.ml')
| -rw-r--r-- | judge/core.ml | 115 |
1 files changed, 61 insertions, 54 deletions
diff --git a/judge/core.ml b/judge/core.ml index ec73639..1c8ad05 100644 --- a/judge/core.ml +++ b/judge/core.ml @@ -3,6 +3,11 @@ open Unix open Protocol let ( |> ) x f = f x +let iteri f l = + let rec aux i = function + | p::q -> f i p; aux (i+1) q + | [] -> () + in aux 0 l (* Description of data structures *) @@ -91,12 +96,12 @@ module Core (G: GAME) : CORE = struct mutable hist: G.game list; p1: player_proc; p2: player_proc; - mutable s: game_status; + mutable gs: game_status; } let p1 g = g.p1.s let p2 g = g.p2.s let pn g = (g.p1.p.name, g.p2.p.name) - let s g = g.s + let s g = g.gs let g g = List.hd g.hist let hist g = g.hist @@ -263,7 +268,7 @@ module Core (G: GAME) : CORE = struct let p1 = open_c (Hashtbl.find players p1) in let p2 = open_c (Hashtbl.find players p2) in let g = G.new_game in - let g = { p1; p2; hist = [g]; s = G.s g } in + let g = { p1; p2; hist = [g]; gs = G.s g } in r_games := g::(!r_games) in let can_launch, cannot_launch = List.partition @@ -297,56 +302,58 @@ module Core (G: GAME) : CORE = struct let pi = if p == g.p1 then P1 else P2 in let op = match pi with P1 -> g.p2 | P2 -> g.p1 in begin try - let l = input_line p.i in - 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; - | Play act, Thinking (time, beg_r) -> - let end_r = Unix.gettimeofday () in - if G.s (List.hd g.hist) <> TurnOf pi then - raise (Eliminated_ex "not your turn (assert failed)"); - let new_g = G.play (List.hd g.hist) act in - let new_s = G.s new_g in - send_m p OK; - send_m op (Play act); - g.s <- new_s; - 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; - p.p.score <- p.p.score + !pt_tie; - op.p.score <- op.p.score + !pt_tie; - true - | Won x -> - 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 _ -> - p.s <- StandBy (time -. (end_r -. beg_r)); - false - | Eliminated _ -> raise (Eliminated_ex ("invalid move: " ^ act)) - in - if finished then begin - p.s <- Saving; - if op.s <> Dead then op.s <- Saving; - end - | FairEnough, Saving -> - kill p.pid Sys.sigterm; - | _, Saving -> - () (* player may be anywhere in its protocol state, we don't care*) - | 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") + try + let l = input_line p.i in + 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; + | Play act, Thinking (time, beg_r) -> + let end_r = Unix.gettimeofday () in + if G.s (List.hd g.hist) <> TurnOf pi then + raise (Eliminated_ex "not your turn (assert failed)"); + let new_g = G.play (List.hd g.hist) act in + let new_s = G.s new_g in + send_m p OK; + send_m op (Play act); + g.gs <- new_s; + g.hist <- new_g::g.hist; + let finished = match new_s with + | Tie -> + send_m p Protocol.Tie; + send_m op Protocol.Tie; + Format.printf "%s vs. %s: tie!@." g.p1.p.name g.p2.p.name; + p.p.score <- p.p.score + !pt_tie; + op.p.score <- op.p.score + !pt_tie; + true + | Won x -> + 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 _ -> + p.s <- StandBy (time -. (end_r -. beg_r)); + false + | Eliminated _ -> raise (Eliminated_ex ("invalid move: " ^ act)) + in + if finished then begin + p.s <- Saving; + if op.s <> Dead then op.s <- Saving; + end + | FairEnough, Saving -> + kill p.pid Sys.sigterm; + | _, Saving -> + () (* player may be anywhere in its protocol state, we don't care*) + | bad_m, _ -> raise (Eliminated_ex ("unexpected message: '" ^ encode bad_m ^ "'")) + with + | Invalid_message m -> raise (Eliminated_ex ("invalid message: '" ^ m ^"'")) + | _ -> raise (Eliminated_ex "exception when reading message") with | Eliminated_ex r -> - send_m p Eliminated; + send_m p Protocol.Eliminated; send_m op YouWin; (* since process is not respecting the protocol, we cannot assume it is doing anything reasonable, so we kill it now rather than later... *) @@ -355,9 +362,9 @@ module Core (G: GAME) : CORE = struct p.p.score <- p.p.score + !pt_elim; if op.s <> Dead then op.s <- Saving; p.s <- Saving; - g.s <- Eliminated pi + g.gs <- Eliminated pi end; - begin match g.s, g.p1.s, g.p2.s, g.p1, g.p2 with + begin match g.gs, g.p1.s, g.p2.s, g.p1, g.p2 with | TurnOf P1, StandBy t, StandBy _, p, _ | TurnOf P2, StandBy _, StandBy t, _, p -> send_m p (YourTurn t); @@ -400,7 +407,7 @@ module Core (G: GAME) : CORE = struct 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; if op.s <> Dead then op.s <- Saving; - g.s <- Eliminated pi + g.gs <- Eliminated pi end; p.s <- Dead; p.p.running <- None; |