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

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

Revision: 1448
          http://toss.svn.sourceforge.net/toss/?rev=1448&view=rev
Author:   lukaszkaiser
Date:     2011-05-19 23:54:24 +0000 (Thu, 19 May 2011)

Log Message:
-----------
Basic concurrency support (run -redodb examples to get concurrent tic-tac-toe).

Modified Paths:
--------------
    trunk/Toss/Arena/Arena.ml
    trunk/Toss/Play/GameTree.ml
    trunk/Toss/Play/Move.ml
    trunk/Toss/Play/Move.mli
    trunk/Toss/Server/DB.ml
    trunk/Toss/Server/ReqHandler.ml
    trunk/Toss/WebClient/Connect.js
    trunk/Toss/WebClient/Login.js
    trunk/Toss/WebClient/Main.js
    trunk/Toss/WebClient/index.html

Added Paths:
-----------
    trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss

Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Arena/Arena.ml	2011-05-19 23:54:24 UTC (rev 1448)
@@ -293,7 +293,8 @@
   (rr) ^ ", " ^ fpstr ("t", t_interval) ^ par_str
 
 (* Print a move as string. *)
-let move_str (lb, i) = "["^ (label_str lb) ^" -> "^ (string_of_int i) ^"]"
+let move_str (lb, i) = Printf.sprintf "[%s -> %i]" (label_str lb) i
+let pmv_str (pl, lb, i) = Printf.sprintf "[%s,%s -> %i]" pl (label_str lb) i
 
 let fprint_loc_body_in struc pnames f player {payoff = in_p; moves = in_m} =
   Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
@@ -815,13 +816,15 @@
         state_game.graph.(i) <- { state_game.graph.(i) with moves = moves };
         ((state_game, state), "LOC MOVES SET")
       ) *)
-    | GetLocMoves (i) -> (* TODO! adapt for concurrency! *)
+    | GetLocMoves (i) ->
       if i < 0 || i > Array.length state_game.graph then
         ((state_game, state), "ERR location "^string_of_int i^" not found")
       else 
-	let all_moves = List.concat (Array.to_list (Array.map (
-	  fun loc -> loc.moves) state_game.graph.(i))) in
-	((state_game,state), (String.concat "; " (List.map move_str all_moves)))
+	let pl i = Aux.rev_assoc state_game.player_names i in
+	let all_moves = List.concat (Array.to_list (
+	  Array.mapi (fun i ploc -> List.map (fun (l, e) -> (pl i, l, e))
+	    ploc.moves) state_game.graph.(i))) in
+	((state_game,state), (String.concat "; " (List.map pmv_str all_moves)))
     | SuggestLocMoves _ ->
       failwith "handle_req: SuggestLocMoves handled in Server"
     | EvalFormula (phi) -> ((state_game, state), "ERR eval not yet implemented")

Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Play/GameTree.ml	2011-05-19 23:54:24 UTC (rev 1448)
@@ -101,7 +101,7 @@
 	  let l_pl = moving_player game.Arena.graph.(leaf_s.Arena.cur_loc) in
 	  let l_info = info_leaf (depth+1) game leaf_s l_pl player in
 	  Leaf (leaf_s, l_pl, l_info) in
-	let children = parallel_map (fun (m,s) -> (m, leaf_of_move s)) moves in
+	let children = parallel_map (fun (_,m,s)-> (m, leaf_of_move s)) moves in
 	Solver.M.clear_timeout ();
 	Node (state, player,info_node depth game state player children,children)
     | Node (state, player, info, children) ->
@@ -241,7 +241,8 @@
 (* Choose one of the maximizing moves (at random) given a game tree. *)
 let choose_moves game = function
   | Terminal _ -> raise Not_found
-  | Leaf (state, _, _) -> Array.to_list (Move.list_moves game state)
+  | Leaf (state, _, _) -> 
+    List.map (fun (_,a,b) -> (a,b)) (Array.to_list (Move.list_moves game state))
   | Node (_, p, info, succ) ->
     let cmp (_, c1) (_, c2) = 
       let nval child = (node_values child).(p) in

Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Play/Move.ml	2011-05-19 23:54:24 UTC (rev 1448)
@@ -115,11 +115,13 @@
   Array.of_list moves, Array.of_list models
 
 let list_moves game s =
-  let select_moving a =(*temporary function - accept just one player w/ moves*)
-    let locs = Aux.array_find_all (fun l -> l.Arena.moves <> []) a in
-    if List.length locs <> 1 then failwith "too many moves in loc for now" else
-      if locs = [] then a.(0) else List.hd locs in
-  let loc = select_moving (game.Arena.graph.(s.Arena.cur_loc)) in
-  let m = gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc in
-  Array.of_list (gen_models_list game.Arena.rules s.Arena.struc s.Arena.time m)
-  
+  let select_moving a =
+    let pls = Aux.array_argfind_all (fun l -> l.Arena.moves <> []) a in
+    if pls = [] then [0] else pls in
+  let loc = game.Arena.graph.(s.Arena.cur_loc) in
+  let moving = select_moving loc in
+  let get_moves pl =
+    let m = gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc.(pl) in
+    (gen_models_list game.Arena.rules s.Arena.struc s.Arena.time m) in
+  Array.of_list (List.concat (
+    List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))

Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Play/Move.mli	2011-05-19 23:54:24 UTC (rev 1448)
@@ -34,4 +34,4 @@
   float -> move array -> move array * Arena.game_state array
 
 val list_moves : Arena.game -> Arena.game_state -> 
-  (move * Arena.game_state) array
+  (int * move * Arena.game_state) array

Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Server/DB.ml	2011-05-19 23:54:24 UTC (rev 1448)
@@ -10,7 +10,8 @@
 let dbFILE = ref ((Unix.getenv "HOME") ^ "/.tossdb.sqlite")
   
 let tGAMES = ref ["Breakthrough"; "Checkers"; "Chess"; "Connect4";
-		  "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe"]
+		  "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe";
+		  "Concurrent-Tic-Tac-Toe"]
 
 let def_gdir = if Sys.file_exists "/usr/share/toss" then
     "/usr/share/toss/games" else "./examples"

Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Server/ReqHandler.ml	2011-05-19 23:54:24 UTC (rev 1448)
@@ -215,8 +215,9 @@
       (strip_ws sep.(0), strip_ws d.(0), strip_ws d.(1)) in
     let make_move m =
       let gs = split "->" m in
-      let lab = split_list "," gs.(0) in
-      (strip_ws (List.hd lab),
+      let lab_all = split_list "," gs.(0) in
+      let (lab_pl, lab) = (List.hd lab_all, List.tl lab_all) in
+      (strip_ws lab_pl, strip_ws (List.hd lab),
        List.map (fun v -> make_itvl (strip_ws v)) (List.tl lab),
        strip_ws gs.(1)) in
     List.map (fun m -> make_move (strip_ws_lst m)) moves
@@ -245,18 +246,20 @@
 
 let client_open_from_str s = client_set_state ("#db#" ^ s)
 
-let client_move_str (m, r, e) = 
+let client_move_str (pl, m, r, e) = 
   let mstr m = String.concat ", " (List.map (fun (a, b) -> a ^ ": " ^ b) m) in
-  "({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
+  pl ^ ",({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
 
 let client_cur_moves () =
-  let append_move moves (r, _, endp) = (* FIXME! currently we ignore itvls *)
-    (List.map (fun m -> (m, r, endp)) (client_query r)) @ moves in
+  let append_move moves (pl, r, _, endp) = (* currently we ignore itvls *)
+    (List.map (fun m -> (pl, m, r, endp)) (client_query r)) @ moves in
   let cur_loc = client_get_cur_loc () in
   let moves = List.fold_left append_move [] (client_get_loc_moves cur_loc) in
   String.concat "; " (List.map client_move_str moves)
 
-let client_get_loc_player i = client_msg ("GET LOC PLAYER " ^ i)
+let client_get_loc_player i = 
+  let msg = client_msg ("GET LOC PLAYER " ^ i) in
+  if (String.length msg > 3 && String.sub msg 0 3 = "ERR") then "-1" else msg
 
 let client_make_move m r endp =
   let _ = client_apply_rule r m "1.0" [] in
@@ -276,7 +279,7 @@
   (t.(0), t.(1))
 
 
-let client_suggest timeout advr =
+let client_suggest pl timeout advr =
   let loc = client_get_cur_loc () in
   let (ts, t) = client_get_time () in
   let m = client_msg ("EVAL LOC MOVES " ^ advr ^ ".0 " ^ loc ^ 
@@ -288,7 +291,7 @@
       let es = Array.map strip_ws (split ":" s) in
       (es.(0), es.(1)) :: emb in
     let emb = List.fold_left append_emb [] (split_list "," msg.(1)) in
-    client_move_str (emb, msg.(0), msg.(3))
+    client_move_str (string_of_int pl, emb, msg.(0), msg.(3))
 
 
 let client_model_get_elem_val el_id vl =
@@ -412,7 +415,7 @@
       | "sv" -> "image/svg+xml"
       | _ -> "text/html charset=utf-8" in
     http_msg true "200 OK" tp [] content
-  ) else http_msg true "404 NOT FOUND" "text/html charset=utf-8" []
+  ) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
     ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
 	"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
 
@@ -476,16 +479,16 @@
     db_cur_insert game pl1 pl2 pid (string_of_int move_pl) model loc info "";
     release_global_lock ();
     pid ^ "$" ^ info ^ "$" ^ (string_of_int move_pl) in
-  let game_select_s g p1 p2 pid m =
+  let game_select_s g p1 p2 pid =
     "game='" ^ g ^ "' and player1='" ^ p1 ^ "' and player2='" ^ p2 ^
-      "' and playid=" ^ pid ^ " and move=" ^ m in
+      "' and playid=" ^ pid in
   let upd_svg g p1 p2 pid m svg_s =
-    let select = game_select_s g p1 p2 pid m in
+    let select = game_select_s g p1 p2 pid in
     let _ = DB.update_table dbFILE ~select ("svg='"^ svg_s ^"'") "cur_states" in
     "" in
   let db_escape s = str_replace "'" "''" s in
   let move_play move_tup g p1 p2 pid m =
-    let sel_s = game_select_s g p1 p2 pid m in
+    let sel_s = game_select_s g p1 p2 pid in
     let old_res= List.hd (dbtable sel_s "cur_states") in
     let (old_toss, old_loc, old_info, old_svg) =
       (old_res.(5), old_res.(6), old_res.(7), old_res.(8)) in
@@ -509,14 +512,14 @@
       [pid; g; p1; p2; m; old_toss; old_loc; old_info; old_svg];
     new_info ^ "$" ^ (string_of_int new_pl) in
   let suggest time g p1 p2 pid m =
-    let res = List.hd (dbtable (game_select_s g p1 p2 pid m) "cur_states") in
+    let res = List.hd (dbtable (game_select_s g p1 p2 pid) "cur_states") in
     let (toss, loc) = (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_cur_loc loc;
     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 time adv_ratio in
+    client_suggest (m+1) time adv_ratio in
   let register_user ui =
     if Array.length ui <> 5 then false else
       let (uid, name, surname, email, pwd) = 
@@ -538,7 +541,7 @@
       let friends = dbtable ("id='" ^ uid ^ "'") "friends" in
       List.map (fun a -> a.(1)) friends in
   let open_db game p1 p2 pid move =
-    let res = dbtable (game_select_s game p1 p2 pid move) "cur_states" in
+    let res = dbtable (game_select_s game p1 p2 pid) "cur_states" in
     let (move, info) = ((List.hd res).(4), (List.hd res).(7)) in
     info ^ "$" ^ move in
   let add_opponent uid oppid =
@@ -604,7 +607,8 @@
     | "NEW_PLAY" ->
       let a = get_args data in new_play a.(1) a.(2) a.(3), []
     | "SUGGEST" ->
-      let a = get_args data in suggest a.(1) a.(2) a.(3) a.(4) a.(5) a.(6), []
+      let a = get_args data in
+      suggest a.(1) a.(2) a.(3) a.(4) a.(5) (int_of_string a.(6)), []
     | "MOVE_PLAY" ->
       let (op_i, cl_i) = (String.index data '(', String.index data ')') in
       let tp_s = String.sub data (op_i+1) (cl_i - op_i-1) in
@@ -618,7 +622,7 @@
       move_play tp a.(0) a.(1) a.(2) a.(3) a.(4), []
     | _ ->
       "MOD_PYTHON ERROR ; Traceback: Unknown Toss Command! \n " ^ tcmd, [] in
-  http_msg false "200 OK" "text/html charset=utf-8" new_cookies resp
+  http_msg false "200 OK" "text/html; charset=utf-8" new_cookies resp
 
 
 let handle_http_msg rstate cmd head msg ck =

Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/Connect.js	2011-05-19 23:54:24 UTC (rev 1448)
@@ -41,11 +41,11 @@
 function set_info (info) {
     var res_arr = [];
     res_arr = info.split("$");
-    if (res_arr.length != 5) { return (false); }
+    if (res_arr.length != 5) { alert (res_arr); return (false); }
     DIM_STR = res_arr[0];
     ELEM_STR = res_arr[1];
     RELS_STR = res_arr[2];
-    if (res_arr[3].substring(0, 1) == "(") {
+    if (res_arr[3].substring(2, 3) == "(") {
 	MOVES_STR = res_arr[3];
 	PAYOFF_STR = "";
     } else {

Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/Login.js	2011-05-19 23:54:24 UTC (rev 1448)
@@ -30,6 +30,7 @@
     list_plays_string ("Gomoku", udata[7]);
     list_plays_string ("Pawn-Whopping", udata[8]);
     list_plays_string ("Tic-Tac-Toe", udata[9]);
+    list_plays_string ("Concurrent-Tic-Tac-Toe", udata[10]);
     get_opponents ();
 }
 

Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/Main.js	2011-05-19 23:54:24 UTC (rev 1448)
@@ -244,8 +244,8 @@
     document.getElementById("game-disp").style.display = "none";
     document.getElementById("plays").style.display = "none";
     GAME_NAME = game;
-    if (game == "Tic-Tac-Toe") { // bigger margins needed
-	create_svg_box (130, 130, "board");
+    if (game == "Tic-Tac-Toe" || game == "Concurrent-Tic-Tac-Toe") { 
+	create_svg_box (130, 130, "board"); // bigger margins needed
     } else {
 	create_svg_box (40, 40, "board");
     }
@@ -277,9 +277,9 @@
 function make_move () {
     if (ASYNC_ALL_REQ_PENDING != 0) { alert ("async"); return; }
     if (CUR_MOVE == "") return;
-    var m = PLAYS[CUR_PLAY_I][3];
+    var m = parseInt(CUR_MOVE.substring (0, 1)) - 1;
     if (PLAYS[CUR_PLAY_I][m] != UNAME && PLAYS[CUR_PLAY_I][m] != "computer") {
-        alert ("It is your Opponent's turn");
+        alert ("It is your Opponent's move");
         return;
     }
     if (! SIMPLE_MOVES) {

Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html	2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/index.html	2011-05-19 23:54:24 UTC (rev 1448)
@@ -258,6 +258,14 @@
   <ul class="plays-list" id="plays-list-Tic-Tac-Toe">
     <li style="display: none;"/>
   </ul>
+  <p class="game-par">
+    <button onclick="new_play('Concurrent-Tic-Tac-Toe')"
+	    class="boldobt">Concurrent-Tic-Tac-Toe</button>
+    (<a href="http://en.wikipedia.org/wiki/Tic-tac-toe">info</a>)
+  </p>
+  <ul class="plays-list" id="plays-list-Concurrent-Tic-Tac-Toe">
+    <li style="display: none;"/>
+  </ul>
 </div>
 
 

Added: trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss	                        (rev 0)
+++ trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss	2011-05-19 23:54:24 UTC (rev 1448)
@@ -0,0 +1,30 @@
+PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 5, depth: 3
+REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
+REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
+REL Row3 (x, y, z) = R(x, y) and R(y, z)
+REL Col3 (x, y, z) = C(x, y) and C(y, z)
+REL DiagA3 (x, y, z) = DiagA(x, y) and DiagA(y, z)
+REL DiagB3 (x, y, z) = DiagB(x, y) and DiagB(y, z)
+REL Conn3 (x, y, z) =
+  Row3(x, y, z) or Col3(x, y, z) or DiagA3(x, y, z) or DiagB3(x, y, z)
+REL WinQ() = ex x, y, z (Q(x) and Q(y) and Q(z) and Conn3(x, y, z))
+REL WinP() = ex x, y, z (P(x) and P(y) and P(z) and Conn3(x, y, z))
+RULE Cross:
+  [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P pre not (WinP() or WinQ())
+RULE Circle:
+  [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not (WinP() or WinQ())
+LOC 0 {
+  PLAYER 1 { PAYOFF :(WinP()) - :(WinQ())
+             MOVES [Cross -> 0] }
+  PLAYER 2 { PAYOFF :(WinQ()) - :(WinP())
+             MOVES [Circle -> 0] }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] "
+	         
+	.  .  .  
+	         
+	.  .  .  
+	         
+	.  .  .  
+"


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