[Toss-devel-svn] SF.net SVN: toss:[1471] trunk/Toss

[<luk...@us...>]

Revision: 1471
          http://toss.svn.sourceforge.net/toss/?rev=1471&view=rev
Author:   lukaszkaiser
Date:     2011-06-05 23:34:06 +0000 (Sun, 05 Jun 2011)

Log Message:
-----------
Pre-caching game states, speedup in web client.

Modified Paths:
--------------
    trunk/Toss/Arena/Arena.ml
    trunk/Toss/Arena/Arena.mli
    trunk/Toss/Arena/ArenaParser.mly
    trunk/Toss/Formula/FormulaOps.ml
    trunk/Toss/Server/ReqHandler.ml
    trunk/Toss/Server/ReqHandler.mli
    trunk/Toss/Server/Server.ml

Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Arena/Arena.ml	2011-06-05 23:34:06 UTC (rev 1471)
@@ -585,8 +585,9 @@
   | SetTime of float * float                       (* Set time step and time *)
   | GetTime                                        (* Get time step and time *)
   | SetState of game * game_state                  (* Set the full state *)
+  | GetState                                       (* Return the state *)
+  | SetModel of Structure.structure                (* Set the model *) 
   | GetModel                                       (* Return the current model*)
-  | GetState                                       (* Return the state *)
 
 
 (* --------------------------- REQUEST HANDLER ------------------------------ *)
@@ -996,8 +997,9 @@
       ((state_game, state), string_of_float (ts) ^ " / " ^ string_of_float (t))
     | SetState (g, s) -> 
       ((g, s), "STATE SET")
+    | GetState -> ((state_game, state), state_str (state_game, state))
+    | SetModel m -> ((state_game, { state with struc = m }), "MODEL SET")
     | GetModel -> ((state_game, state), Structure.sprint state.struc)
-    | GetState -> ((state_game, state), state_str (state_game, state))
 
 
 let can_modify_game = function

Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Arena/Arena.mli	2011-06-05 23:34:06 UTC (rev 1471)
@@ -211,9 +211,11 @@
   | SetTime of float * float                       (** Set time step and time *)
   | GetTime                                        (** Get time step and time *)
   | SetState of game * game_state                  (** Set the full state *)
-  | GetModel                                       (** Return the model *)
   | GetState                                       (** Return the state *)
+  | SetModel of Structure.structure                (** Set the model *) 
+  | GetModel                                       (** Return the model *) 
 
+
 val handle_request : 
   game * game_state -> request -> (game * game_state) * string
 

Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Arena/ArenaParser.mly	2011-06-05 23:34:06 UTC (rev 1471)
@@ -143,6 +143,10 @@
   | SET_CMD STATE_SPEC gs=game_state     { let (g, s) = gs in SetState (g, s) }
   | GET_CMD STATE_SPEC                   { GetState }
   | GET_CMD MODEL_SPEC                   { GetModel }
+  | SET_CMD MODEL_SPEC struct_expr       { SetModel $3 }
+  | SET_CMD MODEL_SPEC model = struct_expr WITH 
+    defs = separated_list (SEMICOLON, rel_def_simple)
+    { SetModel (Arena.add_def_rels model defs) }
   | ADD_CMD ELEM_MOD struct_location
       { AddElem ($3) }
   | ADD_CMD REL_MOD

Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Formula/FormulaOps.ml	2011-06-05 23:34:06 UTC (rev 1471)
@@ -531,15 +531,15 @@
 (* --------------------------- TRANSITIVE CLOSURE --------------------------- *)
 
 (* We construct the lfp transitive closure of phi(x, y, z) over x, y as
-  "lfp T(y) = (y = x or ex n (n in T and phi (n, y, z)))" *)
+  "x = y or lfp T(y) = (phi(x, y, z) or ex n (n in T and phi (n, y, z)))" *)
 let make_lfp_tc x y phi =
   let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in
   let (_, nn) = subst_name_avoiding fv (fo_var_of_string "n") in
   let nnv = fo_var_of_string nn in
   let frT = mso_var_of_string(snd(subst_name_avoiding fv(var_of_string "T"))) in
   let nphi = subst_vars [(x, nn)] phi in
-  let fpphi = Or [Eq (xv, yv); Ex([(nnv :> var)], And [In (nnv, frT); nphi])] in
-  Lfp ((frT :> [ mso_var | so_var ]), [|yv|], fpphi)
+  let fpphi = Or [phi; Ex([(nnv :> var)], And [In (nnv, frT); nphi])] in
+  Or [Eq (xv, yv); Lfp ((frT :> [ mso_var | so_var ]), [|yv|], fpphi)]
 
 (* We construct the mso transitive closure of phi(x, y, z) over x, y as
   "all X (x in X and (all x',y' 

Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Server/ReqHandler.ml	2011-06-05 23:34:06 UTC (rev 1471)
@@ -196,8 +196,21 @@
 
 let client_get_model () = client_msg "GET MODEL"
 
-let client_set_state state_s = ignore (client_msg ("SET STATE " ^ state_s))
+let client_set_model model_s = ignore (client_msg ("SET MODEL " ^ model_s))
 
+let client_game_states = Hashtbl.create 7
+
+let client_set_game game =
+  let client_set_state state_s = ignore (client_msg ("SET STATE "^ state_s)) in
+  let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
+  try
+    let game_cl = Hashtbl.find client_game_states game in
+    client := game_cl
+  with Not_found ->
+    let toss = (List.hd (dbtable ("game='" ^ game ^ "'") "games")).(1) in
+    ignore (client_set_state ("#db#" ^ toss));
+    Hashtbl.add client_game_states game !client
+
 let client_get_cur_loc () = 
   strip_ws (split "/" (client_msg "GET LOC")).(0)
 
@@ -244,8 +257,6 @@
   let add_shift_s sh s = add_shift sh (Array.map strip_ws (split "," s)) in
   List.fold_left add_shift_s [] (List.map strip_ws (split_list ";" m))
 
-let client_open_from_str s = client_set_state ("#db#" ^ s)
-
 let client_move_str (pl, m, r, e) = 
   let mstr m = String.concat ", " (List.map (fun (a, b) -> a ^ ": " ^ b) m) in
   pl ^ ",({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
@@ -415,6 +426,8 @@
 	"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
 
 let handle_http_post cmd head msg ck =
+  let http_start_time = Unix.gettimeofday () in
+  let http_time () = Unix.gettimeofday() -. http_start_time in
   let (tID, dbFILE) = (!DB.tID, !DB.dbFILE) in
   let get_args s = Array.map (strip_all ["'"]) (split ", " s) in
   let dbtable select tbl = DB.get_table dbFILE ~select tbl in
@@ -463,8 +476,7 @@
     if !debug_level > 1 then print_endline "Glob lock release";
     ignore (DB.update_table dbFILE ~select "locked='false'" "lock") in
   let new_play game pl1 pl2 =
-    let toss = (List.hd (dbtable ("game='" ^ game ^ "'") "games")).(1) in
-    client_open_from_str toss;
+    client_set_game (game);
     let info = client_get_game_info () in
     let model = client_get_model () in
     let loc = client_get_cur_loc () in
@@ -481,8 +493,8 @@
     let (g, p1, p2, m, old_toss, old_loc, old_info, old_svg) = 
       (old_res.(1), old_res.(2), old_res.(3), old_res.(4),
        old_res.(5), old_res.(6), old_res.(7), old_res.(8)) in
-    let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
-    client_open_from_str (game_toss ^ "\nMODEL " ^ old_toss);
+    client_set_game (g);
+    client_set_model (old_toss);
     client_set_cur_loc old_loc;
     let (move1a, move2, move3) = move_tup in
     let move1 = strip_all ["{"; "}"] move1a in
@@ -503,9 +515,10 @@
   let suggest player time pid =
     let res = List.hd (dbtable (game_select_s pid) "cur_states") in
     let (g, m, toss, loc) = (res.(1),int_of_string res.(4), res.(5), res.(6)) in
-    let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
-    client_open_from_str (game_toss ^ "\nMODEL " ^ toss);
+    client_set_game (g);
+    client_set_model (toss);
     client_set_cur_loc loc;
+    if !debug_level>1 then Printf.printf "Suggest setup: %fs\n%!" (http_time());
     let adv_ratio_data = client_get_data "adv_ratio" in
     let adv_ratio = if adv_ratio_data = "none" then "4" else adv_ratio_data in
     client_suggest player time adv_ratio in

Modified: trunk/Toss/Server/ReqHandler.mli
===================================================================
--- trunk/Toss/Server/ReqHandler.mli	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Server/ReqHandler.mli	2011-06-05 23:34:06 UTC (rev 1471)
@@ -25,3 +25,7 @@
 
 val full_req_handle : req_state -> in_channel -> out_channel ->
   req_state * bool
+
+
+(* Client db game setting - public only for caching reasons. *)
+val client_set_game : string -> unit

Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml	2011-06-05 21:15:35 UTC (rev 1470)
+++ trunk/Toss/Server/Server.ml	2011-06-05 23:34:06 UTC (rev 1471)
@@ -141,6 +141,7 @@
       (Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))) in
     new_st in
   print_endline ("Precaching " ^ g);
+  ReqHandler.client_set_game g;
   let toss = DB.get_table !DB.dbFILE ~select:("game='" ^ g ^ "'") "games" in
   let init_g = handle (ReqHandler.init_state) 
     ("SET STATE #db#" ^ (List.hd toss).(1)) in
@@ -152,7 +153,7 @@
 let main () =
   Aux.set_optimized_gc ();
   let (server, port, gmdir) = (ref "localhost", ref 8110, ref "") in
-  let (test_s, test_full, precache) = (ref "# # / $", ref false, ref false) in
+  let (test_s, test_full, precache) = (ref "# # / $", ref false, ref true) in
   let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
   let set_parallel_port p = 
     let (_, s) = !GameTree.parallel_toss in
@@ -190,7 +191,7 @@
     ("-test", Arg.String (fun s -> test_s := s), "unit tests for given path");
     ("-fulltest", Arg.String (fun s -> test_s := s; test_full := true),
      "full unit tests for given path, might take longer");
-    ("-precache", Arg.Unit (fun () -> precache := true), "do game pre-caching");
+    ("-nocache", Arg.Unit (fun () -> precache := false), "do no pre-caching");
     ("-experiment", 
      Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i);
 		Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)],
@@ -200,10 +201,6 @@
      "Use a parallel running Toss client (port [p] server [s]) for computation")
   ] in  
   Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
-  if !precache then (
-    List.iter precache_game !DB.tGAMES;
-    print_endline "- precaching finished";
-  );
   if !test_s <> "# # / $" then (
     let (name, full) = (!test_s, !test_full) in
     let len = String.length name in
@@ -224,10 +221,16 @@
     run_test !e_len !e_d1 !e_d2
   ) else if !gmdir <> "" then (
     DB.renew_db ~games_dir:!gmdir
-  ) else try
-	   start_server req_handle !port !server
+  ) else (
+    if !precache then (
+      List.iter precache_game !DB.tGAMES;
+      print_endline "- precaching finished";
+    );
+    try
+      start_server req_handle !port !server
     with Aux.Host_not_found ->
       print_endline "The host you specified was not found."
+  )
 
 let _ =
   (* Test against being called from a test... *)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.