aboutsummaryrefslogtreecommitdiff
path: root/juge/core.ml
diff options
context:
space:
mode:
Diffstat (limited to 'juge/core.ml')
-rw-r--r--juge/core.ml209
1 files changed, 209 insertions, 0 deletions
diff --git a/juge/core.ml b/juge/core.ml
new file mode 100644
index 0000000..e7c44e8
--- /dev/null
+++ b/juge/core.ml
@@ -0,0 +1,209 @@
+open Unix
+
+open Protocol
+
+(* Description of data structures *)
+
+type player = P1 | P2
+
+type game_status =
+ | TurnOf of player
+ | Won of player
+ | 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 *)
+ | Thinking of (float * float) (* temps restant ; heure de début de réflexion *)
+ | Saving
+ | Dead
+
+module type GAME = sig
+ type game (* mutable structure *)
+
+ val name : string (* ex: Morpion récursif *)
+ val id : string (* ex: morpion_rec *)
+
+ val new_game : unit -> (game * game_status)
+
+ val turn : game -> player -> string -> game_status
+end
+
+module type CORE = sig
+ module G : GAME
+
+ type game
+ val p1 : game -> player_proc_status
+ val p2 : game -> player_proc_status
+ val s : game -> game_proc_status
+ val g : game -> G.game
+
+ val init : unit -> unit
+
+ val handle_events : unit -> unit (* is anything happening ? *)
+
+ val add_rounds : unit -> unit (* adds one game of everyone against everyone *)
+
+ val scores : unit -> (string * int) list
+ val games : unit -> game list
+
+end
+
+(* ****************************************** *)
+(* BEGIN IMPLEMENTATION *)
+(* ****************************************** *)
+
+module C (G: GAME) : CORE = struct
+ module G : GAME = G
+
+ type player = {
+ name: string;
+ binary: string;
+ mutable score: int;
+ }
+
+ type player_proc = {
+ pid: int;
+ p: player;
+ i: in_channel;
+ o: out_channel;
+ mutable s: player_proc_status;
+ }
+ let send_m pp m =
+ output_string pp.o (encode m ^ "\n");
+ flush pp.o
+
+ type game = {
+ g: G.game;
+ p1: player_proc;
+ p2: player_proc;
+ mutable s: game_proc_status;
+ }
+ let p1 g = g.p1.s
+ let p2 g = g.p2.s
+ let s g = g.s
+ let g g = g.g
+
+ let players = Hashtbl.create 12
+ let planned_games = Queue.create ()
+ let r_games = ref []
+
+ (* 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 scores () =
+ Hashtbl.fold (fun _ p l -> (p.name, p.score)::l) players []
+ let games () = !r_games
+
+ let init () =
+ (* 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."
+
+ ] in
+ Arg.parse args (fun s -> game_dir := s)
+ "Usage: juge <game_directory>";
+ if !game_dir = "" then begin
+ Format.eprintf "Error: no game directory specified.@.";
+ exit 1
+ end;
+ 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
+ in
+
+ (* 2. REDIRECT STDOUT TO LOG FILE *)
+ let log_file = Filename.concat !game_dir (date^".log") in
+ Format.printf "Juge for '%s' starting up...@." G.name;
+ Format.printf "Redirecting standard output to '%s'.@." log_file;
+ flush Pervasives.stdout;
+ begin try
+ let log_out = Unix.openfile log_file [O_APPEND; O_CREAT; O_WRONLY] 0o644 in
+ dup2 log_out Unix.stdout
+ with _ ->
+ Format.eprintf "Could not open log output file.@.";
+ exit 1
+ end;
+ Format.printf "Juge for '%s' starting up...@." G.name;
+ Format.printf "Session: %s@." date;
+
+ (* 3. LOAD PLAYER LIST *)
+ Format.printf "Loading player list...@.";
+ let fd = try opendir !game_dir with _ ->
+ Format.printf "Could not open directory %s for listing.@." !game_dir;
+ exit 1
+ in
+ let rec rd () =
+ try let s = readdir fd in
+ try
+ let b = Filename.concat (Filename.concat !game_dir s) "player" in
+ let st = Unix.stat b in
+ if (st.st_kind = S_REG || st.st_kind = S_LNK)
+ && (st.st_perm land 0o100 <> 0) then begin
+ Format.printf "- %s@." s;
+ Hashtbl.add players s
+ { name = s;
+ binary = b;
+ score = 0; }
+ end
+ with _ -> ();
+ rd()
+ with End_of_file -> ()
+ in rd ()
+
+ let add_rounds () =
+ Hashtbl.iter
+ (fun p _ -> Hashtbl.iter
+ (fun q _ -> if p <> q then Queue.push (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
+ Format.printf "Launching match: %s vs. %s@." p1 p2;
+
+ let open_c p =
+ let (j2p_i, j2p_o) = pipe () in
+ let (p2j_i, p2j_o) = pipe () in
+ let pid = fork() in
+ if pid = 0 then begin
+ dup2 j2p_i stdin;
+ dup2 p2j_o stdout;
+ execv 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
+ 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; g; s = Initializing s } in
+ r_games := g::(!r_games)
+ done;
+
+ (* 2. LOOK IF ANYBODY IS TELLING US SOMETHING - IF SO, REACT
+ (wait max. 0.01 sec) *)
+ ()
+
+end