[Toss-devel-svn] SF.net SVN: toss:[1260] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1260] trunk/Toss
|
From: <luk...@us...> - 2010-12-19 14:31:22
|
Revision: 1260
http://toss.svn.sourceforge.net/toss/?rev=1260&view=rev
Author: lukstafi
Date: 2010-12-19 14:31:15 +0000 (Sun, 19 Dec 2010)
Log Message:
-----------
GDL parsing: initial commit, in progress.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Play/GDL.ml
trunk/Toss/Play/GDL.mli
trunk/Toss/Play/GameTest.ml
trunk/Toss/Play/Server.ml
Added Paths:
-----------
trunk/Toss/Play/ServerGDLTest.in
trunk/Toss/Play/ServerGDLTest.out
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2010-12-19 12:26:22 UTC (rev 1259)
+++ trunk/Toss/Formula/Aux.ml 2010-12-19 14:31:15 UTC (rev 1260)
@@ -397,3 +397,17 @@
while true do Buffer.add_channel buf file 1 done
with End_of_file -> ());
Buffer.contents buf
+
+let rec input_http_message file =
+ let buf = Buffer.create 256 in
+ let line = ref "POST / HTTP" in
+ let msg_len = ref 0 in
+ while !line <> "" && !line <> "\r" do
+ line := input_line file;
+ let line_len = String.length !line in
+ if line_len > 16 && String.sub !line 0 15 = "Content-length:" then
+ msg_len := int_of_string
+ (String.sub !line 16 (line_len - 16));
+ done;
+ Buffer.add_channel buf file !msg_len;
+ Buffer.contents buf
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2010-12-19 12:26:22 UTC (rev 1259)
+++ trunk/Toss/Formula/Aux.mli 2010-12-19 14:31:15 UTC (rev 1260)
@@ -185,3 +185,7 @@
(** Input a file to a string. *)
val input_file : in_channel -> string
+
+(** Skip the header extracting the [Content-length] field and input the
+ content of an HTTP message. *)
+val input_http_message : in_channel -> string
Modified: trunk/Toss/Play/GDL.ml
===================================================================
--- trunk/Toss/Play/GDL.ml 2010-12-19 12:26:22 UTC (rev 1259)
+++ trunk/Toss/Play/GDL.ml 2010-12-19 14:31:15 UTC (rev 1260)
@@ -41,3 +41,19 @@
(* game ends here: match id, actions on previous step *)
let compile_game_descr entries = entries
+
+let client_player = ref (Const "uninitialized")
+let game_description = ref []
+
+let initialize_game player game_descr startcl =
+ client_player := player;
+ game_description := game_descr;
+ let effort, horizon, heur_adv_ratio =
+ 2, 100, 4.0 in
+ effort, horizon, heur_adv_ratio
+
+let translate_last_action actions =
+ "1", ["1","1"]
+
+let translate_move move new_state =
+ "NOOP"
Modified: trunk/Toss/Play/GDL.mli
===================================================================
--- trunk/Toss/Play/GDL.mli 2010-12-19 12:26:22 UTC (rev 1259)
+++ trunk/Toss/Play/GDL.mli 2010-12-19 14:31:15 UTC (rev 1260)
@@ -39,3 +39,13 @@
val compile_game_descr :
game_descr_entry list -> game_description
+
+val initialize_game :
+ term -> game_description -> int -> int * int * float
+
+val translate_last_action :
+ term list -> string * (string * string) list
+
+(* FIXME: remove dependency on Game? *)
+val translate_move :
+ Game.move -> Game.play_state -> string
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2010-12-19 12:26:22 UTC (rev 1259)
+++ trunk/Toss/Play/GameTest.ml 2010-12-19 14:31:15 UTC (rev 1260)
@@ -561,6 +561,22 @@
Sys.remove "./Play/ServerTest.temp";
assert_equal ~printer:(fun x->x) target result
);
+
+ "server: ServerGDLTest.in GDL Tic-Tac-Toe" >::
+ (fun () ->
+ let in_ch = open_in "./Play/ServerGDLTest.in" in
+ let out_ch = open_out "./Play/ServerGDLTest.temp" in
+ (try while true do
+ Server.req_handle in_ch out_ch done
+ with End_of_file -> ());
+ close_in in_ch; close_out out_ch;
+ let result =
+ Aux.input_file (open_in "./Play/ServerGDLTest.temp") in
+ let target =
+ Aux.input_file (open_in "./Play/ServerGDLTest.out") in
+ Sys.remove "./Play/ServerTest.temp";
+ assert_equal ~printer:(fun x->x) target result
+ );
"play: breakthrough suggest in game" >::
(fun () ->
Modified: trunk/Toss/Play/Server.ml
===================================================================
--- trunk/Toss/Play/Server.ml 2010-12-19 12:26:22 UTC (rev 1259)
+++ trunk/Toss/Play/Server.ml 2010-12-19 14:31:15 UTC (rev 1260)
@@ -19,9 +19,9 @@
let play_state = ref (None : Game.play_state option)
(* Timeout. *)
-let dtimeout = ref (-1);
+let dtimeout = ref (-1)
+let playclock = ref 0
-
(* -------------------- GENERAL SERVER AND REQUEST HANDLER ------------------ *)
exception Host_not_found
@@ -53,23 +53,21 @@
done
let req_of_str s =
- let http_beg = "POST / HTTP/" in
- let http_beg_l = String.length http_beg in
let s_len = String.length s in
- if s_len > http_beg_l && String.sub s 0 http_beg_l = http_beg
+ if s_len > 4 && String.sub s 0 4 = "GDL "
then
- if Str.string_match (Str.regexp "\r?\n\r?\n") s 0
- then
- let m_beg = Str.match_end () in
- Aux.Right (GDLParser.parse_request KIFLexer.lex
- (Lexing.from_string (String.sub s m_beg (s_len-m_beg))))
- else
- raise (Lexer.Parsing_error "Empty HTTP message")
+ Aux.Right (GDLParser.parse_request KIFLexer.lex
+ (Lexing.from_string (String.sub s 4 (s_len-4))))
else
Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))
let rec read_in_line in_ch =
- let line_in = input_line in_ch in
+ let line_in =
+ let rec nonempty () =
+ let line_in = input_line in_ch in
+ if line_in = "" || line_in = "\r" then nonempty ()
+ else line_in in
+ nonempty () in
let line_in_len = String.length line_in in
(* TODO: who needs escaping? *)
let line_in =
@@ -77,12 +75,19 @@
(* String.escaped *) line_in
else
(* String.escaped *) (String.sub line_in 0 (line_in_len-1)) in
- (* We put endlines, encoded by '$', back into the message. *)
- let line =
- String.concat "\n"
- (Str.split (Str.regexp "\\$") line_in) in
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
- line
+ let http_beg = "POST / HTTP/" in
+ let http_beg_l = String.length http_beg in
+ if line_in_len > http_beg_l && String.sub line_in 0 http_beg_l = http_beg
+ then
+ "GDL " ^ Aux.input_http_message in_ch
+ else
+ (* We put endlines, encoded by '$', back into the message.
+ TODO: perhaps a "better" solution now that HTTP has one? *)
+ let line =
+ String.concat "\n"
+ (Str.split (Str.regexp "\\$") line_in) in
+ if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
+ line
let possibly_modifies_game = function
Arena.AddElem _ -> true
@@ -142,8 +147,8 @@
let resp =
match req with
| Aux.Left (Arena.SuggestLocMoves
- (loc, timer, effort, how, horizon, heuristic,
- heur_adv_ratio)) -> (
+ (loc, timer, effort, how, horizon, heuristic,
+ heur_adv_ratio)) -> (
Random.self_init ();
(* TODO: should be in idle time, not now *)
Gc.full_major ();
@@ -173,13 +178,14 @@
Game.move_gs_str !state move
| None -> "None"
)
+
| Aux.Left (Arena.ApplyRule (r_name, mtch, t, p) as req) -> (
if !game_modified then
let (new_state, resp) = Arena.handle_request !state req in
state := new_state; resp
else
- (* trying to restore [Server.play_state] so as to avoid
- reinitialization *)
+ (* trying to restore [Server.play_state] so as to avoid
+ reinitialization *)
let {Arena.rules=rules; graph=graph} = !state.Arena.game in
let struc = !state.Arena.struc in
let fn s n = Structure.find_elem s n in
@@ -193,17 +199,17 @@
!state.Arena.struc graph.(!state.Arena.cur_loc) in
try
for i = 0 to Array.length moves - 1 do
- (* FIXME: handle time and params! *)
+ (* FIXME: handle time and params! *)
let mov = moves.(i) in
if
r_name = mov.Game.rule &&
- (* t = mov.Game.time && *)
- (* something wrong with this:
- List.for_all (fun (pn, pv) ->
- pv = List.assoc pn mov.Game.parameters) p && *)
+ (* t = mov.Game.time && *)
+ (* something wrong with this:
+ List.for_all (fun (pn, pv) ->
+ pv = List.assoc pn mov.Game.parameters) p && *)
List.for_all (fun (e, f) ->
f = List.assoc e mov.Game.embedding) m
- (* TODO: handle location matching *)
+ (* TODO: handle location matching *)
then (
expected_location := mov.Game.next_loc;
let _ = if !debug_level > 2 then
@@ -211,8 +217,8 @@
!expected_location in
raise (Found i))
done;
- (* TODO: if not due to only time or params mismatch,
- block or warn about invalid rule application *)
+ (* TODO: if not due to only time or params mismatch,
+ block or warn about invalid rule application *)
let (new_state, resp) =
Arena.handle_request !state req in
if !debug_level > 0 then
@@ -230,7 +236,7 @@
loc = !state.Arena.cur_loc} pos memory
| _ -> failwith "req_handle: impossible" in
state := new_state;
- (* Rewriting doesn't handle location update. *)
+ (* Rewriting doesn't handle location update. *)
let new_game_state = {
Game.struc = new_state.Arena.struc;
loc = moves.(pos).Game.next_loc;
@@ -242,13 +248,179 @@
};
resp
)
+
| Aux.Left req ->
game_modified := !game_modified ||
possibly_modifies_game req;
let (new_state, resp) = Arena.handle_request !state req in
state := new_state; resp
- | Aux.Right req ->
- failwith "GDL request parsed but handler not implemented yet"
+
+ | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) ->
+ (* GDL will store the player and the game in its state. *)
+ let effort, horizon, heur_adv_ratio =
+ GDL.initialize_game player game_descr startcl in
+ (* TODO: handle timer (startclock) in Game.initialize_default*)
+ let p, ps = Game.initialize_default
+ !state ~effort ~search_method:"alpha_beta_ord"
+ ~horizon ~heur_adv_ratio () in
+ game_modified := false;
+ play := Some p; play_state := Some ps;
+ playclock := playcl;
+ "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 5"
+ ^ "\r\n\r\nREADY"
+
+
+ | Aux.Right (GDL.Play (_, actions)) ->
+ let time_started = int_of_float (Sys.time ()) in
+ let r_name, mtch =
+ GDL.translate_last_action actions in
+
+ let {Arena.rules=rules; graph=graph} = !state.Arena.game in
+ let struc = !state.Arena.struc in
+ let fn s n = Structure.find_elem s n in
+ let r = List.assoc r_name rules in
+ let lhs =
+ r.ContinuousRule.discrete.DiscreteRule.lhs_struc in
+ let m =
+ List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in
+ let moves =
+ Game.gen_moves Game.cGRID_SIZE rules
+ !state.Arena.struc graph.(!state.Arena.cur_loc) in
+ let pos =
+ (try
+ for i = 0 to Array.length moves - 1 do
+ (* FIXME: handle time and params! *)
+ let mov = moves.(i) in
+ if
+ r_name = mov.Game.rule &&
+ (* t = mov.Game.time && *)
+ (* something wrong with this:
+ List.for_all (fun (pn, pv) ->
+ pv = List.assoc pn mov.Game.parameters) p && *)
+ List.for_all (fun (e, f) ->
+ f = List.assoc e mov.Game.embedding) m
+ (* TODO: handle location matching *)
+ then (
+ expected_location := mov.Game.next_loc;
+ let _ = if !debug_level > 2 then
+ Printf.printf "expected_location = %d\n%!"
+ !expected_location in
+ raise (Found i))
+ done;
+ (* TODO: if not due to only time or params mismatch,
+ block or warn about invalid rule application *)
+ failwith
+ "Server GDL Play request: action mismatched with play state"
+ with Found pos -> pos) in
+ let old_struc = !state.Arena.struc in
+ let req = Arena.ApplyRule (r_name, mtch, 0.1, []) in
+ let (new_state, resp) = Arena.handle_request !state req in
+ let memory = match !play, !play_state with
+ | Some play, Some {Game.memory=memory; game_state=pstate} ->
+ Game.update_memory
+ ~num_players:play.Game.game.Arena.num_players
+ {Game.struc=old_struc;
+ time = !state.Arena.time;
+ loc = !state.Arena.cur_loc} pos memory
+ | _ -> failwith "req_handle: impossible" in
+ state := new_state;
+ (* Rewriting doesn't handle location update. *)
+ let new_game_state = {
+ Game.struc = new_state.Arena.struc;
+ loc = moves.(pos).Game.next_loc;
+ time = new_state.Arena.time;
+ } in
+ play_state := Some {
+ Game.game_state = new_game_state;
+ memory = memory;
+ };
+
+ let time_used =
+ time_started - (int_of_float (ceil (Sys.time ()))) in
+ let p, ps =
+ match !play, !play_state with
+ | Some play, Some play_state ->
+ play, play_state
+ | _ -> assert false in
+ ignore (Unix.alarm (!playclock - time_used));
+ let res = Game.suggest p ps in
+ Game.cancel_timeout ();
+ let mov_msg =
+ match res with
+ | Some (move, new_state) ->
+ play_state := Some new_state;
+ GDL.translate_move move new_state
+ | None -> "NOOP" in
+ let msg_len = String.length mov_msg in
+ "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: "
+ ^ string_of_int msg_len ^ "\r\n\r\n" ^ mov_msg
+
+ | Aux.Right (GDL.Stop (_, actions)) ->
+ let r_name, mtch =
+ GDL.translate_last_action actions in
+
+ let {Arena.rules=rules; graph=graph} = !state.Arena.game in
+ let struc = !state.Arena.struc in
+ let fn s n = Structure.find_elem s n in
+ let r = List.assoc r_name rules in
+ let lhs =
+ r.ContinuousRule.discrete.DiscreteRule.lhs_struc in
+ let m =
+ List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in
+ let moves =
+ Game.gen_moves Game.cGRID_SIZE rules
+ !state.Arena.struc graph.(!state.Arena.cur_loc) in
+ let pos =
+ (try
+ for i = 0 to Array.length moves - 1 do
+ (* FIXME: handle time and params! *)
+ let mov = moves.(i) in
+ if
+ r_name = mov.Game.rule &&
+ (* t = mov.Game.time && *)
+ (* something wrong with this:
+ List.for_all (fun (pn, pv) ->
+ pv = List.assoc pn mov.Game.parameters) p && *)
+ List.for_all (fun (e, f) ->
+ f = List.assoc e mov.Game.embedding) m
+ (* TODO: handle location matching *)
+ then (
+ expected_location := mov.Game.next_loc;
+ let _ = if !debug_level > 2 then
+ Printf.printf "expected_location = %d\n%!"
+ !expected_location in
+ raise (Found i))
+ done;
+ (* TODO: if not due to only time or params mismatch,
+ block or warn about invalid rule application *)
+ failwith
+ "Server GDL Play request: action mismatched with play state"
+ with Found pos -> pos) in
+ let old_struc = !state.Arena.struc in
+ let req = Arena.ApplyRule (r_name, mtch, 0.1, []) in
+ let (new_state, resp) = Arena.handle_request !state req in
+ let memory = match !play, !play_state with
+ | Some play, Some {Game.memory=memory; game_state=pstate} ->
+ Game.update_memory
+ ~num_players:play.Game.game.Arena.num_players
+ {Game.struc=old_struc;
+ time = !state.Arena.time;
+ loc = !state.Arena.cur_loc} pos memory
+ | _ -> failwith "req_handle: impossible" in
+ state := new_state;
+ (* Rewriting doesn't handle location update. *)
+ let new_game_state = {
+ Game.struc = new_state.Arena.struc;
+ loc = moves.(pos).Game.next_loc;
+ time = new_state.Arena.time;
+ } in
+ play_state := Some {
+ Game.game_state = new_game_state;
+ memory = memory;
+ };
+ "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 4"
+ ^ "\r\n\r\nDONE"
+
in
if !debug_level > 0 then print_endline ("Repl: " ^ resp ^ "\n");
output_string out_ch (resp ^ "\n");
Added: trunk/Toss/Play/ServerGDLTest.in
===================================================================
--- trunk/Toss/Play/ServerGDLTest.in (rev 0)
+++ trunk/Toss/Play/ServerGDLTest.in 2010-12-19 14:31:15 UTC (rev 1260)
@@ -0,0 +1,62 @@
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 1587
+
+(START MATCH.3316980891 X (ROLE X) (ROLE O) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL X)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL X)) (TRUE (CONTROL O))) (<= (NEXT (CONTROL O)) (TRUE (CONTROL X))) (<= (ROW ?X ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE X)) (NOT (LINE O)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= (GOAL ?PLAYER 0) (NOT (LINE X)) (NOT (LINE O)) OPEN) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN)) 30 30)
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 27
+
+(PLAY MATCH.3316980891 NIL)
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 ((MARK 3 3) NOOP))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 (NOOP (MARK 1 3)))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 ((MARK 2 2) NOOP))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 (NOOP (MARK 1 2)))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(STOP MATCH.3316980891 ((MARK 1 1) NOOP))
Added: trunk/Toss/Play/ServerGDLTest.out
===================================================================
--- trunk/Toss/Play/ServerGDLTest.out (rev 0)
+++ trunk/Toss/Play/ServerGDLTest.out 2010-12-19 14:31:15 UTC (rev 1260)
@@ -0,0 +1,36 @@
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 5
+
+READY
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 10
+
+(MARK 3 3)
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 4
+
+NOOP
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 10
+
+(MARK 2 2)
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 4
+
+NOOP
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 10
+
+(MARK 1 1)
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 4
+
+DONE
+ERR processing completed -- EOF
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
