aboutsummaryrefslogtreecommitdiff
path: root/judge
diff options
context:
space:
mode:
Diffstat (limited to 'judge')
-rw-r--r--judge/core.ml117
-rw-r--r--judge/dummy_game.ml35
-rw-r--r--judge/dummy_player.ml42
-rw-r--r--judge/main.ml98
4 files changed, 211 insertions, 81 deletions
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 ();
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 17:25:17 +0000