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. --- .gitignore | 2 +- judge/_tags | 1 + judge/core.ml | 209 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ judge/protocol.ml | 41 +++++++++++ juge/_tags | 1 - juge/core.ml | 209 ------------------------------------------------------ juge/protocol.ml | 41 ----------- 7 files changed, 252 insertions(+), 252 deletions(-) create mode 100644 judge/_tags create mode 100644 judge/core.ml create mode 100644 judge/protocol.ml delete mode 100644 juge/_tags delete mode 100644 juge/core.ml delete mode 100644 juge/protocol.ml diff --git a/.gitignore b/.gitignore index 3f1e764..262dedf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,7 @@ *.swp *~ -juge/_build/* +judge/_build/* *.native *.byte diff --git a/judge/_tags b/judge/_tags new file mode 100644 index 0000000..eb13bea --- /dev/null +++ b/judge/_tags @@ -0,0 +1 @@ +true: use_unix diff --git a/judge/core.ml b/judge/core.ml new file mode 100644 index 0000000..e7c44e8 --- /dev/null +++ b/judge/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 "; + 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 diff --git a/judge/protocol.ml b/judge/protocol.ml new file mode 100644 index 0000000..3f6d548 --- /dev/null +++ b/judge/protocol.ml @@ -0,0 +1,41 @@ + +exception Invalid_message of string + +type msg = + | Hello of string (* nom du jeu *) + | YourTurn of float (* nombre secondes pour jouer *) + | Play of string (* description textuelle du coup *) + | OK (* coup accepté *) + | YouWin + | YouLose + | Tie + | Eliminated + | FairEnough + +let decode = function + | "OK" -> OK + | "You win" -> YouWin + | "You lose" -> YouLose + | "Tie" -> Tie + | "Eliminated" -> Eliminated + | "Fair enough" -> FairEnough + | s when String.sub s 0 6 = "Hello " -> + Hello (String.sub s 6 (String.length s - 6)) + | s when String.sub s 0 10 = "Your turn " -> + YourTurn (float_of_string (String.sub s 10 (String.length s - 10))) + | s when String.sub s 0 5 = "Play " -> + Play (String.sub s 5 (String.length s - 5)) + | s -> raise (Invalid_message s) + +let encode = function + | Hello x -> "Hello " ^ x + | YourTurn n -> "Your turn " ^ (string_of_float n) + | Play x -> "Play " ^ x + | OK -> "OK" + | YouWin -> "You win" + | YouLose -> "You lose" + | Tie -> "Tie" + | Eliminated -> "Eliminated" + | FairEnough -> "Fair enough" + + diff --git a/juge/_tags b/juge/_tags deleted file mode 100644 index eb13bea..0000000 --- a/juge/_tags +++ /dev/null @@ -1 +0,0 @@ -true: use_unix 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 diff --git a/juge/protocol.ml b/juge/protocol.ml deleted file mode 100644 index 3f6d548..0000000 --- a/juge/protocol.ml +++ /dev/null @@ -1,41 +0,0 @@ - -exception Invalid_message of string - -type msg = - | Hello of string (* nom du jeu *) - | YourTurn of float (* nombre secondes pour jouer *) - | Play of string (* description textuelle du coup *) - | OK (* coup accepté *) - | YouWin - | YouLose - | Tie - | Eliminated - | FairEnough - -let decode = function - | "OK" -> OK - | "You win" -> YouWin - | "You lose" -> YouLose - | "Tie" -> Tie - | "Eliminated" -> Eliminated - | "Fair enough" -> FairEnough - | s when String.sub s 0 6 = "Hello " -> - Hello (String.sub s 6 (String.length s - 6)) - | s when String.sub s 0 10 = "Your turn " -> - YourTurn (float_of_string (String.sub s 10 (String.length s - 10))) - | s when String.sub s 0 5 = "Play " -> - Play (String.sub s 5 (String.length s - 5)) - | s -> raise (Invalid_message s) - -let encode = function - | Hello x -> "Hello " ^ x - | YourTurn n -> "Your turn " ^ (string_of_float n) - | Play x -> "Play " ^ x - | OK -> "OK" - | YouWin -> "You win" - | YouLose -> "You lose" - | Tie -> "Tie" - | Eliminated -> "Eliminated" - | FairEnough -> "Fair enough" - - -- cgit v1.2.3