aboutsummaryrefslogtreecommitdiff
path: root/judge/core.ml
blob: 34d5dc93cf9eac10dbdb47b1106c9a9cbc7a655f (plain) (blame)
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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
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

	exception Eliminated_ex

	type player = {
		name: string;
		binary: string;
		dir: string;
		log_out: file_descr;
		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: judge <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 dir = Filename.concat !game_dir s in
					let b = Filename.concat dir "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;
						(* open log output for player *)
						let p_log_file = Filename.concat dir "stderr.log" in
						let p_log_out = Unix.openfile p_log_file [O_APPEND; O_CREAT; O_WRONLY] 0o644 in
						let f = Format.formatter_of_out_channel (out_channel_of_descr p_log_out) in
						Format.fprintf f "---- Begin session %s@." date;
						Hashtbl.add players	s
							{ name = s;
								binary = b;
								dir;
								log_out = p_log_out;
								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 f = Format.formatter_of_out_channel (out_channel_of_descr p.log_out) in
				Format.fprintf f "--- Begin game (%s vs. %s)@." p1 p2;
				let (j2p_i, j2p_o) = pipe () in
				let (p2j_i, p2j_o) = pipe () in
				let pid = fork() in
				if pid = 0 then begin
					chdir p.dir;
					dup2 j2p_i stdin;
					dup2 p2j_o stdout;
					dup2 p.log_out stderr;
					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) *)
		let in_fd = List.fold_left
			(fun l g -> match g.s with
				| Finished _ -> l
				| _ ->
					let l = match g.p1.s with
						| Dead -> l
						| _ -> (Unix.descr_of_in_channel g.p1.i)::l
					in match g.p2.s with
						| Dead -> l
						| _ -> (Unix.descr_of_in_channel g.p2.i)::l)
			[] !r_games
		in
		let in_fd, _, _ = select in_fd [] [] 0.01 in
		let do_fd fd =
			let g = List.find
				(fun g -> fd = Unix.descr_of_in_channel g.p1.i
						|| fd = Unix.descr_of_in_channel g.p2.i)
				!r_games
			in
			let pi = if Unix.descr_of_in_channel g.p1.i = fd then P1 else P2 in
			let p = match pi with P1 -> g.p1 | P2 -> g.p2 in
			let op = match pi with P1 -> g.p2 | P2 -> g.p1 in
			begin try match decode (input_line p.i), p.s with
			| Hello x, Loading when x = G.id ->
				p.s <- StandBy !game_time;
				if op.s <> Loading then begin
					match g.s, g.p1.s, g.p2.s with
					| Initializing (TurnOf P1), StandBy t, _ ->
						send_m g.p1 (YourTurn t);
						g.p1.s <- Thinking (t, Unix.time());
						g.s <- Running (TurnOf P1)
					| Initializing (TurnOf P2), _, StandBy t ->
						send_m g.p2 (YourTurn t);
						g.p2.s <- Thinking (t, Unix.time());
						g.s <- Running (TurnOf P2)
					| _ -> assert false
				end
			| Play act, Thinking (time, beg_r) ->
				let end_r = Unix.time () in
				let new_s = G.turn g.g pi act in
				begin match new_s with | Eliminated _ -> raise Eliminated_ex | _ -> () end;
				send_m p OK;
				send_m op (Play act);
				let finished = match new_s with
				| Tie ->
					send_m p Tie;
					send_m op Tie;
					Format.printf "%s vs. %s: tie!@." g.p1.p.name g.p2.p.name;
					true
				| Won x when x = pi ->
					send_m p YouWin;
					send_m op YouLose;
					Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name p.p.name;
					true
				| Won x ->
					send_m op YouWin;
					send_m p YouLose;
					Format.printf "%s vs. %s: %s wins!@." g.p1.p.name g.p2.p.name op.p.name;
					true
				| TurnOf _ -> false
				| Eliminated x -> assert false
				in
				if finished then begin
					p.s <- Saving;
					op.s <- Saving;
					g.s <- Finished new_s
				end else begin
					p.s <- StandBy (time -. (end_r -. beg_r));
					g.s <- Running new_s;
					match op.s with
						| StandBy t ->
							send_m op (YourTurn t);
							op.s <- Thinking (t, Unix.time())
						| _ -> assert false
				end
			| FairEnough, Saving ->
				kill p.pid 15;		(* 15 : sigterm *)
				p.s <- Dead
			| _ -> raise Eliminated_ex
			| exception _ -> raise Eliminated_ex
			with
			| Eliminated_ex ->
				send_m p Eliminated;
				send_m op YouWin;
				(* since process is not respecting the protocol, we cannot assume
					it is doing anything reasonable, so we kill it... *)
				kill p.pid 15;
				Format.printf "%s vs. %s: %s eliminated!@." g.p1.p.name g.p2.p.name p.p.name;
				p.s <- Dead;
				op.s <- Saving;
				g.s <- Finished (Eliminated pi)
			end;
		in List.iter do_fd in_fd
	
end