diff options
Diffstat (limited to 'juge/core.ml')
| -rw-r--r-- | juge/core.ml | 209 |
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 |