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

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

Revision: 1613
          http://toss.svn.sourceforge.net/toss/?rev=1613&view=rev
Author:   lukaszkaiser
Date:     2011-10-23 18:48:09 +0000 (Sun, 23 Oct 2011)
Log Message:
-----------
Learning games tied to WebClient.

Modified Paths:
--------------
    trunk/Toss/Server/LearnGame.ml
    trunk/Toss/Server/LearnGame.mli
    trunk/Toss/Server/ReqHandler.ml
    trunk/Toss/WebClient/Connect.js
    trunk/Toss/WebClient/Main.js
    trunk/Toss/WebClient/Style.css
    trunk/Toss/WebClient/index.html

Modified: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/Server/LearnGame.ml	2011-10-23 18:48:09 UTC (rev 1613)
@@ -1,3 +1,13 @@
+(* Learning games from examples. *)
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
+let struc_of_string s = 
+  StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
+
+
 let rec evens ?(acc=[0]) k =
   let last = (List.hd (List.rev acc)) in
   if (List.hd (List.rev acc))> k then
@@ -7,11 +17,6 @@
 let odds k =
   evens ~acc:[1] k 
 
-let playFromDB pid =
-  let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
-  let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
-  List.map (fun x -> ((int_of_string x.(4)),x.(5))) res 
-  
 
 let winFormula winningStates notWinningStates =
   WL.distinguish winningStates notWinningStates
@@ -108,3 +113,29 @@
              MOVES [Mv2 -> 0] }
 }" ^"\n" ^
   "MODEL "^(Structure.str (List.hd (List.hd partylistWin0)))
+
+
+(* Get the play with given id from DB - as a sequence of structures. *)
+let playFromDB pid =
+  let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
+  let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
+  let moveStrucs = List.map (fun x -> ((int_of_string x.(4)), x.(5))) res in
+  let prevs = List.sort (fun (a, b) (c, d) -> a - c) moveStrucs in
+  let cur = dbtable ("playid=" ^ (string_of_int pid)) "cur_states" in 
+  (List.map snd prevs) @ [(List.hd cur).(5)]
+
+(* Learn a two-player win-lose-or-tie game given 4 sets of plays of another
+   game [source]: [wins0] which are now supposed to be won by Player 0,
+   [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
+   are not correct plays of the newly constructed game. *)
+let learnFromDB ~source ~wins0 ~wins1 ~tie ~wrong =
+  if !debug_level > 0 then (
+    let pl l = String.concat ", " (List.map string_of_int l) in
+    print_endline ("Learning from " ^ source ^ " w0: " ^ (pl wins0) ^ " w1: " ^
+		      (pl wins1) ^" tie: "^ (pl tie) ^" wrong: "^ (pl wrong));
+  );
+  let (wins0, wins1, tie, wrong) = 
+    (List.map playFromDB wins0, List.map playFromDB wins1,
+     List.map playFromDB tie, List.map playFromDB wrong) in
+  learnFromParties (List.map (List.map struc_of_string) wins0) 
+    (List.map (List.map struc_of_string) wins1)

Modified: trunk/Toss/Server/LearnGame.mli
===================================================================
--- trunk/Toss/Server/LearnGame.mli	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/Server/LearnGame.mli	2011-10-23 18:48:09 UTC (rev 1613)
@@ -1,6 +1,25 @@
-val learnFromParties: Structure.structure list list -> Structure.structure list list -> string
+(** Module for learning games from examples. *)
 
-val move: Structure.structure -> Structure.structure 
-  -> Structure.structure * Structure.structure
+val move: Structure.structure -> Structure.structure ->
+  Structure.structure * Structure.structure
 
-val playFromDB: int -> (int*string) list
+val learnFromParties:
+  Structure.structure list list -> Structure.structure list list -> string
+
+
+(** Get the play with given id from DB - as a sequence of structure strings. *)
+val playFromDB: int -> string list
+
+(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
+    game [source]: [wins0] which are now supposed to be won by Player 0,
+    [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
+    are not correct plays of the newly constructed game. The plays are given
+    as lists of ids to be retrieved from DB, result is a toss game string. *)
+val learnFromDB: source:string -> wins0: int list -> wins1: int list -> 
+  tie: int list -> wrong: int list -> string
+
+
+(** {2 Debugging} *)
+
+(* At higher debug levels we prints out diagnostic information. *)
+val set_debug_level: int -> unit

Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/Server/ReqHandler.ml	2011-10-23 18:48:09 UTC (rev 1613)
@@ -684,6 +684,16 @@
 	| Lexer.Parsing_error msg -> "Parsing error: " ^ msg
 	| _ -> "Parsing error"
     else "Sorry, saving games is not allowed on this server." in
+  let learn_game game plays_str =
+    let plays = List.map (split_two ":") (split_list "$" plays_str) in
+    let plays_int = List.map (fun (a, b) -> (int_of_string a, b)) plays in
+    let (w0, other) = List.partition (fun (_, b) -> b = "0") plays_int in
+    let (w1, other) = List.partition (fun (_, b) -> b = "1") other in
+    let (tie, other) = List.partition (fun (_, b) -> b = "2") other in
+    let (wrong, _) = List.partition (fun (_, b) -> b = "3") other in
+    LearnGame.learnFromDB ~source:game 
+      ~wins0:(List.map fst w0) ~wins1:(List.map fst w1) 
+      ~tie:(List.map fst tie) ~wrong:(List.map fst wrong) in
   let (tcmd, data) = split_two "#" msg in
   let resp, new_cookies = match tcmd with
     | "USERNAME" ->
@@ -753,6 +763,8 @@
       let tp2 = String.sub tp_s (tp_i+1) (tp_l - tp_i - 1) in
       let tp, a = (strip_ws tp0, strip_ws tp1, strip_ws tp2), get_args args_s in
       move_play tp a.(0), []
+    | "LEARNGAME" ->
+      let a = get_args data in learn_game a.(0) a.(1), []
     | "GETGAME" ->
       let res = dbtable ("game='" ^ data ^ "'") "games" in
       (match List.length res with

Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/Connect.js	2011-10-23 18:48:09 UTC (rev 1613)
@@ -152,6 +152,9 @@
     this.change_data = function (name, surname, email) {
 	return (srv ("CHANGEUSR", name +"$"+ surname +"$"+ email));
     }
+    this.learn_game = function (game, plays) {
+	return (srv ("LEARNGAME", game + ", " + plays)); 
+    }
     this.get_game = function (game) { return (srv("GETGAME", game)); }
     this.set_game = function (game, toss) { 
 	return (srv("SETGAME", game + " $_$ " + toss)); 

Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/Main.js	2011-10-23 18:48:09 UTC (rev 1613)
@@ -95,7 +95,7 @@
 	paragraph.completed_button = completed_bt;
 	completed_bt.setAttribute("class", "completedbt");
 	completed_bt.setAttribute("onclick",
-			    "GAMESPAGE.toggle_completed ('" + game + "')");
+				  "GAMESPAGE.toggle_completed ('" +game+ "')");
 	completed_bt.innerHTML = "Completed games (Show)";
 	closed_plays.appendChild (completed_bt);
 
@@ -103,7 +103,7 @@
 	paragraph.learn_button = learn_button;
 	learn_button.setAttribute("class", "completedbt");
 	learn_button.setAttribute("onclick",
-				      "GAMESPAGE.learn_game ('" + game + "')");
+				  "GAMESPAGE.learn_game ('" + game + "')");
 	learn_button.innerHTML = "Learn";
 	learn_button.style.display = "none";
 	closed_plays.appendChild (learn_button);
@@ -172,7 +172,19 @@
 }
 
 GamesPage.prototype.learn_game = function (game) {
-    alert ("Learning a new game - from plays of " + game + " below - soon.");
+    var lst = CONN.list_plays (game, UNAME);
+    var lst_plays = parse_list ('##', lst);
+    var plays = "$";
+    for (var i = 0; i < lst_plays.length; i++) {
+	lst_plays[i] = play_from_string (game, lst_plays[i]);
+	if (lst_plays[i].cur_state.result != null) {
+	    var pid = lst_plays[i].pid;
+	    var val = document.getElementById ("select_" + pid).value;
+	    if (val != -1) plays += pid + ":" + val + "$";
+	}
+    }
+    var res = CONN.learn_game (game, plays)
+    alert (res);
 }
 
 GamesPage.prototype.toggle_completed = function (game) {
@@ -226,9 +238,22 @@
     var bs = '<button class="obt" title="Open game ' + PLAYS[i].pid + 
 	'" onclick="'+ "play_click('" + game + "', " + PLAYS[i].pid + ", " +
 	i + ')">' + pname + '</button> ';
-    li.innerHTML = bs;
-    if (PLAYS[i].cur_state.result != null) li.innerHTML += '<span class="list_result">' + PLAYS[i].get_formatted_result_string() + '</span>';
-    // +'<a href="#" onclick="'+ "del_play('"+ fn + "')" + '">Delete</a>';
+    if (PLAYS[i].cur_state.result != null) { // completed game
+	li.innerHTML = bs;
+	li.innerHTML += '<span class="list_result">' + 
+	    PLAYS[i].get_formatted_result_string() + '</span>';
+	li.innerHTML += '&nbsp; &nbsp; <span class="play_learn">' +
+	    "Learning:</span>";
+	li.innerHTML += 
+	    '<select class="play_select" id="select_' + PLAYS[i].pid + '">' +
+	    '<option class="play_select_opt" value="-1">skip</option>' +
+	    '<option class="play_select_opt" value="0">wins0</option>' +
+	    '<option class="play_select_opt" value="1">wins1</option>' +
+	    '<option class="play_select_opt" value="2">tie</option>' +
+	    '<option class="play_select_opt" value="3">wrong</option></select>';
+    } else {
+	li.innerHTML = bs;
+    }
     return (li);
 }
 

Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/Style.css	2011-10-23 18:48:09 UTC (rev 1613)
@@ -233,6 +233,33 @@
     border-width: 0px;
 }
 
+.play_select {
+    position: relative;
+    top: -0.1em;
+    color: #260314;
+    font-family: Verdana, 'TeXGyreHerosRegular', sans;
+    font-size: 0.8em;
+    background-color: #fff1d4;
+    padding: 0px;
+    margin: 0px;
+    border-color: #fff1d4;
+    border-radius: 4px;
+    -moz-border-radius: 4px;
+    border-width: 0px;
+}
+
+.play_select_opt {
+    color: #260314;
+    background-color: #fff1d4;
+    border-width: 0px;
+}
+
+.play_learn {
+    color: #260314;
+    font-family: Verdana, 'TeXGyreHerosRegular', sans;
+    font-size: 0.8em;
+}
+
 .forminput, .hiddenforminput {
     border-color: #fff1d4;
     border-radius: 4px;

Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html	2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/index.html	2011-10-23 18:48:09 UTC (rev 1613)
@@ -177,6 +177,7 @@
 <div id="news">
 <h3>News</h3>
 <ul id="welcome-list-news" class="welcome-list">
+<li><b>24/10/11</b>&nbsp; Learning games from examples in web interface</li>
 <li><b>19/10/11</b>&nbsp; Games learning engine and first buttons in the UI</li>
 <li><b>14/09/11</b>&nbsp; Simple editing of games added to web interface</li>
 <li><b>31/07/11</b>&nbsp; Store date and time of moves in games</li>

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