From e720e1dfcddd8eb38fa562cc197b39f14d2fa7a5 Mon Sep 17 00:00:00 2001 From: Alex AUVOLAT Date: Sat, 8 Nov 2014 23:09:37 +0100 Subject: Correct monstruous error. --- juge/core.ml | 209 ----------------------------------------------------------- 1 file changed, 209 deletions(-) delete mode 100644 juge/core.ml (limited to 'juge/core.ml') diff --git a/juge/core.ml b/juge/core.ml deleted file mode 100644 index e7c44e8..0000000 --- a/juge/core.ml +++ /dev/null @@ -1,209 +0,0 @@ -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 "; - 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 -- cgit v1.2.3