1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
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
|
