[Toss-devel-svn] SF.net SVN: toss:[1448] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
From: <luk...@us...> - 2011-05-19 23:54:30
|
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. |