From 415c2c5529e7d33f6ec1236e607ee1f62509de4b Mon Sep 17 00:00:00 2001 From: Alex AUVOLAT Date: Sun, 9 Nov 2014 22:04:48 +0100 Subject: Implement a part of the judge UI; add dummy game & player for testing purposes. --- judge/core.ml | 117 +++++++++++++++++++++++++++++--------------------- judge/dummy_game.ml | 35 +++++++++++++++ judge/dummy_player.ml | 42 ++++++++++++++++++ judge/main.ml | 98 ++++++++++++++++++++++++++++-------------- 4 files changed, 211 insertions(+), 81 deletions(-) create mode 100644 judge/dummy_game.ml create mode 100644 judge/dummy_player.ml (limited to 'judge') diff --git a/judge/core.ml b/judge/core.ml index 70e2bd4..4411937 100644 --- a/judge/core.ml +++ b/judge/core.ml @@ -5,6 +5,7 @@ open Protocol (* Description of data structures *) type player = P1 | P2 +let other_player = function P1 -> P2 | P2 -> P1 type game_status = | TurnOf of player @@ -12,11 +13,6 @@ type game_status = | Tie | Eliminated of player -type game_proc_status = - | Initializing of game_status - | Running of game_status - | Finished of game_status - type player_proc_status = | Loading | StandBy of float (* temps restant sur toute la partie *) @@ -41,7 +37,8 @@ module type CORE = sig type game val p1 : game -> player_proc_status val p2 : game -> player_proc_status - val s : game -> game_proc_status + val pn : game -> string * string + val s : game -> game_status val g : game -> G.game val hist : game -> G.game list (* head: same as g g *) @@ -52,6 +49,7 @@ module type CORE = sig val add_rounds : unit -> unit (* adds one game of everyone against everyone *) + val ql : unit -> int val scores : unit -> (string * int) list val games : unit -> game list @@ -61,7 +59,7 @@ end (* BEGIN IMPLEMENTATION *) (* ****************************************** *) -module C (G: GAME) : CORE = struct +module Core (G: GAME) : CORE = struct module G : GAME = G exception Eliminated_ex of string @@ -72,9 +70,10 @@ module C (G: GAME) : CORE = struct dir: string; log_out: file_descr; mutable score: int; + mutable running: player_proc option; } - type player_proc = { + and player_proc = { pid: int; p: player; i: in_channel; @@ -89,18 +88,21 @@ module C (G: GAME) : CORE = struct mutable hist: G.game list; p1: player_proc; p2: player_proc; - mutable s: game_proc_status; + mutable s: 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 g g = List.hd g.hist let hist g = g.hist let players = Hashtbl.create 12 - let planned_games = Queue.create () + let planned_games = ref [] let r_games = ref [] + let ql () = List.length !planned_games + (* program paremeters *) let par_games = ref 2 (* default: launch two simultaneous games *) let game_time = ref 30.0 (* default: 30 sec for each player *) @@ -132,9 +134,11 @@ module C (G: GAME) : CORE = struct Format.eprintf "Error: no game directory specified.@."; exit 1 end; + if Filename.is_relative !game_dir then + game_dir := Filename.concat (Unix.getcwd()) !game_dir; let date = - let d = Unix.gmtime (Unix.time ()) in - Format.sprintf "%04d%02d%02d%02d%02d" d.tm_year d.tm_mon d.tm_mday d.tm_hour d.tm_min + let d = Unix.gmtime (Unix.gettimeofday ()) in + Format.sprintf "%04d%02d%02d%02d%02d" (d.tm_year+1900) (d.tm_mon+1) d.tm_mday d.tm_hour d.tm_min in (* 2. REDIRECT STDOUT TO LOG FILE *) @@ -160,7 +164,7 @@ module C (G: GAME) : CORE = struct in let rec rd () = try let s = readdir fd in - try + begin try let dir = Filename.concat !game_dir s in let b = Filename.concat dir "player" in let st = Unix.stat b in @@ -177,12 +181,13 @@ module C (G: GAME) : CORE = struct binary = b; dir; log_out = p_log_out; - score = 0; } + score = 0; + running = None; } end - with _ -> (); + with _ -> () end; rd() with End_of_file -> () - in rd () + in rd (); closedir fd let finish () = (* TODO : @@ -194,18 +199,18 @@ module C (G: GAME) : CORE = struct let add_rounds () = Hashtbl.iter (fun p _ -> Hashtbl.iter - (fun q _ -> if p <> q then Queue.push (p, q) planned_games) + (fun q _ -> if p <> q then planned_games := (p, q)::!planned_games) players) players let handle_events () = (* 1. IF NOT ENOUGH MATCHES ARE RUNING, LAUNCH ONE *) - while (List.length - (List.filter (fun g -> match g.s with Finished _ -> false | _ -> true) - !r_games)) < !par_games - && Queue.length planned_games > 0 - do - let p1, p2 = Queue.pop planned_games in + let matches_in_progress = List.length + (List.filter + (fun g -> match g.p1.s, g.p2.s with Dead, Dead -> false | _ -> true) + !r_games) + in + let launch_match p1 p2 = Format.printf "Launching match: %s vs. %s@." p1 p2; let open_c p = @@ -219,38 +224,52 @@ module C (G: GAME) : CORE = struct dup2 j2p_i stdin; dup2 p2j_o stdout; dup2 p.log_out stderr; - execv p.binary [| p.binary |]; + execvp p.binary [| p.binary |]; end; Format.printf "- %s: pid %d@." p.name pid; let pl = { pid; p; i = in_channel_of_descr p2j_i; o = out_channel_of_descr j2p_o; s = Loading } in + p.running <- Some pl; send_m pl (Hello G.id); pl in let p1 = open_c (Hashtbl.find players p1) in let p2 = open_c (Hashtbl.find players p2) in let g, s = G.new_game in - let g = { p1; p2; hist = [g]; s = Initializing s } in + let g = { p1; p2; hist = [g]; s } in r_games := g::(!r_games) - done; - + in + let can_launch, cannot_launch = List.partition + (fun (p1, p2) -> + (Hashtbl.find players p1).running = None + && (Hashtbl.find players p2).running = None) + !planned_games + in + begin match can_launch with + | (p1, p2)::q when matches_in_progress < !par_games -> + launch_match p1 p2; + planned_games := q @ cannot_launch + | _ -> () + end; (* 2. LOOK IF ANYBODY IS TELLING US SOMETHING - IF SO, REACT (wait max. 0.01 sec) *) let in_fd = List.fold_left - (fun l g -> match g.s with - | Finished _ -> l - | _ -> - let l = match g.p1.s with - | Dead -> l - | _ -> (Unix.descr_of_in_channel g.p1.i)::l - in match g.p2.s with - | Dead -> l - | _ -> (Unix.descr_of_in_channel g.p2.i)::l) + (fun l g -> + let l = match g.p1.s with + | Dead -> l + | _ -> (Unix.descr_of_in_channel g.p1.i)::l + in match g.p2.s with + | Dead -> l + | _ -> (Unix.descr_of_in_channel g.p2.i)::l) [] !r_games in - let in_fd, _, _ = select in_fd [] [] 0.01 in + let in_fd, _, _ = + try select in_fd [] [] 0.01 + with + Unix_error (EINTR, _, _) -> [], [], [] + in let do_fd fd = let g = List.find (fun g -> fd = Unix.descr_of_in_channel g.p1.i @@ -264,21 +283,21 @@ module C (G: GAME) : CORE = struct | Hello x, Loading when x = G.id -> p.s <- StandBy !game_time; begin match g.s, g.p1.s, g.p2.s, g.p1, g.p2 with - | Initializing (TurnOf P1), StandBy t, StandBy _, p, _ - | Initializing (TurnOf P2), StandBy _, StandBy t, _, p -> + | TurnOf P1, StandBy t, StandBy _, p, _ + | TurnOf P2, StandBy _, StandBy t, _, p -> send_m p (YourTurn t); - p.s <- Thinking (t, Unix.time()); - g.s <- Running (TurnOf P1) + p.s <- Thinking (t, Unix.gettimeofday()); | _ -> () end | Play act, Thinking (time, beg_r) -> - let end_r = Unix.time () in + let end_r = Unix.gettimeofday () in let new_g, new_s = G.turn (List.hd g.hist) pi act in begin match new_s with | Eliminated _ -> raise (Eliminated_ex ("invalid move: " ^ act)) | _ -> () end; 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 -> @@ -302,19 +321,18 @@ module C (G: GAME) : CORE = struct if finished then begin p.s <- Saving; op.s <- Saving; - g.s <- Finished new_s end else begin p.s <- StandBy (time -. (end_r -. beg_r)); - g.s <- Running new_s; match op.s with | StandBy t -> send_m op (YourTurn t); - op.s <- Thinking (t, Unix.time()) + op.s <- Thinking (t, Unix.gettimeofday ()) | _ -> assert false end | FairEnough, Saving -> - kill p.pid 15; (* 15 : sigterm *) - p.s <- Dead + 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") @@ -324,12 +342,13 @@ module C (G: GAME) : CORE = struct send_m op YouWin; (* since process is not respecting the protocol, we cannot assume it is doing anything reasonable, so we kill it... *) - kill p.pid 15; + 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; - g.s <- Finished (Eliminated pi) + g.s <- Eliminated pi end; in List.iter do_fd in_fd diff --git a/judge/dummy_game.ml b/judge/dummy_game.ml new file mode 100644 index 0000000..869513a --- /dev/null +++ b/judge/dummy_game.ml @@ -0,0 +1,35 @@ +open Core +open Main + +module Dummy : GAME = struct + + type game = player * int + + let new_game = (P1, 10), TurnOf P1 + + let turn (p0, g) p _ = + if p <> p0 || g <= 0 then + (p0, g), Eliminated p + else + let op = other_player p in + (op, g-1), ( + if g - 1 = 0 then + if Random.int 100 = 0 then Eliminated p + else if Random.int 2 = 0 then Won p + else if Random.int 2 = 0 then Won op + else Tie + else + TurnOf op + ) + + let id = "dummy_game" + let name = "Dumm game for testing purposes" + +end + +module C = Core(Dummy) +module Main = Juge(C) + +let () = + Random.self_init (); + Main.run () diff --git a/judge/dummy_player.ml b/judge/dummy_player.ml new file mode 100644 index 0000000..fe19b48 --- /dev/null +++ b/judge/dummy_player.ml @@ -0,0 +1,42 @@ + + +let expect mgs = + let l = read_line () in + begin try + let (s, f) = List.find + (fun (s, _) -> + String.length l >= String.length s + && String.sub l 0 (String.length s) = s) + mgs + in f (String.sub l (String.length s) + (String.length l - String.length s)) + with + Not_found -> + Format.eprintf "Unexpected '%s'.@." l; + exit 1 + end + +let finished _ = + print_string "Fair enough\n" + +let rec turn _ = + expect [ + "Your turn", + (fun _ -> + if Random.int 2 = 0 then Unix.sleep 1; + print_string "Play this_is_a_word\n"; + expect [ "OK", turn ]); + "Play ", turn; + "Tie", finished; + "You win", finished; + "You lose", finished; + "Eliminated", finished + ] + +let () = + Random.self_init (); + expect [ + "Hello dummy_game", + (fun _ -> print_string "Hello dummy_game\n"; + turn "") + ]; diff --git a/judge/main.ml b/judge/main.ml index 5155e02..6a42ff8 100644 --- a/judge/main.ml +++ b/judge/main.ml @@ -19,7 +19,9 @@ end = struct module G = C.G (* Graphic helpers *) - let grey = rgb 64 64 64 + let grey = rgb 112 112 112 + let red = rgb 200 0 0 + let green = rgb 0 150 0 let center () = size_x () / 2, size_y () / 2 @@ -31,10 +33,11 @@ end = struct set_color black; let cr d = draw_rect (cx - w - d) (cy - h - d) - (cx + w + d) (cy + h + d) + (2 * (w + d)) (2 * (h + d)) in cr 20; cr 22; moveto (cx - w) (cy - h); - draw_string m + draw_string m; + synchronize () let tw m = fst (text_size m) @@ -44,13 +47,13 @@ end = struct draw_string m let text1 l c m = - text_l l 20 c m + text_l l 30 c m let text2 l c m = - text_l l (size_x()/2 - 20 - tw m) c m + text_l l (size_x()/2 - 30 - tw m) c m let text3 l c m = - text_l l (size_x()/2 + 20) c m + text_l l (size_x()/2 + 30) c m let text4 l c m = - text_l l (size_x() - 20 - tw m) c m + text_l l (size_x() - 30 - tw m) c m let hl () = draw_poly_line @@ -60,6 +63,10 @@ end = struct (* Init/Close *) let 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 close () = @@ -78,6 +85,11 @@ end = struct | ScoreBoard, '\t' -> curr_view := MatchList false | MatchList _, '\t' -> curr_view := ScoreBoard | MatchList e, 'f' -> curr_view := MatchList (not e) + | MatchList _, 'r' -> curr_view := Question( + "Launch new round?", + (fun () -> C.add_rounds(); curr_view := MatchList false), + !curr_view + ) | Question(_, y, n), 'y' -> y() | Question(_, y, n), 'n' -> curr_view := n | v, 'q' -> @@ -92,50 +104,71 @@ end = struct and display () = clear_graph (); - match !curr_view with + begin match !curr_view with | ScoreBoard -> scoreboard_disp () | MatchList f -> matchlist_disp f | ViewGame g -> game_disp g | Question (q, _, _) -> fullscreen_msg (q ^ " (y/n)") + end; + synchronize () and curr_view = ref ScoreBoard (* Scoreboard view *) and scoreboard_disp () = - text1 2 black "score board"; - text4 2 grey "match list >"; + text1 1 black "score board"; + text4 1 grey "match list >"; hl(); let scores = List.sort (fun (_, sc) (_, sc') -> sc' - sc) (C.scores()) in - let xx l (n, s) t = - text1 l black t; - text1 (l+1) black (" "^n); - text2 (l+1) black (string_of_int s) - in - let scores = match scores with - | first::q -> xx 4 first "first place"; q - | [] -> [] - in - let scores = match scores with - | sec::q -> xx 7 sec "second place"; q - | [] -> [] - in - let scores = match scores with - | thrd::q -> xx 10 thrd "third place"; q - | [] -> [] - in let show_sc i (n, s) = - text3 (i+4) black ((string_of_int (i+3))^". "^n); - text4 (i+1) black (string_of_int s) + text2 (i+4) black (string_of_int (i+1)^". "); + text3 (i+4) black n; + text4 (i+4) black (string_of_int s) in List.iteri show_sc scores (* Match list view *) and matchlist_disp show_only_running = - (* TODO *) - () + text1 1 black "match list"; + text2 1 black "queued matches:"; + text3 1 black (string_of_int (C.ql ())); + text4 1 grey "score board >"; + hl(); + let games = + if show_only_running then + List.filter + (fun g -> match C.p1 g, C.p2 g with Dead, Dead -> false | _ -> true) + (C.games()) + else C.games() + in + let time = Unix.gettimeofday() in + let print_g i g = + let cp1, cp2 = match C.s g with + | TurnOf _ -> black, black + | Won P1 -> green, red + | Won P2 -> red, green + | Tie -> grey, grey + | Eliminated P1 -> red, grey + | Eliminated P2 -> grey, red + in + let mp = function + | Loading -> grey, ">>>" + | Saving -> grey, "<<<" + | Dead -> black, "" + | StandBy t -> grey, Format.sprintf "%.2f" t + | Thinking (t, tb) -> black, + Format.sprintf "[ %.2f ]" (t -. (time -. tb)) + in + let p1n, p2n = C.pn g in + let c, m = mp (C.p1 g) in text1 (i+4) c m; + text2 (i+4) cp1 p1n; + text3 (i+4) cp2 p2n; + let c, m = mp (C.p2 g) in text4 (i+4) c m + in + List.iteri print_g games (* Game view *) and game_disp g = @@ -161,7 +194,8 @@ end = struct UI.init(); begin try while true do C.handle_events (); - UI.handle_events () + UI.handle_events (); + UI.display () done with Exit_judge -> C.finish (); -- cgit v1.2.3