aboutsummaryrefslogtreecommitdiff
path: root/judge
diff options
context:
space:
mode:
Diffstat (limited to 'judge')
-rw-r--r--judge/_tags2
-rw-r--r--judge/core.ml91
-rw-r--r--judge/main.ml171
3 files changed, 227 insertions, 37 deletions
diff --git a/judge/_tags b/judge/_tags
index eb13bea..6c0a352 100644
--- a/judge/_tags
+++ b/judge/_tags
@@ -1 +1 @@
-true: use_unix
+true: use_unix, use_graphics
diff --git a/judge/core.ml b/judge/core.ml
index 34d5dc9..70e2bd4 100644
--- a/judge/core.ml
+++ b/judge/core.ml
@@ -25,14 +25,14 @@ type player_proc_status =
| Dead
module type GAME = sig
- type game (* mutable structure *)
+ type game (* immutable structure *)
val name : string (* ex: Morpion récursif *)
val id : string (* ex: morpion_rec *)
- val new_game : unit -> (game * game_status)
+ val new_game : game * game_status
- val turn : game -> player -> string -> game_status
+ val turn : game -> player -> string -> (game * game_status)
end
module type CORE = sig
@@ -43,8 +43,10 @@ module type CORE = sig
val p2 : game -> player_proc_status
val s : game -> game_proc_status
val g : game -> G.game
+ val hist : game -> G.game list (* head: same as g g *)
val init : unit -> unit
+ val finish : unit -> unit
val handle_events : unit -> unit (* is anything happening ? *)
@@ -62,7 +64,7 @@ end
module C (G: GAME) : CORE = struct
module G : GAME = G
- exception Eliminated_ex
+ exception Eliminated_ex of string
type player = {
name: string;
@@ -84,7 +86,7 @@ module C (G: GAME) : CORE = struct
flush pp.o
type game = {
- g: G.game;
+ mutable hist: G.game list;
p1: player_proc;
p2: player_proc;
mutable s: game_proc_status;
@@ -92,7 +94,8 @@ module C (G: GAME) : CORE = struct
let p1 g = g.p1.s
let p2 g = g.p2.s
let s g = g.s
- let g g = g.g
+ let g g = List.hd g.hist
+ let hist g = g.hist
let players = Hashtbl.create 12
let planned_games = Queue.create ()
@@ -101,6 +104,10 @@ module C (G: GAME) : CORE = struct
(* program paremeters *)
let par_games = ref 2 (* default: launch two simultaneous games *)
let game_time = ref 30.0 (* default: 30 sec for each player *)
+ let pt_win = ref 3 (* default: on win, score += 3 *)
+ 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 scores () =
Hashtbl.fold (fun _ p l -> (p.name, p.score)::l) players []
@@ -110,9 +117,13 @@ module C (G: GAME) : CORE = struct
(* 1. PARSE ARGUMENTS *)
let game_dir = ref "" in
let args = [
- "-p", Arg.Set_int par_games, "How many games to run in parallel.";
- "-t", Arg.Set_float game_time,
- "Time (seconds) allotted to each player for a game."
+ "-p", Arg.Set_int par_games, "How many games to run in parallel (2)";
+ "-s", Arg.Set_float game_time,
+ "Time (seconds) allotted to each player for a game (30)";
+ "-w", Arg.Set_int pt_win, "Points granted on win (+3)";
+ "-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)";
] in
Arg.parse args (fun s -> game_dir := s)
@@ -172,7 +183,14 @@ module C (G: GAME) : CORE = struct
rd()
with End_of_file -> ()
in rd ()
-
+
+ let finish () =
+ (* TODO :
+ - save scores
+ - kill all child processes and wait for them
+ *)
+ ()
+
let add_rounds () =
Hashtbl.iter
(fun p _ -> Hashtbl.iter
@@ -213,8 +231,8 @@ module C (G: GAME) : CORE = struct
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; g; s = Initializing s } in
+ let g, s = G.new_game in
+ let g = { p1; p2; hist = [g]; s = Initializing s } in
r_games := g::(!r_games)
done;
@@ -245,39 +263,38 @@ module C (G: GAME) : CORE = struct
begin try match decode (input_line p.i), p.s with
| Hello x, Loading when x = G.id ->
p.s <- StandBy !game_time;
- if op.s <> Loading then begin
- match g.s, g.p1.s, g.p2.s with
- | Initializing (TurnOf P1), StandBy t, _ ->
- send_m g.p1 (YourTurn t);
- g.p1.s <- Thinking (t, Unix.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 ->
+ send_m p (YourTurn t);
+ p.s <- Thinking (t, Unix.time());
g.s <- Running (TurnOf P1)
- | Initializing (TurnOf P2), _, StandBy t ->
- send_m g.p2 (YourTurn t);
- g.p2.s <- Thinking (t, Unix.time());
- g.s <- Running (TurnOf P2)
- | _ -> assert false
+ | _ -> ()
end
| Play act, Thinking (time, beg_r) ->
let end_r = Unix.time () in
- let new_s = G.turn g.g pi act in
- begin match new_s with | Eliminated _ -> raise Eliminated_ex | _ -> () end;
+ 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.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;
- true
- | Won x when x = pi ->
- send_m p YouWin;
- send_m op YouLose;
- Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name p.p.name;
+ p.p.score <- p.p.score + !pt_tie;
+ op.p.score <- op.p.score + !pt_tie;
true
| Won x ->
- send_m op YouWin;
- send_m p YouLose;
- Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name op.p.name;
+ 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 _ -> false
| Eliminated x -> assert false
@@ -298,17 +315,19 @@ module C (G: GAME) : CORE = struct
| FairEnough, Saving ->
kill p.pid 15; (* 15 : sigterm *)
p.s <- Dead
- | _ -> raise Eliminated_ex
- | exception _ -> raise Eliminated_ex
+ | 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")
with
- | Eliminated_ex ->
+ | Eliminated_ex r ->
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... *)
kill p.pid 15;
- Format.printf "%s vs. %s: %s eliminated!@." g.p1.p.name g.p2.p.name p.p.name;
+ 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.score <- p.p.score + !pt_elim;
op.s <- Saving;
g.s <- Finished (Eliminated pi)
end;
diff --git a/judge/main.ml b/judge/main.ml
new file mode 100644
index 0000000..5155e02
--- /dev/null
+++ b/judge/main.ml
@@ -0,0 +1,171 @@
+open Core
+open Graphics
+
+(* ****************** *)
+(* The user interface *)
+(* ****************** *)
+
+exception Exit_judge
+
+module UI (C : CORE) : sig
+
+ val init : unit -> unit
+ val close : unit -> unit
+ val handle_events : unit -> unit
+ val display : unit -> unit
+
+end = struct
+
+ module G = C.G
+
+ (* Graphic helpers *)
+ let grey = rgb 64 64 64
+
+ let center () = size_x () / 2, size_y () / 2
+
+ let fullscreen_msg m =
+ clear_graph();
+ let tx, ty = text_size m in
+ let cx, cy = center () in
+ let w, h = tx/2, ty/2 in
+ set_color black;
+ let cr d =
+ draw_rect (cx - w - d) (cy - h - d)
+ (cx + w + d) (cy + h + d)
+ in cr 20; cr 22;
+ moveto (cx - w) (cy - h);
+ draw_string m
+
+ let tw m = fst (text_size m)
+
+ let text_l l x c m =
+ set_color c;
+ moveto x (size_y() - ((l+1) * 20));
+ draw_string m
+
+ let text1 l c m =
+ text_l l 20 c m
+ let text2 l c m =
+ text_l l (size_x()/2 - 20 - tw m) c m
+ let text3 l c m =
+ text_l l (size_x()/2 + 20) c m
+ let text4 l c m =
+ text_l l (size_x() - 20 - tw m) c m
+
+ let hl () =
+ draw_poly_line
+ [| 10, size_y() - 50;
+ size_x() - 10, size_y() - 50 |]
+
+ (* Init/Close *)
+ let init () =
+ open_graph " 800x600";
+ fullscreen_msg "Starting up..."
+
+ let close () =
+ close_graph ()
+
+ (* View types *)
+ type view =
+ | ScoreBoard
+ | MatchList of bool
+ | ViewGame of C.game
+ | Question of string * (unit -> unit) * view
+
+ let rec handle_events () =
+ while key_pressed () do
+ match !curr_view, read_key() with
+ | ScoreBoard, '\t' -> curr_view := MatchList false
+ | MatchList _, '\t' -> curr_view := ScoreBoard
+ | MatchList e, 'f' -> curr_view := MatchList (not e)
+ | Question(_, y, n), 'y' -> y()
+ | Question(_, y, n), 'n' -> curr_view := n
+ | v, 'q' ->
+ curr_view := Question(
+ "Really quit?",
+ (fun () ->
+ fullscreen_msg "Exiting...";
+ raise Exit_judge),
+ v)
+ | _ -> ()
+ done
+
+ and display () =
+ clear_graph ();
+ match !curr_view with
+ | ScoreBoard -> scoreboard_disp ()
+ | MatchList f -> matchlist_disp f
+ | ViewGame g -> game_disp g
+ | Question (q, _, _) -> fullscreen_msg (q ^ " (y/n)")
+
+ and curr_view = ref ScoreBoard
+
+ (* Scoreboard view *)
+ and scoreboard_disp () =
+ text1 2 black "score board";
+ text4 2 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)
+ in
+ List.iteri show_sc scores
+
+ (* Match list view *)
+ and matchlist_disp show_only_running =
+ (* TODO *)
+ ()
+
+ (* Game view *)
+ and game_disp g =
+ (* TODO *)
+ ()
+
+end
+
+(* ************* *)
+(* The main loop *)
+(* ************* *)
+
+module Juge (C : CORE) : sig
+
+ val run : unit -> unit
+
+end = struct
+
+ module UI = UI(C)
+
+ let run () =
+ C.init();
+ UI.init();
+ begin try while true do
+ C.handle_events ();
+ UI.handle_events ()
+ done with
+ Exit_judge ->
+ C.finish ();
+ UI.close ()
+ end
+
+end
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 17:06:53 +0000