Thread: [Toss-devel-svn] SF.net SVN: toss:[1496] trunk/Toss (Page 8)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2011-06-25 14:13:21
|
Revision: 1496
http://toss.svn.sourceforge.net/toss/?rev=1496&view=rev
Author: lukaszkaiser
Date: 2011-06-25 14:13:14 +0000 (Sat, 25 Jun 2011)
Log Message:
-----------
Password changing in WebClient.
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Connect.js
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/profile.html
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-06-24 13:49:35 UTC (rev 1495)
+++ trunk/Toss/Server/ReqHandler.ml 2011-06-25 14:13:14 UTC (rev 1496)
@@ -586,6 +586,11 @@
upd ("surname='" ^ udata.(1) ^ "'");
upd ("email='" ^ udata.(2) ^ "'");
"OK" in
+ let change_pwd uid pwd =
+ let uid_s = "id='" ^ uid ^ "'" in
+ let upd s = ignore (DB.update_table dbFILE ~select:uid_s s "users") in
+ upd ("passwd='" ^ pwd ^ "'");
+ "OK" in
let forgotpwd email =
let mail_s = "email='" ^ email ^ "'" in
let usrs = dbtable mail_s "users" in
@@ -642,6 +647,9 @@
let (_, _, mail) = get_user_name_surname_mail data in mail, []
| "FORGOTPWD" ->
forgotpwd data, []
+ | "CHANGEPWD" ->
+ let uid = verif_uid () in
+ if uid = "" then "Please Log In again", [] else change_pwd uid data, []
| "CHANGEUSR" ->
change_user_data (verif_uid ()) (split "$" data), []
| "LIST_PLAYS" ->
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-06-24 13:49:35 UTC (rev 1495)
+++ trunk/Toss/WebClient/Connect.js 2011-06-25 14:13:14 UTC (rev 1496)
@@ -139,6 +139,14 @@
return (srv ("REGISTER", data + "$" + cpwd));
}
this.forgotpwd = function (mail) { return (srv("FORGOTPWD", mail)); }
+ this.change_pwd = function (un, pwd) {
+ var resp = srv("CHANGEPWD", pwd);
+ if (resp == "OK") {
+ this.logout ();
+ this.login (un, true, pwd);
+ return ("Password changed successfully");
+ } else { return (resp); }
+ }
this.change_data = function (name, surname, email) {
return (srv ("CHANGEUSR", name +"$"+ surname +"$"+ email));
}
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-06-24 13:49:35 UTC (rev 1495)
+++ trunk/Toss/WebClient/Login.js 2011-06-25 14:13:14 UTC (rev 1496)
@@ -260,6 +260,22 @@
alert (resp);
}
+// Change user password
+function change_password () {
+ var pwd = document.getElementById('newpwd').value;
+ var rptpwd = document.getElementById('rptnewpwd').value;
+ if (pwd.length < 3) {
+ alert ("Your password is too short." + CORRMSG);
+ return;
+ }
+ if (pwd != rptpwd) {
+ alert ("Password and Repeated Password do not match." + CORRMSG);
+ return;
+ }
+ var resp = CONN.change_pwd (UNAME, crypt(TSALT + pwd));
+ alert (resp);
+}
+
// Change user data
function change_profile () {
var name = document.getElementById('name').value;
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-06-24 13:49:35 UTC (rev 1495)
+++ trunk/Toss/WebClient/Style.css 2011-06-25 14:13:14 UTC (rev 1496)
@@ -532,6 +532,7 @@
#main-profile {
position: relative;
left: 1em;
+ top: 3em;
}
.welcome-list {
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-06-24 13:49:35 UTC (rev 1495)
+++ trunk/Toss/WebClient/profile.html 2011-06-25 14:13:14 UTC (rev 1496)
@@ -61,8 +61,7 @@
<div id="main-profile" style="display: none;">
<h2>Your Profile</h2>
-
-<form id="changeprofileform" action="">
+<div id="changeprofileform">
<p> <span class="reglabel">Name:</span>
<input class="forminput" type="text" name="name" id="name" />
</p>
@@ -74,8 +73,20 @@
</p>
<p><button class="bt" id="changebt" type="button"
onclick="change_profile()">Change</button></p>
-</form>
+</div>
+<h2>Change Password</h2>
+<div id="changepwdform">
+<p> <span class="reglabel">New Password:</span>
+ <input class="forminput" type="password" name="newpwd" id="newpwd" />
+</p>
+<p> <span class="reglabel">Repeat New Password:</span>
+ <input class="forminput" type="password" name="rptnewpwd" id="rptnewpwd" />
+</p>
+<p><button class="bt" id="changepwdbt" type="button"
+ onclick="change_password()">Change Password</button></p>
+</div>
+
<h2>Your Current Opponents</h2>
<div id="opponents-profile">
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-06-28 00:48:46
|
Revision: 1497
http://toss.svn.sourceforge.net/toss/?rev=1497&view=rev
Author: lukaszkaiser
Date: 2011-06-28 00:48:40 +0000 (Tue, 28 Jun 2011)
Log Message:
-----------
Tabs and opponents searching in profile.
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Connect.js
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Play.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/profile.html
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/Server/ReqHandler.ml 2011-06-28 00:48:40 UTC (rev 1497)
@@ -607,8 +607,33 @@
"\nYou can change it after you login on tPlay.\n" ^
"\nThank You!\n\ntPlay Team\n") in
ignore (send_mail email "New password on tPlay.org" mailtxt);
+ print_endline "Subject: New password on tPlay.org";
print_endline mailtxt;
"Your password has been reset and sent to " ^ email ^ "." in
+ let search_users txt =
+ let l, txtlen = "like \"%" ^ txt ^ "%\"", String.length txt in
+ let query_s =
+ Printf.sprintf "name %s or surname %s or id %s or email %s" l l l l in
+ let all = List.map (fun a -> a.(0)) (dbtable query_s "users") in
+ lstr (List.filter (fun s -> String.length s < 2*txtlen + 1) all) in
+ let invite uid email =
+ let usrs = dbtable ("email='" ^ email ^ "'") "users" in
+ if List.length usrs > 0 then
+ Printf.sprintf "Sorry, %s is already a registered email." email
+ else
+ let (uname, usurname, umail) = get_user_name_surname_mail uid in
+ let mailtxt =
+ ("\nYour Friend invites you to play on tPlay.org\n\n" ^
+ "\nYour friend " ^ uname ^ " " ^ usurname ^ " (" ^ umail ^ ") " ^
+ "invites you to join a game on tPlay.org.\n" ^
+ "To this end, please register on: www.tplay.org/register.html\n" ^
+ "\nWe wish you a good game!\n\ntPlay Team\n") in
+ let subj =
+ Printf.sprintf "Invitation to tPlay.org from %s %s" uname usurname in
+ ignore (send_mail email subj mailtxt);
+ print_endline ("Subject: " ^ subj);
+ print_endline mailtxt;
+ "Invitation email has been sent to " ^ email ^ "." in
let (tcmd, data) = split_two "#" msg in
let resp, new_cookies = match tcmd with
| "USERNAME" ->
@@ -634,6 +659,8 @@
let c =
[(tID ^ "username", "a", None); (tID ^ "passphrase", "a", None)] in
("User logged out: " ^ (verif_uid ()), c)
+ | "SEARCHUSR" ->
+ search_users data, []
| "ADDOPP" ->
add_opponent (verif_uid ()) data, []
| "GET_NAME" ->
@@ -645,6 +672,9 @@
| "GET_MAIL" ->
if verif_uid()="" then "You must login first to get email data.", [] else
let (_, _, mail) = get_user_name_surname_mail data in mail, []
+ | "INVITE" ->
+ let uid = verif_uid () in
+ if uid = "" then "Error: please Log In again", [] else invite uid data, []
| "FORGOTPWD" ->
forgotpwd data, []
| "CHANGEPWD" ->
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/Connect.js 2011-06-28 00:48:40 UTC (rev 1497)
@@ -122,7 +122,7 @@
}
this.friends = function () { return (srv ("LIST_FRIENDS", "user")); }
- this.allopnts = function () { return (srv ("LIST_FRIENDS", "**")); }
+ this.search_users = function (txt) { return (srv ("SEARCHUSR", txt)); }
this.plays = function () { return (srv("USERPLAYS", "user")); }
this.username = function () { return (srv("USERNAME", "user")); }
this.addopp = function (opp) { return (srv("ADDOPP", opp)); }
@@ -138,6 +138,7 @@
this.register = function (data, cpwd) {
return (srv ("REGISTER", data + "$" + cpwd));
}
+ this.invite = function (mail) { return (srv("INVITE", mail)); }
this.forgotpwd = function (mail) { return (srv("FORGOTPWD", mail)); }
this.change_pwd = function (un, pwd) {
var resp = srv("CHANGEPWD", pwd);
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/Login.js 2011-06-28 00:48:40 UTC (rev 1497)
@@ -31,7 +31,8 @@
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 ();
+ var lst = CONN.friends ();
+ FRIENDS = parse_list (',', lst);
}
// Clear view
@@ -86,13 +87,54 @@
}
}
-// Html of the list item for adding new opponents.
-function add_opponent_item_html (uname) {
- var onclick = 'onclick="add_opponent (' + "'" + uname + "'" + ')"';
- var bt = '<button class="bt" ' + onclick + ">Add</button>"
- return (bt + " " + disp_name(uname) + " (" + uname + ")")
+// Find opponents given (email or name or surname or username).
+function find_opnts () {
+ var txt = document.getElementById('findopnt').value;
+ if (txt.length < 2) {
+ alert ("Emails and names have at least 2 letters." + CORRMSG);
+ return;
+ }
+ if (txt.indexOf(" ") > 0) {
+ alert ("Emails and names do not contain spaces." + CORRMSG);
+ return;
+ }
+ // Get the list of found users.
+ var lst = CONN.search_users (txt);
+ var users = parse_list (',', lst);
+
+ // Offer to email an invitation if no user was found.
+ document.getElementById("invite").style.display = "block";
+
+ // Helper function: html of the list item for adding new opponents.
+ var add_opponent_item_html = function (uname) {
+ var onclick = 'onclick="add_opponent (' + "'" + uname + "'" + ')"';
+ var bt = '<button class="bt" ' + onclick + ">Add</button>"
+ return (bt + " " + disp_name(uname) + " (" + uname + ")")
+ }
+
+ // Print out the found list.
+ var u = document.getElementById("add-opponents-list");
+ while (u.childNodes.length > 0) { u.removeChild (u.firstChild); }
+ for (var i = 0; i < users.length; i++) {
+ if (users[i] != UNAME && FRIENDS.indexOf(users[i]) == -1) {
+ var li = document.createElement('li');
+ li.innerHTML = add_opponent_item_html (users[i]);
+ u.appendChild (li);
+ }
+ }
}
+// Send invitation email to a new user.
+function invite () {
+ var email = document.getElementById('findopnt').value;
+ if (email.indexOf("@") < 1 || email.indexOf(".") < 1) {
+ alert ("Please provide a valid email address in the search field.");
+ return;
+ }
+ alert (CONN.invite (email));
+ window.location.reload();
+}
+
// Onload handler for the profile page
function startup_profile () {
var un = CONN.username ();
@@ -108,23 +150,14 @@
document.getElementById('name').value = CONN.name (un);
document.getElementById('surname').value = CONN.surname (un);
document.getElementById('email').value = CONN.email (un);
- get_opponents ();
+ var lst = CONN.friends ();
+ FRIENDS = parse_list (',', lst);
var o = document.getElementById("opponents-list");
for (var i = 0; i < FRIENDS.length; i++) {
var li = document.createElement('li');
li.innerHTML = disp_name(FRIENDS[i]) + " (" + FRIENDS[i] + ")";
o.appendChild (li);
}
- var lst = CONN.allopnts ();
- var users = parse_list (',', lst);
- var u = document.getElementById("users-list");
- for (var i = 0; i < users.length; i++) {
- if (users[i] != un && FRIENDS.indexOf(users[i]) == -1) {
- var li = document.createElement('li');
- li.innerHTML = add_opponent_item_html (users[i]);
- u.appendChild (li);
- }
- }
};
}
@@ -149,19 +182,15 @@
// Logout
function logout () {
- clear_view ();
- resp = CONN.logout ();
+ //clear_view ();
+ var resp = CONN.logout ();
+ window.location.reload ();
return;
}
function logout_profile () {
- document.getElementById("loginform").style.display = "inline";
- document.getElementById("topright-register").style.display = "inline";
- document.getElementById("topright").style.display = "none";
- document.getElementById("topuser").innerHTML = "";
- document.getElementById("main-profile").style.display = "none";
- document.getElementById("welcome").style.display = "block";
- resp = CONN.logout ();
+ var resp = CONN.logout ();
+ window.location.reload ();
return;
}
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/Main.js 2011-06-28 00:48:40 UTC (rev 1497)
@@ -363,11 +363,6 @@
//document.getElementById ("plays-list-" + GAME_NAME).appendChild (li);
}
-function get_opponents () {
- var lst = CONN.friends ();
- FRIENDS = parse_list (',', lst);
-}
-
function play_anew (me_starts) {
document.getElementById ('payoffs').innerHTML = "Not Finished Yet";
document.getElementById ('payoffs').style.display = "none";
Modified: trunk/Toss/WebClient/Play.js
===================================================================
--- trunk/Toss/WebClient/Play.js 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/Play.js 2011-06-28 00:48:40 UTC (rev 1497)
@@ -55,6 +55,7 @@
PlayDISP.set_cur_move ("", "");
PlayDISP.show_payoff (this);
this.cur_state.draw_model (this.game);
+ document.getElementById("speedtab").style.display = "inline";
}
Play.prototype.redraw = play_redraw;
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/Style.css 2011-06-28 00:48:40 UTC (rev 1497)
@@ -220,34 +220,42 @@
#speed {
position: relative;
- top: -2px;
+ top: 0px;
font-weight: bold;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
- color: #400827;
- background-color: #fff1d4;
+ color: #fff1d4;
+ background-color: #777777;
border-color: #fff1d4;
border-radius: 4px;
-moz-border-radius: 4px;
- border-width: 1px;
+ border-width: 0px;
}
.speed_val {
- color: #400827;
- background-color: #fff1d4;
- border-color: #400827;
+ color: #fff1d4;
+ font-weight: bold;
+ background-color: #666666;
+ border-width: 0px;
}
-.forminput {
+.forminput, .hiddenforminput {
border-color: #fff1d4;
border-radius: 4px;
-moz-border-radius: 4px;
border-width: 2px;
position: relative;
top: 2px;
+ width: 12em;
}
-.list_result
-{
+.hiddenforminput {
+ color: #fff1d4;
+ background-color: #fff1d4;
+ border: 0px;
+ margin: 4px;
+}
+
+.list_result {
font-size: 0.9em
}
@@ -284,16 +292,11 @@
}
#logoutbt {
- position: relative;
- top: -0.1em;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
font-size: 1em;
font-weight: bold;
color: #fff1d4;
- background-color: #400827;
- border-color: #fff1d4;
- border-radius: 4px;
- -moz-border-radius: 4px;
+ background-color: #260314;
border-width: 0px;
}
@@ -376,7 +379,7 @@
#topright {
position: absolute;
- top: 0.7em;
+ top: 0.5em;
right: 1em;
margin-right: 0em;
display: none;
@@ -389,6 +392,19 @@
margin-right: 0em;
}
+.toprighttab {
+ position: relative;
+ top: 0.5em;
+ background-color: #260314;
+ border-color: #fff1d4;
+ border-style: solid;
+ border-width: 2px 2px 0px 2px;
+ border-radius: 6px 6px 0px 0px;
+ padding-top: 0.15em;
+ padding-bottom: 0.3em;
+ -moz-border-radius: 6px 6px 0px 0px;
+}
+
#bottom {
position: absolute;
bottom: 0px;
@@ -530,11 +546,43 @@
}
#main-profile {
+ display: none;
position: relative;
left: 1em;
top: 3em;
+ margin-bottom: 4em;
+ width: 100%;
}
+.separator-div {
+ width: 100%;
+ padding: 0px;
+ margin-left: -1em;
+ margin-top: 1em;
+ border-top: 1px solid #260314;
+
+}
+
+.positioning-div {
+ position: relative;
+ left: 0px;
+ right: 0px;
+ padding: 0px;
+ margin: 0px;
+}
+
+.profile-right {
+ position: absolute;
+ top: -1.2em;
+ left: 26em; /* 50%; */
+}
+
+#invite {
+ display: none;
+ position: relative;
+ top: -1em;
+}
+
.welcome-list {
list-style: square;
padding-left: 1.5em;
@@ -544,9 +592,9 @@
margin-top: 0.5em;
}
-#users-list {
+#add-opponents-list {
list-style: none;
- padding-left: 1.5em;
+ padding-left: 0em;
margin-top: 0.5em;
padding-bottom: 1em;
}
@@ -565,7 +613,7 @@
background-color: #400827;
font-weight: bold;
padding: 1em;
- border: 1px solid #260314;
+ border: 1px solid #260314;
z-index: 10;
}
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/index.html 2011-06-28 00:48:40 UTC (rev 1497)
@@ -55,18 +55,28 @@
</form>
</div>
<span id="topright">
- Speed: <select id="speed">
- <option class="speed_val" value="1">1s</option>
- <option class="speed_val" value="2">2s</option>
- <option class="speed_val" value="3">3s</option>
- <option class="speed_val" value="4">4s</option>
- <option class="speed_val" value="5">5s</option>
- <option class="speed_val" value="10">10s</option>
- <option class="speed_val" value="15">15s</option>
- <option class="speed_val" value="30">30s</option>
- <option class="speed_val" value="60">60s</option>
- </select>
- <button id="logoutbt" onclick="logout()">Logout</button>
+ <span class="toprighttab">
+ <a href="index.html">Games</a>
+ </span>
+ <span class="toprighttab">
+ <a href="profile.html">Profile</a>
+ </span>
+ <span class="toprighttab">
+ <button id="logoutbt" onclick="logout()">Logout</button>
+ </span>
+ <span class="toprighttab" id="speedtab" style="display: none;">
+ Speed: <select id="speed">
+ <option class="speed_val" value="1">1s</option>
+ <option class="speed_val" value="2">2s</option>
+ <option class="speed_val" value="3">3s</option>
+ <option class="speed_val" value="4">4s</option>
+ <option class="speed_val" value="5">5s</option>
+ <option class="speed_val" value="10">10s</option>
+ <option class="speed_val" value="15">15s</option>
+ <option class="speed_val" value="30">30s</option>
+ <option class="speed_val" value="60">60s</option>
+ </select>
+ </span>
</span>
<span id="topright-register">
<a href="register.html">Register</a>
@@ -179,6 +189,7 @@
<div id="news">
<h3>News</h3>
<ul id="welcome-list-news" class="welcome-list">
+<li><b>27/06/11</b> Tabs and searching opponents in the profile page</li>
<li><b>22/06/11</b> Better organized lists of plays</li>
<li><b>19/06/11</b> News section on the front page of tPlay</li>
<li><b>15/06/11</b> Bug with underscores in user names corrected</li>
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-06-25 14:13:14 UTC (rev 1496)
+++ trunk/Toss/WebClient/profile.html 2011-06-28 00:48:40 UTC (rev 1497)
@@ -46,7 +46,15 @@
</form>
</div>
<span id="topright">
- <button id="logoutbt" onclick="logout_profile()">Logout</button>
+ <span class="toprighttab">
+ <a href="index.html">Games</a>
+ </span>
+ <span class="toprighttab">
+ <a href="profile.html">Profile</a>
+ </span>
+ <span class="toprighttab">
+ <button id="logoutbt" onclick="logout()">Logout</button>
+ </span>
</span>
<span id="topright-register">
<a href="register.html">Register</a>
@@ -59,8 +67,9 @@
</p>
</div>
-<div id="main-profile" style="display: none;">
-<h2>Your Profile</h2>
+<div id="main-profile">
+<div id="change-data">
+<h2>Change Your Data</h2>
<div id="changeprofileform">
<p> <span class="reglabel">Name:</span>
<input class="forminput" type="text" name="name" id="name" />
@@ -74,7 +83,9 @@
<p><button class="bt" id="changebt" type="button"
onclick="change_profile()">Change</button></p>
</div>
+</div>
+<div id="change-password" class="profile-right">
<h2>Change Password</h2>
<div id="changepwdform">
<p> <span class="reglabel">New Password:</span>
@@ -83,27 +94,51 @@
<p> <span class="reglabel">Repeat New Password:</span>
<input class="forminput" type="password" name="rptnewpwd" id="rptnewpwd" />
</p>
+<p> <input class="hiddenforminput" /> </p>
<p><button class="bt" id="changepwdbt" type="button"
onclick="change_password()">Change Password</button></p>
</div>
+</div>
-<h2>Your Current Opponents</h2>
+<div class="separator-div"></div>
-<div id="opponents-profile">
- <ul id="opponents-list"><li style="display: none;"/></ul>
-</div>
+<div class="positioning-div">
+ <div id="find-opponents">
+ <h2>Find New Opponents</h2>
+ <div id="findopntform">
+ <p> <span class="reglabel">Email or Name:</span>
+ <input class="forminput" type="text" name="findopnt" id="findopnt" />
+ </p>
+ <p><button class="bt" id="findopntbt" type="button"
+ onclick="find_opnts()">Find Opponents</button>
+ </p>
+ </div>
+ <ul id="add-opponents-list"><li style="display: none;"/></ul>
+ <div id="invite">
+ <p> <span class="reglabel">Your Friend not here?</span><br/> </p>
+ <p>
+ <button class="bt" id="invitebt" type="button"
+ onclick="invite()">Send Invitation</button>
+ </p>
+ </div>
+ </div>
-<h2>Suggested New Opponents</h2>
-
-<div id="users-profile">
- <ul id="users-list"><li style="display: none;"/></ul>
+ <div id="current-opponents" class="profile-right">
+ <h2>Your Current Opponents</h2>
+ <div id="opponents-profile">
+ <ul id="opponents-list"><li style="display: none;"/></ul>
+ </div>
+ </div>
</div>
</div>
<div id="bottom">
<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
-<a href="contact.html" id="contact">Contact and Info</a>
+<script type="text/javascript">begin_mailto(
+ "tossplay", "gmail.com", "Contact Us");</script>
+tossplay [AT] gmail [DOT] com
+<script type="text/javascript">end_mailto();</script>
</div>
</div>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-02 22:47:03
|
Revision: 1500
http://toss.svn.sourceforge.net/toss/?rev=1500&view=rev
Author: lukaszkaiser
Date: 2011-07-02 22:46:56 +0000 (Sat, 02 Jul 2011)
Log Message:
-----------
Small corrections and adding game descriptions.
Modified Paths:
--------------
trunk/Toss/Server/Server.ml
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
Added Paths:
-----------
trunk/Toss/WebClient/pics/appstore-small.png
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-07-01 23:30:17 UTC (rev 1499)
+++ trunk/Toss/Server/Server.ml 2011-07-02 22:46:56 UTC (rev 1500)
@@ -41,8 +41,6 @@
if !continue then (* collect zombies *)
try
ignore (Unix.waitpid [Unix.WNOHANG] (-1));
- ignore (Unix.waitpid [Unix.WNOHANG] (-1));
- ignore (Unix.waitpid [Unix.WNOHANG] (-1));
with
Unix.Unix_error (e,_,_) -> if !debug_level > 1 then
Printf.printf "UNIX WAITPID: %s\n%!" (Unix.error_message e);
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-07-01 23:30:17 UTC (rev 1499)
+++ trunk/Toss/WebClient/Main.js 2011-07-02 22:46:56 UTC (rev 1500)
@@ -199,11 +199,12 @@
document.getElementById ("opponents").style.display = "none";
document.getElementById (game + "-desc").style.display = "block";
document.getElementById ("game-desc-controls").style.display = "block";
+ GAME_NAME = game;
+ if (SIMPLE_SET) { toggle_game_desc (); }
list_plays (game);
document.getElementById ("welcome").style.display = "none";
document.getElementById ("game-disp").style.display = "none";
document.getElementById ("plays").style.display = "none";
- GAME_NAME = game;
var gd = document.getElementById ("game-disp");
gd.style.display = "block";
gd.setAttribute ("class", "Game-" + game);
@@ -329,6 +330,7 @@
function new_play_do (opp_uid) {
document.getElementById (GAME_NAME + "-desc").style.display = "block";
document.getElementById ("game-desc-controls").style.display = "block";
+ if (SIMPLE_SET) { toggle_game_desc (); }
list_plays (GAME_NAME);
document.getElementById ("welcome").style.display = "none";
document.getElementById ("game-disp").style.display = "none";
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-07-01 23:30:17 UTC (rev 1499)
+++ trunk/Toss/WebClient/Style.css 2011-07-02 22:46:56 UTC (rev 1500)
@@ -501,6 +501,8 @@
}
#game-desc-controls {
+ position: relative;
+ top: -1.5em;
display: none;
width: 80%;
margin: auto;
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-07-01 23:30:17 UTC (rev 1499)
+++ trunk/Toss/WebClient/index.html 2011-07-02 22:46:56 UTC (rev 1500)
@@ -14,6 +14,7 @@
<script type="text/javascript" src="Play.js"> </script>
<script type="text/javascript" src="Main.js"> </script>
<script type="text/javascript" src="Login.js"> </script>
+ <script type="text/javascript" src="https://apis.google.com/js/plusone.js"> </script>
</head>
<body onload="startup('')">
@@ -87,10 +88,11 @@
<div id="welcome">
<p id="welcome-top">Enjoy the best games on <span class="logo-in">tPlay</span>
- for free
- <a href="http://itunes.apple.com/us/app/tplay/id438620686">
- <img style="height: 2em; float:right;" src="pics/appstore.png" />
- </a>
+ for free <span style="float: right;">
+ <a href="http://itunes.apple.com/us/app/tplay/id438620686"
+ ><img style="height: 24px;" src="pics/appstore-small.png" /></a>
+ <g:plusone></g:plusone>
+ </span>
</p>
<p id="p-under-welcome" style="display: none;">
Strategic games are fun!
@@ -172,6 +174,7 @@
<div id="news">
<h3>News</h3>
<ul id="welcome-list-news" class="welcome-list">
+<li><b>03/07/11</b> Added game descriptions viewable when playing</li>
<li><b>30/06/11</b> View previous moves in a play</li>
<li><b>27/06/11</b> Tabs and searching opponents in the profile page</li>
<li><b>22/06/11</b> Better organized lists of plays</li>
@@ -305,10 +308,48 @@
two bishops, and eight pawns. Pieces move in different assigned ways
according to their type, and accordingly are used to attack and capture
the opponent's pieces. The object of the game is to checkmate
- the opponent's king, whereby the king is under immediate attack
- (in check) if there is no way to move or defend it.</p>
- <p><b>Moves.</b> The moves differ by figure.</p>
- <p><b>Objective.</b> Checkmate.</p>
+ the opponent's king.
+ <p><b>Moves.</b> The moves differ by figure. Please consult the chess link
+ above for a complete explanation with examples.</p>
+ <ul>
+ <li>The king moves one square in any direction. The king has also
+ a special move which is called castling and involves moving two fields
+ towards a rook which has not moved before.</li>
+ <li>The rook can move any number of squares along any rank or file,
+ but may not leap over other pieces. Along with the king, the rook,
+ during the king's castling move, jumps over the king.</li>
+ <li>The bishop can move any number of squares diagonally, but may not
+ leap over other pieces.</li>
+ <li>The queen combines the power of the rook and bishop and can move
+ any number of squares along rank, file, or diagonal, but it may not
+ leap over other pieces.</li>
+ <li>The knight moves to any of the closest squares that are not on
+ the same rank, file, or diagonal, thus the move forms an L-shape
+ two squares long and one square wide. The knight is the only piece
+ that can leap over other pieces.</li>
+ <li>The pawn may move forward to the unoccupied square immediately
+ in front of it on the same file; or on its first move it may advance
+ two squares along the same file provided both squares are unoccupied;
+ or it may move to a square occupied by an opponent's piece which is
+ diagonally in front of it on an adjacent file, capturing that piece.
+ The pawn has two special moves: the en passant capture and pawn
+ promotion. In the first it captures another pawn which has just made a
+ two-field move, in the other one it becomes a queen in the last row.</p>
+ </ul>
+ <p><b>Objective.</b>
+ When a king is under immediate attack by one or more of the opponent's
+ pieces, it is said to be in check. A response to a check is a legal
+ move if it results in a position where the king is no longer under
+ direct attack (that is, not in check). This can involve capturing
+ the checking piece; interposing a piece between the checking piece
+ and the king (which is possible only if the attacking piece is a queen,
+ rook, or bishop and there is a square between it and the king); or
+ moving the king to a square where it is not under attack. Castling is
+ not a permissible response to a check. It is illegal for
+ a player to make a move that would put or leave his own king in check.
+ The objective of the game is to checkmate the opponent; this occurs when
+ the opponent's king is in check, and there is no legal way to remove it
+ from attack.</p>
</div>
<div class="game-desc" id="Connect4-desc">
<p><a href="http://en.wikipedia.org/wiki/Connect4">Connect4</a> (also known
Added: trunk/Toss/WebClient/pics/appstore-small.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/WebClient/pics/appstore-small.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-09 10:28:24
|
Revision: 1507
http://toss.svn.sourceforge.net/toss/?rev=1507&view=rev
Author: lukstafi
Date: 2011-07-09 10:28:17 +0000 (Sat, 09 Jul 2011)
Log Message:
-----------
Reimplementation of GDL to Toss translation: untested work in progress.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLParser.mly
trunk/Toss/GGP/Translate.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-07-06 22:13:35 UTC (rev 1506)
+++ trunk/Toss/Formula/Aux.ml 2011-07-09 10:28:17 UTC (rev 1507)
@@ -204,10 +204,14 @@
| hd::tl ->
List.rev_append (List.map (fun e-> hd, e) tl) (pairs tl)
-let all_tuples_for args elems =
- List.fold_left (fun tups _ ->
+let rec fold_n f accu n =
+ if n <= 0 then accu
+ else fold_n f (f accu) (n-1)
+
+let all_ntuples elems arity =
+ fold_n (fun tups ->
concat_map (fun e -> (List.map (fun tup -> e::tup) tups))
- elems) [[]] args
+ elems) [[]] arity
let rec remove_one e = function
| hd::tl when hd = e -> tl
@@ -486,11 +490,7 @@
| hd::tl ->
aux (List.map (fun e->[e]) hd) tl
-let rec fold_n f accu n =
- if n <= 0 then accu
- else fold_n f (f accu) (n-1)
-
(* Character classes. *)
let is_uppercase c = c >= 'A' && c <= 'Z'
let is_lowercase c = c >= 'a' && c <= 'z'
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-07-06 22:13:35 UTC (rev 1506)
+++ trunk/Toss/Formula/Aux.mli 2011-07-09 10:28:17 UTC (rev 1507)
@@ -132,9 +132,8 @@
elements from the list. *)
val pairs : 'a list -> ('a * 'a) list
-(** An [n]th cartesian power of the second list, where [n] is the
- length of the first list. Tail recursive. *)
-val all_tuples_for : 'a list -> 'b list -> 'b list list
+(** An [n]th cartesian power of the list. Tail recursive. *)
+val all_ntuples : 'a list -> int -> 'a list list
(** Remove an occurrence of a value (uses structural equality). *)
val remove_one : 'a -> 'a list -> 'a list
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-07-06 22:13:35 UTC (rev 1506)
+++ trunk/Toss/Formula/AuxTest.ml 2011-07-09 10:28:17 UTC (rev 1507)
@@ -140,7 +140,7 @@
(Aux.map_try f [`A;`B;`C;`D]);
);
- "product, all_tuples_for, concat_foldr" >::
+ "product, all_ntuples, concat_foldr" >::
(fun () ->
let print_llist l = String.concat "; "
(List.map (String.concat ", ") l) in
@@ -154,11 +154,11 @@
assert_equal ~printer:print_llist
[["a"; "a"]; ["a"; "b"]; ["a"; "c"]; ["b"; "a"]; ["b"; "b"]; ["b"; "c"]; ["c"; "a"]; ["c"; "b"]; ["c"; "c"]]
- (Aux.all_tuples_for [();()] ["a";"b";"c"]);
+ (Aux.all_ntuples ["a";"b";"c"] 2);
assert_equal ~printer:print_llist
[["a"; "a"; "a"]; ["a"; "a"; "b"]; ["a"; "b"; "a"]; ["a"; "b"; "b"]; ["b"; "a"; "a"]; ["b"; "a"; "b"]; ["b"; "b"; "a"]; ["b"; "b"; "b"]]
- (Aux.all_tuples_for [();(); ()] ["a";"b"]);
+ (Aux.all_ntuples ["a";"b"] 3);
assert_equal ~printer:print_llist
[["a1"; "b"; "c"; "a1"; "d"]; ["a2"; "b"; "c"; "a1"; "d"];
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-07-06 22:13:35 UTC (rev 1506)
+++ trunk/Toss/GGP/GDL.ml 2011-07-09 10:28:17 UTC (rev 1507)
@@ -1,33 +1,40 @@
(** {2 Game Description Language.}
- Type definitions, helper functions, game specification. *)
+ Type definitions, operations on terms, saturation (i.e. Herbrand
+ model), clause inlining. *)
+
+(* ************************************************************ *)
+(* ************************************************************ *)
+(** {3 Datalog programs: Type definitions and saturation.} *)
+
open Aux.BasicOperators
let debug_level = ref 0
let aggregate_drop_negative = ref false
let aggregate_fixpoint = ref true
-(** Expand static relations that do not have ground facts, are not
- directly recursive, and have arity above the threshold. *)
-let expand_arity_above = ref 0
-
-(** Treat "next" clauses which introduce metavariables only for
- variable-variable mismatch, as non-erasing frame clauses (to be
- ignored). ("Wave" refers to the process of "propagating the frame
- condition" that these clauses are assumed to do, if
- [nonerasing_frame_wave] is set to [true].) *)
-let nonerasing_frame_wave = ref true
-
type term =
| Const of string
| Var of string
- | MVar of string (* meta-variable, not used in GDL *)
- | Func of string * term list
+ | Func of string * term array
+type rel_atom = string * term list
+(** Positive and negative literals separated, disjunctions expanded-out. *)
+type gdl_rule = rel_atom * rel_atom list * rel_atom list
+(** Collect rules by relations. *)
+type def_branch = term list * rel_atom list * rel_atom list
+type gdl_defs = (string * def_branch list) list
+
+module Terms = Set.Make (
+ struct type t = term let compare = Pervasives.compare end)
+module Atoms = Set.Make (
+ struct type t = rel_atom let compare = Pervasives.compare end)
+
type atom =
| Distinct of term list
- | Rel of string * term list
- | Currently of term
+ | Rel of rel_atom
+ | Role of term
+ | True of term
| Does of term * term
type literal =
@@ -35,51 +42,34 @@
| Neg of atom
| Disj of literal list
-type game_descr_entry =
- | Datalog of string * term list * literal list
- | Next of term * literal list
- | Legal of term * term * literal list
- | Goal of term * int * literal list
- | GoalPattern of term * string * literal list
- | Terminal of literal list
- | Role of term
- | Initial of term * literal list
- | Atomic of string * term list
+type clause = rel_atom * literal list
type request =
- | Start of string * term * game_descr_entry list * int * int
- (* prepare game: match id, role, game, startclock, playclock *)
+ | Start of string * term * clause list * int * int
+ (** prepare game: match id, role, game, startclock, playclock *)
| Play of string * term list
- (* request a move: match id, actions on previous step *)
+ (** request a move: match id, actions on previous step *)
| Stop of string * term list
- (* game ends here: match id, actions on previous step *)
+ (** game ends here: match id, actions on previous step *)
let rec term_str = function
| Const c -> c
| Var v -> "?"^v
- | MVar v -> "@"^v
| Func (f, args) ->
"(" ^ f ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
let rec term_to_name ?(nested=false) = function
| Const c -> c
| Var v -> v
- | MVar v -> v
| Func (f, args) ->
f ^ "_" ^ (if nested then "_S_" else "") ^
String.concat "_" (List.map (term_to_name ~nested:true) args) ^
(if nested then "_Z_" else "")
-let rec vars ?(meta=false) = function
- | Const _ -> []
- | Var x -> [x]
- | MVar x -> if meta then [x] else []
- | Func (_, args) -> Aux.concat_map vars args
-
let rec term_vars = function
| Const _ -> Aux.Strings.empty
- | Var v | MVar v -> Aux.Strings.singleton v
+ | Var v -> Aux.Strings.singleton v
| Func (f, args) -> terms_vars args
and terms_vars args =
@@ -87,166 +77,79 @@
(List.map term_vars args)
-let fact_of_atom = function
- | Distinct args -> assert false
+let rel_of_atom = function
+ | Distinct args -> "distinct", args (* not a proper relation -- avoid *)
| Rel (rel, args) -> rel, args
- | Currently arg -> "true", [arg]
+ | Role arg -> "role", [arg]
+ | True arg -> "true", [arg]
| Does (arg1, arg2) -> "does", [arg1; arg2]
+let atom_of_rel = function
+ | "distinct", args -> Distinct args (* not a proper relation -- avoid *)
+ | "role", [arg] -> Role arg
+ | "true", [arg] -> True arg
+ | "does", [arg1; arg2] -> Does (arg1, arg2)
+ | rel, args -> Rel (rel, args)
+
let rec body_of_literal = function
| Pos (Distinct args) ->
[Aux.Right ("distinct", args)] (* not negated actually! *)
| Neg (Distinct _) -> assert false
- | Pos atom -> [Aux.Left (fact_of_atom atom)]
- | Neg atom -> [Aux.Right (fact_of_atom atom)]
+ | Pos atom -> [Aux.Left (rel_of_atom atom)]
+ | Neg atom -> [Aux.Right (rel_of_atom atom)]
| Disj disjs ->
Aux.concat_map body_of_literal disjs
let func_graph f terms =
Aux.map_some (function Func (g, args) when f=g -> Some args | _-> None) terms
-(* Type shortcuts (mostly for documentation). *)
-type gdl_atom = string * term list
-type gdl_rule = gdl_atom * gdl_atom list * gdl_atom list
-(* Definition with collected relation branches and negation-local
- variables found. *)
-type lit_def_branch =
- term list * gdl_atom list * (Aux.Strings.t * gdl_atom) list
-type lit_def = string * lit_def_branch list
-(* Definition with expanded definitions: expansion of a negated
- relation brings negated (possibly locally existentially quantified)
- conjunctions. *)
-type exp_def_branch =
- term list * gdl_atom list * (Aux.Strings.t * gdl_atom list) list
-type exp_def = string * exp_def_branch list
-module Terms = Set.Make (
- struct type t = term let compare = Pervasives.compare end)
-module Atoms = Set.Make (
- struct type t = string * term list let compare = Pervasives.compare end)
-
-
-let lit_def_br_vars (head, body, neg_body : lit_def_branch) =
+let gdl_rule_vars (head, body, neg_body) =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map terms_vars
- (head::List.map snd body @
- List.map (snd -| snd) neg_body))
+ (head::List.map snd (body @ neg_body)))
-let exp_def_br_vars (head, body, neg_body : exp_def_branch) =
+let gdl_rules_vars brs =
List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map terms_vars
- (head::List.map snd body @
- Aux.concat_map (List.map snd -| snd) neg_body))
+ (List.map gdl_rule_vars brs)
-let lit_def_brs_vars brs =
+let rels_vars body =
List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map lit_def_br_vars brs)
+ (List.map (fun (_,args)->terms_vars args) body)
-let exp_def_brs_vars brs =
- List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map exp_def_br_vars brs)
+let gdl_defs_vars defs =
+ List.fold_left
+ (fun acc rels -> Aux.Strings.union acc (rels_vars rels))
+ Aux.Strings.empty
+ (Aux.concat_map (fun (hd,body,neg_body) ->
+ ("",hd)::body @ neg_body) (Aux.concat_map snd defs))
-let sdef_br_vars (head, body, neg_body) =
- exp_def_br_vars ([head], body, neg_body)
+let rules_of_clause (head, body) =
+ let body, neg_body =
+ Aux.partition_choice (Aux.concat_map body_of_literal body) in
+ head, body, neg_body
-let sdef_brs_vars brs =
- List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map sdef_br_vars brs)
-let rels_vars body =
- List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map (fun (_,args)->terms_vars args) body)
+let clause_vars cl = gdl_rule_vars (rules_of_clause cl)
-let rules_of_entry = function
- | Datalog (rel, args, body) ->
- let head = rel, args in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | Next (head, body) ->
- let head = "next", [head] in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | Legal (arg1, arg2, body) ->
- let head = "legal", [arg1; arg2] in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | Goal (arg, payoff, body) ->
- let head = "goal", [arg; Const (string_of_int payoff)] in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | GoalPattern (arg, var, body) ->
- let head = "goal", [arg; Var var] in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | Terminal body ->
- let head = "terminal", [] in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | Role arg -> [("role", [arg]), [], []]
- | Initial (arg, body) ->
- let head = "init", [arg] in
- let bodies = Aux.product (List.map body_of_literal body) in
- List.map (fun body ->
- let pos_body, neg_body = Aux.partition_choice body in
- head, pos_body, neg_body) bodies
- | Atomic (rel, args) -> [(rel, args), [], []]
+let defs_of_rules rules =
+ Aux.map_reduce (fun ((rel, args), body, neg_body) ->
+ rel, (args, body, neg_body)) (fun y x->x::y) [] rules
-let add_neg_body_vars global_vars neg_body : (Aux.Strings.t * gdl_atom) list =
- List.map (fun (_, args as a)->
- let local_vs = Aux.Strings.diff (terms_vars args) global_vars in
- local_vs, a) neg_body
-
-let lit_defs_of_rules rules : (string * lit_def_branch list) list =
- Aux.map_reduce
- (fun ((drel, params), body, neg_body) ->
- let global_vs =
- Aux.Strings.union (terms_vars params) (rels_vars body) in
- drel,(params, body,
- add_neg_body_vars global_vs neg_body))
- (fun x y->y::x) [] rules
-
-let rules_of_lit_defs (defs : lit_def list) =
+let rules_of_defs defs =
Aux.concat_map (fun (rel, branches) ->
List.map (fun (args, body, neg_body) ->
- let neg_body =
- List.map snd neg_body in
(rel, args), body, neg_body) branches) defs
-let exp_brs_of_lit_brs brs =
- List.map (fun (args, body, neg_body) ->
- let neg_body =
- List.map (fun (vs,a) -> vs,[a]) neg_body in
- args, body, neg_body) brs
-
-let exp_defs_of_lit_defs defs : exp_def list =
- List.map (fun (rel, branches) ->
- rel, exp_brs_of_lit_brs branches) defs
-
-
-(* Stratify either w.r.t. the dependency graph ([~def:true]) or its
- subgraph the negation graph ([~def:false]). *)
-let rec stratify ?(def=false) strata (defs : lit_def list) =
+(* Stratify w.r.t. the negation call-graph. *)
+let rec stratify strata defs =
match
List.partition (fun (_, branches) ->
- List.for_all (fun (_, body, neg_body) ->
- let neg_body = List.map snd neg_body in
+ List.for_all (fun (_, _, neg_body) ->
List.for_all (fun (rel1,_) ->
rel1 = "distinct" || rel1 = "true" || rel1 = "does" ||
- not (List.mem_assoc rel1 defs))
- (if def then body @ neg_body
- else neg_body)) branches) defs
+ not (List.mem_assoc rel1 defs)) neg_body)
+ branches) defs
with
| [], [] ->
(* {{{ log entry *)
@@ -269,28 +172,22 @@
(* }}} *)
List.rev (stratum::strata)
| [], _ ->
- if def then raise
+ raise
(Lexer.Parsing_error
- "GDL.stratify: recursive non-static definitions not handled yet")
- else raise
- (Lexer.Parsing_error
"GDL.stratify: cyclic negation dependency")
| stratum, rules ->
- if not def then
let stratum, more_rules = List.partition (fun (_, branches) ->
List.for_all (fun (_, body, neg_body) ->
List.for_all (fun (rel1,_) ->
rel1 = "distinct" || rel1 = "true" || rel1 = "does" ||
not (List.mem_assoc rel1 rules))
body) branches) stratum in
- stratify ~def (stratum::strata) (more_rules @ rules)
- else stratify ~def (stratum::strata) rules
+ stratify (stratum::strata) (more_rules @ rules)
let rec subst_one (x, term as sb) = function
| Var y when x=y -> term
- | MVar y when x=y -> term
- | (Const _ | Var _ | MVar _ as t) -> t
+ | (Const _ | Var _ as t) -> t
| Func (f, args) ->
Func (f, List.map (subst_one sb) args)
@@ -321,73 +218,9 @@
| _ -> raise Not_found
-(* Match the first argument as term against the second argument as
- pattern. Allow nonlinear (object) variables. *)
-let rec match_meta ?(ignore_meta=false) sb m_sb terms1 terms2 =
- match terms1, terms2 with
- | [], [] -> sb, m_sb
- | (Const _ (* | Var _ *) as a)::terms1,
- (Const _ (* | Var _ *) as b)::terms2
- when a=b -> match_meta ~ignore_meta sb m_sb terms1 terms2
- | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
- match_meta ~ignore_meta sb m_sb (args1 @ terms1) (args2 @ terms2)
- | term::terms1, MVar x::terms2 ->
- (* we don't substitute because metavariables are linear *)
- match_meta ~ignore_meta sb ((x, term)::m_sb) terms1 terms2
- | MVar _::terms1, _::terms2 ->
- if ignore_meta then match_meta ~ignore_meta sb m_sb terms1 terms2
- else raise Not_found
- | term::terms1, Var x::terms2 ->
- let sb1 = x, term in
- let sb =
- if List.mem_assoc x sb then
- if List.assoc x sb = term then sb
- else raise Not_found
- else sb1::sb in
- match_meta ~ignore_meta sb m_sb terms1 terms2
- | _ ->
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "match_meta: unmatched (%s) against pattern (%s)\n%!"
- (String.concat ", " (List.map term_str terms1))
- (String.concat ", " (List.map term_str terms2))
- );
- (* }}} *)
- raise Not_found
-
-
-let generalize term1 term2 =
- let fresh_count = ref 0 in
- let rec loop pf terms1 terms2 =
- match terms1, terms2 with
- | [], [] -> (0, 0), [], []
- | (Const a as cst)::terms1, Const b::terms2 when a=b ->
- let (good_vars, good_csts), mism, gens = loop pf terms1 terms2 in
- (good_vars, good_csts+1), mism, cst::gens
- | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
- let (good_vars1, good_csts1), mism1, gen_args = loop f args1 args2 in
- let (good_vars2, good_csts2), mism2, gens = loop pf terms1 terms2 in
- (good_vars1+good_vars2, good_csts1+good_csts2), mism1 @ mism2,
- (Func (f,gen_args))::gens
- | (Var x as var)::terms1, Var y::terms2 when x=y ->
- let (good_vars, good_csts), mism, gens = loop pf terms1 terms2 in
- (good_vars+1, good_csts), mism, var::gens
- | t1::terms1, t2::terms2 ->
- let measure, mism, gens = loop pf terms1 terms2 in
- incr fresh_count;
- measure, (t1,t2)::mism, MVar ("MV"^string_of_int !fresh_count)::gens
- | _::_, [] | [], _::_ -> raise
- (Lexer.Parsing_error
- ("GDL.generalize: arity mismatch at function "^pf)) in
- let measure, mism, gens = loop "impossible" [term1] [term2] in
- measure, !fresh_count, mism, List.hd gens
-
-
let rec subst sb = function
| Var y as t ->
(try List.assoc y sb with Not_found -> t)
- | MVar y as t ->
- (try List.assoc y sb with Not_found -> t)
| Const _ as t -> t
| Func (f, args) ->
Func (f, List.map (subst sb) args)
@@ -409,6 +242,10 @@
if rel1 = rel2 then unify [] args1 args2
else raise Not_found
+let rels_unify atom1 atom2 =
+ try ignore (unify_rels atom1 atom2); true
+ with Not_found -> false
+
let subst_rel sb (rel, args) = rel, List.map (subst sb) args
let subst_rels sb body = List.map (subst_rel sb) body
@@ -418,12 +255,28 @@
let var_terms = List.map (fun v->Var v) (vars1 @ vars2) in
unify [] var_terms (terms1 @ terms2)
-let subst_br sb (head, body, neg_body) =
- List.map (subst sb) head,
+let subst_br sb (args, body, neg_body) =
+ List.map (subst sb) args,
subst_rels sb body,
List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body
-let fact_str (rel, args) =
+
+let subst_atom sb = function
+ | Distinct args -> Distinct (List.map (subst sb) args)
+ | Rel rel_atom -> Rel (subst_rel sb rel_atom)
+ | Role arg -> Role (subst sb arg)
+ | True arg -> True (subst sb arg)
+ | Does (arg1, arg2) -> Does (subst sb arg1, subst sb arg2)
+
+let rec subst_literal sb = function
+ | Pos atom -> Pos (subst_atom sb atom)
+ | Neg atom -> Neg (subst_atom sb atom)
+ | Disj disjs -> Disj (List.map (subst_literal sb) disjs)
+
+let subst_clause sb (head, body) =
+ subst_rel sb head, List.map (subst_literal sb) body
+
+let rel_atom_str (rel, args) =
"(" ^ rel ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
let tuples_str tups =
@@ -434,40 +287,22 @@
let terms_str facts =
String.concat ", " (List.map term_str facts)
-let facts_str facts = String.concat " " (List.map fact_str facts)
+let rel_atoms_str body = String.concat " " (List.map rel_atom_str body)
-let neg_lfacts_str negs =
+let neg_rel_atoms_str neg_body =
String.concat " "
- (List.map (fun (vs,d) ->
- let vs = Aux.Strings.elements vs in
- let q = if vs = [] then ""
- else "forall "^String.concat ", " vs in
- q ^ "(not "^fact_str d^")") negs)
+ (List.map (fun a -> "(not " ^ rel_atom_str a ^")") neg_body)
-let neg_facts_str negs =
- String.concat " "
- (List.map (fun (vs,d) ->
- let vs = Aux.Strings.elements vs in
- let q = if vs = [] then ""
- else "forall "^String.concat ", " vs in
- q ^ "(not (and "^facts_str d^"))") negs)
-
let branch_str rel (args, body, neg_body) =
- "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
- " " ^ neg_facts_str neg_body ^ ")"
+ "("^ rel_atom_str (rel, args) ^ " <= " ^ rel_atoms_str body ^
+ " " ^ neg_rel_atoms_str neg_body ^ ")"
-let lit_def_str (rel, branches) =
+let def_str (rel, branches) =
String.concat "\n" (List.map (fun (args, body, neg_body) ->
- "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
- " " ^ neg_lfacts_str neg_body ^ ")"
- ) branches)
+ "("^ rel_atom_str (rel, args) ^ " <= " ^ rel_atoms_str body ^
+ " " ^ neg_rel_atoms_str neg_body)
+ branches)
-let exp_def_str (rel, branches) =
- String.concat "\n" (List.map (fun (args, body, neg_body) ->
- "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
- " " ^ neg_facts_str neg_body ^ ")"
- ) branches)
-
let sb_str sb =
String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
@@ -486,7 +321,11 @@
if List.mem head tot_base then []
else if List.exists (fun (rel,args as neg_atom) ->
rel = "distinct" && Aux.not_unique args ||
- List.mem neg_atom tot_base) neg_body then []
+ (* faster option: *)
+ (* List.mem neg_atom tot_base *)
+ (* accurate option: *)
+ List.exists (unifies neg_atom) tot_base
+ ) neg_body then []
else [Aux.Left head]
| head, cond1::body, neg_body ->
Aux.map_try (fun fact ->
@@ -494,7 +333,7 @@
if !debug_level > 5 then (
Printf.printf "instantiate_one: trying to unify %s and %s\n%!"
- (fact_str fact) (fact_str cond1)
+ (rel_atom_str fact) (rel_atom_str cond1)
);
(* }}} *)
@@ -515,7 +354,7 @@
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!"
- (facts_str old_base) (facts_str cur_base);
+ (rel_atoms_str old_base) (rel_atoms_str cur_base);
Printf.printf
"inst_stratum: #old_irules = %d, #cur_irules = %d\n%!"
(List.length old_irules) (List.length cur_irules)
@@ -528,7 +367,7 @@
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "inst_stratum: cur-cur = %s\n%!"
- (facts_str new_base1)
+ (rel_atoms_str new_base1)
);
(* }}} *)
let new_base2, new_irules2 =
@@ -536,7 +375,7 @@
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "inst_stratum: cur-old = %s\n%!"
- (facts_str new_base2)
+ (rel_atoms_str new_base2)
);
(* }}} *)
let new_base3, new_irules3 =
@@ -544,7 +383,7 @@
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "inst_stratum: old-cur = %s\n%!"
- (facts_str new_base3)
+ (rel_atoms_str new_base3)
);
(* }}} *)
let new_base = Aux.unique_sorted (new_base1 @ new_base2 @ new_base3)
@@ -564,9 +403,117 @@
instantiate (inst_stratum [] [] base stratum) strata in
instantiate base
- (List.map rules_of_lit_defs (stratify [] (lit_defs_of_rules rules)))
+ (List.map rules_of_defs (stratify [] (defs_of_rules rules)))
+(* ************************************************************ *)
+(* ************************************************************ *)
+(** {3 Transformations of GDL clauses: inlining, negation.} *)
+(** Expand branches of a definition inlining the provided definitions,
+ only expand positive literals. Iterate expansion to support
+ nesting of definitions. *)
+let expand_positive_lits defs brs =
+ let used_vars = ref (gdl_defs_vars (("",brs)::defs)) in
+ let freshen_brs brs =
+ let br_vars = gdl_defs_vars ["",brs] in
+ let sb = List.map
+ (fun v ->
+ v, Aux.not_conflicting_name ~truncate:true !used_vars v)
+ (Aux.Strings.elements br_vars) in
+ used_vars := Aux.add_strings (List.map snd sb) !used_vars;
+ List.map (subst_br sb) brs in
+ let expand_atom (rel, args as atom) result =
+ (let try def_brs = freshen_brs (List.assoc rel defs) in
+ Aux.concat_map (fun (sb, (head, r_body, r_neg_body)) ->
+ let args = subst_terms sb args in
+ List.map (fun (params,d_body,d_neg_body) ->
+ let sb = unify sb params args in
+ let r_br =
+ head, d_body @ r_body, d_neg_body @ r_neg_body in
+ sb, subst_br sb r_br
+ ) def_brs
+ ) result
+ with Not_found ->
+ List.map (fun (sb,(head,r_body,r_neg_body)) ->
+ sb, atom::r_body, r_neg_body) result) in
+ let expand_br (head, body, neg_body) =
+ let init = [[], (head, [], neg_body)] in
+ Aux.concat_foldr expand_atom body init in
+ let rec fix n_brs brs i =
+ let brs = Aux.concat_map expand_br brs in
+ let new_n_brs = List.length brs in
+ if new_n_brs > n_brs && i > 0 then fix new_n_brs brs (i-1)
+ else brs in
+ fix (List.length brs) brs 5
+
+
+(** Form clause bodies whose disjunction is equivalent to the
+ negation of disjunction of given clause bodies. *)
+let negate_bodies conjs =
+ let placeholder = "", [] in
+ let clauses = List.map (fun body -> placeholder, body) conjs in
+ let clauses = List.map rules_of_clause clauses in
+ let clauses = List.map (fun (_,body,neg_body) ->
+ List.map (fun a -> Pos (atom_of_clause a)) body @
+ List.map (fun a -> Neg (atom_of_clause a)) neg_body) clauses in
+ let negated = Aux.product clauses in
+ (* can raise [Not_found] in case of unsatisfiable "not distinct" *)
+ let nclause body =
+ let uniterms, lits =
+ Aux.partition_map (function
+ | Neg (Distinct terms) -> Left terms
+ | Neg atom -> Pos atom
+ | Pos atom -> Neg atom
+ | Disjunction _ -> assert false) body in
+ let sb = List.fold_left unify_all [] uniterms in
+ List.map (subst_literal sb) lits in
+ Aux.map_try nclause negated
+
+
+(** Rename clauses so that they have disjoint variables. Return a cell
+ storing all variables. *)
+let rename_clauses clauses =
+ let used_vars = ref Aux.Strings.empty in
+ let clauses = List.map (fun cl ->
+ let cl_vars = clause_vars cl in
+ let sb =
+ List.map (fun v ->
+ let nv = Aux.not_conflicting_name ~truncate:true !used_vars v in
+ used_vars := Aux.Strings.add nv !used_vars;
+ v, nv
+ ) cl_vars in
+ subst_clause sb cl
+ ) clauses in
+ used_vars, clauses
+
+
+let flatten_disjs body =
+ let rec aux = function
+ | (Pos _ | Neg _) as lit -> [lit]
+ | Disj lits -> Aux.concat_map aux lits in
+ List.map (function
+ | (Pos _ | Neg _) as lit -> lit
+ | Disj _ as disj -> Disj (aux disj)) body
+
+
+let nnf_dnf body =
+ List.map (function
+ | Pos a -> [Neg a]
+ | Neg a -> [Pos a]
+ | Disj lits ->
+ List.map (function
+ | Pos a -> Neg a
+ | Neg a -> Pos a
+ | _ -> assert false) lits
+ ) (List.map flatten_disjs body)
+
+
+(* ************************************************************ *)
+(* ************************************************************ *)
+(** {3 GDL whole-game operations.}
+
+ Aggregate playout, player-denoting variable elimination. *)
+
(* Collect the aggregate playout, but also the actions available in
the state. *)
exception Playout_over
@@ -578,7 +525,7 @@
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "GDL.aggregate_ply: updated base -- %s\n%!"
- (String.concat " " (List.map fact_str base))
+ (rel_atoms_str base)
);
(* }}} *)
let does = Aux.map_some (fun (rel, args) ->
@@ -714,23 +661,258 @@
loop cycle trav [] cycle tail in
loop [] [] [] [] cands
-let cmp_masks t1 t2 =
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "cmp_masks: %s <= %s .. " (term_str t1) (term_str t2);
- );
- (* }}} *)
- try ignore (match_meta [] [] [t2] [t1]);
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "true\n%!";
- );
- (* }}} *)
- true
- with Not_found ->
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "false\n%!";
- );
- (* }}} *)
- false
+
+let expand_players clauses =
+ let players =
+ Aux.map_some (function
+ | ("role", [player]), _ -> Some player
+ | _ -> None
+ ) clauses in
+ let exp_clause (rel, _ as head, body as clause) =
+ (* determine variables standing for players *)
+ let plvars =
+ let head = if rel = "role" then [] else [head] in
+ Aux.concat_map player_vars_of
+ (...
[truncated message content] |
|
From: <luk...@us...> - 2011-07-13 09:55:34
|
Revision: 1511
http://toss.svn.sourceforge.net/toss/?rev=1511&view=rev
Author: lukstafi
Date: 2011-07-13 09:55:22 +0000 (Wed, 13 Jul 2011)
Log Message:
-----------
GDL translation work in progress. Does not compile yet.
Modified Paths:
--------------
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-07-13 09:54:19 UTC (rev 1510)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-07-13 09:55:22 UTC (rev 1511)
@@ -556,8 +556,20 @@
loc_players, loc_noops
-let loc_graph_turn_based loc_players loc_noops rule_cands =
-
+let loc_graph_turn_based player_nums
+ player_payoffs loc_players loc_noops rule_cands =
+ let graph = Array.mapi
+ (fun loc player ->
+ let player_num = List.assoc (term_to_name player) player_nums in
+ let pl_moves =
+ Array.mapi
+ (fun pl_num payoff ->
+ {Arena.payoff = payoff;
+ view = [];
+ heur = [];
+ moves = if pl_num = player_num then pl_moves else []})
+ players)
+ loc_players in
let loc_graph_general_int =
failwith "GDL: General Interaction Games not implemented yet"
@@ -601,7 +613,7 @@
let graph (*: player_loc array array*) =
match turn_data, rule_cands with
| Some (loc_players, loc_noops), Left cands ->
- loc_graph_turn_based loc_players loc_noops cands
+ loc_graph_turn_based players loc_players loc_noops cands
| None, Left cands ->
loc_graph_general_int
| None, Right cands
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-07-13 09:54:19 UTC (rev 1510)
+++ trunk/Toss/www/reference/reference.tex 2011-07-13 09:55:22 UTC (rev 1511)
@@ -1719,7 +1719,16 @@
we first need to compute erasure clauses to prevent constructing
too general rules in the end.
+\paragraph{Concurrent Moves Games} Introduced in
+Section~\ref{subsec-concurrency}, concurrent moves games use a
+factored approach: since the $d_i$ never share variables,
+\texttt{legal} and \texttt{next} clauses are assigned to players and
+the whole construction of structure rewriting rules is done separately
+for each player. Clauses without a \texttt{does} atom are assigned to
+the ``environment''. (In the interpretation, to reuse code, we simply
+build single-term \texttt{legal} tuples for concurrent moves games.)
+
\subsubsection{Erasure Clauses}
So far, we have not accounted for the fact that rewrite rules of Toss
@@ -1794,11 +1803,8 @@
For each suitable tuple $\ol{\calC}, \ol{\calN}$ we have now created
the unifier $\sigma_{\ol{\calC}, \ol{\calN}}$ and computed the erasure
-clauses $\calE_{\ol{\calC}, \ol{\calN}}$. At this point, clauses
-$\ol{\calC}, \ol{\calN}$ are optionally divided according to the
-player of the \texttt{does} relation atom in them, see
-Section~\ref{subsec-concurrency}. To create the rules, we need to
-further partition the \emph{rule clauses} $\sigma_{\ol{\calC},
+clauses $\calE_{\ol{\calC}, \ol{\calN}}$. To create the rules, we need
+to further partition the \emph{rule clauses} $\sigma_{\ol{\calC},
\ol{\calN}}(\calC_i), \sigma_{\ol{\calC}, \ol{\calN}}(\calN_i)$ and
$\calE_{\ol{\calC}, \ol{\calN}}$, and augment them with further
conditions. The reason is that the prepared rule clauses may have
@@ -2071,8 +2077,8 @@
default way of defining simultaneous moves in Toss. We now elaborate
on three modes of building the game graph in the translated game.
-\subsubsection{Turn-based Games} are games where in any game state there
-is at most a single player having genuine choice. Rather than
+\subsubsection{Turn-based Games} are games where in any game state
+there is at most a single player having genuine choice. Rather than
attempting a complex analysis to detect as many turn-based games as
possible, we recognize some cases where in all states, all players but
one have a single legal move that is a constant (term of size
@@ -2084,7 +2090,9 @@
single-player game is also a turn-based game, as another example in a
three-player game the first player may intersperse the moves of second
and third player). We build a corresponding cyclic graph of Toss
-locations.
+locations. We limit the turn-based translation to the case where all
+rule clauses have exactly one \texttt{does} atom (\ie can be
+attributed to exactly one of the players).
\subsubsection{Concurrent Moves Games} \label{par-concurrent-moves}
When translation as a turn-based game fails, but all rule clauses have
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-14 15:52:00
|
Revision: 1512
http://toss.svn.sourceforge.net/toss/?rev=1512&view=rev
Author: lukaszkaiser
Date: 2011-07-14 15:51:48 +0000 (Thu, 14 Jul 2011)
Log Message:
-----------
Small changes to sync compile stuff.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Solver/Structure.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-07-13 09:55:22 UTC (rev 1511)
+++ trunk/Toss/GGP/GDL.ml 2011-07-14 15:51:48 UTC (rev 1512)
@@ -57,14 +57,16 @@
| Const c -> c
| Var v -> "?"^v
| Func (f, args) ->
- "(" ^ f ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
+ "(" ^ f ^ " " ^
+ String.concat " " (List.map term_str (Array.to_list args)) ^ ")"
let rec term_to_name ?(nested=false) = function
| Const c -> c
| Var v -> v
| Func (f, args) ->
f ^ "_" ^ (if nested then "_S_" else "") ^
- String.concat "_" (List.map (term_to_name ~nested:true) args) ^
+ String.concat "_" (List.map (term_to_name ~nested:true)
+ (Array.to_list args)) ^
(if nested then "_Z_" else "")
let rec term_vars = function
@@ -74,7 +76,7 @@
and terms_vars args =
List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map term_vars args)
+ (List.map term_vars (Array.to_list args))
let rel_of_atom = function
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-07-13 09:55:22 UTC (rev 1511)
+++ trunk/Toss/GGP/GDL.mli 2011-07-14 15:51:48 UTC (rev 1512)
@@ -104,3 +104,16 @@
term list * (term list list list * term list list)
val find_cycle : term option list -> term option list
+
+
+(** A path is a position in a tree together with labels on nodes from
+ the root to that position (but excluding the position). *)
+type path = (string * int) list
+
+(** A trie representing a set of paths. *)
+type path_set =
+ | Empty
+ | Here (** Singleton $\{\epsilon\}$. *)
+ | Below of (string * path_set array) list
+ | Here_and_below of (string * path_set array) list
+(* Subtries are in sorted order. *)
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-07-13 09:55:22 UTC (rev 1511)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-07-14 15:51:48 UTC (rev 1512)
@@ -1,4 +1,3 @@
-
type tossrule_data = {
lead_legal : GDL.term;
(* the "legal"/"does" term of the player that performs the move, we
@@ -10,7 +9,7 @@
terms *)
struc_elems : string list;
fixvar_elemvars :
- (string * (term * (string * string list) list) list) list;
+ (string * (GDL.term * (string * string list) list) list) list;
(* "state" terms indexed by variables that they contain, together
with the mask-path of the variable *)
elemvars : GDL.term Aux.StrMap.t;
@@ -21,7 +20,7 @@
type gdl_translation = {
(* map between structure elements and their term representations;
the reverse direction is by using element names *)
- elem_term_map : term Aux.IntMap.t;
+ elem_term_map : GDL.term Aux.IntMap.t;
f_paths : GDL.path_set;
m_paths : GDL.path_set;
masks : GDL.term list;
@@ -31,4 +30,4 @@
val translate_game :
- clause list -> gdl_translation * (Arena.game * Arena.game_state)
+ GDL.clause list -> gdl_translation * (Arena.game * Arena.game_state)
Modified: trunk/Toss/Server/ReqHandler.mli
===================================================================
--- trunk/Toss/Server/ReqHandler.mli 2011-07-13 09:55:22 UTC (rev 1511)
+++ trunk/Toss/Server/ReqHandler.mli 2011-07-14 15:51:48 UTC (rev 1512)
@@ -18,7 +18,7 @@
Formula.real_expr array array option (** heuristic option *)
* bool (** game modified *)
* (Arena.game * Arena.game_state) (** game and state *)
- * Translate.gdl_translation (** current gdl translation *)
+ * TranslateGame.gdl_translation (** current gdl translation *)
* int (** playclock *)
val init_state : req_state
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2011-07-13 09:55:22 UTC (rev 1511)
+++ trunk/Toss/Solver/Structure.ml 2011-07-14 15:51:48 UTC (rev 1512)
@@ -264,10 +264,10 @@
(* Add tuple [tp] to relation [rn] in structure [struc]. *)
let add_rel_named_elems struc rn tp =
let new_struc, tp =
- Array.fold_right (fun (struc, tp) e ->
+ Array.fold_right (fun e (struc, tp) ->
let struc, e = find_or_new_elem struc e in
- struc, e::tp)
- (add_rel_name rn (Array.length tp) struc) tp in
+ struc, e::tp) tp
+ ((add_rel_name rn (Array.length tp) struc), []) in
let tp = Array.of_list tp in
let add_to_relmap rmap =
let tps = StringMap.find rn rmap in
@@ -275,14 +275,14 @@
let new_rel = add_to_relmap new_struc.relations in
let add_to_imap imap e =
try
- IntMap.add e (Tuples.add tp (IntMap.find e imap)) imap
+ TIntMap.add e (Tuples.add tp (TIntMap.find e imap)) imap
with Not_found ->
- IntMap.add e (Tuples.singleton tp) imap in
+ TIntMap.add e (Tuples.singleton tp) imap in
let new_incidence_imap =
try
Array.fold_left add_to_imap (StringMap.find rn new_struc.incidence) tp
with Not_found ->
- Array.fold_left add_to_imap IntMap.empty tp in
+ Array.fold_left add_to_imap TIntMap.empty tp in
let new_incidence = StringMap.add rn new_incidence_imap new_struc.incidence in
{ new_struc with relations = new_rel ; incidence = new_incidence }
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-14 22:56:50
|
Revision: 1513
http://toss.svn.sourceforge.net/toss/?rev=1513&view=rev
Author: lukstafi
Date: 2011-07-14 22:56:38 +0000 (Thu, 14 Jul 2011)
Log Message:
-----------
GDL translation work in progress. Does not compile yet.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/TranslateGame.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-07-14 15:51:48 UTC (rev 1512)
+++ trunk/Toss/Formula/Aux.ml 2011-07-14 22:56:38 UTC (rev 1513)
@@ -441,6 +441,15 @@
done;
true
with Not_found -> false
+
+let array_for_alli f a =
+ try
+ for i = 0 to Array.length a - 1 do
+ if not (f i (Array.unsafe_get a i)) then
+ raise Not_found
+ done;
+ true
+ with Not_found -> false
let array_for_all2 f a b =
let len = Array.length a in
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-07-14 15:51:48 UTC (rev 1512)
+++ trunk/Toss/Formula/Aux.mli 2011-07-14 22:56:38 UTC (rev 1513)
@@ -216,6 +216,9 @@
(** Find if a predicate holds for all elements. *)
val array_for_all : ('a -> bool) -> 'a array -> bool
+(** Find if a position-dependent predicate holds for all elements. *)
+val array_for_alli : (int -> 'a -> bool) -> 'a array -> bool
+
(** Find if a predicate holds for all elements of two arrays
pointwise. Raises [Invalid_argument "Aux.array_for_all2"] if
arrays are of different lengths. *)
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-07-14 15:51:48 UTC (rev 1512)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-07-14 22:56:38 UTC (rev 1513)
@@ -22,6 +22,7 @@
(** Use "true" atoms while computing rule cases. *)
let split_on_state_atoms = ref false
+let env_player = Const "ENVIRONMENT"
type tossrule_data = {
lead_legal : term;
@@ -51,6 +52,9 @@
masks : term list;
tossrule_data : tossrule_data Aux.StrMap.t;
(* rule name to rule translation data *)
+ turnbased_noops : term array array option;
+ (* in case of a turn-based translation, for each location and each
+ player, the player's noop move (if any) for the location *)
}
(* [most_similar c ts] finds a term from [ts] most similar to [c], and
@@ -230,8 +234,11 @@
(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Do not remove the
- "does" atoms from clauses. *)
-let move_tuples used_vars next_cls legal_tuples =
+ "does" atoms from clauses. Also handles as special cases:
+ "concurrent" case with selecting clauses for only one player, and
+ "environment" case for selecting clauses not dependent on any
+ player. *)
+let move_tuples used_vars next_cls mode players legal_tuples =
(* computing the $d_i(\calN)$ for each $\calN$ *)
let fresh_x_f () =
let x_f = Aux.not_conflicting_name !used_vars "x_f" in
@@ -246,14 +253,24 @@
let sb = unify_all sb djs in
let d =
match djs with
- | [] -> fresh_x_f ()
+ | [] ->
+ if mode = `Concurrent then raise Not_found
+ else fresh_x_f ()
| d::_ -> subst sb d in
sb, d::dis
) players ([], []) in
let next_cls =
- Aux.map_try (fun cl ->
- let sb, ds = does_facts cl in
- subst_clause sb cl, ds) next_cls in
+ if mode = `Environment
+ then
+ List.map_some (fun (_,body as cl) ->
+ if List.mem (function Does _ -> true | _ -> false) body
+ then None
+ else Some (cl, [])
+ ) next_cls
+ else
+ Aux.map_try (fun cl ->
+ let sb, ds = does_facts cl in
+ subst_clause sb cl, ds) next_cls in
(* selecting $\ol{\calC},\ol{\calN}$ clauses with
$\sigma_{\ol{\calC},\ol{\calN}}$ applied *)
let tup_unifies ts1 ts2 =
@@ -416,8 +433,15 @@
let general_int_rule_cases (legal_tup, next_cls) =
failwith "General Interaction Games not implemented yet"
-(* The candidates need to be filtered before finishing the
- translation of Toss rules. *)
+(* Generate rule candidates (they need to be filtered before finishing
+ the translation of Toss rules): returns the "legal" terms tuple
+ (ordered by players), the right-hand-sides, and the conditions
+ (concatenated bodies of the selected "legal" and "next" clauses).
+
+ The "concurrent games" case is handled specifically. Instead of
+ rules for tuples of "legal" terms, rules for a single legal term
+ are built. The rules are partitioned among players. The first
+ player is the environment, [env_player]. *)
let create_rule_cands is_turn_based used_vars next_cls clauses =
let players = (* Array.of_list *)
Aux.map_some (function
@@ -442,22 +466,26 @@
| ("legal",[lp; l]), body when lp = p -> Some (l, body)
| _ -> None) legal_cls
) players in
- let process_rule_cands legal_tuples =
- let move_tups = move_tuples used_vars next_cls legal_tuples in
+ let process_rule_cands mode players legal_tuples =
let move_tups =
+ move_tuples used_vars next_cls mode players legal_tuples in
+ let move_tups =
List.map (fun (sb, legal_tup, n_cls) ->
List.map (subst sb) legal_tup,
List.map (subst_clause sb) n_cls) move_tups in
List.map add_erasure_clauses move_tups in
let concurrent_rule_cands player legal_cls =
let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
- let move_tups = process_rule_cands legal_tuples in
- player, Aux.concat_map nonint_rule_cases move_tups
+ let move_tups =
+ process_rule_cands `Concurrent [player] legal_tuples in
+ player, Aux.concat_map nonint_rule_cases (move_tups @ env_tups)
if is_concurrent then
- Right (List.map2 concurrent_rule_cands players legal_by_player)
+ let env_tups =
+ env_player, process_rule_cands `Environment [] [[]] in
+ Right (env_tups @ List.map2 concurrent_rule_cands players legal_by_player)
else
let legal_tuples = Aux.product legal_by_player in
- let move_tups = process_rule_cands legal_tuples in
+ let move_tups = process_rule_cands `General players legal_tuples in
if is_turn_based then
Left (Aux.concat_map nonint_rule_cases move_tups)
else
@@ -556,27 +584,140 @@
loc_players, loc_noops
+let build_toss_rule transl_data rule_names struc fluents
+ synch_precond synch_postcond (legal_tup, case_rhs, case_cond) =
+ let rname =
+ Aux.not_conflicting_name rule_names
+ (String.concat "_" (List.map term_to_name legal_tup)) in
+ rule_names := Aux.Strings.add rname !rule_names;
+ let label =
+ {Arena.rule = rname; time_in = 0.1, 0.1; parameters_in = []} in
+ let precond =
+ synch_precond @ TranslateFormula.translate transl_data case_cond in
+ let rhs_pos = Aux.concat_map
+ (function _, [sterm] ->
+ let s_subterms =
+ map_paths (fun path subt -> subt, path) transl_data.f_paths sterm in
+ let s_subterms = List.filter
+ (fun (subt, _) -> subt <> blank) s_subterms in
+ let vartup = [|var_of_term data sterm|] in
+ List.map (fun (subt, path) ->
+ pred_on_path_subterm path subt, vartup)
+ s_subterms
+ | _ -> assert false)
+ case_rhs in
+ let rhs_pos = synch_postcond @ rhs_pos in
+ let signat = Structure.rel_signature struc in
+ let discrete =
+ DiscreteRule.translate_from_precond ~precond
+ ~add:rhs_pos ~emb_rels:fluents ~signat ~struc_elems in
+ let rule =
+ ContinuousRule.make_rule signature [] discrete
+ [] [] ~pre:discrete.DiscreteRule.pre () in
+ label, (rname, rule)
+
+
let loc_graph_turn_based player_nums
- player_payoffs loc_players loc_noops rule_cands =
+ player_payoffs loc_players loc_noops build_rule rule_cands =
+ let rules = ref [] in
+ let loc_n = Array.length loc_players in
+ let player_rules = Aux.collect player_rules in
let graph = Array.mapi
(fun loc player ->
let player_num = List.assoc (term_to_name player) player_nums in
+ (* a rule belongs to a player if other players' legal terms
+ in the legal tuple are their noop terms for current location *)
+ let loc_rules = Aux.map_some
+ (fun (legal_tup, _, _ as rcand) ->
+ let legal_tup = Array.of_list legal_tup in
+ if Array.for_alli
+ (fun pl noop -> pl = player_num ||
+ Some legal_tup.(pl) = noop)
+ loc_noops.(loc)
+ then Some (build_rule rcand)
+ else None
+ ) rule_cands in
+ let labels, loc_rules = List.split loc_rules in
+ rules := !rules @ loc_rules;
let pl_moves =
+ List.map (fun l -> l, (loc + 1) mod loc_n) labels in
Array.mapi
(fun pl_num payoff ->
{Arena.payoff = payoff;
view = [];
heur = [];
moves = if pl_num = player_num then pl_moves else []})
- players)
+ player_payoffs)
loc_players in
+ graph, !rules
+
+let sControl = "CONTROL__"
let loc_graph_general_int =
failwith "GDL: General Interaction Games not implemented yet"
-let loc_graph_concurrent =
-()
+(* Remember that "environment" is the 0th player -- also in payoffs
+ list. [rule_cands] is a player-indexed array. [players] are all
+ player terms, excluding "environment". *)
+let loc_graph_concurrent players
+ player_payoffs struc build_rule rule_cands =
+ (* finding or creating the control predicate *)
+ let control_pred, control_e, struc =
+ try
+ let control_pred, _ =
+ List.find (fun (rel, ar) -> ar = 1 &&
+ Structure.Tuples.cardinal (Structure.find_rel rel struc) = 1)
+ (Structure.rel_signature struc) in
+ let etup = Structure.Tuples.choose_elem
+ (Structure.find_rel control_pred struc) in
+ control_pred, etup.(0), struc
+ with Not_found ->
+ let struc, control_e =
+ Structure.add_new_elem struc ~name:sControl () in
+ let struc = Structure.add_rel struc [|control_e|] in
+ sControl, control_e, struc in
+ (* adding synchronization to rules and putting it all together *)
+ let player_pred pl = term_to_name pl ^ "__SYNC" in
+ let struc = List.fold_left
+ (fun struc player ->
+ Structure.add_rel_name (player_pred player) 1) players in
+ let control_v =
+ Formula.fo_var_of_string (Structure.elem_name struc control_e) in
+ let player_marker pl =
+ [player_pred pl, [|control_v|]; control_pred, [|control_v|]] in
+ let all_players_precond =
+ (List.map (fun (rel,tup) -> Formula.Rel (rel,tup)))
+ (Aux.concat_map player_marker players) in
+ let rules = ref [] in
+ let player_moves = Array.mapi
+ (fun pl_num (pl, p_rules) ->
+ let p_rules = List.map
+ (fun rcand ->
+ if pl_num = 0 then (* environment *)
+ build_rule struc fluents all_players_precond [] rcand
+ else
+ build_rule struc fluents [] (player_marker pl) rcand)
+ p_rules in
+ (* we need to build first before adding [player_cond] because
+ of how formula translation works *)
+ let labels, p_rules = List.split p_rules in
+ rules := !rules @ p_rules;
+ List.map (fun l -> l, (loc + 1) mod loc_n))
+ rule_cands in
+ let graph =
+ [|
+ Aux.array_map2
+ (fun payoff moves ->
+ {Arena.payoff = payoff;
+ view = [];
+ heur = [];
+ moves = moves})
+ player_payoffs player_moves
+ |] in
+ (graph, !rules), struc
+
+
let translate_game clauses =
let clauses = expand_players clauses in
let used_vars, clauses = rename_clauses clauses in
@@ -610,14 +751,21 @@
) clauses) in
let player_names = Array.to_list
(Array.mapi (fun i p -> term_to_name p, i) players) in
- let graph (*: player_loc array array*) =
+ (* possibly update the structure with a control element and predicate *)
+ let (graph, rules), struc =
match turn_data, rule_cands with
| Some (loc_players, loc_noops), Left cands ->
- loc_graph_turn_based players loc_players loc_noops cands
+ let build_rule =
+ build_toss_rule transl_data rule_names struc fluents [] [] in
+ loc_graph_turn_based players loc_players loc_noops build_rule
+ cands, struc
| None, Left cands ->
loc_graph_general_int
| None, Right cands
- loc_graph_concurrent
+ let build_rule =
+ build_toss_rule transl_data rule_names in
+ loc_graph_concurrent players player_payoffs struc build_rule
+ rule_cands
| _ -> assert false
in
let game = {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-26 19:51:02
|
Revision: 1517
http://toss.svn.sourceforge.net/toss/?rev=1517&view=rev
Author: lukstafi
Date: 2011-07-26 19:50:54 +0000 (Tue, 26 Jul 2011)
Log Message:
-----------
GDL translation work in progress (simple debugging). Does not compile yet.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-07-19 15:20:56 UTC (rev 1516)
+++ trunk/Toss/GGP/GDL.ml 2011-07-26 19:50:54 UTC (rev 1517)
@@ -18,20 +18,22 @@
| Var of string
| Func of string * term array
-type rel_atom = string * term list
+type rel_atom = string * term array
(** Positive and negative literals separated, disjunctions expanded-out. *)
type gdl_rule = rel_atom * rel_atom list * rel_atom list
(** Collect rules by relations. *)
-type def_branch = term list * rel_atom list * rel_atom list
+type def_branch = term array * rel_atom list * rel_atom list
type gdl_defs = (string * def_branch list) list
+type substitution = (string * term) list
+
module Terms = Set.Make (
struct type t = term let compare = Pervasives.compare end)
module Atoms = Set.Make (
struct type t = rel_atom let compare = Pervasives.compare end)
type atom =
- | Distinct of term list
+ | Distinct of term array
| Rel of rel_atom
| Role of term
| True of term
@@ -58,15 +60,15 @@
| Var v -> "?"^v
| Func (f, args) ->
"(" ^ f ^ " " ^
- String.concat " " (List.map term_str (Array.to_list args)) ^ ")"
+ String.concat " " (Array.to_list (Array.map term_str args)) ^ ")"
let rec term_to_name ?(nested=false) = function
| Const c -> c
| Var v -> v
| Func (f, args) ->
f ^ "_" ^ (if nested then "_S_" else "") ^
- String.concat "_" (List.map (term_to_name ~nested:true)
- (Array.to_list args)) ^
+ String.concat "_"
+ (Array.to_list (Array.map (term_to_name ~nested:true) args)) ^
(if nested then "_Z_" else "")
let rec term_vars = function
@@ -75,27 +77,36 @@
| Func (f, args) -> terms_vars args
and terms_vars args =
- List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map term_vars (Array.to_list args))
+ Array.fold_left Aux.Strings.union Aux.Strings.empty
+ (Array.map term_vars args)
+let rec atoms_of_body body =
+ Aux.concat_map
+ (function Pos a -> [a] | Neg a -> [a]
+ | Disj ds -> atoms_of_body ds) body
+let atoms_of_clause (rel_atom, body) =
+ Rel rel_atom :: atoms_of_body body
+
let rel_of_atom = function
- | Distinct args -> "distinct", args (* not a proper relation -- avoid *)
+ | Distinct args -> "distinct", args
+ (* not a proper relation -- avoid *)
| Rel (rel, args) -> rel, args
- | Role arg -> "role", [arg]
- | True arg -> "true", [arg]
- | Does (arg1, arg2) -> "does", [arg1; arg2]
+ | Role arg -> "role", [|arg|]
+ | True arg -> "true", [|arg|]
+ | Does (arg1, arg2) -> "does", [|arg1; arg2|]
let atom_of_rel = function
- | "distinct", args -> Distinct args (* not a proper relation -- avoid *)
- | "role", [arg] -> Role arg
- | "true", [arg] -> True arg
- | "does", [arg1; arg2] -> Does (arg1, arg2)
+ | "distinct", args -> Distinct args
+ (* not a proper relation -- avoid *)
+ | "role", [|arg|] -> Role arg
+ | "true", [|arg|] -> True arg
+ | "does", [|arg1; arg2|] -> Does (arg1, arg2)
| rel, args -> Rel (rel, args)
let rec body_of_literal = function
| Pos (Distinct args) ->
- [Aux.Right ("distinct", args)] (* not negated actually! *)
+ [Aux.Right ("distinct", args)] (* not negated actually! *)
| Neg (Distinct _) -> assert false
| Pos atom -> [Aux.Left (rel_of_atom atom)]
| Neg atom -> [Aux.Right (rel_of_atom atom)]
@@ -106,33 +117,31 @@
Aux.map_some (function Func (g, args) when f=g -> Some args | _-> None) terms
-let gdl_rule_vars (head, body, neg_body) =
+let gdl_rule_vars ((_,head_args), body, neg_body) =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map terms_vars
- (head::List.map snd (body @ neg_body)))
+ (head_args::List.map snd (body @ neg_body)))
let gdl_rules_vars brs =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map gdl_rule_vars brs)
-let rels_vars body =
+let rels_vars (body : (string * term array) list) =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map (fun (_,args)->terms_vars args) body)
let gdl_defs_vars defs =
- List.fold_left
- (fun acc rels -> Aux.Strings.union acc (rels_vars rels))
- Aux.Strings.empty
- (Aux.concat_map (fun (hd,body,neg_body) ->
- ("",hd)::body @ neg_body) (Aux.concat_map snd defs))
+ rels_vars
+ (Aux.concat_map (fun (hd,body,neg_body) ->
+ ("",hd)::body @ neg_body) (Aux.concat_map snd defs))
-let rules_of_clause (head, body) =
+let rule_of_clause (head, body) =
let body, neg_body =
Aux.partition_choice (Aux.concat_map body_of_literal body) in
head, body, neg_body
-let clause_vars cl = gdl_rule_vars (rules_of_clause cl)
+let clause_vars cl = gdl_rule_vars (rule_of_clause cl)
let defs_of_rules rules =
Aux.map_reduce (fun ((rel, args), body, neg_body) ->
@@ -191,7 +200,7 @@
| Var y when x=y -> term
| (Const _ | Var _ as t) -> t
| Func (f, args) ->
- Func (f, List.map (subst_one sb) args)
+ Func (f, Array.map (subst_one sb) args)
(* Eliminate [terms1] variables when possible. *)
let rec unify sb terms1 terms2 =
@@ -200,7 +209,7 @@
| Const a::terms1, Const b::terms2 when a=b ->
unify sb terms1 terms2
| Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
- unify sb (args1 @ terms1) (args2 @ terms2)
+ unify sb (Array.to_list args1 @ terms1) (Array.to_list args2 @ terms2)
| Var x::terms1, Var y::terms2 when x=y ->
unify sb terms1 terms2
| (Var x::terms1, (Var _ | Const _ as term)::terms2
@@ -219,13 +228,15 @@
(List.map (subst_one sb1) terms2)
| _ -> raise Not_found
+let unify_args args1 args2 =
+ unify [] (Array.to_list args1) (Array.to_list args2)
let rec subst sb = function
| Var y as t ->
(try List.assoc y sb with Not_found -> t)
| Const _ as t -> t
| Func (f, args) ->
- Func (f, List.map (subst sb) args)
+ Func (f, Array.map (subst sb) args)
let rec unify_all sb = function
| [] | [_] -> sb
@@ -241,14 +252,14 @@
with Not_found -> false
let unify_rels (rel1, args1) (rel2, args2) =
- if rel1 = rel2 then unify [] args1 args2
+ if rel1 = rel2 then unify_args args1 args2
else raise Not_found
let rels_unify atom1 atom2 =
try ignore (unify_rels atom1 atom2); true
with Not_found -> false
-let subst_rel sb (rel, args) = rel, List.map (subst sb) args
+let subst_rel sb (rel, args) = rel, Array.map (subst sb) args
let subst_rels sb body = List.map (subst_rel sb) body
let compose_sb sb1 sb2 =
@@ -258,13 +269,13 @@
unify [] var_terms (terms1 @ terms2)
let subst_br sb (args, body, neg_body) =
- List.map (subst sb) args,
+ Array.map (subst sb) args,
subst_rels sb body,
- List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body
+ subst_rels sb neg_body
let subst_atom sb = function
- | Distinct args -> Distinct (List.map (subst sb) args)
+ | Distinct args -> Distinct (Array.map (subst sb) args)
| Rel rel_atom -> Rel (subst_rel sb rel_atom)
| Role arg -> Role (subst sb arg)
| True arg -> True (subst sb arg)
@@ -279,13 +290,9 @@
subst_rel sb head, List.map (subst_literal sb) body
let rel_atom_str (rel, args) =
- "(" ^ rel ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
+ "(" ^ rel ^ " " ^
+ String.concat " " (Array.to_list (Array.map term_str args)) ^ ")"
-let tuples_str tups =
- let tup_str tup =
- "("^String.concat " " (List.map term_str tup) ^")" in
- String.concat " " (List.map tup_str tups)
-
let terms_str facts =
String.concat ", " (List.map term_str facts)
@@ -309,7 +316,7 @@
String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
let proto_rel_str (rel, args) =
- rel ^"(" ^ String.concat ", " (Array.to_list args) ^")"
+ rel ^"(" ^ String.concat ", " args ^")"
(* TODO: optimize by using rel-indexing (also in [aggregate_playout]).
@@ -317,16 +324,17 @@
(* Variables still left after saturation have universal interpretation! *)
let saturate base rules =
- let instantiate_one tot_base cur_base irules =
+ let instantiate_one (tot_base : rel_atom list)
+ (cur_base : rel_atom list) irules =
Aux.concat_map (function
| head, [], neg_body ->
if List.mem head tot_base then []
else if List.exists (fun (rel,args as neg_atom) ->
- rel = "distinct" && Aux.not_unique args ||
+ rel = "distinct" && Aux.not_unique (Array.to_list args) ||
(* faster option: *)
(* List.mem neg_atom tot_base *)
(* accurate option: *)
- List.exists (unifies neg_atom) tot_base
+ List.exists (rels_unify neg_atom) tot_base
) neg_body then []
else [Aux.Left head]
| head, cond1::body, neg_body ->
@@ -423,27 +431,28 @@
v, Aux.not_conflicting_name ~truncate:true !used_vars v)
(Aux.Strings.elements br_vars) in
used_vars := Aux.add_strings (List.map snd sb) !used_vars;
+ let sb = List.map (fun (v,t) -> v, Var t) sb in
List.map (subst_br sb) brs in
- let expand_atom (rel, args as atom) result =
+ (* FIXME: make sure it's OK!!! *)
+ let expand_atom (rel, args as atom)
+ (sb, (head, r_body, r_neg_body)) =
(let try def_brs = freshen_brs (List.assoc rel defs) in
- Aux.concat_map (fun (sb, (head, r_body, r_neg_body)) ->
- let args = subst_terms sb args in
- List.map (fun (params,d_body,d_neg_body) ->
- let sb = unify sb params args in
- let r_br =
- head, d_body @ r_body, d_neg_body @ r_neg_body in
- sb, subst_br sb r_br
- ) def_brs
- ) result
+ let args = Array.map (subst sb) args in
+ List.map (fun (params,d_body,d_neg_body) ->
+ let sb = unify sb (Array.to_list params) (Array.to_list args) in
+ let r_br =
+ head, d_body @ r_body, d_neg_body @ r_neg_body in
+ sb, subst_br sb r_br
+ ) def_brs
with Not_found ->
- List.map (fun (sb,(head,r_body,r_neg_body)) ->
- sb, atom::r_body, r_neg_body) result) in
+ [sb, (head, atom::r_body, r_neg_body)]) in
let expand_br (head, body, neg_body) =
let init = [[], (head, [], neg_body)] in
Aux.concat_foldr expand_atom body init in
let rec fix n_brs brs i =
let brs = Aux.concat_map expand_br brs in
let new_n_brs = List.length brs in
+ let brs = List.map snd brs in
if new_n_brs > n_brs && i > 0 then fix new_n_brs brs (i-1)
else brs in
fix (List.length brs) brs 5
@@ -454,19 +463,19 @@
let negate_bodies conjs =
let placeholder = "", [] in
let clauses = List.map (fun body -> placeholder, body) conjs in
- let clauses = List.map rules_of_clause clauses in
+ let clauses = List.map rule_of_clause clauses in
let clauses = List.map (fun (_,body,neg_body) ->
- List.map (fun a -> Pos (atom_of_clause a)) body @
- List.map (fun a -> Neg (atom_of_clause a)) neg_body) clauses in
+ List.map (fun a -> Pos (atom_of_rel a)) body @
+ List.map (fun a -> Neg (atom_of_rel a)) neg_body) clauses in
let negated = Aux.product clauses in
(* can raise [Not_found] in case of unsatisfiable "not distinct" *)
let nclause body =
let uniterms, lits =
Aux.partition_map (function
- | Neg (Distinct terms) -> Left terms
- | Neg atom -> Pos atom
- | Pos atom -> Neg atom
- | Disjunction _ -> assert false) body in
+ | Neg (Distinct terms) -> Aux.Left (Array.to_list terms)
+ | Neg atom -> Aux.Right (Pos atom)
+ | Pos atom -> Aux.Right (Neg atom)
+ | Disj _ -> assert false) body in
let sb = List.fold_left unify_all [] uniterms in
List.map (subst_literal sb) lits in
Aux.map_try nclause negated
@@ -482,8 +491,8 @@
List.map (fun v ->
let nv = Aux.not_conflicting_name ~truncate:true !used_vars v in
used_vars := Aux.Strings.add nv !used_vars;
- v, nv
- ) cl_vars in
+ v, Var nv
+ ) (Aux.Strings.elements cl_vars) in
subst_clause sb cl
) clauses in
used_vars, clauses
@@ -507,7 +516,7 @@
| Pos a -> Neg a
| Neg a -> Pos a
| _ -> assert false) lits
- ) (List.map flatten_disjs body)
+ ) (flatten_disjs body)
(* ************************************************************ *)
@@ -522,7 +531,7 @@
let aggregate_ply players static current rules =
let base =
- Aux.map_prepend static (fun term -> "true", [term]) current in
+ Aux.map_prepend static (fun term -> "true", [|term|]) current in
let base = saturate (base @ static) rules in
(* {{{ log entry *)
if !debug_level > 4 then (
@@ -535,15 +544,15 @@
if (* no move *)
Aux.array_existsi (fun _ player ->
List.for_all (function
- |_, (Var _::_) -> false
- | _, (actor::_) -> player <> actor | _ -> true)
+ |_, [|Var _; _ |] -> false
+ | _, [|actor; _ |] -> player <> actor | _ -> true)
does) players
then (
(* {{{ log entry *)
if !debug_level > 0 then (
let players_nomove =
Aux.array_find_all (fun player ->
- List.for_all (function _, (actor::_) -> player <> actor
+ List.for_all (function _, [|actor; _|] -> player <> actor
| _ -> true)
does) players in
Printf.printf
@@ -554,11 +563,11 @@
raise Playout_over)
else
let step = saturate (does @ base) rules in
- let step = Aux.map_some (function ("next", [arg]) -> Some arg
+ let step = Aux.map_some (function ("next", [|arg|]) -> Some arg
| _ -> None) step in
if !aggregate_fixpoint && (* fixpoint reached *)
List.for_all (function
- | Func (_,[arg]) when
+ | Func (_,[|arg|]) when
Aux.array_existsi (fun _ player -> arg=player) players -> true
| term -> List.mem term current
) step
@@ -594,8 +603,8 @@
let static_base = saturate [] static_rules in
let state_rules =
List.map (function
- | ("legal", [player; _] as head), body, neg_body ->
- head, ("role", [player])::body,
+ | ("legal", [|player; _|] as head), body, neg_body ->
+ head, ("role", [|player|])::body,
if !aggregate_drop_negative then [] else neg_body
| ("does", _ (* as head *)), body, _ -> assert false
(* head, body, [] *)
@@ -624,7 +633,7 @@
(* FIXME: this is identity, right? remove *)
let init_base = saturate static_base state_rules in
let init_state =
- Aux.map_some (function ("init", [arg]) -> Some arg
+ Aux.map_some (function ("init", [|arg|]) -> Some arg
| _ -> None) init_base in
(* {{{ log entry *)
if !debug_level > 0 then (
@@ -664,18 +673,23 @@
loop [] [] [] [] cands
+let player_vars_of rels =
+ Aux.map_some (function
+ | "does", [|Var v; _|] -> Some v
+ | "legal", [|Var v; _|] -> Some v
+ | _ -> None) rels
+
+
let expand_players clauses =
let players =
Aux.map_some (function
- | ("role", [player]), _ -> Some player
+ | ("role", [|player|]), _ -> Some player
| _ -> None
) clauses in
- let exp_clause (rel, _ as head, body as clause) =
+ let exp_clause clause =
(* determine variables standing for players *)
let plvars =
- let head = if rel = "role" then [] else [head] in
- Aux.concat_map player_vars_of
- (head @ List.map rel_of_atom body) in
+ player_vars_of (List.map rel_of_atom (atoms_of_clause clause)) in
if plvars = [] then [clause]
else
let sbs = List.map (fun v ->
@@ -700,7 +714,7 @@
else aux (more @ nonstable)
(List.filter (fun (rel,_) -> not (List.mem rel more)) remaining)
in
- aux [] remaining
+ aux [] defs
let state_terms body =
@@ -735,6 +749,8 @@
| Here_and_below of (string * path_set array) list
(* Subtries are in sorted order. *)
+let empty_path_set = Empty
+
let path_str p =
String.concat "_" (List.map (fun (rel, arg) ->
rel ^ "_" ^ string_of_int arg) p)
@@ -742,7 +758,10 @@
let paths_union ps1 ps2 =
let rec aux = function
| Empty, p | p, Empty -> p
- | Here, Below ps | Below ps, Here -> Here_and_below ps
+ | Here, Here -> Here
+ | Here, Below ps | Below ps, Here
+ | Here, Here_and_below ps
+ | Here_and_below ps, Here -> Here_and_below ps
| Below ps1, Below ps2 -> Below (merge (ps1, ps2))
| Below ps1, Here_and_below ps2
| Here_and_below ps2, Below ps1
@@ -751,7 +770,7 @@
and merge = function
| [], ps | ps, [] -> ps
| ((rel1, args1)::ps1), ((rel2, args2)::ps2) when rel1 = rel2 ->
- let args = Aux.array_map2 aux args1 args2 in
+ let args = Aux.array_map2 (fun x y->aux (x,y)) args1 args2 in
(rel1, args)::merge (ps1, ps2)
| ((rel1, _ as rel_ps)::ps1), ((rel2, _)::_ as ps2) when rel1 < rel2 ->
rel_ps::merge (ps1, ps2)
@@ -761,12 +780,16 @@
let add_path arities p ps =
let rec aux = function
- | [], Empty -> Here
+ | [], (Here | Empty) -> Here
| [], (Below ps | Here_and_below ps) -> Here_and_below ps
| (rel, pos)::suffix, Below ps ->
Below (add suffix rel pos ps)
| (rel, pos)::suffix, Here_and_below ps ->
Here_and_below (add suffix rel pos ps)
+ | (rel, pos)::suffix, Empty ->
+ Below (add suffix rel pos [])
+ | (rel, pos)::suffix, Here ->
+ Here_and_below (add suffix rel pos [])
and add p rel pos ps =
(let try args, ps = Aux.pop_assoc rel ps in
(* Keeping functional... *)
@@ -806,7 +829,7 @@
aux (ps, t)
(** Find the subterm at given path, if the term does not have the
- path, return [Not_found]; [at_path p t] is $t \tpos p$. *)
+ path, raise [Not_found]; [at_path p t] is $t \tpos p$. *)
let at_path t p =
let rec aux = function
| [], t -> t
@@ -825,13 +848,13 @@
| Empty, t -> []
| Here, t -> [t]
| Here_and_below subps, t -> t::(aux (Below subps, t))
- | Below subps, (Func (rel, args) as t)
+ | Below subps, (Func (rel, args))
when not fail_at_missing ->
(let try argps = List.assoc rel subps in
let res = Aux.array_map2 (fun ps t -> aux (ps,t)) argps args in
List.concat (Array.to_list res)
with Not_found -> [])
- | Below [rel1, argps], (Func (rel2, args) as t)
+ | Below [rel1, argps], (Func (rel2, args))
when rel1 = rel2 (* && fail_at_missing *) ->
let res = Aux.array_map2 (fun ps t -> aux (ps,t)) argps args in
List.concat (Array.to_list res)
@@ -845,8 +868,8 @@
| Empty, t -> []
| Here, t -> [f (List.rev revp) t]
| Here_and_below subps, t ->
- f (List.rev revp) t::(aux path (Below subps, t))
- | Below subps, (Func (rel, args) as t) ->
+ f (List.rev revp) t::(aux revp (Below subps, t))
+ | Below subps, (Func (rel, args)) ->
(let try argps = List.assoc rel subps in
let res =
Array.mapi (fun i ps -> aux ((rel,i)::revp) (ps,args.(i))) argps in
@@ -860,13 +883,14 @@
that has been included, are not included. *)
let rec term_paths ?(prefix_only=false) cond = function
| Func (rel, args) as t ->
- let subps = Array.map (term_paths p) args in
- let no_sub = Array.for_all (fun subp -> subp = Empty) subps in
+ let subps = Array.map (term_paths ~prefix_only cond) args in
+ let no_sub = Aux.array_for_all (fun subp -> subp = Empty) subps in
let here = cond t in
if no_sub && not here then Empty
- else if here && not no_sub && not prefix_only then Here_and_below subps
+ else if here && not no_sub && not prefix_only
+ then Here_and_below [rel, subps]
else if here then Here
- else Below subps
+ else Below [rel, subps]
| t -> if cond t then Here else Empty
(** The number of nodes in a term tree. *)
@@ -894,10 +918,11 @@
let paths_to_list ps =
let rec subpaths subps =
Aux.concat_map (fun (rel, subps) ->
- Array.to_list
- (Array.mapi (fun i ps ->
- let sub_res = aux ps in
- List.map (fun p -> (rel, i)::p) sub_res) subps)) subps
+ List.concat
+ (Array.to_list
+ (Array.mapi (fun i ps ->
+ let sub_res = aux ps in
+ List.map (fun p -> (rel, i)::p) sub_res) subps))) subps
and aux = function
| Empty -> []
| Here -> [[]]
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-07-19 15:20:56 UTC (rev 1516)
+++ trunk/Toss/GGP/GDL.mli 2011-07-26 19:50:54 UTC (rev 1517)
@@ -5,34 +5,16 @@
val aggregate_drop_negative : bool ref
val aggregate_fixpoint : bool ref
-(** Expand static relations that do not have ground facts and have
- arity above the threshold. *)
-val expand_arity_above : int ref
+(** {3 Datalog programs: Type definitions and saturation.} *)
-(** Treat "next" clauses which introduce metavariables only for
- variable-variable mismatch, as non-erasing frame clauses (to be
- ignored). ("Wave" refers to the process of "propagating the frame
- condition" that these clauses are assumed to do, if
- [nonerasing_frame_wave] is set to [true].) *)
-val nonerasing_frame_wave : bool ref
-
type term =
| Const of string
| Var of string
- | Func of string * term list
+ | Func of string * term array
-type rel_atom = string * term list
-(** Positive and negative literals separated, disjunctions expanded-out. *)
-type gdl_rule = rel_atom * rel_atom list * rel_atom list
-(** Collect rules by relations. *)
-type def_branch = term list * rel_atom list * rel_atom list
-type gdl_defs = (string * def_branch list) list
-
-module Terms : Set.S with type elt = term
-module Atoms : Set.S with type elt = rel_atom
-
+type rel_atom = string * term array
type atom =
- | Distinct of term list
+ | Distinct of term array
| Rel of rel_atom
| Role of term
| True of term
@@ -43,8 +25,19 @@
| Neg of atom
| Disj of literal list
+(** Positive and negative literals separated, disjunctions expanded-out. *)
+type gdl_rule = rel_atom * rel_atom list * rel_atom list
+(** Collect rules by relations. *)
+type def_branch = term array * rel_atom list * rel_atom list
+type gdl_defs = (string * def_branch list) list
+
type clause = rel_atom * literal list
+type path = (string * int) list
+
+type path_set
+
+
type request =
| Start of string * term * clause list * int * int
(** prepare game: match id, role, game, startclock, playclock *)
@@ -53,67 +46,102 @@
| Stop of string * term list
(** game ends here: match id, actions on previous step *)
-val term_str : term -> string
-val terms_str : term list -> string
-val sb_str : (string * term) list -> string
-val rel_atom_str : rel_atom -> string
-val rel_atoms_str : rel_atom list -> string
-val def_str :
- string * (term list * rel_atom list * rel_atom list) -> string
-val tuples_str : term list list -> string
-val proto_rel_str : string * string array -> string
-val gdl_rule_vars : gdl_rule -> Aux.Strings.t
-val gdl_rules_vars : gdl_rule list -> Aux.Strings.t
+val atoms_of_body : literal list -> atom list
+val rel_of_atom : atom -> rel_atom
-val branch_str : string -> def_branch -> string
+val term_vars : term -> Aux.Strings.t
+val clause_vars : clause -> Aux.Strings.t
-val func_graph : string -> term list -> term list list
+val defs_of_rules : gdl_rule list -> gdl_defs
+val rule_of_clause : clause -> gdl_rule
-val rules_of_clause : clause -> gdl_rule list
+val nnf_dnf : literal list -> literal list list
-val terms_vars : term list -> Aux.Strings.t
-val rels_vars : rel_atom list -> Aux.Strings.t
+type substitution = (string * term) list
+val unify : substitution -> term list -> term list -> substitution
+val unify_all : substitution -> term list -> substitution
+val subst : substitution -> term -> term
+val subst_rels : substitution -> rel_atom list -> rel_atom list
+val subst_clause : substitution -> clause -> clause
+
+(** {3 Transformations of GDL clauses: inlining, negation.} *)
+
+(** Expand branches of a definition inlining the provided definitions,
+ only expand positive literals. Iterate expansion to support
+ nesting of definitions. *)
+val expand_positive_lits : gdl_defs -> def_branch list -> def_branch list
+
+(** Form clause bodies whose disjunction is equivalent to the
+ negation of disjunction of given clause bodies. *)
+val negate_bodies : literal list list -> literal list list
+
+(** {3 GDL translation helpers.} *)
+
+val blank : term
+
val term_to_name : ?nested:bool -> term -> string
-val term_vars : term -> Aux.Strings.t
-val compose_sb : (string * term) list -> (string * term) list ->
- (string * term) list
+val state_terms : literal list -> term list
-val subst_one : string * term -> term -> term
-val subst : (string * term) list -> term -> term
-val subst_rel : (string * term) list -> rel_atom -> rel_atom
-val subst_rels : (string * term) list -> rel_atom list -> rel_atom list
-val subst_br : (string * term) list -> def_branch -> def_branch
-val defs_of_rules : gdl_rule list -> gdl_defs
+(** {3 GDL whole-game operations.}
-val unify :
- (string * term) list -> term list -> term list -> (string * term) list
+ Aggregate playout, player-denoting variable elimination. *)
-val unifies : term -> term -> bool
+(** Partition relations into stable (not depending, even indirectly,
+ on "true") and remaining ones. *)
+val stable_rels : gdl_defs -> string list * string list
-val saturate : rel_atom list -> gdl_rule list -> rel_atom list
-val stratify : gdl_defs list -> gdl_defs -> gdl_defs list
-
+(** Besides the aggregate playout, also return the separation of rules
+ into static and dynamic. Note that the list of playout states is
+ one longer than that of playout actions. *)
val aggregate_playout :
term array -> int -> gdl_rule list ->
- gdl_rule list * gdl_rule list * (string * term list) list *
- term list * (term list list list * term list list)
+ gdl_rule list * gdl_rule list *
+ rel_atom list * term list *
+ (term array list list * term list list)
-val find_cycle : term option list -> term option list
+(** {3 Paths and operations involving terms and paths.} *)
+(** [simult_subst ps s t] substitutes [s] at all [t] paths that belong
+ to the set [ps], returns $t[ps \ot s]$. *)
+val simult_subst : path_set -> term -> term -> term
-(** A path is a position in a tree together with labels on nodes from
- the root to that position (but excluding the position). *)
-type path = (string * int) list
+(** Find the list of results of a function applied to paths from the
+ given set that are in the term, and to subterms at these paths. *)
+val map_paths : (path -> term -> 'a) -> path_set -> term -> 'a list
-(** A trie representing a set of paths. *)
-type path_set =
- | Empty
- | Here (** Singleton $\{\epsilon\}$. *)
- | Below of (string * path_set array) list
- | Here_and_below of (string * path_set array) list
-(* Subtries are in sorted order. *)
+(** Toss relations hold between subterms of GDL state terms: generate
+ Toss relation name. *)
+val rel_on_paths : string -> path list -> string
+
+(** Some Toss predicates are generated from a path and an expected
+ subterm at that path. *)
+val pred_on_path_subterm : path -> term -> string
+
+(** All paths in a term pointing to subterms that satisfy a
+ predicate. With [~prefix_only:true], paths that contain a path
+ that has been included, are not included. *)
+val term_paths : ?prefix_only:bool -> (term -> bool) -> term -> path_set
+
+(** Find the subterm at given path, if the term does not have the
+ path, raise [Not_found]; [at_path p t] is $t \tpos p$. *)
+val at_path : term -> path -> term
+
+(** The set of paths that merges two terms, the cardinality of this
+ set, and the size of the largest common subtree. *)
+val merge_terms : term -> term -> path_set * int * int
+
+(** Find the list of subterms at paths from the given set, if the term
+ does not have some of the paths, ignore them if [~fail_at_missing:false],
+ raise [Not_found] if [~fail_at_missing:true]. *)
+val at_paths : ?fail_at_missing:bool -> path_set -> term -> term list
+
+val empty_path_set : path_set
+val paths_union : path_set -> path_set -> path_set
+
+(** List the paths in a set. *)
+val paths_to_list : path_set -> path list
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-07-19 15:20:56 UTC (rev 1516)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-07-26 19:50:54 UTC (rev 1517)
@@ -3,12 +3,8 @@
open GDL
let rel_atoms body =
- let rec aux = function
- | Pos (Rel (rel, args)) -> [rel, args]
- | Neg (Rel (rel, args)) -> [rel, args]
- | Disj ls -> Aux.concat_map aux ls
- | _ -> [] in
- Aux.concat_map aux body
+ Aux.map_some (function Rel (rel, args) -> Some (rel, args)
+ | _ -> None) (atoms_of_body body)
@@ -22,33 +18,33 @@
let aux conj =
List.fold_right (fun lit acc -> match lit with
| (Pos (True _) | Neg (True _)) as lit ->
- List.map (fun conj -> Left lit::conj) acc
+ List.map (fun conj -> Aux.Left lit::conj) acc
| Disj ls as lit ->
if List.for_all (function Pos _ -> true | _ -> false) ls
|| List.for_all (function Neg _ -> true | _ -> false) ls
then
- List.map (fun conj -> Left lit::conj) acc
+ List.map (fun conj -> Aux.Left lit::conj) acc
else
Aux.concat_map (function
| (Pos (True _) | Neg (True _)) as lit ->
- List.map (fun conj -> Left lit::conj) acc
- | lit -> List.map (fun conj -> Right lit::conj) acc
+ List.map (fun conj -> Aux.Left lit::conj) acc
+ | ...
[truncated message content] |
|
From: <luk...@us...> - 2011-07-26 21:50:46
|
Revision: 1518
http://toss.svn.sourceforge.net/toss/?rev=1518&view=rev
Author: lukaszkaiser
Date: 2011-07-26 21:50:38 +0000 (Tue, 26 Jul 2011)
Log Message:
-----------
Corrections towards compilation.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLParser.mly
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Tests.ml
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/GDL.mli 2011-07-26 21:50:38 UTC (rev 1518)
@@ -77,6 +77,9 @@
negation of disjunction of given clause bodies. *)
val negate_bodies : literal list list -> literal list list
+val func_graph : string -> term list -> term array list
+
+
(** {3 GDL translation helpers.} *)
val blank : term
Modified: trunk/Toss/GGP/GDLParser.mly
===================================================================
--- trunk/Toss/GGP/GDLParser.mly 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/GDLParser.mly 2011-07-26 21:50:38 UTC (rev 1518)
@@ -28,7 +28,7 @@
| c=WORD { Const c }
| sexp=delimited (OPEN, list (term), CLOSE)
{ match sexp with
- | Const c::args -> Func (c, args)
+ | Const c::args -> Func (c, Array.of_list args)
| _ -> raise (Lexer.Parsing_error "GDL term: not a constant head")
}
| error {
@@ -37,29 +37,29 @@
atom:
| r=WORD {
- if r="TERMINAL" then Rel ("terminal", [])
- else Rel (r, []) }
+ if r="TERMINAL" then Rel ("terminal", [||])
+ else Rel (r, [||]) }
| sexp=delimited (OPEN, list (term), CLOSE)
{ match sexp with
| (Const "distinct" | Const "DISTINCT")::args ->
- Distinct args
+ Distinct (Array.of_list args)
| [(Const "true" | Const "TRUE"); arg] ->
True arg
| [(Const "does" | Const "DOES"); player; action] ->
Does (player, action)
| (Const "role" | Const "ROLE")::player ->
- Role player
+ Role (List.hd player) (* FIXME!!! *)
| (Const "init" | Const "INIT")::state ->
- Rel ("init", state)
+ Rel ("init", Array.of_list state)
| (Const "next" | Const "NEXT")::state ->
- Rel ("next", state)
+ Rel ("next", Array.of_list state)
| (Const "terminal" | Const "TERMINAL")::no_arg ->
- Rel ("terminal", no_arg)
+ Rel ("terminal", Array.of_list no_arg)
| (Const "legal" | Const "LEGAL")::args ->
- Rel ("legal", args)
+ Rel ("legal", Array.of_list args)
| (Const "goal" | Const "GOAL")::args ->
- Rel ("goal", args)
- | Const r::args -> Rel (r, args)
+ Rel ("goal", Array.of_list args)
+ | Const r::args -> Rel (r, Array.of_list args)
| _ -> raise (Lexer.Parsing_error "GDL atom: not a constant head")
}
| error {
@@ -75,7 +75,7 @@
| OPEN REVIMPL head=atom body=list (literal) CLOSE
{ match head with
| Rel rel_atom -> rel_atom, body
- | Role player -> ("role", [player]), body
+ | Role player -> ("role", [|player|]), body
| True _ ->
raise (Lexer.Parsing_error "GDL rule: \"true\" in head")
| Distinct _ ->
@@ -85,7 +85,7 @@
}
| a=atom
{ match a with
- | Role player -> ("role", [player]), []
+ | Role player -> ("role", [|player|]), []
| Rel rel_atom -> rel_atom, []
| _ ->
raise (Lexer.Parsing_error
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/GDLTest.ml 2011-07-26 21:50:38 UTC (rev 1518)
@@ -39,15 +39,14 @@
| _, [] -> true
| [], _ -> aux players playout
| player::turn, state::playout ->
- if GDL.func_graph "control" state <> [[player]]
- then false
- else aux turn playout in
+ if GDL.func_graph "control" state <> [[|player|]] then false else
+ aux turn playout in
aux players playout
let tests = "GDL" >::: [
- "saturate" >::
+(* "saturate" >::
(fun () ->
let descr = parse_game_descr
"
@@ -76,7 +75,7 @@
"(a 1) (a 2) (a 3) (two-of-three 1 2) (two-of-three 1 3) (two-of-three 2 1) (two-of-three 2 3) (two-of-three 3 1) (two-of-three 3 2)"
(String.concat " "
(List.map GDL.fact_str res));
- );
+ );
"saturate recursive" >::
(fun () ->
@@ -103,7 +102,7 @@
"(lte 0 0) (lte 0 1) (lte 0 2) (lte 0 3) (lte 0 4) (lte 0 5) (lte 0 6) (lte 0 7) (lte 0 8) (lte 1 1) (lte 1 2) (lte 1 3) (lte 1 4) (lte 1 5) (lte 1 6) (lte 1 7) (lte 1 8) (lte 2 2) (lte 2 3) (lte 2 4) (lte 2 5) (lte 2 6) (lte 2 7) (lte 2 8) (lte 3 3) (lte 3 4) (lte 3 5) (lte 3 6) (lte 3 7) (lte 3 8) (lte 4 4) (lte 4 5) (lte 4 6) (lte 4 7) (lte 4 8) (lte 5 5) (lte 5 6) (lte 5 7) (lte 5 8) (lte 6 6) (lte 6 7) (lte 6 8) (lte 7 7) (lte 7 8) (lte 8 8) (number 0) (number 1) (number 2) (number 3) (number 4) (number 5) (number 6) (number 7) (number 8) (succ 0 1) (succ 1 2) (succ 2 3) (succ 3 4) (succ 4 5) (succ 5 6) (succ 6 7) (succ 7 8)"
(String.concat " "
(List.map GDL.fact_str res));
- );
+ ); *)
]
let exec = Aux.run_test_if_target "GDLTest" tests
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-07-26 21:50:38 UTC (rev 1518)
@@ -64,6 +64,16 @@
term_arities : (string * int) list;
}
+let empty_transl_data = {
+ f_paths = empty_path_set;
+ m_paths = empty_path_set;
+ all_paths = empty_path_set;
+ mask_reps = [];
+ defined_rels = [];
+ defrel_arg_type = ref [];
+ term_arities = [];
+}
+
let blank_out data t =
simult_subst data.f_paths blank t
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-07-26 21:50:38 UTC (rev 1518)
@@ -13,5 +13,7 @@
term_arities : (string * int) list;
}
+val empty_transl_data : transl_data
+
val translate :
transl_data -> GDL.literal list list -> Formula.formula
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-07-26 21:50:38 UTC (rev 1518)
@@ -64,6 +64,24 @@
(* term representatives of structure elements *)
}
+let empty_gdl_translation = {
+ elem_term_map = Aux.IntMap.empty;
+ f_paths = empty_path_set;
+ m_paths = empty_path_set;
+ masks = [];
+ tossrule_data = Aux.StrMap.empty;
+ turnbased_noops = None;
+ playing_as = 0;
+ is_concurrent = false;
+ transl_data = TranslateFormula.empty_transl_data;
+ element_terms = Aux.IntMap.empty;
+}
+
+let our_turn gdl state = true
+
+let noop_move gdl state = "NOOP"
+
+
(* [most_similar c ts] finds a term from [ts] most similar to [c], and
the set of paths that merges the found term and [c]; as in the
definition of $s_\calC$ and $t_\calC$ for a clause $\calC \in
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-07-26 21:50:38 UTC (rev 1518)
@@ -1,5 +1,5 @@
type tossrule_data = {
- lead_legal : GDL.term;
+ legal_tuple : GDL.term;
(* the "legal"/"does" term of the player that performs the move, we
call its parameters "fixed variables" as they are provided externally *)
precond : Formula.formula;
@@ -8,26 +8,25 @@
(* the elements of LHS/RHS structures, corresponding to the "next"
terms *)
struc_elems : string list;
- fixvar_elemvars :
- (string * (GDL.term * (string * string list) list) list) list;
- (* "state" terms indexed by variables that they contain, together
- with the mask-path of the variable *)
- elemvars : GDL.term Aux.StrMap.t;
-(* "state" terms indexed by Toss variable names they generate *)
+ fixvar_terms : (string * (GDL.term * GDL.path) list) list;
+ rulevar_terms : GDL.term Aux.StrMap.t;
}
(** Data to be used when translating moves. *)
-type gdl_translation = {
- (* map between structure elements and their term representations;
- the reverse direction is by using element names *)
- elem_term_map : GDL.term Aux.IntMap.t;
- f_paths : GDL.path_set;
- m_paths : GDL.path_set;
- masks : GDL.term list;
- tossrule_data : tossrule_data Aux.StrMap.t;
- (* rule name to rule translation data *)
-}
+type gdl_translation
+val empty_gdl_translation : gdl_translation
val translate_game :
GDL.clause list -> gdl_translation * (Arena.game * Arena.game_state)
+
+val translate_incoming_move :
+ gdl_translation -> (Arena.game * Arena.game_state) -> GDL.term list ->
+ string * (int * int) list
+
+val translate_outgoing_move : gdl_translation ->
+ (Arena.game * Arena.game_state) -> string -> (int * int) list -> string
+
+val noop_move : gdl_translation -> Arena.game_state -> string
+
+val our_turn : gdl_translation -> (Arena.game * Arena.game_state) -> bool
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-07-26 21:50:38 UTC (rev 1518)
@@ -39,16 +39,15 @@
| _, [] -> true
| [], _ -> aux players playout
| player::turn, state::playout ->
- if GDL.func_graph "control" state <> [[player]]
- then false
- else aux turn playout in
+ if GDL.func_graph "control" state <> [[|player|]] then false else
+ aux turn playout in
aux players playout
let game_test_case ~game_name ~player ~loc0_rule_name ~loc0_emb
~loc0_move ~loc0_noop ~loc1 ~loc1_rule_name ~loc1_emb ~loc1_noop
~loc1_move =
let game = load_rules ("./GGP/examples/"^game_name^".gdl") in
- let gdl, res = Translate.translate_game (Const player) game in
+ let gdl, res = TranslateGame.translate_game (*Const player*) game in
let goal_name =
(*if !GDL.prune_rulecands_at = GDL.Never
then game_name^"-simpl-unpruned.toss"
@@ -70,10 +69,10 @@
let emb =
Arena.emb_of_names res rname loc0_emb in
let transl =
- Translate.translate_outgoing_move gdl res rname emb in
+ TranslateGame.translate_outgoing_move gdl res rname emb in
assert_equal ~printer:(fun x->x) loc0_move transl;
let move =
- Translate.translate_incoming_move gdl res
+ TranslateGame.translate_incoming_move gdl res
[pte loc0_move; pte loc0_noop] in
assert_equal ~msg:"own incoming move" ~printer:(emb_str res)
(norm_move (rname, emb)) (norm_move move);
@@ -84,15 +83,15 @@
let emb =
Arena.emb_of_names res rname loc1_emb in
let move =
- Translate.translate_incoming_move gdl res
+ TranslateGame.translate_incoming_move gdl res
[pte loc1_noop; pte loc1_move] in
assert_equal ~msg:"opponent incoming move"
~printer:(emb_str res)
(norm_move (rname, emb)) (norm_move move)
-let tests = "Translate" >::: [
-
+let tests = "TranslateGame" >::: [
+ (*
"expand_def_rules" >::
(fun () ->
let descr = parse_game_descr
@@ -126,10 +125,10 @@
"cell_x71_y26__blank_", "cell_1_1_MV1";
"control__blank_", "control_MV1"]
~loc1_noop:"noop" ~loc1_move:"(mark 1 1)"
- );
+ ); *)
]
-let bigtests = "TranslateBig" >::: [
+let bigtests = "TranslateGameBig" >::: [
"connect5" >::
(fun () ->
@@ -186,10 +185,10 @@
let a =
- Aux.run_test_if_target "TranslateTest" tests
+ Aux.run_test_if_target "TranslateGameTest" tests
let a =
- Aux.run_test_if_target "TranslateTest" bigtests
+ Aux.run_test_if_target "TranslateGameTest" bigtests
let a () =
GDL.debug_level := 4;
@@ -205,10 +204,9 @@
| Some tests -> ignore (run_test_tt ~verbose:true tests)
| None -> ()
-let regenerate ~debug ~game_name ~player =
+(* let regenerate ~debug ~game_name ~player =
Printf.printf "Regenerating %s...\n%!" game_name;
if debug then (
- Translate.debug_level := 4;
GameSimpl.debug_level := 4;
DiscreteRule.debug_level := 4);
Translate.generate_test_case := Some game_name;
@@ -222,3 +220,4 @@
regenerate ~debug:false ~game_name:"breakthrough" ~player:"white";
(* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
(* regen_with_debug ~game_name:"connect4" ~player:"white" *)
+*)
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/Server/ReqHandler.ml 2011-07-26 21:50:38 UTC (rev 1518)
@@ -17,11 +17,11 @@
Formula.real_expr array array option (** heuristic option *)
* bool (** game modified *)
* (Arena.game * Arena.game_state) (** game and state *)
- * Translate.gdl_translation (** current gdl translation *)
+ * TranslateGame.gdl_translation (** current gdl translation *)
* int (** playclock *)
let init_state =
- (None, true, Arena.empty_state, Translate.empty_gdl_translation, 0)
+ (None, true, Arena.empty_state, TranslateGame.empty_gdl_translation, 0)
(* TODO; FIXME; remove the function below. *)
@@ -83,12 +83,9 @@
Random.self_init ();
let old_force_competitive = !Heuristic.force_competitive in
Heuristic.force_competitive := true;
- let new_state, params, new_gdl_transl =
- Translate.initialize_game player game_descr startcl in
- let effort, horizon, advr =
- match params with
- | Some (e,h,r) -> Some e, Some h, Some r
- | None -> None, None, None in
+ let new_gdl_transl, new_state =
+ TranslateGame.translate_game game_descr in
+ let effort, horizon, advr = (None, None, None) in
let new_heur =
Heuristic.default_heuristic ~struc:(snd new_state).Arena.struc
?advr (fst new_state) in
@@ -101,7 +98,7 @@
let time_started = Unix.gettimeofday () in
let r_name, mtch =
- Translate.translate_last_action gdl_transl state actions in
+ TranslateGame.translate_incoming_move gdl_transl state actions in
let state =
if r_name <> "" then (
@@ -136,7 +133,7 @@
else
let mov_msg =
let time_used = time_started -. Unix.gettimeofday () in
- if Translate.our_turn gdl_transl state then (
+ if TranslateGame.our_turn gdl_transl state then (
Play.set_timeout (float(playclock) -. time_used -. 0.07);
let heur = match g_heur with
| Some h -> h
@@ -144,11 +141,11 @@
let (move, _) =
Aux.random_elem (Play.maximax_unfold_choose 5500
(fst state) (snd state) heur) in
- Translate.translate_move gdl_transl state
+ TranslateGame.translate_outgoing_move gdl_transl state
move.Move.rule move.Move.embedding
) else (
Gc.compact ();
- Translate.noop_move gdl_transl (snd state)
+ TranslateGame.noop_move gdl_transl (snd state)
) in
let msg_len = String.length mov_msg in
("HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: "
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-07-26 19:50:54 UTC (rev 1517)
+++ trunk/Toss/Server/Tests.ml 2011-07-26 21:50:38 UTC (rev 1518)
@@ -32,9 +32,9 @@
]
let ggp_tests = "GGP", [
- "GameSimplTest", [GameSimplTest.tests];
- "GDLTest", [GDLTest.tests];
- "TranslateTest", [TranslateTest.tests; TranslateTest.bigtests];
+ "GameSimplTest", [GameSimplTest.tests];
+ "GDLTest", [GDLTest.tests];
+ "TranslateGameTest", [TranslateGameTest.tests; TranslateGameTest.bigtests];
]
let server_tests = "Server", [
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-29 09:53:52
|
Revision: 1519
http://toss.svn.sourceforge.net/toss/?rev=1519&view=rev
Author: lukstafi
Date: 2011-07-29 09:53:41 +0000 (Fri, 29 Jul 2011)
Log Message:
-----------
GDL translation work in progress: compilation fixes. Tests do not work yet.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Server/ReqHandler.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/GDL.ml 2011-07-29 09:53:41 UTC (rev 1519)
@@ -286,8 +286,10 @@
| Neg atom -> Neg (subst_atom sb atom)
| Disj disjs -> Disj (List.map (subst_literal sb) disjs)
+let rec subst_literals sb = List.map (subst_literal sb)
+
let subst_clause sb (head, body) =
- subst_rel sb head, List.map (subst_literal sb) body
+ subst_rel sb head, subst_literals sb body
let rel_atom_str (rel, args) =
"(" ^ rel ^ " " ^
@@ -675,6 +677,7 @@
let player_vars_of rels =
Aux.map_some (function
+ | "goal", [|Var v; _|] -> Some v
| "does", [|Var v; _|] -> Some v
| "legal", [|Var v; _|] -> Some v
| _ -> None) rels
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/GDL.mli 2011-07-29 09:53:41 UTC (rev 1519)
@@ -62,8 +62,12 @@
val unify : substitution -> term list -> term list -> substitution
val unify_all : substitution -> term list -> substitution
+val rels_unify : rel_atom -> rel_atom -> bool
val subst : substitution -> term -> term
+val subst_rel : substitution -> rel_atom -> rel_atom
val subst_rels : substitution -> rel_atom list -> rel_atom list
+val subst_literal : substitution -> literal -> literal
+val subst_literals : substitution -> literal list -> literal list
val subst_clause : substitution -> clause -> clause
(** {3 Transformations of GDL clauses: inlining, negation.} *)
@@ -77,18 +81,24 @@
negation of disjunction of given clause bodies. *)
val negate_bodies : literal list list -> literal list list
+(** Rename clauses so that they have disjoint variables. Return a cell
+ storing all variables. *)
+val rename_clauses : clause list -> Aux.Strings.t ref * clause list
+
val func_graph : string -> term list -> term array list
+
(** {3 GDL translation helpers.} *)
val blank : term
+val term_str : term -> string
val term_to_name : ?nested:bool -> term -> string
val state_terms : literal list -> term list
+val term_arities : term -> (string * int) list
-
(** {3 GDL whole-game operations.}
Aggregate playout, player-denoting variable elimination. *)
@@ -107,6 +117,10 @@
rel_atom list * term list *
(term array list list * term list list)
+val find_cycle : term option list -> term option list
+
+val expand_players : clause list -> clause list
+
(** {3 Paths and operations involving terms and paths.} *)
(** [simult_subst ps s t] substitutes [s] at all [t] paths that belong
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-07-29 09:53:41 UTC (rev 1519)
@@ -291,11 +291,12 @@
failwith "GGP/TranslateFormula: finding path for defined relation argument undetermined by state terms not implemented yet")
p_defside p_callside in
(* now building the translation *)
- let defvars = Array.mapi (fun i _ ->
- Formula.fo_var_of_string ("v"^string_of_int i)) arg_paths in
+ let defvars =
+ Array.mapi (fun i _ -> "v"^string_of_int i) arg_paths in
let defbody (args,(rels_phi,pos_state,neg_state)) s_defside =
let arg_eqs = Array.mapi
(fun i v ->
+ let v = Formula.fo_var_of_string v in
let in_I = p_defside.(i) <> None in
if in_I
then
@@ -324,7 +325,7 @@
p_defside arg_paths in
data.defrel_arg_type :=
(rel, defrel_arg_type) :: !(data.defrel_arg_type);
- rel, (defvars, Formula.Or def_disjuncts) in
+ rel, (Array.to_list defvars, Formula.Or def_disjuncts) in
List.map build_defrel data.defined_rels
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-07-29 09:53:41 UTC (rev 1519)
@@ -13,7 +13,14 @@
term_arities : (string * int) list;
}
+val blank_out : transl_data -> GDL.term -> GDL.term
+val var_of_term : transl_data -> GDL.term -> Formula.fo_var
+
val empty_transl_data : transl_data
val translate :
transl_data -> GDL.literal list list -> Formula.formula
+
+val build_defrels :
+ transl_data -> GDL.clause list ->
+ (string * (string list * Formula.formula)) list
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-07-29 09:53:41 UTC (rev 1519)
@@ -3,6 +3,7 @@
*)
open GDL
+open TranslateFormula
(** Translate stable relations that otherwise would be translated as
structure relations, but have arity above the threshold, as
@@ -25,9 +26,12 @@
let env_player = Const "ENVIRONMENT"
type tossrule_data = {
- legal_tuple : term;
- (* the "legal"/"does" term of the player that performs the move, we
- call its parameters "fixed variables" as they are provided externally *)
+ legal_tuple : term array;
+ (* the "legal"/"does" term of the player that performs the move
+ (when a singleton) or the players that participate in the move
+ (then ordered in the same way as players),
+ we call its parameters "fixed variables" as they are provided
+ externally *)
precond : Formula.formula;
(* the LHS match condition (the LHS structure and the precondition) *)
rhs_add : (string * string array) list;
@@ -60,8 +64,7 @@
is_concurrent : bool;
transl_data : TranslateFormula.transl_data;
(* mostly the same data as above, but packed for formula translation *)
- element_terms : term Aux.IntMap.t;
- (* term representatives of structure elements *)
+ fluents : string list;
}
let empty_gdl_translation = {
@@ -74,7 +77,7 @@
playing_as = 0;
is_concurrent = false;
transl_data = TranslateFormula.empty_transl_data;
- element_terms = Aux.IntMap.empty;
+ fluents = [];
}
let our_turn gdl state = true
@@ -190,9 +193,12 @@
let frame_clauses, move_clauses, f_paths =
fluent_paths_and_frames clauses in
let next_clauses =
- List.map (fun ((_,s_C),body_C) -> s_C, true, body_C) frame_clauses
- @ List.map (fun ((_,s_C),body_C) -> s_C, false, body_C)
- move_clauses in
+ List.map (function
+ | (_,[|s_C|]),body_C -> s_C, true, body_C
+ | _ -> assert false) frame_clauses
+ @ List.map (function
+ | (_,[|s_C|]),body_C -> s_C, false, body_C
+ | _ -> assert false) move_clauses in
let arities =
("EQ_", 2)::
Aux.unique_sorted
@@ -219,8 +225,6 @@
List.assoc rel arities <= !defined_arity_above) stable_rels in
let struc_rels = "EQ_"::struc_rels in
let defined_rels = defined_rels @ nonstable_rels in
- let elem_term_map = Aux.strmap_of_assoc
- (List.map (fun e -> term_to_name e, e) element_reps) in
let struc =
List.fold_left (fun struc rel ->
let arity = List.assoc rel arities in
@@ -269,23 +273,70 @@
else struc
) struc element_reps
) struc mask_reps in
+ (*
+ let elem_term_map = Aux.strmap_of_assoc
+ (List.map (fun e -> term_to_name e, e) element_reps) in
+ *)
+ let elem_term_map = Aux.intmap_of_assoc
+ (List.map (fun e ->
+ Structure.find_elem struc (term_to_name e), e) element_reps) in
next_clauses, f_paths, m_paths, mask_reps, defined_rels,
!stable_rels, !fluents,
stable_base, init_state, struc, agg_actions, elem_term_map
+(* substitute a "next" clause with frame info *)
+let subst_fnextcl sb (head, frame, body) =
+ subst sb head, frame, subst_literals sb body
+(* substitute a "legal" or "next" clause (with only a legal/state term
+ in the head) *)
+let subst_ln_cl sb (head, body) =
+ subst sb head, subst_literals sb body
+
+
+(* Callgraph for creating "move tuples" and Toss rules.
+
+ (1) [create_init_struc] prepares [next_cls], segregated into frame
+ clauses and normal clauses, with head term extracted.
+
+ (2) [move_tuples] selects maximal tuples of [next_cls] such that
+ their "legal"/"does" terms unify.
+
+ (3) [add_erasure_clauses] converts frame into erasure clauses, and
+ adds the result to non-frame clauses (without framing
+ information).
+
+ (4) [process_rule_cands] calls [move_tuples], applies the unifier,
+ and calls [add_erasure_clauses].
+
+ (5) [rule_cases] distributes clauses from a move tuple to
+ disjointly cover all applicability conditions. Then it collects all
+ head terms and conflates the bodies to produce a rule
+ candidate. Legality conditions are not passed to [rule_cases].
+
+ (6) [turnbased_rule_cases], [concurrent_rule_cases] and
+ [general_int_rule_cases] call [rule_cases], add legal terms and
+ legality conditions to the result when appropriate (the
+ environment does not have legality conditions). Rules for players
+ as well as for the environment (when not turn-based) are built.
+
+ (7) [create_rule_cands] calls the right routine of (6).
+
+*)
+
+
(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Do not remove the
"does" atoms from clauses. Also handles as special cases:
"concurrent" case with selecting clauses for only one player, and
"environment" case for selecting clauses not dependent on any
- player. *)
+ player. Preserve legal clauses into the output tuples. *)
let move_tuples used_vars next_cls mode players legal_tuples =
(* computing the $d_i(\calN)$ for each $\calN$ *)
let fresh_x_f () =
let x_f = Aux.not_conflicting_name !used_vars "x_f" in
used_vars := Aux.Strings.add x_f !used_vars;
Var x_f in
- let does_facts (_,body) =
+ let does_facts (_,_,body) =
List.fold_right (fun p (sb, dis) ->
let djs =
(* FIXME: check if "negative true" is properly handled *)
@@ -304,7 +355,7 @@
let next_cls =
if mode = `Environment
then
- Aux.map_some (fun (_,body as cl) ->
+ Aux.map_some (fun (_,_,body as cl) ->
if List.exists
(function Pos (Does _) | Neg (Does _) -> true | _ -> false) body
then None
@@ -313,13 +364,14 @@
else
Aux.map_try (fun cl ->
let sb, ds = does_facts cl in
- subst_clause sb cl, ds) next_cls in
+ subst_fnextcl sb cl, ds) next_cls in
(* selecting $\ol{\calC},\ol{\calN}$ clauses with
$\sigma_{\ol{\calC},\ol{\calN}}$ applied *)
let tup_unifies ts1 ts2 =
try ignore (unify [] ts1 ts2); true
with Not_found -> false in
- let move_clauses cs =
+ let move_clauses legal_tup =
+ let cs = List.map fst legal_tup in
(* bag of next clauses for each legal tuple *)
let next_clauses =
List.filter (fun (n_cl, ds) -> tup_unifies cs ds) next_cls in
@@ -355,7 +407,8 @@
(sb, tup_ds, n_cl::n_cls)
with Not_found -> cl_tup
) cl_tup next_clauses in
- List.map maximality cl_tups in
+ let cl_tups = List.map maximality cl_tups in
+ List.map (fun (sb, _, n_cls) -> sb, legal_tup, n_cls) cl_tups in
Aux.concat_map move_clauses legal_tuples
@@ -395,7 +448,7 @@
let frames = List.map maximality frames in
let frames =
List.map (fun (sb, s, bodies) ->
- s, List.map (subst_rels sb) bodies) frames in
+ s, List.map (subst_literals sb) bodies) frames in
let erasure_cls =
Aux.concat_map (fun (s, bodies) ->
let nbodies = negate_bodies bodies in
@@ -408,7 +461,8 @@
(* Assign rule clauses to rule cases, i.e. candidates for
- Toss rules. Collect the conditions and RHS state terms together. *)
+ Toss rules. Collect the conditions and RHS state terms together.
+ Frame clauses are already processed into erasure clauses. *)
let rule_cases next_cls =
let atoms = Aux.concat_map
(fun (_, body) -> Aux.map_some (function
@@ -419,7 +473,7 @@
let patterns =
let next_cls = Array.of_list next_cls in
List.map (fun a ->
- Array.map (fun i (_, body) ->
+ Array.mapi (fun i (_, body) ->
if List.mem (Neg a) body then -1
else if List.mem (Pos a) body then 1
else 0
@@ -427,8 +481,8 @@
a) atoms in
let patterns = Aux.collect patterns in
let patterns = List.filter (fun (pat, _) ->
- Array.exists (fun v-> v < 1) pat &&
- Array.exists (fun v-> v > -1) pat) patterns in
+ Aux.array_existsi (fun _ v-> v < 1) pat &&
+ Aux.array_existsi (fun _ v-> v > -1) pat) patterns in
let pos_choice = List.map (fun _ -> true) patterns in
let neg_choice = List.map (fun _ -> false) patterns in
let choices = Aux.product [pos_choice; neg_choice] in
@@ -448,34 +502,63 @@
) choice patterns
) next_cls in
let case_rhs, case_conds = List.split case_cls in
- case_cls, case_rhs, separation_cond @ case_conds in
+ case_cls, case_rhs, separation_cond @ List.concat case_conds in
List.map rule_case choices
-let nonint_rule_cases (legal_tup, next_cls) =
- let legal_tup, legal_cond = List.split legal_tup in
- let legal_cond = List.combine legal_cond in
- List.map (fun (case_rhs, case_cond) ->
- legal_tup, case_rhs, case_cond @ legal_cond
- ) (rule_cases next_cls)
+let process_rule_cands used_vars next_cls mode players legal_tuples =
+ let move_tups =
+ move_tuples used_vars next_cls mode players legal_tuples in
+ let move_tups =
+ List.map (fun (sb, legal_tup, n_cls) ->
+ List.map (subst_ln_cl sb) legal_tup,
+ List.map (subst_fnextcl sb) n_cls) move_tups in
+ List.map add_erasure_clauses move_tups
+
+let add_legal_cond (legal_tup, next_cls) =
+ let legal_tup, legal_cond = List.split legal_tup in
+ let legal_cond = List.concat legal_cond in
+ List.map (fun (case_cls, case_rhs, case_cond) ->
+ legal_tup, case_rhs, case_cond @ legal_cond
+ ) (rule_cases next_cls)
+
+
+let turnbased_rule_cases used_vars next_cls players legal_by_player =
+ let legal_tuples = Aux.product legal_by_player in
+ let move_tups =
+ process_rule_cands
+ used_vars next_cls `General players legal_tuples in
+ let rules = Aux.concat_map add_legal_cond move_tups in
+ (* we do not look for the players -- for turn-based case, it's done
+ while building game graph *)
+ Aux.Left rules
+
+
(* If "Concurrent Moves" case, divide rule clauses among players. *)
-let concurrent_rule_cases players (legal_tup, next_cls) =
- Array.mapi (fun i player ->
- let legal_head, legal_cond = legal_tup.(i) in
- let cls = List.filter
- (fun (_,cl_body) -> List.exists (
- function Does (p, _) when p=player -> true | _ -> false)
- cl_body)
- next_cls in
- List.map (fun (case_rhs, case_cond) ->
- legal_head, case_rhs, case_cond @ legal_cond
- ) (rule_cases cls)
- ) players
+let concurrent_rule_cases used_vars next_cls players legal_by_player =
+ let env_pl_tups =
+ env_player,
+ process_rule_cands used_vars next_cls `Environment [] [[]] in
+ let player_rules =
+ List.map2 (fun player legal_cls ->
+ (* [process_rule_cands] works with players tuples, so we "cheat" *)
+ let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
+ let move_tups =
+ process_rule_cands
+ used_vars next_cls `Concurrent [player] legal_tuples in
+ player, move_tups
+ ) players legal_by_player in
+ let player_rules = List.map
+ (fun (player, move_tups) ->
+ player, Aux.concat_map add_legal_cond move_tups)
+ (player_rules @ [env_pl_tups]) in
+ Aux.Right player_rules
-let general_int_rule_cases (legal_tup, next_cls) =
+let general_int_rule_cases used_vars next_cls players legal_by_player =
failwith "General Interaction Games not implemented yet"
+
(* Generate rule candidates (they need to be filtered before finishing
the translation of Toss rules): returns the "legal" terms tuple
(ordered by players), the right-hand-sides, and the conditions
@@ -489,52 +572,35 @@
let create_rule_cands is_turn_based used_vars next_cls clauses =
let players = (* Array.of_list *)
Aux.map_some (function
- | ("role", [player]), _ -> Some player
+ | ("role", [|player|]), _ -> Some player
| _ -> None
) clauses in
let legal_cls =
List.filter (fun ((rel,_),_) -> rel="legal") clauses in
let is_concurrent = not is_turn_based &&
List.for_all
- (fun (_, body) ->
+ (fun (_, _, body) ->
List.length
- (List.filter (function Does _ -> true | _ -> false) body)
+ (List.filter
+ (function Pos (Does _) | Neg (Does _) -> true | _ -> false) body)
<= 1)
next_cls in
- (* let next_cls =
- List.filter (fun ((rel,_),_) -> rel="next") clauses in *)
(* constructing $(\calC_1,...,\calC_n)$ tuples *)
let legal_by_player =
List.map (fun p ->
Aux.map_some (function
- | ("legal",[lp; l]), body when lp = p -> Some (l, body)
+ | ("legal",[|lp; l|]), body when lp = p -> Some (l, body)
| _ -> None) legal_cls
) players in
- let process_rule_cands mode players legal_tuples =
- let move_tups =
- move_tuples used_vars next_cls mode players legal_tuples in
- let move_tups =
- List.map (fun (sb, legal_tup, n_cls) ->
- List.map (subst sb) legal_tup,
- List.map (subst_clause sb) n_cls) move_tups in
- List.map add_erasure_clauses move_tups in
- let concurrent_rule_cands player legal_cls =
- let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
- let move_tups =
- process_rule_cands `Concurrent [player] legal_tuples in
- player, Aux.concat_map nonint_rule_cases (move_tups @ env_tups) in
- if is_concurrent then
- let env_tups =
- env_player, process_rule_cands `Environment [] [[]] in
- Right
- (List.map2 concurrent_rule_cands players legal_by_player @ env_tups)
- else
- let legal_tuples = Aux.product legal_by_player in
- let move_tups = process_rule_cands `General players legal_tuples in
- if is_turn_based then
- Left (Aux.concat_map nonint_rule_cases move_tups)
+ let result =
+ if is_concurrent then
+ concurrent_rule_cases used_vars next_cls players legal_by_player
+ else if is_turn_based then
+ turnbased_rule_cases used_vars next_cls players legal_by_player
else
- Left (Aux.concat_map general_int_rule_cases move_tups)
+ general_int_rule_cases used_vars next_cls players legal_by_player
+ in
+ result, is_concurrent
let filter_rule_cands stable_base defined_rels rule_cands =
@@ -547,13 +613,13 @@
not (List.exists (rels_unify a) stable_base)
| _ -> true in
let check_cands cands =
- List.filter (fun (_, _, _, case_conds) ->
+ List.filter (fun (_, _, case_conds) ->
List.for_all check_atom case_conds
) cands in
match rule_cands with
- | Left cands -> Left (check_cands cands)
- | Right cands ->
- Right (List.map (fun (p,cands) -> p, check_cands cands) cands)
+ | Aux.Left cands -> Aux.Left (check_cands cands)
+ | Aux.Right cands ->
+ Aux.Right (List.map (fun (p,cands) -> p, check_cands cands) cands)
exception Not_turn_based
@@ -563,7 +629,7 @@
let check_turn_based players agg_actions =
let noop_cands = List.map (fun actions ->
let actions = Aux.map_reduce
- (function [player; action] -> player, action
+ (function [|player; action|] -> player, action
| _ -> assert false) (fun y x->x::y) [] actions in
List.map (function
| player, [Const _ as noop] -> player, Some noop
@@ -603,6 +669,8 @@
(List.map (function Some p -> p | None -> players.(0))
loc_players) in
let loc_n = Array.length loc_players in
+ let players_n = Array.length players in
+ let find_player p = Aux.array_argfind (fun x -> x = p) players in
(* noop actions of a player in a location *)
let loc_noops =
let i = ref 0 in
@@ -630,54 +698,56 @@
let build_toss_rule transl_data rule_names struc fluents
synch_precond synch_postcond (legal_tuple, case_rhs, case_cond) =
let rname =
- Aux.not_conflicting_name rule_names
+ Aux.not_conflicting_name !rule_names
(String.concat "_" (List.map term_to_name legal_tuple)) in
rule_names := Aux.Strings.add rname !rule_names;
let label =
{Arena.rule = rname; time_in = 0.1, 0.1; parameters_in = []} in
let precond =
- synch_precond @ TranslateFormula.translate transl_data case_cond in
+ Formula.And
+ (synch_precond @
+ (* singleton disjunct, i.e. no disjunction *)
+ [TranslateFormula.translate transl_data [case_cond]]) in
let rhs_add = Aux.concat_map
- (function _, [sterm] ->
+ (fun sterm ->
let s_subterms =
- map_paths (fun path subt -> subt, path) transl_data.f_paths sterm in
+ map_paths (fun path subt -> subt, path)
+ transl_data.TranslateFormula.f_paths sterm in
let s_subterms = List.filter
(fun (subt, _) -> subt <> blank) s_subterms in
- let vartup = [|TranslateFormula.var_of_term data sterm|] in
+ (* same as [TranslateFormula.var_of_term], but only the name *)
+ let vartup = [|term_to_name (blank_out transl_data sterm)|] in
List.map (fun (subt, path) ->
pred_on_path_subterm path subt, vartup)
- s_subterms
- | _ -> assert false)
+ s_subterms)
case_rhs in
let rhs_add = synch_postcond @ rhs_add in
let signat = Structure.rel_signature struc in
+ let struc_elems = List.map
+ (fun sterm -> term_to_name (blank_out transl_data sterm))
+ case_rhs in
let discrete =
DiscreteRule.translate_from_precond ~precond
~add:rhs_add ~emb_rels:fluents ~signat ~struc_elems in
let rule =
- ContinuousRule.make_rule signature [] discrete
+ ContinuousRule.make_rule signat [] discrete
[] [] ~pre:discrete.DiscreteRule.pre () in
- let struc_elem_terms = List.map
- (function _, [sterm] -> sterm | _ -> assert false)
- case_rhs in
- let struc_elems = List.map
- (fun sterm -> Formula.var_str (TranslateFormula.var_of_term data sterm))
- struc_elem_terms in
- let elemvars = Aux.strmap_of_assoc
- (List.combine struc_elems struc_elem_terms) in
- let fixvar_terms = List.map
+ let rulevar_terms = Aux.strmap_of_assoc
+ (List.combine struc_elems case_rhs) in
+ let fixvar_terms = Aux.concat_map
(fun sterm -> map_paths
(fun path -> function Var v -> v, (sterm, path)
| _ -> assert false)
- (term_paths (function Var _ -> true | _ -> false) sterm))
- struc_elem_terms in
+ (term_paths (function Var _ -> true | _ -> false) sterm) sterm)
+ case_rhs in
+ let fixvar_terms = Aux.collect fixvar_terms in
let tossrule_data = {
- legal_tuple = legal_tuple;
+ legal_tuple = Array.of_list legal_tuple;
precond = precond;
rhs_add = rhs_add;
struc_elems = struc_elems;
fixvar_terms = fixvar_terms;
- elemvars = elemvars;
+ rulevar_terms = rulevar_terms;
} in
((rname, tossrule_data), label), (rname, rule)
@@ -695,7 +765,7 @@
let loc_rules = Aux.map_some
(fun (legal_tup, _, _ as rcand) ->
let legal_tup = Array.of_list legal_tup in
- if Array.for_alli
+ if Aux.array_for_alli
(fun pl noop -> pl = player_num ||
Some legal_tup.(pl) = noop)
loc_noops.(loc)
@@ -711,7 +781,7 @@
Array.mapi
(fun pl_num payoff ->
{Arena.payoff = payoff;
- view = [];
+ view = Formula.And [], []; (* FIXME: ? *)
heur = [];
moves = if pl_num = player_num then pl_moves else []})
player_payoffs)
@@ -723,49 +793,57 @@
let loc_graph_general_int =
failwith "GDL: General Interaction Games not implemented yet"
-(* Remember that "environment" is the last player -- also in payoffs
- list. [rule_cands] is a player-indexed array. [players] are all
- player terms, excluding "environment". *)
+(* "environment" will the last player -- also in payoffs
+ array. [players] are all player terms, excluding "environment"! *)
let loc_graph_concurrent players
player_payoffs struc build_rule fluents rule_cands =
(* finding or creating the control predicate *)
+ let num_players = Array.length players in
let control_pred, control_e, struc =
try
let control_pred, _ =
List.find (fun (rel, ar) -> ar = 1 &&
- Structure.Tuples.cardinal (Structure.find_rel rel struc) = 1)
+ Structure.Tuples.cardinal (Structure.rel_find rel struc) = 1)
(Structure.rel_signature struc) in
- let etup = Structure.Tuples.choose_elem
- (Structure.find_rel control_pred struc) in
+ let etup = Structure.Tuples.choose
+ (Structure.rel_find control_pred struc) in
control_pred, etup.(0), struc
with Not_found ->
let struc, control_e =
Structure.add_new_elem struc ~name:sControl () in
- let struc = Structure.add_rel struc [|control_e|] in
+ let struc = Structure.add_rel struc sControl [|control_e|] in
sControl, control_e, struc in
(* adding synchronization to rules and putting it all together *)
let player_pred pl = term_to_name pl ^ "__SYNC" in
- let struc = List.fold_left
+ let struc = Array.fold_left
(fun struc player ->
- Structure.add_rel_name (player_pred player) 1) players in
+ Structure.add_rel_name (player_pred player) 1 struc) struc players in
+ let control_vn = Structure.elem_name struc control_e in
let control_v =
- Formula.fo_var_of_string (Structure.elem_name struc control_e) in
+ Formula.fo_var_of_string control_vn in
let player_marker pl =
[player_pred pl, [|control_v|]; control_pred, [|control_v|]] in
- let fluents = List.map player_pred players @ fluents in
+ let player_marker_rhs pl =
+ [player_pred pl, [|control_vn|]; control_pred, [|control_vn|]] in
+ let lplayers = Array.to_list players in
+ let fluents = List.map player_pred lplayers @ fluents in
let all_players_precond =
(List.map (fun (rel,tup) -> Formula.Rel (rel,tup)))
- (Aux.concat_map player_marker players) in
+ (Aux.concat_map player_marker lplayers) in
let rules = ref [] in
let tossr_data = ref [] in
- let player_moves = Array.mapi
- (fun pl_num (pl, p_rules) ->
+ let players_with_env = Array.of_list
+ (Array.to_list players @ [env_player]) in
+ let player_moves = List.map
+ (fun (pl, p_rules) ->
+ let pl_num =
+ Aux.array_argfind (fun x -> x = pl) players_with_env in
let p_rules = List.map
(fun rcand ->
if pl_num = num_players then (* environment *)
build_rule struc fluents all_players_precond [] rcand
else
- build_rule struc fluents [] (player_marker pl) rcand)
+ build_rule struc fluents [] (player_marker_rhs pl) rcand)
p_rules in
(* we need to build first before adding [player_cond] because
of how formula translation works *)
@@ -773,14 +851,15 @@
let p_rdata, labels = List.split p_rdata in
rules := !rules @ p_rules;
tossr_data := !tossr_data @ p_rdata;
- List.map (fun l -> l, (loc + 1) mod loc_n))
+ pl_num, List.map (fun l -> l, 0) labels)
rule_cands in
+ let player_moves = Aux.array_from_assoc player_moves in
let graph =
[|
Aux.array_map2
(fun payoff moves ->
{Arena.payoff = payoff;
- view = [];
+ view = Formula.And [], []; (* FIXME: ? *)
heur = [];
moves = moves})
player_payoffs player_moves
@@ -788,20 +867,98 @@
(graph, !rules, !tossr_data), struc
+(* We assume that clauses for different goal values are disjoint, for
+ non-disjoint we sum each component. *)
+let compute_payoffs transl_data players clauses =
+ (* TODO: we should expand non-constant value expressions... *)
+ let goal_cls = Aux.map_some
+ (function (("goal",[|player; value|]), body) ->
+ Some (player,(value,body)) | _ -> None) clauses in
+ let goal_cls =
+ List.map (fun (player, goal_brs) -> player, Aux.collect goal_brs)
+ (Aux.collect goal_cls) in
+ let player_goals = Array.map
+ (fun player ->
+ try List.assoc player goal_cls
+ with Not_found -> failwith
+ ("TranslateGame.compute_payoffs: no goal provided for player "
+ ^ term_to_name player))
+ players in
+ (* Translate the goal conditions. *)
+ let payoffs = Array.map
+ (fun goals -> List.map
+ (fun (score, disjs) ->
+ let score =
+ match score with
+ | Const pay ->
+ (try float_of_string pay with _ -> assert false)
+ | _ -> failwith
+ ("TranslateGame.compute_payoffs: non-constant " ^
+ "goal values not implemented yet") in
+ let goal_phi = translate transl_data disjs in
+ let phi_vars = FormulaOps.free_vars goal_phi in
+ score,
+ if phi_vars = [] then goal_phi
+ else Formula.Ex (phi_vars, goal_phi))
+ goals)
+ player_goals in
+ (* Offset the values to remove the most inconvenient goal
+ condition. *)
+ let payoffs = Array.map
+ (fun payoff ->
+ let sized =
+ List.map (fun (score,phi) -> GameSimpl.niceness phi, score)
+ payoff in
+ (* Sort in increasing niceness -- to remove the least nice. *)
+ let base_score =
+ match List.sort Pervasives.compare sized with [] -> 0.
+ | (_, score)::_ -> score in
+ match payoff with
+ | [score, guard] ->
+ Formula.Times (
+ Formul...
[truncated message content] |
|
From: <luk...@us...> - 2011-07-30 17:34:30
|
Revision: 1521
http://toss.svn.sourceforge.net/toss/?rev=1521&view=rev
Author: lukaszkaiser
Date: 2011-07-30 17:34:24 +0000 (Sat, 30 Jul 2011)
Log Message:
-----------
Small WebClient corrections.
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/index.html
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-07-29 10:13:18 UTC (rev 1520)
+++ trunk/Toss/Server/ReqHandler.ml 2011-07-30 17:34:24 UTC (rev 1521)
@@ -564,7 +564,10 @@
let list_friends all uid =
if all then List.map (fun a -> a.(0)) (dbtable "" "users") else
let friends = dbtable ("id='" ^ uid ^ "'") "friends" in
- List.map (fun a -> a.(1)) friends in
+ let friends = List.map (fun a -> a.(1)) friends in
+ let contacts = dbtable ("fid='" ^ uid ^ "'") "friends" in
+ let contacts = List.map (fun a -> a.(0)) contacts in
+ Aux.unique_sorted (friends @ contacts) in
let open_db pid =
let res = dbtable (game_select_s pid) "cur_states" in
let (move, info) = ((List.hd res).(4), (List.hd res).(7)) in
@@ -574,11 +577,11 @@
if res = [] then "NONE" else (List.hd res).(7) in
let add_opponent uid oppid =
if uid = "" then "You must login first to add opponents." else
- let (name, _, _) = get_user_name_surname_mail oppid in
- if name = "" then "No such opponent found among tPlay users." else (
- DB.insert_table dbFILE "friends" "id, fid" [uid; oppid];
- "OK"
- ) in
+ let (name, _, _) = get_user_name_surname_mail oppid in
+ if name = "" then "No such opponent found among tPlay users." else (
+ DB.insert_table dbFILE "friends" "id, fid" [uid; oppid];
+ "OK"
+ ) in
let change_user_data uid udata =
if uid = "" then "You must login first to change data." else
if Array.length udata <> 3 then "Internal error, data not changed." else
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-07-29 10:13:18 UTC (rev 1520)
+++ trunk/Toss/WebClient/index.html 2011-07-30 17:34:24 UTC (rev 1521)
@@ -177,6 +177,7 @@
<div id="news">
<h3>News</h3>
<ul id="welcome-list-news" class="welcome-list">
+<li><b>30/07/11</b> Corrected opponent lists in the Profile tab</li>
<li><b>03/07/11</b> Added game descriptions viewable when playing</li>
<li><b>30/06/11</b> View previous moves in a play</li>
<li><b>27/06/11</b> Tabs and searching opponents in the profile page</li>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-07-31 22:11:30
|
Revision: 1522
http://toss.svn.sourceforge.net/toss/?rev=1522&view=rev
Author: lukaszkaiser
Date: 2011-07-31 22:11:24 +0000 (Sun, 31 Jul 2011)
Log Message:
-----------
Remember time of moves in the db.
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/index.html
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-07-30 17:34:24 UTC (rev 1521)
+++ trunk/Toss/Server/ReqHandler.ml 2011-07-31 22:11:24 UTC (rev 1522)
@@ -509,7 +509,7 @@
let move_play move_tup pid =
let sel_s = game_select_s pid in
let old_res= List.hd (dbtable sel_s "cur_states") in
- let (g, p1, p2, m, old_toss, old_loc, old_info, old_svg) =
+ let (g, p1, p2, m, old_toss, old_loc, old_info, old_time) =
(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
client_set_game (g);
@@ -527,10 +527,11 @@
cur_upd ("toss='" ^ new_toss ^ "'");
cur_upd ("info='" ^ new_info_db ^ "'");
cur_upd ("loc='" ^ move3 ^ "'");
+ cur_upd ("svg='" ^ string_of_float (Unix.gettimeofday ()) ^ "'");
cur_upd ("move=" ^ (string_of_int ((int_of_string m) + 1)));
DB.insert_table dbFILE "old_states"
"playid, game, player1, player2, move, toss, loc, info, svg"
- [pid; g; p1; p2; m; old_toss; old_loc; del_q old_info; old_svg];
+ [pid; g; p1; p2; m; old_toss; old_loc; del_q old_info; old_time];
new_info in
let suggest player time pid =
let res = List.hd (dbtable (game_select_s pid) "cur_states") in
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-07-30 17:34:24 UTC (rev 1521)
+++ trunk/Toss/WebClient/index.html 2011-07-31 22:11:24 UTC (rev 1522)
@@ -177,6 +177,7 @@
<div id="news">
<h3>News</h3>
<ul id="welcome-list-news" class="welcome-list">
+<li><b>31/07/11</b> Store date and time of moves in games</li>
<li><b>30/07/11</b> Corrected opponent lists in the Profile tab</li>
<li><b>03/07/11</b> Added game descriptions viewable when playing</li>
<li><b>30/06/11</b> View previous moves in a play</li>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-04 03:58:43
|
Revision: 1524
http://toss.svn.sourceforge.net/toss/?rev=1524&view=rev
Author: lukstafi
Date: 2011-08-04 03:58:35 +0000 (Thu, 04 Aug 2011)
Log Message:
-----------
GDL translation bugfixing: detect turn based games using random playouts (minor commit).
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/GDL.ml 2011-08-04 03:58:35 UTC (rev 1524)
@@ -577,14 +577,15 @@
raise Playout_over)
else
let step = saturate (does @ base) rules in
- let step = Aux.map_some (function ("next", [|arg|]) -> Some arg
- | _ -> None) step in
+ let step_state = Aux.map_some
+ (function ("next", [|arg|]) -> Some arg
+ | _ -> None) step in
if !playout_fixpoint && (* fixpoint reached *)
List.for_all (function
| Func (_,[|arg|]) when
Aux.array_existsi (fun _ player -> arg=player) players -> true
| term -> List.mem term current
- ) step
+ ) step_state
then (
(* {{{ log entry *)
if !debug_level > 0 then (
@@ -592,8 +593,17 @@
);
(* }}} *)
raise Playout_over)
+ else if not aggregate && (* terminal position reached *)
+ List.mem_assoc "terminal" step
+ then (
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.ply: playout over due to terminal position\n%!";
+ );
+ (* }}} *)
+ raise Playout_over)
else
- List.map snd does, step
+ List.map snd does, step_state
(* Besides the playout, also return the separation of rules
into static and dynamic. Note that the list of playout states is
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/GDLTest.ml 2011-08-04 03:58:35 UTC (rev 1524)
@@ -23,7 +23,7 @@
let descr =
GDLParser.parse_game_description KIFLexer.lex
(Lexing.from_channel f) in
- (* List.map GDL.rule_of_entry *) descr
+ descr
let emb_str (game, state) (rname, emb) =
let r = List.assoc rname game.Arena.rules in
@@ -104,7 +104,7 @@
(List.map GDL.rel_atom_str res));
);
- "playout" >::
+ "playout simple" >::
(fun () ->
let descr = parse_game_descr
"
@@ -156,6 +156,27 @@
(does o (mark b a)) (does x noop)"])
);
+ "playout connect5" >::
+ (fun () ->
+ let descr = load_rules ("./GGP/examples/connect5.gdl") in
+
+ let _, _, _, _, (rand_actions, _) =
+ GDL.playout ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
+ 10 (Aux.concat_map GDL.rules_of_clause descr) in
+ let noop_actions = Aux.take_n 9
+ (List.map
+ (Aux.map_some
+ (function [|player; Const "noop"|] -> Some player
+ | _ -> None)) rand_actions) in
+ let res =
+ String.concat "; "
+ (List.map (fun pacts -> String.concat ", "
+ (List.map term_str pacts)) noop_actions) in
+ assert_equal ~msg:"connect5 noop moves by players"
+ ~printer:(fun x->x)
+ "o; x; o; x; o; x; o; x; o" res;
+ );
+
]
let exec = Aux.run_test_if_target "GDLTest" tests
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-04 03:58:35 UTC (rev 1524)
@@ -283,6 +283,7 @@
let elem_term_map = Aux.intmap_of_assoc
(List.map (fun e ->
Structure.find_elem struc (term_to_name e), e) element_reps) in
+ players, rules,
next_clauses, f_paths, m_paths, mask_reps, defined_rels,
!stable_rels, !fluents,
stable_base, init_state, struc, agg_actions, elem_term_map
@@ -629,73 +630,90 @@
(* Check if game is turn based and return the player cycle if it is,
otherwise rise [Not_turn_based]. Also return the [noop] actions
for players in the locations. *)
-let check_turn_based players agg_actions =
- let noop_cands = List.map (fun actions ->
- let actions = Aux.map_reduce
- (function [|player; action|] -> player, action
- | _ -> assert false) (fun y x->x::y) [] actions in
- List.map (function
- | player, [Const _ as noop] -> player, Some noop
- | player, _ -> player, None) actions
- ) agg_actions in
- let control_cands = List.map (fun noop_cands ->
- List.fold_left (fun accu -> function
- | player, None ->
- if accu = None then Some player
- else raise Not_turn_based
- | _, Some _ -> accu) None noop_cands) noop_cands in
- let noop_cands = List.map Aux.collect noop_cands in
+let check_turn_based players rules =
+ let check_one_playout () =
+ let _, _, _, _, (playout_actions, _) =
+ playout ~aggregate:false players !agg_playout_horizon rules in
+ let noop_cands = List.map (fun actions ->
+ let actions = Aux.map_reduce
+ (function [|player; action|] -> player, action
+ | _ -> assert false) (fun y x->x::y) [] actions in
+ List.map (function
+ | player, [Const _ as noop] -> player, Some noop
+ | player, _ -> player, None) actions
+ ) playout_actions in
+ let control_cands = List.map (fun noop_cands ->
+ List.fold_left (fun accu -> function
+ | player, None ->
+ if accu = None then Some player
+ else raise Not_turn_based
+ | _, Some _ -> accu) None noop_cands) noop_cands in
+ let noop_cands = List.map Aux.collect noop_cands in
(* throw in players with (multiple) constant actions *)
- let control_noop_cands = List.map2 (fun ccand noops ->
- let nccands, noops = Aux.partition_map
- (function player, [] -> assert false
- | player, [noop] -> Aux.Right (player, noop)
- | player, more_actions -> Aux.Left player) noops in
- match ccand, nccands with
- | None, [player] -> Some player, noops
- | Some _, [] -> ccand, noops
- | _ -> raise Not_turn_based
- ) control_cands noop_cands in
- let control_cands, noop_cands =
- List.split control_noop_cands in
+ let control_noop_cands = List.map2 (fun ccand noops ->
+ let nccands, noops = Aux.partition_map
+ (function player, [] -> assert false
+ | player, [noop] -> Aux.Right (player, noop)
+ | player, more_actions -> Aux.Left player) noops in
+ match ccand, nccands with
+ | None, [player] -> Some player, noops
+ | Some _, [] -> ccand, noops
+ | _ -> raise Not_turn_based
+ ) control_cands noop_cands in
+ let control_cands, noop_cands =
+ List.split control_noop_cands in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "check_turn_based: control player cands %s\n%!"
+ (String.concat " "
+ (List.map (function Some t->term_str t | None->"None")
+ control_cands))
+ );
+ (* }}} *)
(* 2b *)
- let loc_players = find_cycle control_cands in
+ let loc_players = find_cycle control_cands in
(* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "check_turn_based: location players %s\n%!"
- (String.concat " "
- (List.map (function Some t->term_str t | None->"None")
- loc_players))
- );
+ if !debug_level > 0 then (
+ Printf.printf "check_turn_based: location players %s\n%!"
+ (String.concat " "
+ (List.map (function Some t->term_str t | None->"None")
+ loc_players))
+ );
(* }}} *)
- let loc_players = Array.of_list
- (List.map (function Some p -> p | None -> players.(0))
- loc_players) in
- let loc_n = Array.length loc_players in
- let players_n = Array.length players in
- let find_player p = Aux.array_argfind (fun x -> x = p) players in
+ let loc_players = Array.of_list
+ (List.map (function Some p -> p | None -> players.(0))
+ loc_players) in
+ let loc_n = Array.length loc_players in
+ let players_n = Array.length players in
+ let find_player p = Aux.array_argfind (fun x -> x = p) players in
(* noop actions of a player in a location *)
- let loc_noops =
- let i = ref 0 in
- let noops = ref noop_cands in
- let loc_noops = Array.make_matrix loc_n players_n None in
- while !noops <> [] do
- List.iter (function _, None -> ()
- | player, (Some _ as noop) ->
- let p_i = find_player player in
- if loc_noops.(!i).(p_i) = None
- then loc_noops.(!i).(p_i) <- noop
- else if loc_noops.(!i).(p_i) <> noop
+ let loc_noops =
+ let i = ref 0 in
+ let noops = ref noop_cands in
+ let loc_noops = Array.make_matrix loc_n players_n None in
+ while !noops <> [] do
+ List.iter (function _, None -> ()
+ | player, (Some _ as noop) ->
+ let p_i = find_player player in
+ if loc_noops.(!i).(p_i) = None
+ then loc_noops.(!i).(p_i) <- noop
+ else if loc_noops.(!i).(p_i) <> noop
(* moves are not simultaneous, but different [noop] actions
are used by the same player -- can be resolved by
introducing separate locations for each noop case *)
- then raise Not_turn_based)
- (List.hd !noops);
- incr i; if !i = loc_n then i := 0;
- noops := List.tl !noops
- done;
- loc_noops in
- loc_players, loc_noops
+ then raise Not_turn_based)
+ (List.hd !noops);
+ incr i; if !i = loc_n then i := 0;
+ noops := List.tl !noops
+ done;
+ loc_noops in
+ loc_players, loc_noops in
+ (* doing the playouts "a couple" = 3 times *)
+ let data1 = check_one_playout () in
+ let data2 = check_one_playout () in
+ let data3 = check_one_playout () in
+ if data1 = data2 && data1 = data3 then data1
+ else raise Not_turn_based
let build_toss_rule transl_data rule_names struc fluents
@@ -946,17 +964,13 @@
let translate_game ~playing_as clauses =
let clauses = expand_players clauses in
let used_vars, clauses = rename_clauses clauses in
- let next_cls, f_paths, m_paths, mask_reps, defined_rels,
+ let players, rules,
+ next_cls, f_paths, m_paths, mask_reps, defined_rels,
stable_rels, fluents,
stable_base, init_state, struc, agg_actions, elem_term_map =
create_init_struc clauses in
- let players = Array.of_list
- (Aux.map_some (function
- | ("role", [|player|]), _ -> Some player
- | _ -> None
- ) clauses) in
let turn_data =
- try Some (check_turn_based players agg_actions)
+ try Some (check_turn_based players rules)
with Not_turn_based -> None in
let rule_cands, is_concurrent =
create_rule_cands (turn_data <> None) used_vars next_cls clauses in
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-04 03:58:35 UTC (rev 1524)
@@ -23,7 +23,7 @@
let descr =
GDLParser.parse_game_description KIFLexer.lex
(Lexing.from_channel f) in
- (* List.map GDL.rule_of_entry *) descr
+ descr
let emb_str (game, state) (rname, emb) =
let r = List.assoc rname game.Arena.rules in
@@ -171,7 +171,7 @@
]
let a () =
- (* GDL.debug_level := 5; *)
+ (* GDL.debug_level := 2; *)
TranslateGame.debug_level := 4;
GameSimpl.debug_level := 4;
(* DiscreteRule.debug_level := 4; *)
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/www/reference/reference.tex 2011-08-04 03:58:35 UTC (rev 1524)
@@ -2110,16 +2110,16 @@
attempting a complex analysis to detect as many turn-based games as
possible, we recognize some cases where in all states, all players but
one have a single legal move that is a constant (term of size
-one). Such move is conventionally called \texttt{noop}. We simply
-check what moves are available to players in the states of the
-aggregate playout. Due to the character of aggregate playout, we only
-handle the case where the alternation of control forms a cycle
-(players do not need to strictly alternate, for example a
-single-player game is also a turn-based game, as another example in a
-three-player game the first player may intersperse the moves of second
-and third player). We build a corresponding cyclic graph of Toss
-locations. We limit the turn-based translation to the case where all
-rule clauses have exactly one \texttt{does} atom (\ie can be
+one). Such move is conventionally called \texttt{noop}. In the current
+implementation we simply check what moves are available to players in
+the states of a couple of random playouts, so the detection is
+unsound. We only handle the case where the alternation of control
+forms a cycle (players do not need to strictly alternate, for example
+a single-player game is also a turn-based game, as another example in
+a three-player game the first player may intersperse the moves of
+second and third player). We build a corresponding cyclic graph of
+Toss locations. We limit the turn-based translation to the case where
+all rule clauses have exactly one \texttt{does} atom (\ie can be
attributed to exactly one of the players).
\subsubsection{Concurrent Moves Games} \label{par-concurrent-moves}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-04 16:40:19
|
Revision: 1525
http://toss.svn.sourceforge.net/toss/?rev=1525&view=rev
Author: lukstafi
Date: 2011-08-04 16:40:12 +0000 (Thu, 04 Aug 2011)
Log Message:
-----------
GDL translation fixing: bug expanding player variables.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/Formula/Aux.ml 2011-08-04 16:40:12 UTC (rev 1525)
@@ -193,6 +193,11 @@
fold_left_try f (f accu a) l
with Not_found -> fold_left_try f accu l
+let rec power dom img =
+ List.fold_right (fun v sbs ->
+ concat_map (fun e -> List.map (fun sb -> (v,e)::sb) sbs) img)
+ dom [[]]
+
let product l =
List.fold_right (fun set prod ->
concat_map (fun el -> List.map (fun tup -> el::tup) prod) set)
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/Formula/Aux.mli 2011-08-04 16:40:12 UTC (rev 1525)
@@ -125,6 +125,10 @@
[Not_found]. *)
val fold_left_try : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+(** [power dom img] generates all functions with domain [dom] and
+ image [img], as graphs. *)
+val power : 'a list -> 'b list -> ('a * 'b) list list
+
(** Cartesian product of lists. Not tail recursive. *)
val product : 'a list list -> 'a list list
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/GDL.ml 2011-08-04 16:40:12 UTC (rev 1525)
@@ -313,10 +313,7 @@
" " ^ neg_rel_atoms_str neg_body ^ ")"
let def_str (rel, branches) =
- String.concat "\n" (List.map (fun (args, body, neg_body) ->
- "("^ rel_atom_str (rel, args) ^ " <= " ^ rel_atoms_str body ^
- " " ^ neg_rel_atoms_str neg_body)
- branches)
+ String.concat "\n" (List.map (branch_str rel) branches)
let sb_str sb =
String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
@@ -718,7 +715,8 @@
| "legal", [|Var v; _|] -> Some v
| _ -> None) rels
-
+(* Expand players, and also remove the "role" atoms since they become
+ redundant. *)
let expand_players clauses =
let players =
Aux.map_some (function
@@ -731,8 +729,7 @@
player_vars_of (List.map rel_of_atom (atoms_of_clause clause)) in
if plvars = [] then [clause]
else
- let sbs = List.map (fun v ->
- List.map (fun pl -> v, pl) players) plvars in
+ let sbs = Aux.power plvars players in
List.map (fun sb -> subst_clause sb clause) sbs in
Aux.concat_map exp_clause clauses
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/GDL.mli 2011-08-04 16:40:12 UTC (rev 1525)
@@ -104,6 +104,7 @@
val term_arities : term -> (string * int) list
val rel_atom_str : rel_atom -> string
+val def_str : string * def_branch list -> string
(** {3 GDL whole-game operations.}
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/GDLTest.ml 2011-08-04 16:40:12 UTC (rev 1525)
@@ -156,13 +156,28 @@
(does o (mark b a)) (does x noop)"])
);
+ "expand players connect5" >::
+ (fun () ->
+ let descr = load_rules ("./GGP/examples/connect5.gdl") in
+ let clauses = expand_players descr in
+ let legal_def = List.assoc "legal"
+ (GDL.defs_of_rules
+ (Aux.concat_map GDL.rules_of_clause clauses)) in
+ assert_equal ~msg:"expanded legal branches" ~printer:(fun x->x)
+ "((legal x (mark ?x ?y)) <= (true (control x)) (true (cell ?x ?y b)) )
+((legal o (mark ?x ?y)) <= (true (control o)) (true (cell ?x ?y b)) )
+((legal x noop) <= (role x) (not (true (control x))))
+((legal o noop) <= (role o) (not (true (control o))))"
+ (GDL.def_str ("legal", legal_def));
+ );
+
"playout connect5" >::
(fun () ->
let descr = load_rules ("./GGP/examples/connect5.gdl") in
-
+ let clauses = expand_players descr in
let _, _, _, _, (rand_actions, _) =
GDL.playout ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
- 10 (Aux.concat_map GDL.rules_of_clause descr) in
+ 10 (Aux.concat_map GDL.rules_of_clause clauses) in
let noop_actions = Aux.take_n 9
(List.map
(Aux.map_some
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-04 16:40:12 UTC (rev 1525)
@@ -20,8 +20,8 @@
[nonerasing_frame_wave] is set to [true].) *)
let nonerasing_frame_wave = ref true
-(** Limit on the number of steps for aggregate playout. *)
-let agg_playout_horizon = ref 30
+(** Limit on the number of steps for aggregate and random playouts. *)
+let playout_horizon = ref 30
(** Use "true" atoms while computing rule cases. *)
let split_on_state_atoms = ref false
@@ -188,7 +188,7 @@
let rules = Aux.concat_map rules_of_clause clauses in
let stable_rel_defs, nonstable_rel_defs,
stable_base, init_state, (agg_actions, agg_states) =
- playout ~aggregate:true players !agg_playout_horizon rules in
+ playout ~aggregate:true players !playout_horizon rules in
let stable_rels = Aux.unique_sorted
(List.map (fun ((rel,_),_,_)->rel) stable_rel_defs) in
let nonstable_rels = Aux.unique_sorted
@@ -632,8 +632,25 @@
for players in the locations. *)
let check_turn_based players rules =
let check_one_playout () =
- let _, _, _, _, (playout_actions, _) =
- playout ~aggregate:false players !agg_playout_horizon rules in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "check_turn_based: starting check_one_playout\n"
+ );
+ (* }}} *)
+ let _, _, _, _, (playout_actions, playout_states) =
+ playout ~aggregate:false players !playout_horizon rules in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ let actions = List.map
+ (List.map (fun a->"does", a)) playout_actions in
+ let res =
+ String.concat ";\n" (List.map (fun step -> String.concat " "
+ (List.map GDL.rel_atom_str step)) actions) in
+ Printf.printf
+ "check_turn_based: no of states: %d, playout actions:\n%s\n%!"
+ (List.length playout_states) res
+ );
+ (* }}} *)
let noop_cands = List.map (fun actions ->
let actions = Aux.map_reduce
(function [|player; action|] -> player, action
@@ -648,8 +665,16 @@
if accu = None then Some player
else raise Not_turn_based
| _, Some _ -> accu) None noop_cands) noop_cands in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "check_turn_based: control player pre-cands:\n%s\n%!"
+ (String.concat " "
+ (List.map (function Some t->term_str t | None->"None")
+ control_cands))
+ );
+ (* }}} *)
let noop_cands = List.map Aux.collect noop_cands in
- (* throw in players with (multiple) constant actions *)
+ (* throw in players with (multiple) constant actions *)
let control_noop_cands = List.map2 (fun ccand noops ->
let nccands, noops = Aux.partition_map
(function player, [] -> assert false
@@ -664,29 +689,29 @@
List.split control_noop_cands in
(* {{{ log entry *)
if !debug_level > 1 then (
- Printf.printf "check_turn_based: control player cands %s\n%!"
+ Printf.printf "check_turn_based: control player cands:\n%s\n%!"
(String.concat " "
(List.map (function Some t->term_str t | None->"None")
control_cands))
);
(* }}} *)
- (* 2b *)
+ (* 2b *)
let loc_players = find_cycle control_cands in
- (* {{{ log entry *)
+ (* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "check_turn_based: location players %s\n%!"
(String.concat " "
(List.map (function Some t->term_str t | None->"None")
loc_players))
);
- (* }}} *)
+ (* }}} *)
let loc_players = Array.of_list
(List.map (function Some p -> p | None -> players.(0))
loc_players) in
let loc_n = Array.length loc_players in
let players_n = Array.length players in
let find_player p = Aux.array_argfind (fun x -> x = p) players in
- (* noop actions of a player in a location *)
+ (* noop actions of a player in a location *)
let loc_noops =
let i = ref 0 in
let noops = ref noop_cands in
@@ -698,9 +723,9 @@
if loc_noops.(!i).(p_i) = None
then loc_noops.(!i).(p_i) <- noop
else if loc_noops.(!i).(p_i) <> noop
- (* moves are not simultaneous, but different [noop] actions
- are used by the same player -- can be resolved by
- introducing separate locations for each noop case *)
+ (* moves are not simultaneous, but different [noop] actions
+ are used by the same player -- can be resolved by
+ introducing separate locations for each noop case *)
then raise Not_turn_based)
(List.hd !noops);
incr i; if !i = loc_n then i := 0;
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-08-04 16:40:12 UTC (rev 1525)
@@ -1,6 +1,9 @@
(** Local level of logging. *)
val debug_level : int ref
+(** Limit on plys for both aggregate and random playouts. *)
+val playout_horizon : int ref
+
type tossrule_data = {
legal_tuple : GDL.term array;
(* the "legal"/"does" term of the player that performs the move
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-04 16:40:12 UTC (rev 1525)
@@ -171,7 +171,7 @@
]
let a () =
- (* GDL.debug_level := 2; *)
+ GDL.debug_level := 2;
TranslateGame.debug_level := 4;
GameSimpl.debug_level := 4;
(* DiscreteRule.debug_level := 4; *)
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/www/reference/reference.tex 2011-08-04 16:40:12 UTC (rev 1525)
@@ -1764,11 +1764,13 @@
We determine which clauses are frame clauses prior to partitioning
into the rule clauses and computing the substitution
$\sigma_{\ol{\calC},\ol{\calN}}$ -- at the point where fluent paths
-are computed. It is unclear which wave clauses should be considered
-frame clauses -- we optimistically assume that all wave clauses not
-depending on player actions (\ie not containing \texttt{does}) are
-frame clauses (and in the current implementation we ignore frame-wave
-clauses as they do not provide useful erasure clauses).
+are computed. It is difficult to establish which wave clauses should
+be considered frame clauses. In the current implementation, we
+optimistically assume that all wave clauses not depending on player
+actions (\ie not containing \texttt{does}) are frame clauses (and
+currently we ignore frame-wave clauses as they do not provide useful
+erasure clauses). In the future, we might perform deeper checking as
+to which wave clauses are frame clauses.
From the frame clauses in $\sigma_{\ol{\calC}, \ol{\calN}}(\calN_1), \dots,
\sigma_{\ol{\calC}, \ol{\calN}}(\calN_m)$, we select subsets $J$
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-05 18:35:16
|
Revision: 1527
http://toss.svn.sourceforge.net/toss/?rev=1527&view=rev
Author: lukstafi
Date: 2011-08-05 18:35:09 +0000 (Fri, 05 Aug 2011)
Log Message:
-----------
GDL translation fixing: initial structure generation bug (wrong terms as elements); setting up formula translation testing.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Server/Tests.ml
Added Paths:
-----------
trunk/Toss/GGP/TranslateFormulaTest.ml
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-05 12:09:48 UTC (rev 1526)
+++ trunk/Toss/GGP/GDL.mli 2011-08-05 18:35:09 UTC (rev 1527)
@@ -174,6 +174,8 @@
val at_paths : ?fail_at_missing:bool -> path_set -> term -> term list
val empty_path_set : path_set
+(** Add path to a set. First argument gives term arities. *)
+val add_path : (string -> int) -> path -> path_set -> path_set
val paths_union : path_set -> path_set -> path_set
(** List the paths in a set. *)
Added: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml (rev 0)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-05 18:35:09 UTC (rev 1527)
@@ -0,0 +1,74 @@
+open OUnit
+open TranslateFormula
+
+let parse_game_descr s =
+ GDLParser.parse_game_description KIFLexer.lex
+ (Lexing.from_string s)
+
+let parse_term s =
+ GDLParser.parse_term KIFLexer.lex
+ (Lexing.from_string s)
+
+let pte = parse_term
+
+let state_of_file s =
+ let f = open_in s in
+ let res =
+ ArenaParser.parse_game_state Lexer.lex
+ (Lexing.from_channel f) in
+ res
+
+let load_rules fname =
+ let f = open_in fname in
+ let descr =
+ GDLParser.parse_game_description KIFLexer.lex
+ (Lexing.from_channel f) in
+ descr
+
+let connect5_data =
+ let term_arities =
+ ["control", 1; "cell", 3; "x", 0; "o", 0; "b", 0; "mark", 2] in
+ let arities f = List.assoc f term_arities in
+ let f_paths = List.fold_right (GDL.add_path arities)
+ [["cell", 2]; ["control", 0]] GDL.empty_path_set in
+ let m_paths = List.fold_right (GDL.add_path arities)
+ [["cell", 0]; ["cell", 1]] GDL.empty_path_set in
+ let all_paths = GDL.paths_union f_paths m_paths in
+ let mask_reps =
+ [GDL.Func ("control", [|GDL.blank|]);
+ GDL.Func ("cell", [|GDL.blank; GDL.blank; GDL.blank|])] in
+ let defined_rels = [
+ "adjacent_cell"; "col"; "conn5"; "diag1"; "diag2";
+ "exists_empty_cell"; "exists_line_of_five"; "goal"; "legal"; "next";
+ "row"; "terminal"] in
+ {
+ f_paths = f_paths;
+ m_paths = m_paths;
+ all_paths = all_paths;
+ mask_reps = mask_reps;
+ defined_rels = defined_rels;
+ defrel_arg_type = ref [];
+ term_arities = term_arities;
+ }
+
+let tests = "TranslateFormula" >::: [
+
+ "defined relations connect5" >::
+ (fun () ->
+ let descr = load_rules ("./GGP/examples/connect5.gdl") in
+ let clauses = GDL.expand_players descr in
+ let transl_data = connect5_data in
+ let defined_rels =
+ TranslateFormula.build_defrels transl_data clauses in
+ let res = String.concat "\n"
+ (List.map (fun (rel,(args,body)) ->
+ rel^"("^String.concat ", " args^
+ ") = "^Formula.str body) defined_rels) in
+ assert_equal ~msg:"connect5 noop moves by players"
+ ~printer:(fun x->x)
+ "" res;
+ );
+
+]
+
+let exec = Aux.run_test_if_target "TranslateFormulaTest" tests
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-05 12:09:48 UTC (rev 1526)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-05 18:35:09 UTC (rev 1527)
@@ -327,6 +327,7 @@
(String.concat ", " struc_rels) (String.concat ", " defined_rels)
);
(* }}} *)
+ let stable_rels = ref Aux.Strings.empty in
let struc =
List.fold_left (fun struc rel ->
let arity = List.assoc rel arities in
@@ -338,37 +339,42 @@
let tup = Array.of_list (List.map2 at_path etup ptup) in
if rel = "EQ_" && arity = 2 && tup.(0) = tup.(1)
|| List.mem (rel, tup) static_base
- then
+ then (
+ stable_rels := Aux.Strings.add fact_rel !stable_rels;
Structure.add_rel_named_elems struc fact_rel
- (Array.map term_to_name tup)
+ (* we add the element repr. tuple if subterms at ptup
+ are in relation *)
+ (Aux.array_map_of_list term_to_name etup))
else struc
) struc elem_tups
) struc path_tups
) (Structure.empty_structure ()) struc_rels in
(* adding anchor and fluent predicates *)
- let add_pred rels struc paths elements =
+ let add_pred sig_only rels struc paths elements =
List.fold_left (fun struc path ->
Aux.fold_left_try (fun struc elem ->
let pred =
pred_on_path_subterm path (at_path elem path) in
- if List.mem pred !rels then struc
- else (
- rels := pred :: !rels;
- let tup = [|elem|] in
- Structure.add_rel_named_elems struc pred
- (Array.map term_to_name tup))
+ rels := Aux.Strings.add pred !rels;
+ if sig_only
+ then Structure.add_rel_name pred 1 struc
+ else
+ (* in case the state term is not element repr. yet *)
+ let elem = simult_subst f_paths blank elem in
+ let tup = [|term_to_name elem|] in
+ Structure.add_rel_named_elems struc pred tup
) struc elements
) struc paths in
- let stable_rels = ref [] in
- let fluents = ref [] in
- let struc = add_pred stable_rels struc m_pathl element_reps in
- let struc = add_pred fluents struc f_pathl init_state in
+ let fluents = ref Aux.Strings.empty in
+ let struc = add_pred false stable_rels struc m_pathl element_reps in
+ let struc = add_pred false fluents struc f_pathl init_state in
+ let struc = add_pred true fluents struc f_pathl element_terms in
(* adding mask predicates *)
let all_paths = paths_union m_paths f_paths in
let struc =
List.fold_left (fun struc m ->
let pred = term_to_name m in
- stable_rels := pred :: !stable_rels;
+ stable_rels := Aux.Strings.add pred !stable_rels;
List.fold_left (fun struc elem ->
if simult_subst all_paths blank elem = m
then (
@@ -378,7 +384,7 @@
) struc element_reps
) struc mask_reps in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "create_init_struc: resulting struc=\n%s\n%!"
(Structure.str struc)
);
@@ -392,7 +398,7 @@
Structure.find_elem struc (term_to_name e), e) element_reps) in
players, rules,
next_clauses, f_paths, m_paths, mask_reps, defined_rels,
- !stable_rels, !fluents,
+ Aux.Strings.elements !stable_rels, Aux.Strings.elements !fluents,
static_base, init_state, struc, agg_actions, elem_term_map
(* substitute a "next" clause with frame info *)
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-05 12:09:48 UTC (rev 1526)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-05 18:35:09 UTC (rev 1527)
@@ -143,18 +143,18 @@
assert_equal ~msg:"defined_rels" ~printer:(fun x->x)
"adjacent_cell, col, conn5, diag1, diag2, exists_empty_cell, exists_line_of_five, goal, legal, next, row, terminal"
- (String.concat ", " defined_rels);
+ (String.concat ", " (List.sort String.compare defined_rels));
assert_equal ~msg:"fluents" ~printer:(fun x->x)
- "control_0x, control_0o, cell_2b, cell_2x, cell_2o"
+ "cell_2b, cell_2o, cell_2x, control_0o, control_0x"
(String.concat ", " fluents);
assert_equal ~msg:"stable_rels" ~printer:(fun x->x)
- "A LOT OF THEM"
+ "EQ___cell_0__cell_0, EQ___cell_0__cell_1, EQ___cell_1__cell_0, EQ___cell_1__cell_1, adjacent__cell_0__cell_0, adjacent__cell_0__cell_1, adjacent__cell_1__cell_0, adjacent__cell_1__cell_1, cell_0a, cell_0b, cell_0c, cell_0d, cell_0e, cell_0f, cell_0g, cell_0h, cell_1a, cell_1b, cell_1c, cell_1d, cell_1e, cell_1f, cell_1g, cell_1h, cell__BLANK___BLANK___BLANK_, control__BLANK_, coordinate__cell_0, coordinate__cell_1, nextcol__cell_0__cell_0, nextcol__cell_0__cell_1, nextcol__cell_1__cell_0, nextcol__cell_1__cell_1"
(String.concat ", " stable_rels);
assert_equal ~msg:"structure elements" ~printer:(fun x->x)
- "cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_, cell_a_e__BLANK_, cell_a_f__BLANK_, cell_a_g__BLANK_, cell_a_h__BLANK_, cell_b_a__BLANK_, cell_b_b__BLANK_, cell_b_c__BLANK_, cell_b_d__BLANK_, cell_b_e__BLANK_, cell_b_f__BLANK_, cell_b_g__BLANK_, cell_b_h__BLANK_, cell_c_a__BLANK_, cell_c_b__BLANK_, cell_c_c__BLANK_, cell_c_d__BLANK_, cell_c_e__BLANK_, cell_c_f__BLANK_, cell_c_g__BLANK_, cell_c_h__BLANK_, cell_d_a__BLANK_, cell_d_b__BLANK_, cell_d_c__BLANK_, cell_d_d__BLANK_, cell_d_e__BLANK_, cell_d_f__BLANK_, cell_d_g__BLANK_, cell_d_h__BLANK_, cell_e_a__BLANK_, cell_e_b__BLANK_, cell_e_c__BLANK_, cell_e_d__BLANK_, cell_e_e__BLANK_, cell_e_f__BLANK_, cell_e_g__BLANK_, cell_e_h__BLANK_, cell_f_a__BLANK_, cell_f_b__BLANK_, cell_f_c__BLANK_, cell_f_d__BLANK_, cell_f_e__BLANK_, cell_f_f__BLANK_, cell_f_g__BLANK_, cell_f_h__BLANK_, cell_g_a__BLANK_, cell_g_b__BLANK_, cell_g_c__BLANK_, cell_g_d__BLANK_, cell_g_e__BLANK_, cell_g_f__BLANK_, cell_g_g__BLANK_, cell_g_h__BLANK_, cell_h_a__BLANK_, cell_h_b__BLANK_, cell_h_c__BLANK_, cell_h_d__BLANK_, cell_h_e__BLANK_, cell_h_f__BLANK_, cell_h_g__BLANK_, cell_h_h__BLANK_"
+ "cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_, cell_a_e__BLANK_, cell_a_f__BLANK_, cell_a_g__BLANK_, cell_a_h__BLANK_, cell_b_a__BLANK_, cell_b_b__BLANK_, cell_b_c__BLANK_, cell_b_d__BLANK_, cell_b_e__BLANK_, cell_b_f__BLANK_, cell_b_g__BLANK_, cell_b_h__BLANK_, cell_c_a__BLANK_, cell_c_b__BLANK_, cell_c_c__BLANK_, cell_c_d__BLANK_, cell_c_e__BLANK_, cell_c_f__BLANK_, cell_c_g__BLANK_, cell_c_h__BLANK_, cell_d_a__BLANK_, cell_d_b__BLANK_, cell_d_c__BLANK_, cell_d_d__BLANK_, cell_d_e__BLANK_, cell_d_f__BLANK_, cell_d_g__BLANK_, cell_d_h__BLANK_, cell_e_a__BLANK_, cell_e_b__BLANK_, cell_e_c__BLANK_, cell_e_d__BLANK_, cell_e_e__BLANK_, cell_e_f__BLANK_, cell_e_g__BLANK_, cell_e_h__BLANK_, cell_f_a__BLANK_, cell_f_b__BLANK_, cell_f_c__BLANK_, cell_f_d__BLANK_, cell_f_e__BLANK_, cell_f_f__BLANK_, cell_f_g__BLANK_, cell_f_h__BLANK_, cell_g_a__BLANK_, cell_g_b__BLANK_, cell_g_c__BLANK_, cell_g_d__BLANK_, cell_g_e__BLANK_, cell_g_f__BLANK_, cell_g_g__BLANK_, cell_g_h__BLANK_, cell_h_a__BLANK_, cell_h_b__BLANK_, cell_h_c__BLANK_, cell_h_d__BLANK_, cell_h_e__BLANK_, cell_h_f__BLANK_, cell_h_g__BLANK_, cell_h_h__BLANK_, control__BLANK_"
(String.concat ", "
(List.map (Structure.elem_name struc) (Structure.elements struc)))
);
@@ -236,48 +236,7 @@
"control__blank_", "control_MV1"]
~loc1_noop:"noop" ~loc1_move:"(mark f g)"
-let a () =
- let descr = load_rules ("./GGP/examples/connect5.gdl") in
- let clauses = GDL.expand_players descr in
- let players, rules,
- next_cls, f_paths, m_paths, mask_reps, defined_rels,
- stable_rels, fluents,
- stable_base, init_state, struc, agg_actions, elem_term_map =
- TranslateGame.create_init_struc clauses in
- assert_equal ~msg:"f_paths" ~printer:(fun x->x)
- "cell_2; control_0"
- (String.concat "; "
- (List.map GDL.path_str (GDL.paths_to_list f_paths)));
-
- assert_equal ~msg:"m_paths" ~printer:(fun x->x)
- "cell_0; cell_1"
- (String.concat "; "
- (List.map GDL.path_str (GDL.paths_to_list m_paths)));
-
- assert_equal ~msg:"mask_reps" ~printer:(fun x->x)
- "(cell _BLANK_ _BLANK_ _BLANK_); (control _BLANK_)"
- (String.concat "; "
- (List.map GDL.term_str mask_reps));
-
- assert_equal ~msg:"defined_rels" ~printer:(fun x->x)
- "adjacent_cell, col, conn5, diag1, diag2, exists_empty_cell, exists_line_of_five, goal, legal, next, row, terminal"
- (String.concat ", " defined_rels);
-
- assert_equal ~msg:"fluents" ~printer:(fun x->x)
- "control_0x, control_0o, cell_2b, cell_2x, cell_2o"
- (String.concat ", " fluents);
-
- assert_equal ~msg:"stable_rels" ~printer:(fun x->x)
- "A LOT OF THEM"
- (String.concat ", " stable_rels);
-
- assert_equal ~msg:"structure elements" ~printer:(fun x->x)
- "cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_, cell_a_e__BLANK_, cell_a_f__BLANK_, cell_a_g__BLANK_, cell_a_h__BLANK_, cell_b_a__BLANK_, cell_b_b__BLANK_, cell_b_c__BLANK_, cell_b_d__BLANK_, cell_b_e__BLANK_, cell_b_f__BLANK_, cell_b_g__BLANK_, cell_b_h__BLANK_, cell_c_a__BLANK_, cell_c_b__BLANK_, cell_c_c__BLANK_, cell_c_d__BLANK_, cell_c_e__BLANK_, cell_c_f__BLANK_, cell_c_g__BLANK_, cell_c_h__BLANK_, cell_d_a__BLANK_, cell_d_b__BLANK_, cell_d_c__BLANK_, cell_d_d__BLANK_, cell_d_e__BLANK_, cell_d_f__BLANK_, cell_d_g__BLANK_, cell_d_h__BLANK_, cell_e_a__BLANK_, cell_e_b__BLANK_, cell_e_c__BLANK_, cell_e_d__BLANK_, cell_e_e__BLANK_, cell_e_f__BLANK_, cell_e_g__BLANK_, cell_e_h__BLANK_, cell_f_a__BLANK_, cell_f_b__BLANK_, cell_f_c__BLANK_, cell_f_d__BLANK_, cell_f_e__BLANK_, cell_f_f__BLANK_, cell_f_g__BLANK_, cell_f_h__BLANK_, cell_g_a__BLANK_, cell_g_b__BLANK_, cell_g_c__BLANK_, cell_g_d__BLANK_, cell_g_e__BLANK_, cell_g_f__BLANK_, cell_g_g__BLANK_, cell_g_h__BLANK_, cell_h_a__BLANK_, cell_h_b__BLANK_, cell_h_c__BLANK_, cell_h_d__BLANK_, cell_h_e__BLANK_, cell_h_f__BLANK_, cell_h_g__BLANK_, cell_h_h__BLANK_"
- (String.concat ", "
- (List.map (Structure.elem_name struc) (Structure.elements struc)))
-
-
let a () =
match test_filter
[(* "GDLBig:1:breakthrough" *) "GDLBig:0:connect5"]
@@ -303,3 +262,8 @@
(* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
(* regen_with_debug ~game_name:"connect4" ~player:"white" *)
*)
+
+let exec =
+ Aux.run_test_if_target "TranslateGameTest"
+ ("TranslateGame" >::: [tests; bigtests])
+
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-08-05 12:09:48 UTC (rev 1526)
+++ trunk/Toss/Server/Tests.ml 2011-08-05 18:35:09 UTC (rev 1527)
@@ -35,6 +35,7 @@
"GameSimplTest", [GameSimplTest.tests];
"GDLTest", [GDLTest.tests];
"TranslateGameTest", [TranslateGameTest.tests; TranslateGameTest.bigtests];
+ "TranslateFormulaTest", [TranslateFormulaTest.tests];
]
let server_tests = "Server", [
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-08 20:58:42
|
Revision: 1529
http://toss.svn.sourceforge.net/toss/?rev=1529&view=rev
Author: lukstafi
Date: 2011-08-08 20:58:36 +0000 (Mon, 08 Aug 2011)
Log Message:
-----------
GDL translation specification: (1) default paths for defined relation translation, (2) eliminating variables at fluent paths, (3) eliminating ground arguments of relations. (1) and (2) implemented. Not tested (tests do not pass yet).
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/GDL.ml 2011-08-08 20:58:36 UTC (rev 1529)
@@ -723,6 +723,7 @@
| _ -> None
) clauses in
let exp_clause clause =
+ (* TODO: remove "role" atoms *)
(* determine variables standing for players *)
let plvars =
player_vars_of (List.map rel_of_atom (atoms_of_clause clause)) in
@@ -978,3 +979,27 @@
(** A "blank" term. *)
let blank = Const "_BLANK_"
+
+
+(* [expand_path_vars_by p ts clauses] expands variables that have
+ occurrences at path [p] in some state term of a clause, by terms
+ [ts]. *)
+let expand_path_vars_by p ts clauses =
+ let exp_clause ((h_rel, h_args), body as clause) =
+ (* determine variables standing for players *)
+ let pstates = state_terms (Pos (Rel (h_rel, h_args))::body) in
+ let pvars = Aux.map_try
+ (fun s -> term_vars (at_path s p)) pstates in
+ let pvars = Aux.Strings.elements
+ (List.fold_left Aux.Strings.union Aux.Strings.empty pvars) in
+ if pvars = [] then [clause]
+ else
+ let sbs = Aux.power pvars ts in
+ List.map (fun sb -> subst_clause sb clause) sbs in
+ Aux.concat_map exp_clause clauses
+
+
+let ground_vars_at_paths ps_sterms clauses =
+ List.fold_left (fun clauses (p, ts) ->
+ expand_path_vars_by p ts clauses
+ ) clauses ps_sterms
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/GDL.mli 2011-08-08 20:58:36 UTC (rev 1529)
@@ -182,3 +182,9 @@
val paths_to_list : path_set -> path list
val path_str : path -> string
+
+(** Expand variables that have occurrences at given paths in some
+ state term of a clause, by subterms at those paths in the list of
+ ground terms. *)
+val ground_vars_at_paths :
+ (path * term list) list -> clause list -> clause list
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-08-08 20:58:36 UTC (rev 1529)
@@ -62,6 +62,7 @@
defrel_arg_type : (string * defrel_arg_type) list ref;
(* late binding to store $ArgType# data *)
term_arities : (string * int) list;
+ rel_default_path : (string * path option array) list;
}
let empty_transl_data = {
@@ -72,6 +73,7 @@
defined_rels = [];
defrel_arg_type = ref [];
term_arities = [];
+ rel_default_path = [];
}
let blank_out data t =
@@ -217,7 +219,6 @@
(* {3 Build and use defined relations.} *)
let build_defrels data clauses =
- (* let data = !data_ref in *)
let all_branches = Aux.concat_map
(fun ((rel,args),body) ->
List.map (fun phi -> rel, (args, phi)) (separate_disj [body]))
@@ -283,13 +284,20 @@
(fun i ->
function Some _ -> None | None -> callside_for_arg i)
p_defside in
- let arg_paths = Aux.array_map2
- (fun defside callside ->
+ let arg_paths = Array.mapi
+ (fun i defside ->
+ let callside = p_callside.(i) in
match defside, callside with
| Some p, _ | None, Some p -> p
- | None, None -> (* find a good path *)
- failwith "GGP/TranslateFormula: finding path for defined relation argument undetermined by state terms not implemented yet")
- p_defside p_callside in
+ | None, None ->
+ (* the ArgType(R,i) = NoSide,p variant is precomputed *)
+ match (List.assoc rel data.rel_default_path).(i) with
+ | Some p -> p
+ | None -> failwith
+ (Printf.sprintf
+ "TranslateFormula.build_defrels: could not \
+ determine path for relation %s argument %d" rel i)
+ ) p_defside in
(* now building the translation *)
let defvars =
Array.mapi (fun i _ -> "v"^string_of_int i) arg_paths in
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-08-08 20:58:36 UTC (rev 1529)
@@ -11,6 +11,7 @@
defrel_arg_type : (string * defrel_arg_type) list ref;
(** late binding to store $ArgType$ data *)
term_arities : (string * int) list;
+ rel_default_path : (string * GDL.path option array) list;
}
val blank_out : transl_data -> GDL.term -> GDL.term
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-08 20:58:36 UTC (rev 1529)
@@ -27,7 +27,8 @@
let connect5_data =
let term_arities =
- ["control", 1; "cell", 3; "x", 0; "o", 0; "b", 0; "mark", 2] in
+ ["control", 1; "cell", 3; "x", 0; "o", 0; "b", 0; "mark", 2;
+ "a", 0; "b", 0; "c", 0; "d", 0; "e", 0; "f", 0; "g", 0; "h", 0] in
let arities f = List.assoc f term_arities in
let f_paths = List.fold_right (GDL.add_path arities)
[["cell", 2]; ["control", 0]] GDL.empty_path_set in
@@ -37,10 +38,18 @@
let mask_reps =
[GDL.Func ("control", [|GDL.blank|]);
GDL.Func ("cell", [|GDL.blank; GDL.blank; GDL.blank|])] in
- let defined_rels = [
- "adjacent_cell"; "col"; "conn5"; "diag1"; "diag2";
- "exists_empty_cell"; "exists_line_of_five"; "goal"; "legal"; "next";
- "row"; "terminal"] in
+ let defrel_arities = [
+ "adjacent_cell", 4;
+ "col__x", 0; "col__o", 0; "col__b", 0;
+ "conn5__x", 0; "conn5__o", 0; "conn5__b", 0;
+ "diag1__x", 0; "diag1__o", 0; "diag1__b", 0;
+ "diag2__x", 0; "diag2__o", 0; "diag2__b", 0;
+ "exists_empty_cell", 0; "exists_line_of_five", 0;
+ "row__x", 0; "row__o", 0; "row__b", 0] in
+ let defined_rels = List.map fst defrel_arities in
+ let default_path = Some ["cell", 0] in
+ let rel_default_path = List.map
+ (fun (rel, ar) -> rel, Array.make ar default_path) defrel_arities in
{
f_paths = f_paths;
m_paths = m_paths;
@@ -49,6 +58,7 @@
defined_rels = defined_rels;
defrel_arg_type = ref [];
term_arities = term_arities;
+ rel_default_path = rel_default_path;
}
let tests = "TranslateFormula" >::: [
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-08 20:58:36 UTC (rev 1529)
@@ -264,24 +264,17 @@
(List.map GDL.path_str (GDL.paths_to_list f_paths)))
);
(* }}} *)
- let next_clauses =
- List.map (function
- | (_,[|s_C|]),body_C -> s_C, true, body_C
- | _ -> assert false) frame_clauses
- @ List.map (function
- | (_,[|s_C|]),body_C -> s_C, false, body_C
- | _ -> assert false) move_clauses in
let arities =
("EQ_", 2)::
Aux.unique_sorted
(List.map (fun ((rel, args),_) -> rel, Array.length args)
clauses) in
- let element_terms =
+ let ground_state_terms =
List.fold_left (fun acc st -> Aux.unique_sorted (st @ acc)) []
agg_states in
let element_reps =
Aux.unique_sorted (List.map (fun t ->
- simult_subst f_paths blank t) element_terms) in
+ simult_subst f_paths blank t) ground_state_terms) in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
@@ -368,7 +361,7 @@
let fluents = ref Aux.Strings.empty in
let struc = add_pred false stable_rels struc m_pathl element_reps in
let struc = add_pred false fluents struc f_pathl init_state in
- let struc = add_pred true fluents struc f_pathl element_terms in
+ let struc = add_pred true fluents struc f_pathl ground_state_terms in
(* adding mask predicates *)
let all_paths = paths_union m_paths f_paths in
let struc =
@@ -397,9 +390,9 @@
(List.map (fun e ->
Structure.find_elem struc (term_to_name e), e) element_reps) in
players, rules,
- next_clauses, f_paths, m_paths, mask_reps, defined_rels,
+ frame_clauses, move_clauses, f_paths, m_paths, mask_reps, defined_rels,
Aux.Strings.elements !stable_rels, Aux.Strings.elements !fluents,
- static_base, init_state, struc, agg_actions, elem_term_map
+ static_base, init_state, struc, ground_state_terms, elem_term_map
(* substitute a "next" clause with frame info *)
let subst_fnextcl sb (head, frame, body) =
@@ -1097,16 +1090,62 @@
payoffs
+let transl_arg_type_no_side defined_rels static_base init_state
+ ground_at_m_paths =
+ assert (ground_at_m_paths <> []);
+ List.map (fun (rel, ar) ->
+ let rel_graph = Aux.assoc_all rel static_base in
+ match rel_graph with
+ (* empty graph, take any path *)
+ | [] -> rel, Array.make ar None
+ | tup::tups ->
+ let projs =
+ List.fold_left
+ (fun agg_tup tup ->
+ Aux.array_map2 (fun x y->x::y) tup agg_tup)
+ (Array.map (fun t->[t]) tup) tups in
+ let intersects = Array.map
+ (fun rel_proj ->
+ let rel_proj = Aux.unique_sorted rel_proj in
+ List.sort (fun (i,_) (j,_) -> j-i) (
+ List.map
+ (fun (p, pts) ->
+ List.length (Aux.list_inter rel_proj pts), p)
+ ground_at_m_paths)) projs in
+ rel,
+ Array.map (function (_, p)::_ -> Some p | [] -> None)
+ intersects
+ ) defined_rels
+
+
(* [playing_as] is only used for building move translation data, the
translation is independent of the selected player. *)
let translate_game ~playing_as clauses =
let clauses = expand_players clauses in
let used_vars, clauses = rename_clauses clauses in
let players, rules,
- next_cls, f_paths, m_paths, mask_reps, defined_rels,
- stable_rels, fluents,
- static_base, init_state, struc, agg_actions, elem_term_map =
+ frame_clauses, move_clauses, f_paths, m_paths,
+ mask_reps, defined_rels, stable_rels, fluents,
+ static_base, init_state, struc, ground_state_terms, elem_term_map =
create_init_struc clauses in
+ let ground_at paths = List.map
+ (fun p ->
+ p, Aux.map_try (fun s -> at_path s p) ground_state_terms)
+ (paths_to_list paths) in
+ let ground_at_f_paths = ground_at f_paths in
+ let clauses =
+ ground_vars_at_paths ground_at_f_paths clauses in
+ let frame_clauses =
+ ground_vars_at_paths ground_at_f_paths frame_clauses in
+ let move_clauses =
+ ground_vars_at_paths ground_at_f_paths move_clauses in
+ let next_cls =
+ List.map (function
+ | (_,[|s_C|]),body_C -> s_C, true, body_C
+ | _ -> assert false) frame_clauses
+ @ List.map (function
+ | (_,[|s_C|]),body_C -> s_C, false, body_C
+ | _ -> assert false) move_clauses in
let turn_data =
try Some (check_turn_based players rules)
with Not_turn_based -> None in
@@ -1114,10 +1153,13 @@
create_rule_cands (turn_data <> None) used_vars next_cls clauses in
let rule_cands =
filter_rule_cands static_base defined_rels rule_cands in
- let all_state_terms =
- Aux.concat_map state_terms (List.map snd clauses) in
let term_arities = Aux.unique_sorted
- (Aux.concat_map term_arities all_state_terms) in
+ (Aux.concat_map term_arities ground_state_terms) in
+ let defined_rel_arities = List.map
+ (fun rel ->
+ let args = List.assoc rel (List.map fst clauses) in
+ rel, Array.length args)
+ defined_rels in
let transl_data = {
TranslateFormula.f_paths = f_paths;
m_paths = m_paths;
@@ -1126,6 +1168,9 @@
defined_rels = defined_rels;
defrel_arg_type = ref []; (* built in TranslateFormula *)
term_arities = term_arities;
+ rel_default_path =
+ transl_arg_type_no_side defined_rel_arities static_base init_state
+ (ground_at m_paths);
} in
let defined_rels = TranslateFormula.build_defrels transl_data clauses in
let player_names = Array.to_list
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-08-08 20:58:36 UTC (rev 1529)
@@ -51,16 +51,16 @@
(* Create the initial structure and assorted data. Exposed for testing
purposes.
- [players, rules, next_cls, f_paths, m_paths, mask_reps,
+ [players, rules, frame_cls, move_cls, f_paths, m_paths, mask_reps,
defined_rels, stable_rels, fluents, stable_base, init_state,
- struc, agg_actions, elem_term_map = create_init_struc clauses] *)
+ struc, ground_state_terms, elem_term_map = create_init_struc clauses] *)
val create_init_struc :
GDL.clause list ->
GDL.term array * GDL.gdl_rule list *
- (GDL.term * bool * GDL.literal list) list * GDL.path_set *
+ GDL.clause list * GDL.clause list * GDL.path_set *
GDL.path_set * GDL.term list * string list * string list *
string list * GDL.rel_atom list * GDL.term list *
- Structure.structure * GDL.term array list list *
+ Structure.structure * GDL.term list *
GDL.term Aux.IntMap.t
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-08 20:58:36 UTC (rev 1529)
@@ -117,13 +117,12 @@
"connect5 translation data" >::
(fun () ->
- (* perhaps should be a small test, takes mediocrily long *)
let descr = load_rules ("./GGP/examples/connect5.gdl") in
let clauses = GDL.expand_players descr in
let players, rules,
- next_cls, f_paths, m_paths, mask_reps, defined_rels,
+ frame_cls, move_cls, f_paths, m_paths, mask_reps, defined_rels,
stable_rels, fluents,
- stable_base, init_state, struc, agg_actions, elem_term_map =
+ stable_base, init_state, struc, ground_state_terms, elem_term_map =
TranslateGame.create_init_struc clauses in
assert_equal ~msg:"f_paths" ~printer:(fun x->x)
@@ -141,6 +140,8 @@
(String.concat "; "
(List.map GDL.term_str mask_reps));
+ (* adjacent_cell is a defined relation only because it has
+ large arity: see {!TranslateGame.defined_arity_above}. *)
assert_equal ~msg:"defined_rels" ~printer:(fun x->x)
"adjacent_cell, col, conn5, diag1, diag2, exists_empty_cell, exists_line_of_five, goal, legal, next, row, terminal"
(String.concat ", " (List.sort String.compare defined_rels));
@@ -222,6 +223,7 @@
(* DiscreteRule.debug_level := 4; *)
()
+
let a () =
game_test_case ~game_name:"connect5" ~player:"x"
~own_plnum:0 ~opponent_plnum:1
@@ -263,7 +265,7 @@
(* regen_with_debug ~game_name:"connect4" ~player:"white" *)
*)
-let exec =
+let exec () =
Aux.run_test_if_target "TranslateGameTest"
("TranslateGame" >::: [tests; bigtests])
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-08-08 05:20:23 UTC (rev 1528)
+++ trunk/Toss/www/reference/reference.tex 2011-08-08 20:58:36 UTC (rev 1529)
@@ -1306,11 +1306,15 @@
clearly referring to players (\ie arguments of positive \texttt{role}
atoms, first arguments to positive \texttt{does} atoms and to
\texttt{legal}) by substituting them by players of $G$ (\ie arguments
-of \texttt{role} facts), duplicating the clauses. From this transformed
-specification, we derive the elements of the Toss structure
-(Section~\ref{subsec-elems}), the relations (Section~\ref{subsec-rels}),
-the rewriting rules (Section~\ref{subsec-rules}) and finally the move
-translation function (Section~\ref{subsec-move-tr}).
+of \texttt{role} facts), duplicating the clauses. From this
+specification, we derive the elements (Section~\ref{subsec-elems}) and
+the stable relations and initial fluents (Section~\ref{subsec-rels})
+of the Toss structure. Having separated the fluent from the stable
+part of state terms, we further transform the definition $G$ by
+expanding variables corresponding to fluents, and use the transformed
+specification to derive the defined relations in Toss, the rewriting
+rules (Section~\ref{subsec-rules}) and finally the move translation
+function (Section~\ref{subsec-move-tr}).
\subsection{Elements of the Toss Structure} \label{subsec-elems}
@@ -1624,6 +1628,42 @@
% formulas.
%\end{definition}
+\subsection{Expanding the GDL Game Definition}
+
+Prior to further processing, we modify the wave clauses of the
+game. Let $\calN \in \mathrm{Next}_{W}$, we add to the body of $\calN$
+a \texttt{true} atom $(\mathtt{true} \ BL(s_\calN)$ (where
+$\mathtt{BL}(t)=t\big[\calP_f \ot \mathtt{BLANK}\big]$). The added
+state term will be the corresponding LHS element of the RHS element
+introduced by the clause.
+
+Now we discuss transformations of the game $G$ that result in a longer
+(having more clauses) but simpler definition. \emph{Eliminating a GDL
+ variable $x \in FV(\calC)$ by a set of terms $T$} means replacing
+the clause $C$ the variable occurs in, with a set of clauses $\calC_t
+= \calC[v \ot t]$ for $t \in T$. First such transformation initiated
+the translation process: we eliminated variables ranging over players
+(by virtue of occurring in \texttt{does}, \texttt{legal} or
+\texttt{goal} atoms), by the players of the game.
+
+Before generating Toss formulas we also transform the definition $G$
+by grounding all variables that have occurrences at fluent paths, \ie
+eliminating these variables by constants that occur at these paths in
+ground state terms $\calS$.
+
+After eliminating variables, we eliminate arguments of a defined
+relation that are ground in the head of each clause defining the
+relation. We generate a new relation name for each value of the
+argument. We replace all atoms of the old relation by those new
+relations to which the eliminated argument of the atom can be
+instantiated, if necessary duplicating the clause containing the atom
+(if some variables need to be eliminated by the instantiation).
+
+As an optimization, instead of duplicating the clause, if a variable
+is local to an atom (in all cases of eliminating a variable), we can
+replace the atom by a disjunction of corresponding atoms, or if it is
+a negative literal, by a conjunction of negated atoms.
+
\subsection{Structure Rewriting Rules}
To create the structure rewriting rule for the Toss game,
@@ -1632,13 +1672,6 @@
be the players in $G$, \ie let there be \texttt{(role $p_1$)}
up to \texttt{(role $p_n$)} facts in $G$, in this order.
-Prior to further processing, we modify the wave clauses of the
-game. Let $\calN \in \mathrm{Next}_{W}$, we add to the body of $\calN$
-a \texttt{true} atom $(\mathtt{true} \ BL(s_\calN)$ (where
-$\mathtt{BL}(t)=t\big[\calP_f \ot \mathtt{BLANK}\big]$). The added
-state term will be the corresponding LHS element of the RHS element
-introduced by the clause.
-
\subsubsection{Move Clauses}
By GDL specification, a legal joint move of the players is a tuple of
@@ -2011,7 +2044,7 @@
\ldots, \mathtt{(<= (R \ t^k_1 \ldots t^k_n) \ b_k)}.\]
For the $i$th argument of $R$ ($i \in \{1,\ldots,n\}$) we will find
$\mathtt{ArgType}(R,i)$ with possible values
-$(\mathtt{DefSide},\calS_i,p_i)$ and $(\mathtt{CallSide},p_i)$, with a mapping $\calS_i$ into state terms
+$(\mathtt{DefSide},\calS_i,p_i)$, $(\mathtt{CallSide},p_i)$ and $(\mathtt{NoSide},p_i)$, with a mapping $\calS_i$ into state terms
corresponding to the argument in a given context and a path $p_i \in
\calP_m$ corresponding to the subterm position selected to
``transfer'' the argument.
@@ -2034,21 +2067,30 @@
the domain of $\calS_i(p_i)$ is maximal. Set $\mathtt{ArgType}(R,i) =
(\mathtt{CallSide},p_i)$.
-The specific definition of $\mathtt{ArgType}(R,i) =
-(\mathtt{CallSide},p_i)$ is not relevant for correctness, but (for
-correctness) $p_i \in \calP_m$ should be a path whose domain, \ie the
-set $\big\{t \big| s\tpos_{p_i} = t, s \in \calS\big\}$, contains the
-domain of the $i$th argument of $R$, \ie the sum of projections of $R$
-on $i$th argument for all possible game states. The current definition
-above does not guarantee this; the exact implementation may further
-evolve as $\mathtt{ArgType}$ is relevant for the quality of
-translation (\ie how many simplifications can be applied, see
-Section~\ref{sec-game-simpl}).
+In case neither $\mathtt{DefSide}$ nor $\mathtt{CallSide}$ approach is
+satisfactory, we set $\mathtt{ArgType}(R,i) = (\mathtt{NoSide},p_i)$,
+where the path $p_i \in \calP_m$ is selected so that the intersection
+of the projection of the graph of $R$ for the initial game state
+$g_{R,i} = \{s | G \vdash R(t_1,\ldots,t_n) \textit{ for any }
+\ol{t} \textit{ s.t. } t_i = s\}$, and the set of subterms of state
+terms at path $p_i$, $g_{p_i} = \{s \tpos_{p_i} | s \in \calS\}$, is
+maximal w.r.t. cardinality ($p_i = \arg \max_{p \in \calP_m} \left|
+ g_{R,i} \cap g_p \right|$).
+For correctness, $p_i \in \calP_m$ should be a path whose domain, \ie
+the set $\big\{t \big| s\tpos_{p_i} = t, s \in \calS\big\}$, contains
+the domain of the $i$th argument of $R$, \ie the sum of projections of
+$R$ on $i$th argument for all possible game states. The current
+definition above does not guarantee this; the exact implementation may
+further evolve as $\mathtt{ArgType}$ is relevant for the quality of
+translation (\ie both for correctness and how many simplifications can
+be applied, see Section~\ref{sec-game-simpl}).
+
We are ready to provide the translated definition $R_{def}$. Let
$v_1,\ldots,v_n$ be fresh Toss variables, let $\calI_R = \big\{i
\big| \mathtt{ArgType}(R,i) =
-(\mathtt{DefSide},\calS_i,p_i)\big\}$ and $p_{R,i}$ be such that $\mathtt{ArgType}(R,i) =
+(\mathtt{DefSide},\calS_i,p_i)\big\}$ and $p_{R,i}$ be such that
+$\mathtt{ArgType}(R,i) =
(\mathtt{DefSide},\calS_i,p_{R,i})$ or $\mathtt{ArgType}(R,i) =
(\mathtt{CallSide},p_{R,i})$. Let $\mathtt{BL}(p \ot t)$ for
a path $p$ and term $t$ be a state term containing $t$ at path $p$,
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-09 06:21:54
|
Revision: 1530
http://toss.svn.sourceforge.net/toss/?rev=1530&view=rev
Author: lukaszkaiser
Date: 2011-08-09 06:21:46 +0000 (Tue, 09 Aug 2011)
Log Message:
-----------
Moving move type to Arena.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Play/MoveTest.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Server/ReqHandler.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Arena/Arena.ml 2011-08-09 06:21:46 UTC (rev 1530)
@@ -10,7 +10,7 @@
(* A single move consists of applying a rewrite rule for a time from the
[time_in] interval, and parameters from the interval list. *)
type label = {
- rule : string ;
+ lb_rule : string ;
time_in : float * float ;
parameters_in : (string * (float * float)) list ;
}
@@ -47,6 +47,14 @@
cur_loc : int ;
}
+type move = {
+ mv_time : float ;
+ parameters : (string * float) list ;
+ rule : string ;
+ next_loc : int ;
+ embedding : (int * int) list ;
+}
+
let zero_loc = { payoff = Formula.Const 0. ;
view = (Formula.And [], []);
heur = [];
@@ -80,7 +88,8 @@
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
- let rules_of_loc l = List.map (fun (lab,_) -> lab.rule) l.(player_no).moves in
+ let rules_of_loc l =
+ List.map (fun (lab,_) -> lab.lb_rule) l.(player_no).moves in
List.concat (List.map rules_of_loc (Array.to_list game.graph))
(* Add a defined relation to a structure. *)
@@ -132,7 +141,7 @@
let time_in, parameters_in =
try Aux.pop_assoc "t" params
with Not_found -> (cDEFAULT_TIMESTEP, cDEFAULT_TIMESTEP), params in
- { rule = rname;
+ { lb_rule = rname;
time_in = time_in;
parameters_in = parameters_in;
}, target_loc
@@ -285,7 +294,7 @@
(* Print a label as a string. *)
let label_str
- {rule = rr; time_in = t_interval; parameters_in = param_intervals} =
+ {lb_rule = rr; time_in = t_interval; parameters_in = param_intervals} =
let fpstr (f,(fs, fe)) =
f ^ ": " ^ (string_of_float fs) ^ " -- " ^ (string_of_float fe) in
let par_str = if param_intervals = [] then " " else
@@ -304,7 +313,7 @@
if moves <> [] then
Format.fprintf f "@[<1>MOVES@ %a@]@ "
(Aux.fprint_sep_list ";" (fun f ({
- rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
+ lb_rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
Format.fprintf f "[@,@[<1>%s" r;
if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
@@ -492,13 +501,13 @@
let label, dest = List.hd dmoves1 in
Printf.sprintf
"At location %d, only the first game has label %s->%d"
- i label.rule dest));
+ i label.lb_rule dest));
let dmoves2 = Aux.list_diff loc2.moves loc1.moves in
if dmoves2 <> [] then raise (Diff_result (
let label, dest = List.hd dmoves1 in
Printf.sprintf
"At location %d, only the second game has label %s->%d"
- i label.rule dest));
+ i label.lb_rule dest));
let poff1 =
FormulaOps.map_to_formulas_expr Formula.flatten loc1.payoff in
let poff2 =
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Arena/Arena.mli 2011-08-09 06:21:46 UTC (rev 1530)
@@ -5,7 +5,7 @@
(** A single move consists of applying a rewrite rule for a time from the
[time_in] interval, and parameters from the interval list. *)
type label = {
- rule : string ;
+ lb_rule : string ;
time_in : float * float ;
parameters_in : (string * (float * float)) list ;
}
@@ -34,6 +34,15 @@
defined_rels : (string * (string list * Formula.formula)) list ;
}
+(** Move - complete basic action data. **)
+type move = {
+ mv_time : float ;
+ parameters : (string * float) list ;
+ rule : string ;
+ next_loc : int ;
+ embedding : (int * int) list ;
+}
+
(** State of the game. *)
type game_state = {
struc : Structure.structure ;
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-09 06:21:46 UTC (rev 1530)
@@ -854,7 +854,7 @@
(String.concat "_" (List.map term_to_name legal_tuple)) in
rule_names := Aux.Strings.add rname !rule_names;
let label =
- {Arena.rule = rname; time_in = 0.1, 0.1; parameters_in = []} in
+ {Arena.lb_rule = rname; time_in = 0.1, 0.1; parameters_in = []} in
let precond =
Formula.And
(synch_precond @
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Play/GameTree.ml 2011-08-09 06:21:46 UTC (rev 1530)
@@ -27,7 +27,7 @@
| Leaf of Arena.game_state * int * 'a
(* leaf with state, player, and info *)
| Node of Arena.game_state * int * 'a *
- (Move.move * ('a, 'b) abstract_game_tree) array
+ (Arena.move * ('a, 'b) abstract_game_tree) array
(* node with state, player, moves and info *)
(* Abstract tree printing function. *)
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Play/GameTree.mli 2011-08-09 06:21:46 UTC (rev 1530)
@@ -16,7 +16,7 @@
| Leaf of Arena.game_state * int * 'a
(** leaf with state, player, and info *)
| Node of Arena.game_state * int * 'a *
- (Move.move * ('a, 'b) abstract_game_tree) array
+ (Arena.move * ('a, 'b) abstract_game_tree) array
(** node with state, player, moves *)
(** Abstract tree printing function. *)
@@ -43,9 +43,9 @@
info_terminal : (int -> Arena.game -> Arena.game_state -> int -> 'a -> 'b) ->
info_leaf : (int -> Arena.game -> Arena.game_state -> int -> int -> 'a) ->
info_node : (int -> Arena.game -> Arena.game_state -> int ->
- (Move.move * ('a, 'b) abstract_game_tree) array -> 'a) ->
+ (Arena.move * ('a, 'b) abstract_game_tree) array -> 'a) ->
choice : (int -> Arena.game -> Arena.game_state -> int -> 'a ->
- (Move.move * ('a, 'b) abstract_game_tree) array -> int) ->
+ (Arena.move * ('a, 'b) abstract_game_tree) array -> int) ->
('a, 'b) abstract_game_tree -> ('a, 'b) abstract_game_tree
@@ -84,7 +84,7 @@
(** Choose all maximizing moves given a game tree. *)
val choose_moves : Arena.game -> 'a game_tree ->
- (Move.move * Arena.game_state) list
+ (Arena.move * Arena.game_state) list
(** Game tree initialization. *)
@@ -97,8 +97,8 @@
Formula.real_expr array array ->
info_leaf : (int -> Arena.game -> Arena.game_state -> 'a) ->
info_node : (int -> int -> float array ->
- (Move.move * 'a game_tree) array -> 'a) ->
+ (Arena.move * 'a game_tree) array -> 'a) ->
choice : (float array option ref -> int -> Arena.game -> Arena.game_state ->
- int -> 'a node_info -> (Move.move * 'a game_tree) array -> int) ->
+ int -> 'a node_info -> (Arena.move * 'a game_tree) array -> int) ->
'a game_tree -> 'a game_tree
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Play/Move.ml 2011-08-09 06:21:46 UTC (rev 1530)
@@ -5,36 +5,28 @@
let cGRID_SIZE = 5
-(* Data to return a move as a suggestion rather than directly. *)
-type move = {
- mv_time : float ;
- parameters : (string * float) list ;
- rule : string ;
- next_loc : int ; (* next location in the arena *)
- embedding : (int * int) list ;
-}
-
(* Make a move in a game. *)
let make_move m (game, state) =
- let req = Arena.ApplyRuleInt (m.rule, m.embedding, m.mv_time, m.parameters) in
+ let req = Arena.ApplyRuleInt
+ (m.Arena.rule, m.Arena.embedding, m.Arena.mv_time, m.Arena.parameters) in
let (new_game, new_state), _ = Arena.handle_request (game, state) req in
- (new_game, { new_state with Arena.cur_loc = m.next_loc })
+ (new_game, { new_state with Arena.cur_loc = m.Arena.next_loc })
(* Print a move as string.
TODO: perhaps find a nicer syntax? See {!TestGame.move_str}. *)
let move_str rules struc move =
- let r = List.assoc move.rule rules in
+ let r = List.assoc move.Arena.rule rules in
let rhs_struc = r.ContinuousRule.discrete.DiscreteRule.rhs_struc in
let fpstr (f, fv) =
f ^ ": " ^ (string_of_float fv) in
- let par_str = if move.parameters = [] then " " else
- ", " ^ (String.concat ", " (List.map fpstr move.parameters)) in
+ let par_str = if move.Arena.parameters = [] then " " else
+ ", " ^ (String.concat ", " (List.map fpstr move.Arena.parameters)) in
let p_name (r, e) =
Structure.elem_str rhs_struc r ^": "^ Structure.elem_str struc e in
- let emb = String.concat ", " (List.map p_name move.embedding) in
- (move.rule) ^ "; " ^ emb ^ "; " ^ fpstr ("t", move.mv_time) ^ par_str ^
- "; " ^ (string_of_int move.next_loc)
+ let emb = String.concat ", " (List.map p_name move.Arena.embedding) in
+ (move.Arena.rule) ^ "; " ^ emb ^ "; " ^ fpstr ("t", move.Arena.mv_time) ^
+ par_str ^ "; " ^ (string_of_int move.Arena.next_loc)
let move_gs_str (game, state) move =
move_str game.Arena.rules state.Arena.struc move
@@ -45,8 +37,8 @@
let p_name (r, e) =
string_of_int r ^ ":" ^ Structure.elem_str struc e in
let emb = String.concat ", "
- (List.map p_name (List.sort Pervasives.compare move.embedding)) in
- move.rule ^ "{" ^ emb ^ "}"
+ (List.map p_name (List.sort Pervasives.compare move.Arena.embedding)) in
+ move.Arena.rule ^ "{" ^ emb ^ "}"
let move_gs_str_short state move = move_str_short state.Arena.struc move
@@ -56,7 +48,7 @@
let matchings =
Aux.concat_map
(fun (label,next_loc) ->
- let rule = List.assoc label.Arena.rule rules in
+ let rule = List.assoc label.Arena.lb_rule rules in
List.map (fun emb -> label,next_loc,emb)
(ContinuousRule.matches model rule))
loc.Arena.moves in
@@ -70,9 +62,9 @@
let t = (t_r +. t_l) /. 2. in
if label.Arena.parameters_in = [] then
[| {
- mv_time = t;
+ Arena.mv_time = t;
parameters = [];
- rule = label.Arena.rule;
+ rule = label.Arena.lb_rule;
next_loc = next_loc;
embedding = emb
} |]
@@ -90,9 +82,9 @@
) params_in in
let grid = Aux.product axes in
Aux.array_map_of_list (fun params -> {
- mv_time = t;
+ Arena.mv_time = t;
parameters = List.combine param_names params;
- rule = label.Arena.rule;
+ rule = label.Arena.lb_rule;
next_loc = next_loc;
embedding = emb}
) grid
@@ -102,12 +94,12 @@
let gen_models_list rules model time moves =
Aux.map_some (fun mv ->
- let rule = List.assoc mv.rule rules in
+ let rule = List.assoc mv.Arena.rule rules in
Aux.map_option
(fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *)
- (mv, {Arena.cur_loc = mv.next_loc; struc = model; time = time}))
- (ContinuousRule.rewrite_single model time mv.embedding
- rule mv.mv_time mv.parameters)) (Array.to_list moves)
+ (mv, {Arena.cur_loc = mv.Arena.next_loc; struc = model; time = time}))
+ (ContinuousRule.rewrite_single model time mv.Arena.embedding
+ rule mv.Arena.mv_time mv.Arena.parameters)) (Array.to_list moves)
let gen_models rules model time moves =
let res = gen_models_list rules model time moves in
Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Play/Move.mli 2011-08-09 06:21:46 UTC (rev 1530)
@@ -1,24 +1,15 @@
(** Move definition, generation and helper functions. *)
-(** Data to return a move as a suggestion rather than directly. *)
-type move = {
- mv_time : float ;
- parameters : (string * float) list ;
- rule : string ;
- next_loc : int ; (** next location in the arena *)
- embedding : (int * int) list ;
-}
-
val move_str : (string * ContinuousRule.rule) list ->
- Structure.structure -> move -> string
-val move_gs_str : Arena.game * Arena.game_state -> move -> string
+ Structure.structure -> Arena.move -> string
+val move_gs_str : Arena.game * Arena.game_state -> Arena.move -> string
-val move_str_short : Structure.structure -> move -> string
-val move_gs_str_short : Arena.game_state -> move -> string
+val move_str_short : Structure.structure -> Arena.move -> string
+val move_gs_str_short : Arena.game_state -> Arena.move -> string
(** Make a move in a game. *)
-val make_move : move ->
+val make_move : Arena.move ->
Arena.game * Arena.game_state -> Arena.game * Arena.game_state
@@ -28,10 +19,10 @@
(** Generate moves available from a state, as an array, in fixed order. *)
val gen_moves : int -> (string * ContinuousRule.rule) list ->
- Structure.structure -> Arena.player_loc -> move array
+ Structure.structure -> Arena.player_loc -> Arena.move array
val gen_models : (string * ContinuousRule.rule) list -> Structure.structure ->
- float -> move array -> move array * Arena.game_state array
+ float -> Arena.move array -> Arena.move array * Arena.game_state array
val list_moves : Arena.game -> Arena.game_state ->
- (int * move * Arena.game_state) array
+ (int * Arena.move * Arena.game_state) array
Modified: trunk/Toss/Play/MoveTest.ml
===================================================================
--- trunk/Toss/Play/MoveTest.ml 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Play/MoveTest.ml 2011-08-09 06:21:46 UTC (rev 1530)
@@ -4,11 +4,11 @@
"move to string" >::
(fun () ->
let mv = {
- Move.mv_time = 0.;
- Move.parameters = [];
- Move.rule = "rule";
- Move.next_loc = 1;
- Move.embedding = [(1, 1)];
+ Arena.mv_time = 0.;
+ parameters = [];
+ rule = "rule";
+ next_loc = 1;
+ embedding = [(1, 1)];
} in
let s = Structure.empty_structure () in
assert_equal ~printer:(fun x -> x) (Move.move_str_short s mv)
Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Play/Play.mli 2011-08-09 06:21:46 UTC (rev 1530)
@@ -16,10 +16,10 @@
(** Maximax unfolding upto depth, keep previous moves for stability. *)
val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
Formula.real_expr array array ->
- int GameTree.game_tree * (Move.move * Arena.game_state) list list ->
- int GameTree.game_tree * (Move.move * Arena.game_state) list list
+ int GameTree.game_tree * (Arena.move * Arena.game_state) list list ->
+ int GameTree.game_tree * (Arena.move * Arena.game_state) list list
(** Maximax unfold upto depth and choose move. *)
val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
Arena.game_state -> Formula.real_expr array array ->
- (Move.move * Arena.game_state) list
+ (Arena.move * Arena.game_state) list
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-08-08 20:58:36 UTC (rev 1529)
+++ trunk/Toss/Server/ReqHandler.ml 2011-08-09 06:21:46 UTC (rev 1530)
@@ -64,15 +64,15 @@
try
for i = 0 to Array.length moves - 1 do
let mov = moves.(i) in
- if r_name = mov.Move.rule && List.for_all
- (fun (e, f) -> f = List.assoc e mov.Move.embedding) mtch then
+ if r_name = mov.Arena.rule && List.for_all
+ (fun (e, f) -> f = List.assoc e mov.Arena.embedding) mtch then
raise (Found i)
done;
failwith "GDL Play request: action mismatched with play state"
with Found pos -> pos) in
let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
let (new_state_noloc, resp) = Arena.handle_request state req in
- let new_loc = moves.(pos).Move.next_loc in
+ let new_loc = moves.(pos).Arena.next_loc in
(fst new_state_noloc,
{snd new_state_noloc with Arena.cur_loc = new_loc})
) else state
@@ -147,7 +147,7 @@
Aux.random_elem (Play.maximax_unfold_choose 5500
(fst state) (snd state) heur) in
TranslateGame.translate_outgoing_move gdl_transl state
- move.Move.rule move.Move.embedding
+ move.Arena.rule move.Arena.embedding
) else (
Gc.compact ();
TranslateGame.noop_move gdl_transl (snd state)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-10 02:59:57
|
Revision: 1531
http://toss.svn.sourceforge.net/toss/?rev=1531&view=rev
Author: lukaszkaiser
Date: 2011-08-10 02:59:51 +0000 (Wed, 10 Aug 2011)
Log Message:
-----------
Adding history to game state and related changes.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Play/PlayTest.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Arena/Arena.ml 2011-08-10 02:59:51 UTC (rev 1531)
@@ -38,15 +38,10 @@
player_names : (string * int) list ;
data : (string * string) list ;
defined_rels : (string * (string list * Formula.formula)) list ;
+ starting_struc : Structure.structure ;
}
-(* State of the game and additional information. *)
-type game_state = {
- struc : Structure.structure ;
- time : float ;
- cur_loc : int ;
-}
-
+(* Move - complete basic action data. *)
type move = {
mv_time : float ;
parameters : (string * float) list ;
@@ -55,6 +50,16 @@
embedding : (int * int) list ;
}
+(* State of the game and additional information. *)
+type game_state = {
+ struc : Structure.structure ;
+ time : float ;
+ cur_loc : int ;
+ history : (move * float option) list ;
+}
+
+
+
let zero_loc = { payoff = Formula.Const 0. ;
view = (Formula.And [], []);
heur = [];
@@ -68,12 +73,13 @@
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
+ starting_struc = emp_struc ;
num_players=1;},
{struc = emp_struc ;
time = 0.0 ;
cur_loc = 0 ;
+ history = [] ;
}
-
(* -------------------- PARSER HELPER ------------------------------ *)
@@ -137,7 +143,7 @@
exception Arena_definition_error of string
-let make_move rname params target_loc =
+let make_move_arena rname params target_loc =
let time_in, parameters_in =
try Aux.pop_assoc "t" params
with Not_found -> (cDEFAULT_TIMESTEP, cDEFAULT_TIMESTEP), params in
@@ -282,10 +288,12 @@
player_names = player_names;
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
+ starting_struc = state;
}, {
struc = state;
time = time;
cur_loc = cur_loc;
+ history = [];
}
@@ -1061,3 +1069,14 @@
| GetState -> false
| SetModel _ -> true
| GetModel -> false
+
+
+(* Make a move in a game. *)
+let make_move m (game, state) =
+ let req = ApplyRuleInt (m.rule, m.embedding, m.mv_time, m.parameters) in
+ let (new_game, new_state), _ = handle_request (game, state) req in
+ (new_game,
+ { new_state with cur_loc = m.next_loc ;
+ history = (m, None) :: state.history })
+
+
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Arena/Arena.mli 2011-08-10 02:59:51 UTC (rev 1531)
@@ -32,8 +32,10 @@
player_names : (string * int) list ;
data : (string * string) list ;
defined_rels : (string * (string list * Formula.formula)) list ;
+ starting_struc : Structure.structure ;
}
+
(** Move - complete basic action data. **)
type move = {
mv_time : float ;
@@ -43,15 +45,21 @@
embedding : (int * int) list ;
}
+
(** State of the game. *)
type game_state = {
struc : Structure.structure ;
time : float ;
cur_loc : int ;
+ history : (move * float option) list ;
}
val empty_state : game * game_state
+(** Make a move in a game. *)
+val make_move : move -> game * game_state -> game * game_state
+
+
(** Translate from names to elements to get rule embedding. *)
val emb_of_names :
game * game_state -> string -> (string * string) list -> (int * int) list
@@ -113,7 +121,7 @@
val array_of_players :
'a -> (string * int) list -> (string * 'a) list -> 'a array
-val make_move :
+val make_move_arena :
string -> (string * (float * float)) list -> int -> label * int
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-08-10 02:59:51 UTC (rev 1531)
@@ -31,7 +31,7 @@
COMMA, separated_pair (ID, COLON,
separated_pair (FLOAT, INTERV, FLOAT)))
RARR LOC_MOD? target = INT CLOSESQ
- { make_move r params target }
+ { make_move_arena r params target }
| OPENSQ error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in move definition."
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-10 02:59:51 UTC (rev 1531)
@@ -1204,6 +1204,7 @@
player_names = player_names;
data = [];
defined_rels = defined_rels;
+ starting_struc = struc;
} in
let tossrule_data = Aux.strmap_of_assoc tossrule_data in
let playing_as =
@@ -1223,7 +1224,7 @@
fluents = fluents;
} in
gdl_translation,
- (game, {Arena.struc = struc; time = 0.; cur_loc = 0})
+ (game, {Arena.struc = struc; history = []; time = 0.; cur_loc = 0})
(* ************************************************************ *)
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-08-10 02:59:51 UTC (rev 1531)
@@ -21,13 +21,14 @@
let state_of_file ?(struc="") ?(time=0.) ?(loc=0) fname =
let (g, s) = raw_state_of_file fname in
let structure = if struc = "" then s.Arena.struc else struc_of_str struc in
- (g, { Arena.struc = structure; time = time; cur_loc = loc })
+ (g, { Arena.struc = structure; time = time; cur_loc = loc; history = [] })
let tests = "GameTree" >::: [
"abstract tree init, to string" >::
(fun () ->
- let s = {Arena.struc=Structure.empty_structure(); cur_loc=0; time=0.} in
+ let s = {Arena.struc=Structure.empty_structure();
+ cur_loc=0; time=0.; history = []} in
let t = Leaf (s, 1, 5) in
assert_equal ~printer:(fun x -> x)
"\n|| Leaf. Player 1 loc 0 time 0.0.\n|| [ | | ]\n|| 5"
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Play/Move.ml 2011-08-10 02:59:51 UTC (rev 1531)
@@ -5,14 +5,6 @@
let cGRID_SIZE = 5
-(* Make a move in a game. *)
-let make_move m (game, state) =
- let req = Arena.ApplyRuleInt
- (m.Arena.rule, m.Arena.embedding, m.Arena.mv_time, m.Arena.parameters) in
- let (new_game, new_state), _ = Arena.handle_request (game, state) req in
- (new_game, { new_state with Arena.cur_loc = m.Arena.next_loc })
-
-
(* Print a move as string.
TODO: perhaps find a nicer syntax? See {!TestGame.move_str}. *)
let move_str rules struc move =
@@ -92,19 +84,23 @@
-let gen_models_list rules model time moves =
+let gen_models_list rules state time moves =
Aux.map_some (fun mv ->
let rule = List.assoc mv.Arena.rule rules in
Aux.map_option
(fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *)
- (mv, {Arena.cur_loc = mv.Arena.next_loc; struc = model; time = time}))
- (ContinuousRule.rewrite_single model time mv.Arena.embedding
+ (mv,
+ {Arena.cur_loc = mv.Arena.next_loc;
+ history = (mv, None) :: state.Arena.history;
+ struc = model;
+ time = time}))
+ (ContinuousRule.rewrite_single state.Arena.struc time mv.Arena.embedding
rule mv.Arena.mv_time mv.Arena.parameters)) (Array.to_list moves)
-let gen_models rules model time moves =
- let res = gen_models_list rules model time moves in
- let moves, models = List.split res in
- Array.of_list moves, Array.of_list models
+let gen_models rules state time moves =
+ let res = gen_models_list rules state time moves in
+ let moves, states = List.split res in
+ Array.of_list moves, Array.of_list states
let list_moves game s =
let select_moving a =
@@ -114,6 +110,6 @@
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
+ (gen_models_list game.Arena.rules s 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-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Play/Move.mli 2011-08-10 02:59:51 UTC (rev 1531)
@@ -8,11 +8,6 @@
val move_gs_str_short : Arena.game_state -> Arena.move -> string
-(** Make a move in a game. *)
-val make_move : Arena.move ->
- Arena.game * Arena.game_state -> Arena.game * Arena.game_state
-
-
(** Default number of sample points per parameter in tree search.
TODO: fixed for now. *)
val cGRID_SIZE : int
@@ -21,7 +16,7 @@
val gen_moves : int -> (string * ContinuousRule.rule) list ->
Structure.structure -> Arena.player_loc -> Arena.move array
-val gen_models : (string * ContinuousRule.rule) list -> Structure.structure ->
+val gen_models : (string * ContinuousRule.rule) list -> Arena.game_state ->
float -> Arena.move array -> Arena.move array * Arena.game_state array
val list_moves : Arena.game -> Arena.game_state ->
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2011-08-09 06:21:46 UTC (rev 1530)
+++ trunk/Toss/Play/PlayTest.ml 2011-08-10 02:59:51 UTC (rev 1531)
@@ -21,7 +21,7 @@
let state_of_file ?(struc="") ?(time=0.) ?(loc=0) fname =
let (g, s) = raw_state_of_file fname in
let structure = if struc = "" then s.Arena.struc else struc_of_str struc in
- (g, { Arena.struc = structure; time = time; cur_loc = loc })
+ (g, { Arena.struc = structure; time = time; cur_loc = loc; history = [] })
let test_maximax ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-10 03:31:08
|
Revision: 1532
http://toss.svn.sourceforge.net/toss/?rev=1532&view=rev
Author: lukstafi
Date: 2011-08-10 03:31:00 +0000 (Wed, 10 Aug 2011)
Log Message:
-----------
GDL translation: eliminating ground arguments of relations. (TranslateFormula and TranslateGame tests do not pass yet.)
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/Formula/Aux.ml 2011-08-10 03:31:00 UTC (rev 1532)
@@ -117,6 +117,11 @@
match l with
| [] -> init
| a::l -> concat_map (f a) (concat_foldr f l init)
+
+let rec concat_foldl f l init =
+ match l with
+ | [] -> init
+ | a::l -> concat_foldl f l (concat_map (f a) init)
let list_remove v l = List.filter (fun w->v<>w) l
@@ -394,6 +399,14 @@
if !i >= n then raise Not_found
else !i
+let array_argfindi f a =
+ let i = ref 0 in
+ let n = Array.length a in
+ while !i < n && not (f !i (Array.unsafe_get a !i)) do
+ incr i done;
+ if !i >= n then raise Not_found
+ else !i
+
let array_find_all f a =
let r = ref [] in
for i = Array.length a - 1 downto 0 do
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/Formula/Aux.mli 2011-08-10 03:31:00 UTC (rev 1532)
@@ -72,6 +72,9 @@
[concat_foldr f (a::l) init = concat_map (f a) (concat_foldr f l init)] *)
val concat_foldr : ('a -> 'b -> 'b list) -> 'a list -> 'b list -> 'b list
+(** [concat_foldl f (a::l) init = concat_foldl f l (concat_map (f a) init)] *)
+val concat_foldl : ('a -> 'b -> 'b list) -> 'a list -> 'b list -> 'b list
+
(** Remove all elements equal to the argument, using structural
inequality. *)
val list_remove : 'a -> 'a list -> 'a list
@@ -212,6 +215,8 @@
val array_argfind : ('a -> bool) -> 'a array -> int
+val array_argfindi : (int -> 'a -> bool) -> 'a array -> int
+
(** Find all elements for which [f] holds. *)
val array_find_all : ('a -> bool) -> 'a array -> 'a list
(** Find all indices for which [f] holds. *)
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/GGP/GDL.ml 2011-08-10 03:31:00 UTC (rev 1532)
@@ -315,6 +315,18 @@
let def_str (rel, branches) =
String.concat "\n" (List.map (branch_str rel) branches)
+let atom_str a = rel_atom_str (rel_of_atom a)
+
+let rec literal_str = function
+ | Pos atom -> atom_str atom
+ | Neg atom -> "(not "^atom_str atom^")"
+ | Disj disjs ->
+ "(or "^String.concat " " (List.map literal_str disjs)^")"
+
+let clause_str (head, body) =
+ "(<= "^rel_atom_str head^"\n "^String.concat "\n "
+ (List.map literal_str body)^")"
+
let sb_str sb =
String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
@@ -521,6 +533,84 @@
) (flatten_disjs body)
+let find_ground_arg rel clauses =
+ match Aux.assoc_all rel (List.map fst clauses) with
+ | [] -> raise Not_found
+ | (args::_ as all_args) ->
+ Aux.array_argfindi
+ (fun i _ ->
+ List.for_all (fun args ->
+ Aux.Strings.is_empty (term_vars args.(i))) all_args)
+ args
+
+let elim_ground_arg_in_body rel arg grounding (head, body) =
+
+ let expand_atom args add_lit (sb, (head, body)) =
+ (* [short_args] will be subsituted with [sb] inside [r_br] *)
+ let short_args = Array.init (Array.length args - 1)
+ (fun i -> if i < arg then args.(i) else args.(i+1)) in
+ let inst_arg = subst sb args.(arg) in
+ Aux.map_try
+ (fun ground ->
+ let sb = unify sb [ground] [inst_arg] in
+ let r_gr = rel ^ "__" ^ term_to_name ground in
+ let r_br = head, add_lit (Rel (r_gr, short_args)) body in
+ sb, subst_clause sb r_br)
+ grounding in
+
+ let rec expand_literal emb_lit literal (sb, (head, body) as accu) =
+ match literal with
+ | Pos (Rel (r, args)) when r=rel ->
+ expand_atom args (fun a body -> emb_lit (Pos a) body) accu
+ | Neg (Rel (r, args)) when r=rel ->
+ expand_atom args (fun a body -> emb_lit (Neg a) body) accu
+ | Pos _ | Neg _ -> [sb, (head, emb_lit literal body)]
+ | Disj disjs ->
+ let emb_lit lit body =
+ match body with
+ | Disj disjs::body -> Disj (lit::disjs)::body
+ | _ -> assert false in
+ (* unfortunately only works with one level of disjunctions *)
+ (* TODO: optimization when splitting clause not necessary *)
+ Aux.concat_foldr (expand_literal emb_lit) disjs
+ [sb, (head, Disj []::body)] in
+
+ let init = [[], (head, [])] in
+ let result =
+ Aux.concat_foldr (expand_literal (fun l body-> l::body)) body init in
+ List.map (fun (sb, cl) -> subst_clause sb cl) result
+
+let elim_ground_arg rel arg clauses =
+ let rel_brs, clauses =
+ List.partition (fun ((r,_),_) -> r=rel) clauses in
+ let grounding = Aux.unique_sorted
+ (List.map (fun ((_,args),_) -> args.(arg)) rel_brs) in
+ let renamed_brs = List.map
+ (fun ((_,args), body) ->
+ let short_args = Array.init (Array.length args - 1)
+ (fun i -> if i < arg then args.(i) else args.(i+1)) in
+ let rname = rel ^ "__" ^ term_to_name args.(arg) in
+ (rname, short_args), body)
+ rel_brs in
+ Aux.concat_map (elim_ground_arg_in_body rel arg grounding)
+ (renamed_brs @ clauses)
+
+let elim_ground_args rels clauses =
+ let modified = ref false in
+ let rec aux clauses = function
+ | [] -> clauses
+ | rel::rels ->
+ (let try arg = find_ground_arg rel clauses in
+ modified := true;
+ aux (elim_ground_arg rel arg clauses) rels
+ with Not_found -> aux clauses rels) in
+ let rec fix clauses =
+ modified := false;
+ let clauses = aux clauses rels in
+ if !modified then fix clauses else clauses in
+ fix clauses
+
+
(* ************************************************************ *)
(* ************************************************************ *)
(** {3 GDL whole-game operations.}
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/GGP/GDL.mli 2011-08-10 03:31:00 UTC (rev 1532)
@@ -91,8 +91,8 @@
val func_graph : string -> term list -> term array list
+val elim_ground_args : string list -> clause list -> clause list
-
(** {3 GDL translation helpers.} *)
val blank : term
@@ -105,6 +105,7 @@
val rel_atom_str : rel_atom -> string
val def_str : string * def_branch list -> string
+val clause_str : clause -> string
(** {3 GDL whole-game operations.}
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/GGP/GDLTest.ml 2011-08-10 03:31:00 UTC (rev 1532)
@@ -171,6 +171,106 @@
(GDL.def_str ("legal", legal_def));
);
+ "eliminate ground args simple" >::
+ (fun () ->
+ let descr = parse_game_descr
+ "
+(<= (conn5 ?r)
+ (or (col ?r) (row ?r)))
+(<= (row x)
+ (true (cell ?a ?y x))
+ (nextcol ?a ?b)
+ (true (cell ?b ?y x))
+ (nextcol ?b ?c)
+ (true (cell ?c ?y x))
+ (nextcol ?c ?d)
+ (true (cell ?d ?y x))
+ (nextcol ?d ?e)
+ (true (cell ?e ?y x)))
+(<= (col x)
+ (true (cell ?x ?a x))
+ (nextcol ?a ?b)
+ (true (cell ?x ?b x))
+ (nextcol ?b ?c)
+ (true (cell ?x ?c x))
+ (nextcol ?c ?d)
+ (true (cell ?x ?d x))
+ (nextcol ?d ?e)
+ (true (cell ?x ?e x)))
+(<= (row o)
+ (true (cell ?a ?y o))
+ (nextcol ?a ?b)
+ (true (cell ?b ?y o))
+ (nextcol ?b ?c)
+ (true (cell ?c ?y o))
+ (nextcol ?c ?d)
+ (true (cell ?d ?y o))
+ (nextcol ?d ?e)
+ (true (cell ?e ?y o)))
+(<= (col o)
+ (true (cell ?x ?a o))
+ (nextcol ?a ?b)
+ (true (cell ?x ?b o))
+ (nextcol ?b ?c)
+ (true (cell ?x ?c o))
+ (nextcol ?c ?d)
+ (true (cell ?x ?d o))
+ (nextcol ?d ?e)
+ (true (cell ?x ?e o)))
+" in
+ let result = elim_ground_args ["conn5"; "col"; "row"] descr in
+ let res_s =
+ (String.concat "\n" (List.map GDL.clause_str result)) in
+ assert_equal ~printer:(fun x->x)
+ "(<= (conn5__o )
+ (or (col__o ) (row__o )))
+(<= (conn5__x )
+ (or (col__x ) (row__x )))
+(<= (row__x )
+ (true (cell ?a ?y x))
+ (nextcol ?a ?b)
+ (true (cell ?b ?y x))
+ (nextcol ?b ?c)
+ (true (cell ?c ?y x))
+ (nextcol ?c ?d)
+ (true (cell ?d ?y x))
+ (nextcol ?d ?e)
+ (true (cell ?e ?y x)))
+(<= (row__o )
+ (true (cell ?a ?y o))
+ (nextcol ?a ?b)
+ (true (cell ?b ?y o))
+ (nextcol ?b ?c)
+ (true (cell ?c ?y o))
+ (nextcol ?c ?d)
+ (true (cell ?d ?y o))
+ (nextcol ?d ?e)
+ (true (cell ?e ?y o)))
+(<= (col__x )
+ (true (cell ?x ?a x))
+ (nextcol ?a ?b)
+ (true (cell ?x ?b x))
+ (nextcol ?b ?c)
+ (true (cell ?x ?c x))
+ (nextcol ?c ?d)
+ (true (cell ?x ?d x))
+ (nextcol ?d ?e)
+ (true (cell ?x ?e x)))
+(<= (col__o )
+ (true (cell ?x ?a o))
+ (nextcol ?a ?b)
+ (true (cell ?x ?b o))
+ (nextcol ?b ?c)
+ (true (cell ?x ?c o))
+ (nextcol ?c ?d)
+ (true (cell ?x ?d o))
+ (nextcol ?d ?e)
+ (true (cell ?x ?e o)))"
+ res_s
+ );
+]
+
+let bigtests = "GDLBig" >::: [
"playout connect5" >::
(fun () ->
let descr = load_rules ("./GGP/examples/connect5.gdl") in
@@ -194,4 +294,8 @@
]
+let a () =
+ GDL.debug_level := 5
+
+
let exec = Aux.run_test_if_target "GDLTest" tests
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-10 03:31:00 UTC (rev 1532)
@@ -66,8 +66,10 @@
"defined relations connect5" >::
(fun () ->
let descr = load_rules ("./GGP/examples/connect5.gdl") in
+ let transl_data = connect5_data in
let clauses = GDL.expand_players descr in
- let transl_data = connect5_data in
+ let clauses =
+ GDL.elim_ground_args transl_data.defined_rels clauses in
let defined_rels =
TranslateFormula.build_defrels transl_data clauses in
let res = String.concat "\n"
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-10 03:31:00 UTC (rev 1532)
@@ -1139,6 +1139,9 @@
ground_vars_at_paths ground_at_f_paths frame_clauses in
let move_clauses =
ground_vars_at_paths ground_at_f_paths move_clauses in
+ let defined_rels = Aux.list_diff defined_rels
+ ["goal"; "legal"; "next"; "terminal"] in
+ let clauses = elim_ground_args defined_rels clauses in
let next_cls =
List.map (function
| (_,[|s_C|]),body_C -> s_C, true, body_C
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/Server/Tests.ml 2011-08-10 03:31:00 UTC (rev 1532)
@@ -33,7 +33,7 @@
let ggp_tests = "GGP", [
"GameSimplTest", [GameSimplTest.tests];
- "GDLTest", [GDLTest.tests];
+ "GDLTest", [GDLTest.tests; GDLTest.bigtests];
"TranslateGameTest", [TranslateGameTest.tests; TranslateGameTest.bigtests];
"TranslateFormulaTest", [TranslateFormulaTest.tests];
]
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-08-10 02:59:51 UTC (rev 1531)
+++ trunk/Toss/www/reference/reference.tex 2011-08-10 03:31:00 UTC (rev 1532)
@@ -1646,8 +1646,13 @@
(by virtue of occurring in \texttt{does}, \texttt{legal} or
\texttt{goal} atoms), by the players of the game.
-Before generating Toss formulas we also transform the definition $G$
-by grounding all variables that have occurrences at fluent paths, \ie
+Another form of expansion was the inlining of clauses, used only for
+finding fluent paths. (In particular, \texttt{does} atoms were then
+replaced by appropriately instantiated bodies of \texttt{legal}
+clauses.)
+
+Before generating Toss formulas we transform the definition $G$ by
+grounding all variables that have occurrences at fluent paths, \ie
eliminating these variables by constants that occur at these paths in
ground state terms $\calS$.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-12 14:07:51
|
Revision: 1536
http://toss.svn.sourceforge.net/toss/?rev=1536&view=rev
Author: lukstafi
Date: 2011-08-12 14:07:42 +0000 (Fri, 12 Aug 2011)
Log Message:
-----------
GDL translation fixing: debugged and refined erasure clause generation; small fix in GameSimpl.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-11 14:04:23 UTC (rev 1535)
+++ trunk/Toss/GGP/GDL.ml 2011-08-12 14:07:42 UTC (rev 1536)
@@ -242,6 +242,13 @@
| Func (f, args) ->
Func (f, Array.map (subst sb) args)
+let rec subst_consts sb = function
+ | Const y as t ->
+ (try List.assoc y sb with Not_found -> t)
+ | Var _ as t -> t
+ | Func (f, args) ->
+ Func (f, Array.map (subst sb) args)
+
let rec unify_all sb = function
| [] | [_] -> sb
| t1::t2::tl ->
@@ -266,6 +273,8 @@
let subst_rel sb (rel, args) = rel, Array.map (subst sb) args
let subst_rels sb body = List.map (subst_rel sb) body
+let subst_consts_rel sb (rel, args) = rel, Array.map (subst_consts sb) args
+
let compose_sb sb1 sb2 =
let vars1, terms1 = List.split sb1 in
let vars2, terms2 = List.split sb2 in
@@ -285,16 +294,33 @@
| True arg -> True (subst sb arg)
| Does (arg1, arg2) -> Does (subst sb arg1, subst sb arg2)
+let subst_consts_atom sb = function
+ | Distinct args -> Distinct (Array.map (subst sb) args)
+ | Rel rel_atom -> Rel (subst_consts_rel sb rel_atom)
+ | Role arg -> Role (subst_consts sb arg)
+ | True arg -> True (subst_consts sb arg)
+ | Does (arg1, arg2) -> Does (subst_consts sb arg1, subst sb arg2)
+
let rec subst_literal sb = function
| Pos atom -> Pos (subst_atom sb atom)
| Neg atom -> Neg (subst_atom sb atom)
| Disj disjs -> Disj (List.map (subst_literal sb) disjs)
+let rec subst_consts_literal sb = function
+ | Pos atom -> Pos (subst_consts_atom sb atom)
+ | Neg atom -> Neg (subst_consts_atom sb atom)
+ | Disj disjs -> Disj (List.map (subst_consts_literal sb) disjs)
+
let rec subst_literals sb = List.map (subst_literal sb)
+let rec subst_consts_literals sb = List.map (subst_consts_literal sb)
+
let subst_clause sb (head, body) =
subst_rel sb head, subst_literals sb body
+let subst_consts_clause sb (head, body) =
+ subst_consts_rel sb head, subst_consts_literals sb body
+
let rel_atom_str (rel, args) =
"(" ^ rel ^ " " ^
String.concat " " (Array.to_list (Array.map term_str args)) ^ ")"
@@ -473,7 +499,9 @@
(** Form clause bodies whose disjunction is equivalent to the
- negation of disjunction of given clause bodies. *)
+ negation of disjunction of given clause bodies. Keep the
+ substitution so that the heads of corresponding clauses can be
+ substituted too. *)
let negate_bodies conjs =
let placeholder = "", [] in
let clauses = List.map (fun body -> placeholder, body) conjs in
@@ -491,7 +519,7 @@
| Pos atom -> Aux.Right (Neg atom)
| Disj _ -> assert false) body in
let sb = List.fold_left unify_all [] uniterms in
- List.map (subst_literal sb) lits in
+ sb, List.map (subst_literal sb) lits in
Aux.map_try nclause negated
@@ -825,8 +853,8 @@
let exp_clause clause =
(* TODO: remove "role" atoms *)
(* determine variables standing for players *)
- let plvars =
- player_vars_of (List.map rel_of_atom (atoms_of_clause clause)) in
+ let plvars = Aux.unique_sorted
+ (player_vars_of (List.map rel_of_atom (atoms_of_clause clause))) in
if plvars = [] then [clause]
else
let sbs = Aux.power plvars players in
@@ -1081,13 +1109,14 @@
let blank = Const "_BLANK_"
-(* [expand_path_vars_by p ts clauses] expands variables that have
- occurrences at path [p] in some state term of a clause, by terms
- [ts]. *)
-let expand_path_vars_by p ts clauses =
- let exp_clause ((h_rel, h_args), body as clause) =
+(* [expand_path_vars_by prepare_lits p ts clauses] expands variables
+ that have occurrences at path [p] in some state term of a clause
+ (from which pre-processed literals are extracted by
+ [prepare_lits]), by terms [ts]. *)
+let expand_path_vars_by prepare_lits p ts clauses =
+ let exp_clause clause =
(* determine variables standing for players *)
- let pstates = state_terms (Pos (Rel (h_rel, h_args))::body) in
+ let pstates = state_terms (prepare_lits clause) in
let pvars = Aux.map_try
(fun s -> term_vars (at_path s p)) pstates in
let pvars = Aux.Strings.elements
@@ -1099,7 +1128,7 @@
Aux.concat_map exp_clause clauses
-let ground_vars_at_paths ps_sterms clauses =
+let ground_vars_at_paths prepare_lits ps_sterms clauses =
List.fold_left (fun clauses (p, ts) ->
- expand_path_vars_by p ts clauses
+ expand_path_vars_by prepare_lits p ts clauses
) clauses ps_sterms
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-11 14:04:23 UTC (rev 1535)
+++ trunk/Toss/GGP/GDL.mli 2011-08-12 14:07:42 UTC (rev 1536)
@@ -51,6 +51,7 @@
val rel_of_atom : atom -> rel_atom
val term_vars : term -> Aux.Strings.t
+val terms_vars : term array -> Aux.Strings.t
val clause_vars : clause -> Aux.Strings.t
val defs_of_rules : gdl_rule list -> gdl_defs
@@ -64,11 +65,13 @@
val unify_all : substitution -> term list -> substitution
val rels_unify : rel_atom -> rel_atom -> bool
val subst : substitution -> term -> term
+val subst_consts : substitution -> term -> term
val subst_rel : substitution -> rel_atom -> rel_atom
val subst_rels : substitution -> rel_atom list -> rel_atom list
val subst_literal : substitution -> literal -> literal
val subst_literals : substitution -> literal list -> literal list
val subst_clause : substitution -> clause -> clause
+val subst_consts_clause : substitution -> clause -> clause
(** Saturation currently exposed for testing purposes. *)
val saturate :
@@ -82,8 +85,11 @@
val expand_positive_lits : gdl_defs -> def_branch list -> def_branch list
(** Form clause bodies whose disjunction is equivalent to the
- negation of disjunction of given clause bodies. *)
-val negate_bodies : literal list list -> literal list list
+ negation of disjunction of given clause bodies. Keep the
+ substitution so that the heads of corresponding clauses can be
+ substituted too. *)
+val negate_bodies :
+ literal list list -> (substitution * literal list) list
(** Rename clauses so that they have disjoint variables. Return a cell
storing all variables. *)
@@ -107,6 +113,7 @@
val state_terms : literal list -> term list
val term_arities : term -> (string * int) list
+val atom_str : atom -> string
val rel_atom_str : rel_atom -> string
val def_str : string * def_branch list -> string
val literal_str : literal -> string
@@ -189,8 +196,10 @@
val path_str : path -> string
-(** Expand variables that have occurrences at given paths in some
- state term of a clause, by subterms at those paths in the list of
- ground terms. *)
+(* [ground_vars_at_paths prepare_lits ps_sterms clauses] expands
+ variables that have occurrences at paths in [ps_sterms] in some
+ state term of a clause (from which pre-processed literals are
+ extracted by [prepare_lits]), by terms provided in [ps_sterms]. *)
val ground_vars_at_paths :
+ (clause -> literal list) ->
(path * term list) list -> clause list -> clause list
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-08-11 14:04:23 UTC (rev 1535)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-08-12 14:07:42 UTC (rev 1536)
@@ -143,6 +143,12 @@
module Tups = Structure.Tuples
let simplify ?(keep_nonempty_predicates=true) (game, state) =
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GameSimpl: defined_rels = %s\n%!"
+ (String.concat ", " (List.map fst game.Arena.defined_rels))
+ );
+ (* }}} *)
let struc = state.Arena.struc in
let signat = Structure.rel_signature struc in
let nelems = Structure.nbr_elems struc in
@@ -254,7 +260,9 @@
let rel2, _ =
List.find (fun (rel2, arity2) ->
arity = arity2 &&
- not (Aux.Strings.mem rel2 fluents ||
+ not (Aux.Strings.mem rel1 fluents ||
+ Aux.Strings.mem rel2 fluents ||
+ List.mem_assoc rel1 game.Arena.defined_rels ||
List.mem_assoc rel2 game.Arena.defined_rels) &&
included_in rel1 rel2 && included_in rel2 rel1
) signat in
@@ -419,8 +427,10 @@
match phi1, phi2 with
| _ when phi1 = phi2 -> true
| Rel (rel1, args1), Rel (rel2, args2) when args1 = args2 ->
- not (Aux.Strings.mem rel1 fluents) &&
- not (Aux.Strings.mem rel2 fluents) &&
+ not (Aux.Strings.mem rel1 fluents ||
+ Aux.Strings.mem rel2 fluents ||
+ List.mem_assoc rel1 game.Arena.defined_rels ||
+ List.mem_assoc rel2 game.Arena.defined_rels) &&
included_in rel1 rel2
| _ -> false in
let game =
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2011-08-11 14:04:23 UTC (rev 1535)
+++ trunk/Toss/GGP/GameSimplTest.ml 2011-08-12 14:07:42 UTC (rev 1536)
@@ -48,7 +48,7 @@
]
-let a =
+let a () =
Aux.run_test_if_target "GameSimplTest" tests
let a () =
@@ -73,3 +73,20 @@
output_string resf res_str;
close_out resf;
Printf.printf "\nRESULT:\n%s\n%!" res_str
+
+
+let a () =
+ GameSimpl.debug_level := 5;
+ let connect5 = state_of_file "./GGP/tests/connect5-raw.toss" in
+ let res = GameSimpl.simplify connect5 in
+ let goal = state_of_file "./GGP/tests/connect5-simpl.toss" in
+ let resf = open_out "./GGP/tests/connect5-temp.toss" in
+ let res_str = Arena.state_str res in
+ output_string resf res_str;
+ close_out resf;
+ let eq, msg = Arena.compare_diff goal res in
+ assert_bool
+ ("tests/connect5-raw.toss to tests/connect5-simpl.toss, see \
+ GGP/tests/connect5-temp.toss: "^msg)
+ eq;
+ Sys.remove "./GGP/tests/connect5-temp.toss"
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-11 14:04:23 UTC (rev 1535)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-12 14:07:42 UTC (rev 1536)
@@ -144,8 +144,13 @@
let descr = load_rules ("./GGP/examples/connect5.gdl") in
let ground_at_f_paths, transl_data = connect5_data in
let clauses = GDL.expand_players descr in
+ let prepare_lits ((h_rel, h_args), body) =
+ if h_rel = "next" then (GDL.Pos (GDL.True h_args.(0))::body)
+ else if h_rel = "frame next"
+ then Aux.list_remove (GDL.Pos (GDL.True h_args.(0))) body
+ else body in
let clauses =
- GDL.ground_vars_at_paths ground_at_f_paths clauses in
+ GDL.ground_vars_at_paths prepare_lits ground_at_f_paths clauses in
let defined_rels, clauses =
GDL.elim_ground_args transl_data.defined_rels clauses in
(* {{{ log entry *)
@@ -201,20 +206,21 @@
~printer:(fun x->x)
"conn5__o() = col__o() or diag1__o() or diag2__o() or row__o()"
(result "conn5__o");
- assert_equal ~msg:"col__o defined relation translation"
+
+ assert_equal ~msg:"col__x defined relation translation"
~printer:(fun x->x)
- "col__o() = ex cell_x_a__BLANK_, cell_x_b__BLANK_, cell_x_c__BLANK_, cell_x_d__BLANK_,
+ "col__x() = ex cell_x_a__BLANK_, cell_x_b__BLANK_, cell_x_c__BLANK_, cell_x_d__BLANK_,
cell_x_e__BLANK_
(cell__BLANK___BLANK___BLANK_(cell_x_a__BLANK_) and
- cell_2o(cell_x_a__BLANK_) and
+ cell_2x(cell_x_a__BLANK_) and
cell__BLANK___BLANK___BLANK_(cell_x_b__BLANK_) and
- cell_2o(cell_x_b__BLANK_) and
+ cell_2x(cell_x_b__BLANK_) and
cell__BLANK___BLANK___BLANK_(cell_x_c__BLANK_) and
- cell_2o(cell_x_c__BLANK_) and
+ cell_2x(cell_x_c__BLANK_) and
cell__BLANK___BLANK___BLANK_(cell_x_d__BLANK_) and
- cell_2o(cell_x_d__BLANK_) and
+ cell_2x(cell_x_d__BLANK_) and
cell__BLANK___BLANK___BLANK_(cell_x_e__BLANK_) and
- cell_2o(cell_x_e__BLANK_) and nextcol__cell_1__cell_1(cell_x_a__BLANK_,
+ cell_2x(cell_x_e__BLANK_) and nextcol__cell_1__cell_1(cell_x_a__BLANK_,
cell_x_b__BLANK_) and nextcol__cell_1__cell_1(cell_x_b__BLANK_,
cell_x_c__BLANK_) and nextcol__cell_1__cell_1(cell_x_c__BLANK_,
cell_x_d__BLANK_) and nextcol__cell_1__cell_1(cell_x_d__BLANK_,
@@ -239,7 +245,7 @@
cell_x_b__BLANK_) and EQ___cell_0__cell_0(cell_x_e__BLANK_,
cell_x_c__BLANK_) and EQ___cell_0__cell_0(cell_x_e__BLANK_,
cell_x_d__BLANK_))"
- (result "col__o");
+ (result "col__x");
);
]
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-11 14:04:23 UTC (rev 1535)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-12 14:07:42 UTC (rev 1536)
@@ -20,9 +20,11 @@
open GDL
open TranslateFormula
+open Aux.BasicOperators
(** Local level of logging. *)
let debug_level = ref 0
+let generate_test_case = ref None
(** Translate static relations that otherwise would be translated as
structure relations, but have arity above the threshold, as
@@ -528,14 +530,27 @@
Aux.concat_map move_clauses legal_tuples
-let add_erasure_clauses (legal_tup, next_cls) =
- (* let fixed_vars = terms_vars legal_tup in *)
+let add_erasure_clauses f_paths (legal_tup, next_cls) =
+ let fixed_vars = terms_vars (Aux.array_map_of_list fst legal_tup) in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "add_erasure_clauses: fixed_vars=%s\n%!"
+ (String.concat ", " (Aux.Strings.elements fixed_vars))
+ );
+ (* }}} *)
let frame_cls =
Aux.map_some (fun (s, frame, body) ->
if frame then Some (s, body) else None) next_cls in
- (* two passes to ensure coverage and maximality *)
- (* FIXME-TODO: treat fixed-vars as consts, by substituting them with
+ (* two passes to ensure coverage and maximality *)
+ (* Treating fixed-vars as consts, by substituting them with
Const, and later substituting-back Var *)
+ let fixed_to_const = List.map
+ (fun v -> v, Const v) (Aux.Strings.elements fixed_vars) in
+ let frame_cls = List.map
+ (subst_clause fixed_to_const)
+ (List.map (fun (s,body)->("frame next",[|s|]),body) frame_cls) in
+ let frame_cls =
+ List.map (fun ((_,h),body) -> h.(0),body) frame_cls in
let rec coverage = function
| (s, body)::more_cls
, ((sb, s_acc, bodies)::other_frames as all_frames) ->
@@ -556,20 +571,67 @@
if List.mem body bodies then frame
else
try
- let sb = unify sb [s] [s_acc] in
- let s_acc = subst sb s in
- (sb, s_acc, body::bodies)
+ let sb = unify sb [s] [s_acc] in
+ let s_acc = subst sb s in
+ (sb, s_acc, body::bodies)
with Not_found -> frame
) frame frame_cls in
let frames = List.map maximality frames in
let frames =
List.map (fun (sb, s, bodies) ->
s, List.map (subst_literals sb) bodies) frames in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "add_erasure_clauses: frames --\n%!";
+ let print_frame (s, bodies) =
+ Printf.printf "FRAME: %s\n%!" (term_str s);
+ List.iter
+ (fun body-> print_endline
+ (String.concat " "(List.map literal_str body))) bodies in
+ List.iter print_frame frames; flush stdout;
+ );
+ (* }}} *)
let erasure_cls =
Aux.concat_map (fun (s, bodies) ->
let nbodies = negate_bodies bodies in
- List.map (fun b -> s, b) nbodies
+ List.map
+ (fun (nsb, b) ->
+ simult_subst f_paths blank (subst nsb s),
+ Aux.unique_sorted b)
+ nbodies
) frames in
+ (* Remove erasure clauses that still have free variables, because
+ after negation they have universal interpretation. *)
+ let erasure_cls = List.filter
+ (fun (s, body) ->
+ let cl_vars = clause_vars (("erasure",[|s|]), body) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "ERASURE: %s with vars %s\nbody: %s\n%!"
+ (term_str s)
+ (String.concat ", " (Aux.Strings.elements cl_vars))
+ (String.concat " " (List.map literal_str body))
+ );
+ (* }}} *)
+ Aux.Strings.is_empty cl_vars)
+ (Aux.unique_sorted erasure_cls) in
+ (* Recover fixed variables. *)
+ let fixed_to_var = List.map
+ (fun v -> v, Var v) (Aux.Strings.elements fixed_vars) in
+ let erasure_cls = List.map
+ (subst_consts_clause fixed_to_var)
+ (List.map (fun (s,body)->("erasure next",[|s|]),body) erasure_cls) in
+ let erasure_cls =
+ List.map (fun ((_,h),body) -> h.(0),body) erasure_cls in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "add_erasure_clauses: erasure clauses --\n%!";
+ let print_erasure (s, body) =
+ Printf.printf "ERASURE: %s <== %s\n%!" (term_str s)
+ (String.concat " " (List.map literal_str body)) in
+ List.iter print_erasure erasure_cls; flush stdout;
+ );
+ (* }}} *)
let next_cls =
Aux.map_some (fun (s, frame, body) ->
if not frame then Some (s, body) else None) next_cls in
@@ -586,65 +648,121 @@
| (Pos (True _ as a) | Neg (True _ as a))
when !split_on_state_atoms -> Some a
| _ -> None) body) next_cls in
- let patterns =
- let next_cls = Array.of_list next_cls in
- List.map (fun a ->
- Array.mapi (fun i (_, body) ->
- if List.mem (Neg a) body then -1
- else if List.mem (Pos a) body then 1
- else 0
- ) next_cls,
- a) atoms in
- let patterns = Aux.collect patterns in
- let patterns = List.filter (fun (pat, _) ->
- Aux.array_existsi (fun _ v-> v < 1) pat &&
- Aux.array_existsi (fun _ v-> v > -1) pat) patterns in
- let pos_choice = List.map (fun _ -> true) patterns in
- let neg_choice = List.map (fun _ -> false) patterns in
- let choices = Aux.product [pos_choice; neg_choice] in
- let rule_case choice =
- let separation_cond =
- List.concat
- (List.map2 (fun b (_, atoms) ->
- if b then List.map (fun a -> Pos a) atoms
- else List.map (fun a -> Neg a) atoms) choice patterns) in
- let case_cls =
- List.filter (fun (_, body) ->
- List.for_all2 (fun b (_, atoms) ->
- if b then (* atoms not excluded *)
- List.for_all (fun a -> not (List.mem (Neg a) body)) atoms
- else (* atoms not included *)
- List.for_all (fun a -> not (List.mem (Pos a) body)) atoms
+ if atoms = [] then (* single partition *)
+ let case_rhs, case_conds = List.split next_cls in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "rule_cases: single partition\n%!";
+ );
+ (* }}} *)
+ [next_cls, case_rhs, List.concat case_conds]
+ else
+ let patterns =
+ let next_cls = Array.of_list next_cls in
+ List.map (fun a ->
+ Array.mapi (fun i (_, body) ->
+ if List.mem (Neg a) body then -1
+ else if List.mem (Pos a) body then 1
+ else 0
+ ) next_cls,
+ a) atoms in
+ let patterns = Aux.collect patterns in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "rule_cases: patterns --\n%!";
+ let print_pat (pattern, atoms) =
+ Printf.printf "%a: %s\n%!"
+ (Aux.array_fprint (fun ch -> Printf.fprintf ch "%+d")) pattern
+ (String.concat " " (List.map atom_str atoms)) in
+ List.iter print_pat patterns
+ );
+ (* }}} *)
+ let patterns = List.filter (fun (pat, _) ->
+ Aux.array_existsi (fun _ v-> v < 1) pat &&
+ Aux.array_existsi (fun _ v-> v > -1) pat) patterns in
+ let pos_choice = List.map (fun _ -> true) patterns in
+ let neg_choice = List.map (fun _ -> false) patterns in
+ let choices = Aux.product [pos_choice; neg_choice] in
+ let rule_case choice =
+ let separation_cond =
+ List.concat
+ (List.map2 (fun b (_, atoms) ->
+ if b then List.map (fun a -> Pos a) atoms
+ else List.map (fun a -> Neg a) atoms) choice patterns) in
+ let case_cls =
+ List.filter (fun (_, body) ->
+ List.for_all2 (fun b (_, atoms) ->
+ if b then (* atoms not excluded *)
+ List.for_all (fun a -> not (List.mem (Neg a) body)) atoms
+ else (* atoms not included *)
+ List.for_all (fun a -> not (List.mem (Pos a) body)) atoms
) choice patterns
- ) next_cls in
- let case_rhs, case_conds = List.split case_cls in
- case_cls, case_rhs, separation_cond @ List.concat case_conds in
- List.map rule_case choices
+ ) next_cls in
+ let case_rhs, case_conds = List.split case_cls in
+ case_cls, case_rhs, separation_cond @ List.concat case_conds in
+ let res = List.map rule_case choices in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "rule_cases: next clauses partitioned into rules\n%!";
+ let print_case i (_, case_rhs, case_cond) =
+ Printf.printf "\nRCAND: #%d\nRHS: %s\nLHS: %s\n%!" i
+ (String.concat " " (List.map term_str case_rhs))
+ (String.concat " " (List.map literal_str case_cond)) in
+ Array.iteri print_case (Array.of_list res)
+ );
+ (* }}} *)
+ res
-let process_rule_cands used_vars next_cls mode players legal_tuples =
+let process_rule_cands used_vars f_paths next_cls mode players legal_tuples =
let move_tups =
move_tuples used_vars next_cls mode players legal_tuples in
let move_tups =
List.map (fun (sb, legal_tup, n_cls) ->
List.map (subst_ln_cl sb) legal_tup,
List.map (subst_fnextcl sb) n_cls) move_tups in
- List.map add_erasure_clauses move_tups
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf
+ "process_rule_cands: move tuples before adding erasure cls--\n%!";
+ let nclause_str (rhs, is_frame, body) =
+ Printf.printf
+ "%s <=fr:%b= %s\n%!"(term_str rhs) is_frame
+ (String.concat " "(List.map literal_str body)) in
+ let print_tup i (legal_tup, n_cls) =
+ Printf.printf "CAND: #%d\nlegal_tup: %s\n%!" i
+ (String.concat ", "(List.map (term_str -| fst) legal_tup));
+ Printf.printf "clauses:\n%!";
+ List.iter nclause_str n_cls in
+ Array.iteri print_tup (Array.of_list move_tups)
+ );
+ (* }}} *)
+ List.map (add_erasure_clauses f_paths) move_tups
let add_legal_cond (legal_tup, next_cls) =
let legal_tup, legal_cond = List.split legal_tup in
let legal_cond = List.concat legal_cond in
List.map (fun (case_cls, case_rhs, case_cond) ->
- legal_tup, case_rhs, case_cond @ legal_cond
+ legal_tup, Aux.unique_sorted case_rhs,
+ Aux.unique_sorted (case_cond @ legal_cond)
) (rule_cases next_cls)
-let turnbased_rule_cases used_vars next_cls players legal_by_player =
+let turnbased_rule_cases used_vars f_paths next_cls players legal_by_player =
let legal_tuples = Aux.product legal_by_player in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "turnbased_rule_cases: legal_tuples --\n%!";
+ let print_ltup i ltuple =
+ Printf.printf "LEGAL: #%d -- %s\n%!" i
+ (String.concat "; "(List.map (term_str -| fst) ltuple)) in
+ Array.iteri print_ltup (Array.of_list legal_tuples);
+ );
+ (* }}} *)
let move_tups =
process_rule_cands
- used_vars next_cls `General players legal_tuples in
+ used_vars f_paths next_cls `General players legal_tuples in
let rules = Aux.concat_map add_legal_cond move_tups in
(* we do not look for the players -- for turn-based case, it's done
while building game graph *)
@@ -652,17 +770,17 @@
(* If "Concurrent Moves" case, divide rule clauses among players. *)
-let concurrent_rule_cases used_vars next_cls players legal_by_player =
+let concurrent_rule_cases used_vars f_paths next_cls players legal_by_player =
let env_pl_tups =
env_player,
- process_rule_cands used_vars next_cls `Environment [] [[]] in
+ process_rule_cands used_vars f_paths next_cls `Environment [] [[]] in
let player_rules =
List.map2 (fun player legal_cls ->
(* [process_rule_cands] works with players tuples, so we "cheat" *)
let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
let move_tups =
process_rule_cands
- used_vars next_cls `Concurrent [player] legal_tuples in
+ used_vars f_paths next_cls `Concurrent [player] legal_tuples in
player, move_tups
) players legal_by_player in
let player_rules = List.map
@@ -671,7 +789,7 @@
(player_rules @ [env_pl_tups]) in
Aux.Right player_rules
-let general_int_rule_cases used_vars next_cls players legal_by_player =
+let general_int_rule_cases used_vars f_paths next_cls players legal_by_player =
failwith "General Interaction Games not implemented yet"
@@ -685,7 +803,7 @@
are built. The rules are partitioned among players. The last
player is the environment, [env_player] (this way, the numbering of
players can be the same as in turn-based case). *)
-let create_rule_cands is_turn_based used_vars next_cls clauses =
+let create_rule_cands is_turn_based used_vars f_paths next_cls clauses =
let players = (* Array.of_list *)
Aux.map_some (function
| ("role", [|player|]), _ -> Some player
@@ -693,6 +811,12 @@
) clauses in
let legal_cls =
List.filter (fun ((rel,_),_) -> rel="legal") clauses in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "create_rule_cands: legal_clauses --\n%s\n%!"
+ (String.concat "\n"(List.map clause_str legal_cls))
+ );
+ (* }}} *)
let is_concurrent = not is_turn_based &&
List.for_all
(fun (_, _, body) ->
@@ -710,12 +834,28 @@
) players in
let result =
if is_concurrent then
- concurrent_rule_cases used_vars next_cls players legal_by_player
+ concurrent_rule_cases used_vars f_paths next_cls players legal_by_player
else if is_turn_based then
- turnbased_rule_cases used_vars next_cls players legal_by_player
+ turnbased_rule_cases used_vars f_paths next_cls players legal_by_player
else
- general_int_rule_cases used_vars next_cls players legal_by_player
+ general_int_rule_cases used_vars f_paths next_cls players legal_by_player
in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ let pl_rulecands = match result with
+ | Aux.Left rcands -> [Const "All Players", rcands]
+ | Aux.Right pl_rcands -> pl_rcands in
+ let print_rcand i (_, case_rhs, case_cond) =
+ Printf.printf "\nRCAND: #%d\nRHS: %s\nLHS: %s\n%!" i
+ (String.concat " " (List.map term_str case_rhs))
+ (String.concat " " (List.map literal_str case_cond)) in
+ let print_rcands (player, rcands) =
+ Printf.printf "create_rule_cands: player %s --\n%!"
+ (term_str player);
+ Array.iteri print_rcand (Array.of_list rcands) in
+ List.iter print_rcands pl_rulecands
+ );
+ (* }}} *)
result, is_concurrent
@@ -730,7 +870,14 @@
| _ -> true in
let check_cands cands =
List.filter (fun (_, _, case_conds) ->
- List.for_all check_atom case_conds
+ let res = List.for_all check_atom case_conds in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "check_cands: cond %s -- %b\n%!"
+ (String.concat " "(List.map literal_str case_conds)) res
+ );
+ (* }}} *)
+ res
) cands in
match rule_cands with
| Aux.Left cands -> Aux.Left (check_cands cands)
@@ -848,8 +995,8 @@
(* doing the playouts "a couple" = 3 times *)
let data1 = check_one_playout () in
let data2 = check_one_playout () in
- let data3 = check_one_playout () in
- if data1 = data2 && data1 = data3 then data1
+ (* let data3 = check_one_playout () in *)
+ if data1 = data2 (* && data1 = data3 *) then data1
else raise Not_turn_based
@@ -1136,11 +1283,17 @@
create_init_struc clauses in
let ground_at paths = List.map
(fun p ->
- p, Aux.map_try (fun s -> at_path s p) ground_state_terms)
+ p, Aux.unique_sorted
+ (Aux.map_try (fun s -> at_path s p) ground_state_terms))
(paths_to_list paths) in
let ground_at_f_paths = ground_at f_paths in
+ let prepare_lits ((h_rel, h_args), body) =
+ if h_rel = "next" then (Pos (True h_args.(0))::body)
+ else if h_rel = "frame next"
+ then Aux.list_remove (Pos (True h_args.(0))) body
+ else body in
let clauses =
- ground_vars_at_paths ground_at_f_paths clauses in
+ GDL.ground_vars_at_paths prepare_lits ground_at_f_paths clauses in
let defined_rels = Aux.list_diff defined_rels
["goal"; "legal"; "next"; "terminal"] in
let defined_rels, clauses = elim_ground_args defined_rels clauses in
@@ -1154,7 +1307,7 @@
try Some (check_turn_based players rules)
with Not_turn_based -> None in
let rule_cands, is_concurrent =
- create_rule_cands (turn_data <> None) used_vars next_cls clauses in
+ create_rule_cands (turn_data <> None) used_vars f_paths next_cls clauses in
let rule_cands =
filter_rule_cands static_base defined_rels rule_cands in
let term_arities = Aux.unique_sorted
@@ -1210,12 +1363,14 @@
defined_rels = defined_rels;
starting_struc = struc;
} in
+ let result =
+ game, {Arena.struc = struc; history = []; time = 0.; cur_loc = 0} in
...
[truncated message content] |
|
From: <luk...@us...> - 2011-08-13 01:39:42
|
Revision: 1537
http://toss.svn.sourceforge.net/toss/?rev=1537&view=rev
Author: lukstafi
Date: 2011-08-13 01:39:33 +0000 (Sat, 13 Aug 2011)
Log Message:
-----------
GDL translation fixing: small specification fix regarding same variables from both positive and negated state terms; Structure corrected to discard adding new elements with existing names; fixes in preparing precondition and other data for rule generation; for turn-based translation, consider only legal clause tuples with single player having non-noop move.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/Solver/Structure.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-08-13 01:39:33 UTC (rev 1537)
@@ -719,12 +719,12 @@
List.map fst (List.filter (fun (rel, ar) ->
let selector = Structure.free_for_rel rel ar in
let res = Solver.M.check selector rphi in
- (* {{{ log entry *)
+ (* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf "compile_rule.expand_def_rels: %s on %s = %b\n%!"
rel (Structure.str selector) res
);
- (* }}} *)
+ (* }}} *)
res
) signat)
else [rel] in
@@ -836,6 +836,24 @@
embedding formula, but we need to avoid negating their support *)
let lhs_opt_rels, lhs_pos_tups, lhs_pos_expanded =
compile_opt_rels lhs_rels in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "compile_rule: lhs_pos_tups=%s\n%!"
+ (String.concat "; "(List.map (fun (rel,tups)->
+ rel^"{"^String.concat ";"(List.map (fun tup ->
+ "("^String.concat ", "
+ (Array.to_list (Array.map (
+ Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
+ lhs_pos_tups));
+ Printf.printf "compile_rule: lhs_pos_expanded=%s\n%!"
+ (String.concat "; "(List.map (fun (rel,tups)->
+ rel^"{"^String.concat ";"(List.map (fun tup ->
+ "("^String.concat ", "
+ (Array.to_list (Array.map (
+ Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
+ lhs_pos_expanded));
+ );
+ (* }}} *)
let lhs_all_tups n =
List.map Array.of_list (Aux.product (
Aux.fold_n (fun acc -> lhs_elems::acc) [] n)) in
@@ -862,6 +880,17 @@
with Not_found -> failwith
("not in signature: " ^ rel))))
base_emb_rels in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "compile_rule: lhs_neg_tups=%s\n%!"
+ (String.concat "; "(List.map (fun (rel,tups)->
+ rel^"{"^String.concat ";"(List.map (fun tup ->
+ "("^String.concat ", "
+ (Array.to_list (Array.map (
+ Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
+ lhs_neg_tups));
+ );
+ (* }}} *)
(* injectivity checking *)
let lhs_alldif_tups =
triang_product 2 lhs_elem_vars in
@@ -872,11 +901,11 @@
Aux.concat_map (fun (rel, tups) ->
List.map (fun tup -> Rel (rel, varify_lhs tup)) tups)
lhs_pos_tups @
- Aux.concat_map (fun (rel, tups) ->
- List.map (fun tup -> Not (Rel (rel, varify_lhs tup))) tups)
+ Aux.concat_map (fun (rel, tups) ->
+ List.map (fun tup -> Not (Rel (rel, varify_lhs tup))) tups)
lhs_neg_tups @
- List.map (function [x;y] -> Not (Eq (`FO x, `FO y))
- | _ -> assert false) lhs_alldif_tups @
+ List.map (function [x;y] -> Not (Eq (`FO x, `FO y))
+ | _ -> assert false) lhs_alldif_tups @
(FormulaOps.as_conjuncts precond)
) in
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-08-13 01:39:33 UTC (rev 1537)
@@ -234,7 +234,7 @@
let universal_part =
if neg_terms = [] then []
else [Formula.Not (
- Formula.Ex ((neg_vars :> Formula.var list),
+ Formula.Ex (((Aux.list_diff neg_vars pos_vars) :> Formula.var list),
Formula.And [
(* positive because they form a "premise" *)
transl_rels data rels_eqs all_terms neg_terms;
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-13 01:39:33 UTC (rev 1537)
@@ -38,8 +38,14 @@
[nonerasing_frame_wave] is set to [true].) *)
let nonerasing_frame_wave = ref true
+(** When translating as turn-based, filter-out moves composed only of
+ actions such that each is a "noop" action of some player at some
+ location. Assumes that players do not use their "noop" actions
+ for purposes other than waiting for their turn. *)
+let noops_not_moves = ref true
+
(** Limit on the number of steps for aggregate and random playouts. *)
-let playout_horizon = ref 30
+let playout_horizon = ref 20
(** Use "true" atoms while computing rule cases. *)
let split_on_state_atoms = ref false
@@ -443,11 +449,11 @@
*)
-(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Do not remove the
- "does" atoms from clauses. Also handles as special cases:
- "concurrent" case with selecting clauses for only one player, and
- "environment" case for selecting clauses not dependent on any
- player. Preserve legal clauses into the output tuples. *)
+(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Also handles as
+ special cases: "concurrent" case with selecting clauses for only
+ one player, and "environment" case for selecting clauses not
+ dependent on any player. Preserve legal clauses into the output
+ tuples. *)
let move_tuples used_vars next_cls mode players legal_tuples =
(* computing the $d_i(\calN)$ for each $\calN$ *)
let fresh_x_f () =
@@ -459,7 +465,7 @@
let djs =
(* FIXME: check if "negative true" is properly handled *)
Aux.map_some (function
- | (Pos (Does (dp, d)) | Neg (Does (dp, d))) when dp = p -> Some d
+ | Pos (Does (dp, d)) when dp = p -> Some d
| _ -> None) body in
let sb = unify_all sb djs in
let d =
@@ -526,7 +532,13 @@
with Not_found -> cl_tup
) cl_tup next_clauses in
let cl_tups = List.map maximality cl_tups in
- List.map (fun (sb, _, n_cls) -> sb, legal_tup, n_cls) cl_tups in
+ (* removing "does" atoms from clauses *)
+ List.map (fun (sb, _, n_cls) ->
+ let n_cls = List.map (fun (head,frame,body) ->
+ head, frame,
+ List.filter
+ (function Pos (Does _) -> false | _ -> true) body) n_cls in
+ sb, legal_tup, n_cls) cl_tups in
Aux.concat_map move_clauses legal_tuples
@@ -749,8 +761,21 @@
) (rule_cases next_cls)
-let turnbased_rule_cases used_vars f_paths next_cls players legal_by_player =
+let turnbased_rule_cases loc_noops used_vars f_paths next_cls
+ players legal_by_player =
let legal_tuples = Aux.product legal_by_player in
+ (* remove tuples with multiple players making moves
+ TODO: could be enhanced by only excluding a noop of a player for
+ that player *)
+ let all_noops = Aux.map_some (fun x->x)
+ (Aux.concat_map Array.to_list (Array.to_list loc_noops)) in
+ let legal_tuples = List.filter
+ (fun legal_tup ->
+ let num_not_noops =
+ List.length (Aux.list_diff (List.map fst legal_tup) all_noops) in
+ num_not_noops = 1
+ || (num_not_noops = 0 && not !noops_not_moves))
+ legal_tuples in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "turnbased_rule_cases: legal_tuples --\n%!";
@@ -817,7 +842,7 @@
(String.concat "\n"(List.map clause_str legal_cls))
);
(* }}} *)
- let is_concurrent = not is_turn_based &&
+ let is_concurrent = is_turn_based = None &&
List.for_all
(fun (_, _, body) ->
List.length
@@ -835,10 +860,14 @@
let result =
if is_concurrent then
concurrent_rule_cases used_vars f_paths next_cls players legal_by_player
- else if is_turn_based then
- turnbased_rule_cases used_vars f_paths next_cls players legal_by_player
else
- general_int_rule_cases used_vars f_paths next_cls players legal_by_player
+ match is_turn_based with
+ | Some (_, loc_noops) ->
+ turnbased_rule_cases loc_noops used_vars f_paths next_cls
+ players legal_by_player
+ | None ->
+ general_int_rule_cases used_vars f_paths next_cls
+ players legal_by_player
in
(* {{{ log entry *)
if !debug_level > 2 then (
@@ -1031,14 +1060,18 @@
let struc_elems = List.map
(fun sterm -> term_to_name (blank_out transl_data sterm))
case_rhs in
+ let rulevar_terms = Aux.strmap_of_assoc
+ (List.combine struc_elems case_rhs) in
+ let struc_elems = Aux.unique_sorted struc_elems in
+ let precond = FormulaOps.del_vars_quant
+ (List.map Formula.fo_var_of_string struc_elems :> Formula.var list)
+ precond in
let discrete =
DiscreteRule.translate_from_precond ~precond
~add:rhs_add ~emb_rels:fluents ~signat ~struc_elems in
let rule =
ContinuousRule.make_rule signat [] discrete
[] [] ~pre:discrete.DiscreteRule.pre () in
- let rulevar_terms = Aux.strmap_of_assoc
- (List.combine struc_elems case_rhs) in
let fixvar_terms = Aux.concat_map
(fun sterm -> map_paths
(fun path -> function Var v -> v, (sterm, path)
@@ -1307,7 +1340,7 @@
try Some (check_turn_based players rules)
with Not_turn_based -> None in
let rule_cands, is_concurrent =
- create_rule_cands (turn_data <> None) used_vars f_paths next_cls clauses in
+ create_rule_cands turn_data used_vars f_paths next_cls clauses in
let rule_cands =
filter_rule_cands static_base defined_rels rule_cands in
let term_arities = Aux.unique_sorted
@@ -1365,6 +1398,12 @@
} in
let result =
game, {Arena.struc = struc; history = []; time = 0.; cur_loc = 0} in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "\n\ntranslate_game: before simplification --\n%s\n%!"
+ (Arena.sprint_state_full result)
+ );
+ (* }}} *)
let tossrule_data = Aux.strmap_of_assoc tossrule_data in
let playing_as =
Aux.array_argfind (fun x -> x = playing_as) players in
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-13 01:39:33 UTC (rev 1537)
@@ -220,7 +220,7 @@
(* GDL.debug_level := 2; *)
TranslateGame.debug_level := 4;
GameSimpl.debug_level := 4;
- (* DiscreteRule.debug_level := 4; *)
+ DiscreteRule.debug_level := 4;
()
@@ -271,9 +271,9 @@
DiscreteRule.debug_level := discreterule_dl);
TranslateGame.generate_test_case := None
-let a () =
- (* regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer"; *)
- regenerate ~debug:false ~game_name:"connect5" ~player:"x";
+let a =
+ regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer";
+ (* regenerate ~debug:false ~game_name:"connect5" ~player:"x"; *)
(* regenerate ~debug:true ~game_name:"breakthrough" ~player:"white"; *)
(* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
(* regen_with_debug ~game_name:"connect4" ~player:"white"; *)
Modified: trunk/Toss/GGP/tests/connect5-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-raw.toss 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/GGP/tests/connect5-raw.toss 2011-08-13 01:39:33 UTC (rev 1537)
@@ -1,4 +1,3 @@
-; not correct yet, but you can have a look at what works already
REL adjacent_cell(v0, v1, v2, v3) =
ex cell_x22__BLANK___BLANK_, cell_y22__BLANK___BLANK_,
cell_x23__BLANK___BLANK_, cell_y23__BLANK___BLANK_
@@ -411,78 +410,40 @@
cell__BLANK___BLANK___BLANK_(cell_e_y8__BLANK_))
PLAYERS x, o
RULE mark_x5_y5_noop:
- [cell_x5_y5__BLANK_, cell_x5_y5__BLANK_, control__BLANK_ |
- _opt_cell_2b {cell_x5_y5__BLANK_; control__BLANK_};
+ [cell_x5_y5__BLANK_, control__BLANK_ |
+ _opt_cell_2b (control__BLANK_);
_opt_cell_2o {cell_x5_y5__BLANK_; control__BLANK_};
_opt_cell_2x {cell_x5_y5__BLANK_; control__BLANK_};
- _opt_control_0o {cell_x5_y5__BLANK_; control__BLANK_};
- _opt_control_0x {cell_x5_y5__BLANK_; control__BLANK_}
+ _opt_control_0o (cell_x5_y5__BLANK_);
+ _opt_control_0x (cell_x5_y5__BLANK_); cell_2b (cell_x5_y5__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_x5_y5__BLANK_);
+ control_0x (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
- [cell_x5_y5__BLANK_, cell_x5_y5__BLANK_, control__BLANK_ |
+ [cell_x5_y5__BLANK_, control__BLANK_ |
cell_2x (cell_x5_y5__BLANK_); control_0o (control__BLANK_) |
] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- (not ex control__BLANK_ control_0o(control__BLANK_) and
- ex cell_x5_y5__BLANK_, control__BLANK_
- (cell_2b(cell_x5_y5__BLANK_) and
- cell__BLANK___BLANK___BLANK_(cell_x5_y5__BLANK_) and
- control_0x(control__BLANK_) and control__BLANK_(control__BLANK_)))
-RULE noop_noop:
- [control__BLANK_, control__BLANK_ |
- _opt_cell_2b (control__BLANK_); _opt_cell_2o (control__BLANK_);
- _opt_cell_2x (control__BLANK_); _opt_control_0o (control__BLANK_);
- _opt_control_0x (control__BLANK_)
- |
- ] ->
- [control__BLANK_, control__BLANK_ |
- control_0o (control__BLANK_); control_0x (control__BLANK_) |
- ] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- not
- ex control__BLANK_, control__BLANK_
- ((control_0o(control__BLANK_) and control__BLANK_(control__BLANK_)) or
- (control_0x(control__BLANK_) and control__BLANK_(control__BLANK_)))
RULE noop_mark_x6_y6:
- [cell_x6_y6__BLANK_, cell_x6_y6__BLANK_, control__BLANK_ |
- _opt_cell_2b {cell_x6_y6__BLANK_; control__BLANK_};
+ [cell_x6_y6__BLANK_, control__BLANK_ |
+ _opt_cell_2b (control__BLANK_);
_opt_cell_2o {cell_x6_y6__BLANK_; control__BLANK_};
_opt_cell_2x {cell_x6_y6__BLANK_; control__BLANK_};
- _opt_control_0o {cell_x6_y6__BLANK_; control__BLANK_};
- _opt_control_0x {cell_x6_y6__BLANK_; control__BLANK_}
+ _opt_control_0o (cell_x6_y6__BLANK_);
+ _opt_control_0x (cell_x6_y6__BLANK_); cell_2b (cell_x6_y6__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_x6_y6__BLANK_);
+ control_0o (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
- [cell_x6_y6__BLANK_, cell_x6_y6__BLANK_, control__BLANK_ |
+ [cell_x6_y6__BLANK_, control__BLANK_ |
cell_2o (cell_x6_y6__BLANK_); control_0x (control__BLANK_) |
] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- (not ex control__BLANK_ control_0x(control__BLANK_) and
- ex cell_x6_y6__BLANK_, control__BLANK_
- (cell_2b(cell_x6_y6__BLANK_) and
- cell__BLANK___BLANK___BLANK_(cell_x6_y6__BLANK_) and
- control_0o(control__BLANK_) and control__BLANK_(control__BLANK_)))
-RULE noop_noop0:
- [control__BLANK_, control__BLANK_ |
- _opt_cell_2b (control__BLANK_); _opt_cell_2o (control__BLANK_);
- _opt_cell_2x (control__BLANK_); _opt_control_0o (control__BLANK_);
- _opt_control_0x (control__BLANK_)
- |
- ] ->
- [control__BLANK_, control__BLANK_ |
- control_0o (control__BLANK_); control_0x (control__BLANK_) |
- ] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- not
- ex control__BLANK_, control__BLANK_
- ((control_0o(control__BLANK_) and control__BLANK_(control__BLANK_)) or
- (control_0x(control__BLANK_) and control__BLANK_(control__BLANK_)))
LOC 0 {
PLAYER x {
PAYOFF
100. * :((true and conn5__x() and true)) +
50. * :((true and not exists_line_of_five() and true))
- MOVES [mark_x5_y5_noop -> 1]; [noop_noop -> 1] }
+ MOVES [mark_x5_y5_noop -> 1] }
PLAYER o {
PAYOFF
100. * :((true and conn5__o() and true)) +
@@ -500,7 +461,7 @@
PAYOFF
100. * :((true and conn5__o() and true)) +
50. * :((true and not exists_line_of_five() and true))
- MOVES [noop_mark_x6_y6 -> 0]; [noop_noop0 -> 0] }
+ MOVES [noop_mark_x6_y6 -> 0] }
}
MODEL
[cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_,
Modified: trunk/Toss/GGP/tests/connect5-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-simpl.toss 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/GGP/tests/connect5-simpl.toss 2011-08-13 01:39:33 UTC (rev 1537)
@@ -1,4 +1,3 @@
-; not correct yet, but you can have a look at what works already
REL adjacent_cell(v0, v1, v2, v3) =
ex cell_x19__BLANK___BLANK_, cell_y19__BLANK___BLANK_,
cell_x19__BLANK___BLANK_, cell_y20__BLANK___BLANK_
@@ -211,75 +210,35 @@
R: EQ___cell_0__cell_0__AND__nextcol__cell_1__cell_1,
R1: nextcol__cell_0__cell_0__AND_INV__nextcol__cell_1__cell_1
RULE mark_x5_y5_noop:
- [cell_x5_y5__BLANK_, cell_x5_y5__BLANK_, control__BLANK_ |
- _opt_cell_2b {cell_x5_y5__BLANK_; control__BLANK_};
+ [cell_x5_y5__BLANK_, control__BLANK_ |
+ _opt_cell_2b (control__BLANK_);
_opt_cell_2o {cell_x5_y5__BLANK_; control__BLANK_};
_opt_cell_2x {cell_x5_y5__BLANK_; control__BLANK_};
- _opt_control_0o {cell_x5_y5__BLANK_; control__BLANK_};
- _opt_control_0x {cell_x5_y5__BLANK_; control__BLANK_}
+ _opt_control_0o (cell_x5_y5__BLANK_);
+ _opt_control_0x (cell_x5_y5__BLANK_); cell_2b (cell_x5_y5__BLANK_);
+ control_0x (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
- [cell_x5_y5__BLANK_, cell_x5_y5__BLANK_, control__BLANK_ |
+ [cell_x5_y5__BLANK_, control__BLANK_ |
cell_2x (cell_x5_y5__BLANK_); control_0o (control__BLANK_) |
] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- (not ex control__BLANK_ control_0o(control__BLANK_) and
- ex cell_x5_y5__BLANK_, control__BLANK_
- (control__BLANK_(control__BLANK_) and cell_2b(cell_x5_y5__BLANK_) and
- control_0x(control__BLANK_) and
- not control__BLANK_(cell_x5_y5__BLANK_)))
-RULE noop_noop:
- [control__BLANK_, control__BLANK_ |
- _opt_cell_2b (control__BLANK_); _opt_cell_2o (control__BLANK_);
- _opt_cell_2x (control__BLANK_); _opt_control_0o (control__BLANK_);
- _opt_control_0x (control__BLANK_)
- |
- ] ->
- [control__BLANK_, control__BLANK_ |
- control_0o (control__BLANK_); control_0x (control__BLANK_) |
- ] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- not
- ex control__BLANK_, control__BLANK_
- ((control__BLANK_(control__BLANK_) and control_0o(control__BLANK_)) or
- (control__BLANK_(control__BLANK_) and control_0x(control__BLANK_)))
RULE noop_mark_x6_y6:
- [cell_x6_y6__BLANK_, cell_x6_y6__BLANK_, control__BLANK_ |
- _opt_cell_2b {cell_x6_y6__BLANK_; control__BLANK_};
+ [cell_x6_y6__BLANK_, control__BLANK_ |
+ _opt_cell_2b (control__BLANK_);
_opt_cell_2o {cell_x6_y6__BLANK_; control__BLANK_};
_opt_cell_2x {cell_x6_y6__BLANK_; control__BLANK_};
- _opt_control_0o {cell_x6_y6__BLANK_; control__BLANK_};
- _opt_control_0x {cell_x6_y6__BLANK_; control__BLANK_}
+ _opt_control_0o (cell_x6_y6__BLANK_);
+ _opt_control_0x (cell_x6_y6__BLANK_); cell_2b (cell_x6_y6__BLANK_);
+ control_0o (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
- [cell_x6_y6__BLANK_, cell_x6_y6__BLANK_, control__BLANK_ |
+ [cell_x6_y6__BLANK_, control__BLANK_ |
cell_2o (cell_x6_y6__BLANK_); control_0x (control__BLANK_) |
] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- (not ex control__BLANK_ control_0x(control__BLANK_) and
- ex cell_x6_y6__BLANK_, control__BLANK_
- (control__BLANK_(control__BLANK_) and cell_2b(cell_x6_y6__BLANK_) and
- control_0o(control__BLANK_) and
- not control__BLANK_(cell_x6_y6__BLANK_)))
-RULE noop_noop0:
- [control__BLANK_, control__BLANK_ |
- _opt_cell_2b (control__BLANK_); _opt_cell_2o (control__BLANK_);
- _opt_cell_2x (control__BLANK_); _opt_control_0o (control__BLANK_);
- _opt_control_0x (control__BLANK_)
- |
- ] ->
- [control__BLANK_, control__BLANK_ |
- control_0o (control__BLANK_); control_0x (control__BLANK_) |
- ] emb cell_2b, cell_2o, cell_2x, control_0o, control_0x
- pre
- not
- ex control__BLANK_, control__BLANK_
- ((control__BLANK_(control__BLANK_) and control_0o(control__BLANK_)) or
- (control__BLANK_(control__BLANK_) and control_0x(control__BLANK_)))
LOC 0 {
PLAYER x { PAYOFF 100. * :(conn5__x()) + 50. * :(not exists_line_of_five())
- MOVES [mark_x5_y5_noop -> 1]; [noop_noop -> 1] }
+ MOVES [mark_x5_y5_noop -> 1] }
PLAYER o { PAYOFF 100. * :(conn5__o()) + 50. * :(not exists_line_of_five())
}
}
@@ -288,7 +247,7 @@
PLAYER x { PAYOFF 100. * :(conn5__x()) + 50. * :(not exists_line_of_five())
}
PLAYER o { PAYOFF 100. * :(conn5__o()) + 50. * :(not exists_line_of_five())
- MOVES [noop_mark_x6_y6 -> 0]; [noop_noop0 -> 0] }
+ MOVES [noop_mark_x6_y6 -> 0] }
}
MODEL
[cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_,
Modified: trunk/Toss/GGP/tests/tictactoe-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-raw.toss 2011-08-12 14:07:42 UTC (rev 1536)
+++ trunk/Toss/GGP/tests/tictactoe-raw.toss 2011-08-13 01:39:33 UTC (rev 1537)
@@ -1,542 +1,402 @@
+REL column__b(v0) =
+ ex cell_1_n4__BLANK_, cell_2_n4__BLANK_, cell_3_n4__BLANK_
+ (v0 = cell_1_n4__BLANK_ and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_2_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_2_n4__BLANK_, cell_1_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_2_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_3_n4__BLANK_, cell_1_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_3_n4__BLANK_, cell_2_n4__BLANK_) and
+ cell_01(cell_1_n4__BLANK_) and cell_2b(cell_1_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_n4__BLANK_) and
+ cell_02(cell_2_n4__BLANK_) and cell_2b(cell_2_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_n4__BLANK_) and
+ cell_03(cell_3_n4__BLANK_) and cell_2b(cell_3_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_n4__BLANK_))
+REL column__o(v0) =
+ ex cell_1_n4__BLANK_, cell_2_n4__BLANK_, cell_3_n4__BLANK_
+ (v0 = cell_1_n4__BLANK_ and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_2_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_2_n4__BLANK_, cell_1_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_2_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_3_n4__BLANK_, cell_1_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_3_n4__BLANK_, cell_2_n4__BLANK_) and
+ cell_01(cell_1_n4__BLANK_) and cell_2o(cell_1_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_n4__BLANK_) and
+ cell_02(cell_2_n4__BLANK_) and cell_2o(cell_2_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_n4__BLANK_) and
+ cell_03(cell_3_n4__BLANK_) and cell_2o(cell_3_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_n4__BLANK_))
+REL column__x(v0) =
+ ex cell_1_n4__BLANK_, cell_2_n4__BLANK_, cell_3_n4__BLANK_
+ (v0 = cell_1_n4__BLANK_ and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_2_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_2_n4__BLANK_, cell_1_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_2_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_3_n4__BLANK_, cell_1_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_3_n4__BLANK_, cell_2_n4__BLANK_) and
+ cell_01(cell_1_n4__BLANK_) and cell_2x(cell_1_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_n4__BLANK_) and
+ cell_02(cell_2_n4__BLANK_) and cell_2x(cell_2_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_n4__BLANK_) and
+ cell_03(cell_3_n4__BLANK_) and cell_2x(cell_3_n4__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_n4__BLANK_))
+REL diagonal__b() =
+ ex cell_1_3__BLANK_, cell_2_2__BLANK_, cell_3_1__BLANK_
+ (true and true and
+ cell_01(cell_1_3__BLANK_) and cell_13(cell_1_3__BLANK_) and
+ cell_2b(cell_1_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_3__BLANK_) and
+ cell_02(cell_2_2__BLANK_) and cell_12(cell_2_2__BLANK_) and
+ cell_2b(cell_2_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_2__BLANK_) and
+ cell_03(cell_3_1__BLANK_) and cell_11(cell_3_1__BLANK_) and
+ cell_2b(cell_3_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_1__BLANK_)) or
+ ex cell_1_1__BLANK_, cell_2_2__BLANK_, cell_3_3__BLANK_
+ (true and true and
+ cell_01(cell_1_1__BLANK_) and cell_11(cell_1_1__BLANK_) and
+ cell_2b(cell_1_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_1__BLANK_) and
+ cell_02(cell_2_2__BLANK_) and cell_12(cell_2_2__BLANK_) and
+ cell_2b(cell_2_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_2__BLANK_) and
+ cell_03(cell_3_3__BLANK_) and cell_13(cell_3_3__BLANK_) and
+ cell_2b(cell_3_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_3__BLANK_))
+REL diagonal__o() =
+ ex cell_1_3__BLANK_, cell_2_2__BLANK_, cell_3_1__BLANK_
+ (true and true and
+ cell_01(cell_1_3__BLANK_) and cell_13(cell_1_3__BLANK_) and
+ cell_2o(cell_1_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_3__BLANK_) and
+ cell_02(cell_2_2__BLANK_) and cell_12(cell_2_2__BLANK_) and
+ cell_2o(cell_2_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_2__BLANK_) and
+ cell_03(cell_3_1__BLANK_) and cell_11(cell_3_1__BLANK_) and
+ cell_2o(cell_3_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_1__BLANK_)) or
+ ex cell_1_1__BLANK_, cell_2_2__BLANK_, cell_3_3__BLANK_
+ (true and true and
+ cell_01(cell_1_1__BLANK_) and cell_11(cell_1_1__BLANK_) and
+ cell_2o(cell_1_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_1__BLANK_) and
+ cell_02(cell_2_2__BLANK_) and cell_12(cell_2_2__BLANK_) and
+ cell_2o(cell_2_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_2__BLANK_) and
+ cell_03(cell_3_3__BLANK_) and cell_13(cell_3_3__BLANK_) and
+ cell_2o(cell_3_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_3__BLANK_))
+REL diagonal__x() =
+ ex cell_1_3__BLANK_, cell_2_2__BLANK_, cell_3_1__BLANK_
+ (true and true and
+ cell_01(cell_1_3__BLANK_) and cell_13(cell_1_3__BLANK_) and
+ cell_2x(cell_1_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_3__BLANK_) and
+ cell_02(cell_2_2__BLANK_) and cell_12(cell_2_2__BLANK_) and
+ cell_2x(cell_2_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_2__BLANK_) and
+ cell_03(cell_3_1__BLANK_) and cell_11(cell_3_1__BLANK_) and
+ cell_2x(cell_3_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_1__BLANK_)) or
+ ex cell_1_1__BLANK_, cell_2_2__BLANK_, cell_3_3__BLANK_
+ (true and true and
+ cell_01(cell_1_1__BLANK_) and cell_11(cell_1_1__BLANK_) and
+ cell_2x(cell_1_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_1_1__BLANK_) and
+ cell_02(cell_2_2__BLANK_) and cell_12(cell_2_2__BLANK_) and
+ cell_2x(cell_2_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_2_2__BLANK_) and
+ cell_03(cell_3_3__BLANK_) and cell_13(cell_3_3__BLANK_) and
+ cell_2x(cell_3_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_3_3__BLANK_))
+REL line__b() =
+ (true and diagonal__b() and true) or
+ (true and
+ ex cell__BLANK__m6__BLANK_ (column__b(cell__BLANK__m6__BLANK_) and true) and
+ true) or
+ (true and
+ ex cell_m5__BLANK___BLANK_ (row__b(cell_m5__BLANK___BLANK_) and true) and
+ true)
+REL line__o() =
+ (true and diagonal__o() and true) or
+ (true and
+ ex cell__BLANK__m6__BLANK_ (column__o(cell__BLANK__m6__BLANK_) and true) and
+ true) or
+ (true and
+ ex cell_m5__BLANK___BLANK_ (row__o(cell_m5__BLANK___BLANK_) and true) and
+ true)
+REL line__x() =
+ (true and diagonal__x() and true) or
+ (true and
+ ex cell__BLANK__m6__BLANK_ (column__x(cell__BLANK__m6__BLANK_) and true) and
+ true) or
+ (true and
+ ex cell_m5__BLANK___BLANK_ (row__x(cell_m5__BLANK___BLANK_) and true) and
+ true)
+REL open() =
+ ex cell_m7_n5__BLANK_
+ (true and true and
+ cell_2b(cell_m7_n5__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_m7_n5__BLANK_))
+REL row__b(v0) =
+ ex cell_m4_1__BLANK_, cell_m4_2__BLANK_, cell_m4_3__BLANK_
+ (v0 = cell_m4_1__BLANK_ and
+ EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_2__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_3__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_2__BLANK_, cell_m4_1__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_2__BLANK_, cell_m4_3__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_3__BLANK_, cell_m4_1__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_3__BLANK_, cell_m4_2__BLANK_) and
+ cell_11(cell_m4_1__BLANK_) and cell_2b(cell_m4_1__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_m4_1__BLANK_) and
+ cell_12(cell_m4_2__BLANK_) and cell_2b(cell_m4_2__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_m4_2__BLANK_) and
+ cell_13(cell_m4_3__BLANK_) and cell_2b(cell_m4_3__BLANK_) and
+ cell__BLANK___BLANK___BLANK_(cell_m4_3__BLANK_))
+REL row__o(v0) =
+ ex cell_m4_1__BLANK_, cell_m4_2__BLANK_, cell_m4_3__BLANK_
+ (v0 = cell_m4_1__BLANK_ and
+ EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_2__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_3__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_2__BLANK_, cell_m4_1__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_2__BLANK_, cell_m4_3__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_3__BLANK_, cell_m4_1__BLANK_) and
+ E...
[truncated message content] |
|
From: <luk...@us...> - 2011-08-13 21:19:29
|
Revision: 1539
http://toss.svn.sourceforge.net/toss/?rev=1539&view=rev
Author: lukstafi
Date: 2011-08-13 21:19:21 +0000 (Sat, 13 Aug 2011)
Log Message:
-----------
GDL translation: completely reworked clause partitioning for rule candidate generation (replacing a placeholder in the reimplementation); a couple of bug fixes.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-08-13 21:19:21 UTC (rev 1539)
@@ -124,19 +124,21 @@
let free_vars phi =
remove_dup_vars [] (List.sort compare_vars (free_vars_acc [] phi))
-(* Delete top-most ex/all quantification of [vs] in the formula. *)
+(* Delete all quantification over [vs] in the formula. *)
let rec del_vars_quant vs = function
| Eq _ | Rel _ | In _ | SO _ | RealExpr _ as f -> f
| Not phi -> Not (del_vars_quant vs phi)
| And (flist) -> And (List.map (del_vars_quant vs) flist)
| Or (flist) -> Or (List.map (del_vars_quant vs) flist)
| Ex ([], phi) | All ([], phi) -> del_vars_quant vs phi
- | Ex (v :: vr, phi) when List.mem v vs ->
- del_vars_quant (Aux.list_remove v vs) (Ex (vr, phi))
- | Ex (v :: vr, phi) -> Ex ([v], del_vars_quant vs (Ex (vr, phi)))
- | All (v :: vr, phi) when List.mem v vs ->
- del_vars_quant (Aux.list_remove v vs) (All (vr, phi))
- | All (v :: vr, phi) -> All ([v], del_vars_quant vs (All (vr, phi)))
+ | Ex (vr, phi) ->
+ let vr = Aux.list_diff vr vs in
+ if vr = [] then del_vars_quant vs phi
+ else Ex (vr, del_vars_quant vs phi)
+ | All (vr, phi) ->
+ let vr = Aux.list_diff vr vs in
+ if vr = [] then del_vars_quant vs phi
+ else All (vr, del_vars_quant vs phi)
| Lfp (r, xs, phi) -> Lfp (r, xs, del_vars_quant vs phi)
| Gfp (r, xs, phi) -> Gfp (r, xs, del_vars_quant vs phi)
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/GDL.ml 2011-08-13 21:19:21 UTC (rev 1539)
@@ -247,7 +247,7 @@
(try List.assoc y sb with Not_found -> t)
| Var _ as t -> t
| Func (f, args) ->
- Func (f, Array.map (subst sb) args)
+ Func (f, Array.map (subst_consts sb) args)
let rec unify_all sb = function
| [] | [_] -> sb
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-08-13 21:19:21 UTC (rev 1539)
@@ -275,13 +275,25 @@
match spec with
| None -> rel
| Some spec -> DiscreteRule.orig_rel_of rel in
- rel <> "" &&
- not (Aux.Strings.mem rel fluents) &&
- not (List.mem_assoc rel game.Arena.defined_rels) &&
- not (List.exists (fun (_,(rel2,_)) -> rel2=rel) equivalent) &&
- not (Aux.Strings.mem (fst (List.assoc rel equivalent)) fluents ||
- List.mem_assoc (fst (List.assoc rel equivalent))
- game.Arena.defined_rels)
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "removable: %s...%!" rel
+ );
+ (* }}} *)
+ let res =
+ rel <> "" &&
+ not (Aux.Strings.mem rel fluents) &&
+ not (List.mem_assoc rel game.Arena.defined_rels) &&
+ not (List.exists (fun (_,(rel2,_)) -> rel2=rel) equivalent) &&
+ not (Aux.Strings.mem (fst (List.assoc rel equivalent)) fluents ||
+ List.mem_assoc (fst (List.assoc rel equivalent))
+ game.Arena.defined_rels) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "%B\n%!" res;
+ );
+ (* }}} *)
+ res
in
(* {{{ log entry *)
if !debug_level > 0 then (
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-08-13 21:19:21 UTC (rev 1539)
@@ -209,7 +209,8 @@
let pos_terms = state_terms pos_state_phi in
let pos_vars = List.map (var_of_term data) pos_terms in
let neg_terms = state_terms neg_state_phi in
- let neg_vars = List.map (var_of_term data) neg_terms in
+ let neg_vars =
+ Aux.list_diff (List.map (var_of_term data) neg_terms) pos_vars in
let all_terms = pos_terms @ neg_terms in
let phi_vars = clause_vars
(("", [| |]),
@@ -231,15 +232,18 @@
(* negation-normal-form of "not neg_state_phi" *)
Formula.Or (
List.map (transl_state data) (nnf_dnf neg_state_phi)) in
+ let negated_part =
+ Formula.And [
+ (* positive because they form a "premise" *)
+ transl_rels data rels_eqs all_terms neg_terms;
+ (* the universal "conclusion" *)
+ negated_neg_state_transl] in
let universal_part =
if neg_terms = [] then []
+ else if neg_vars = []
+ then [Formula.Not negated_part]
else [Formula.Not (
- Formula.Ex (((Aux.list_diff neg_vars pos_vars) :> Formula.var list),
- Formula.And [
- (* positive because they form a "premise" *)
- transl_rels data rels_eqs all_terms neg_terms;
- (* the universal "conclusion" *)
- negated_neg_state_transl]))] in
+ Formula.Ex ((neg_vars :> Formula.var list), negated_part))] in
let base_part =
Formula.And (
[ ext_phi;
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-13 21:19:21 UTC (rev 1539)
@@ -47,9 +47,6 @@
(** Limit on the number of steps for aggregate and random playouts. *)
let playout_horizon = ref 20
-(** Use "true" atoms while computing rule cases. *)
-let split_on_state_atoms = ref false
-
let env_player = Const "ENVIRONMENT"
type tossrule_data = {
@@ -452,8 +449,8 @@
(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Also handles as
special cases: "concurrent" case with selecting clauses for only
one player, and "environment" case for selecting clauses not
- dependent on any player. Preserve legal clauses into the output
- tuples. *)
+ dependent on any player. Preserve "legal" clauses into the output
+ tuples. Mark which "next" clauses contained "does" atoms. *)
let move_tuples used_vars next_cls mode players legal_tuples =
(* computing the $d_i(\calN)$ for each $\calN$ *)
let fresh_x_f () =
@@ -532,12 +529,19 @@
with Not_found -> cl_tup
) cl_tup next_clauses in
let cl_tups = List.map maximality cl_tups in
- (* removing "does" atoms from clauses *)
+ (* Removing "does" atoms from clauses, but leaving a trace: a
+ clause containing "does" atom is required to participate in
+ the rewrite rule. *)
List.map (fun (sb, _, n_cls) ->
let n_cls = List.map (fun (head,frame,body) ->
- head, frame,
- List.filter
- (function Pos (Does _) -> false | _ -> true) body) n_cls in
+ if List.exists
+ (function Pos (Does _) -> true | _ -> false) body
+ then
+ head, (frame, true),
+ List.filter
+ (function Pos (Does _) -> false | _ -> true) body
+ else
+ head, (frame, false), body) n_cls in
sb, legal_tup, n_cls) cl_tups in
Aux.concat_map move_clauses legal_tuples
@@ -551,7 +555,7 @@
);
(* }}} *)
let frame_cls =
- Aux.map_some (fun (s, frame, body) ->
+ Aux.map_some (fun (s, (frame, _), body) ->
if frame then Some (s, body) else None) next_cls in
(* two passes to ensure coverage and maximality *)
(* Treating fixed-vars as consts, by substituting them with
@@ -592,6 +596,13 @@
let frames =
List.map (fun (sb, s, bodies) ->
s, List.map (subst_literals sb) bodies) frames in
+ (* removing the framed state terms *)
+ let frames =
+ let filter_out s body =
+ List.filter
+ (function Pos (True t) when t=s -> false | _ -> true) body in
+ List.map (fun (s, bodies) ->
+ s, List.map (filter_out s) bodies) frames in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "add_erasure_clauses: frames --\n%!";
@@ -633,54 +644,112 @@
let erasure_cls = List.map
(subst_consts_clause fixed_to_var)
(List.map (fun (s,body)->("erasure next",[|s|]),body) erasure_cls) in
+ (* Erasure clauses are considered as not having "does" atoms,
+ although of course the frame clauses did have "does" atoms. *)
let erasure_cls =
- List.map (fun ((_,h),body) -> h.(0),body) erasure_cls in
+ List.map (fun ((_,h),body) -> h.(0),false,body) erasure_cls in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "add_erasure_clauses: erasure clauses --\n%!";
- let print_erasure (s, body) =
+ let print_erasure (s, _, body) =
Printf.printf "ERASURE: %s <== %s\n%!" (term_str s)
(String.concat " " (List.map literal_str body)) in
List.iter print_erasure erasure_cls; flush stdout;
);
(* }}} *)
let next_cls =
- Aux.map_some (fun (s, frame, body) ->
- if not frame then Some (s, body) else None) next_cls in
+ Aux.map_some (fun (s, (frame, required), body) ->
+ if not frame then Some (s, required, body) else None) next_cls in
legal_tup, next_cls @ erasure_cls
-(* Assign rule clauses to rule cases, i.e. candidates for
- Toss rules. Collect the conditions and RHS state terms together.
- Frame clauses are already processed into erasure clauses. *)
-let rule_cases next_cls =
- let atoms = Aux.concat_map
- (fun (_, body) -> Aux.map_some (function
- | Pos (Rel _ as a) | Neg (Rel _ as a) -> Some a
- | (Pos (True _ as a) | Neg (True _ as a))
- when !split_on_state_atoms -> Some a
- | _ -> None) body) next_cls in
- if atoms = [] then (* single partition *)
- let case_rhs, case_conds = List.split next_cls in
+let ignore_rhs = Const "__IGNORE_RHS__"
+
+(* Assign rule clauses to rule cases, i.e. candidates for Toss
+ rules. Collect the conditions and RHS state terms together. Frame
+ clauses are already processed into erasure clauses. Rule clauses
+ should contain the "legal" clauses with heads replaced by
+ "_IGNORE_RHS_" terms which will be discarded later; "legal" clauses
+ and "next" clauses that contained "does" atoms should be marked as
+ required.
+
+ We call atoms or literals "deterministic" if they are not under
+ disjunction. First we collect deterministic literals of required
+ clauses, and remove unrequired clauses that have deterministic
+ literals conflicting with deterministic literals of required clauses.
+
+ The candidates are built by partitioning rule clauses. We select
+ "case-split atoms": the deterministic atoms of unrequired clauses
+ that are not deterministic atoms of required clauses. To further
+ decrease the number of case-split atoms, we build "patterns":
+ collect atoms that occur in the same clauses with the same sign,
+ and from each pattern we pick just one arbitrary atom. We generate
+ all sign assingments to case-split atoms -- each is a potential
+ rule case. For each sign assignment, we select exactly those
+ unrequired clauses that have no literals disagreeing with the sign
+ assignment.
+
+ TODO: unrequired clauses with disjunctions may avoid being
+ excluded. If this poses problems we might need to expand
+ disjunctions containing potentially case-split atoms.
+
+*)
+let rule_cases rule_cls =
+ let required_cls = Aux.map_some
+ (fun (h, required, body) ->
+ if required then Some (h, body) else None) rule_cls in
+ let unrequired_cls = Aux.map_some
+ (fun (h, required, body) ->
+ if not required then Some (h, body) else None) rule_cls in
+ let forbidden_lits = Aux.unique_sorted
+ (Aux.concat_map
+ (fun (_, body) -> Aux.map_some (function
+ | Pos (Rel _ as a) | Pos (True _ as a) -> Some (Neg a)
+ | Neg (Rel _ as a) | Neg (True _ as a) -> Some (Pos a)
+ | _ -> None) body) required_cls) in
+ let unrequired_cls = List.filter
+ (fun (_, body) ->
+ not (List.exists (fun flit -> List.mem flit body)
+ forbidden_lits))
+ unrequired_cls in
+ let req_atoms = List.map
+ (function Pos a -> a | Neg a -> a | _ -> assert false)
+ forbidden_lits in
+ let unreq_atoms = Aux.unique_sorted
+ (Aux.concat_map
+ (fun (_, body) -> Aux.map_some (function
+ | Pos (Rel _ as a) | Pos (True _ as a)
+ | Neg (Rel _ as a) | Neg (True _ as a) -> Some a
+ | _ -> None) body) unrequired_cls) in
+ let split_atoms = Aux.list_diff unreq_atoms req_atoms in
+ if split_atoms = [] then (* single partition *)
+ let rule_cls = required_cls @ unrequired_cls in
+ let case_rhs, case_conds = List.split rule_cls in
+ let case_rhs = Aux.list_remove ignore_rhs case_rhs in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "rule_cases: single partition\n%!";
);
(* }}} *)
- [next_cls, case_rhs, List.concat case_conds]
+ [Aux.unique_sorted case_rhs,
+ Aux.unique_sorted (List.concat case_conds)]
else
let patterns =
- let next_cls = Array.of_list next_cls in
+ let unrequired_cls = Array.of_list unrequired_cls in
List.map (fun a ->
Array.mapi (fun i (_, body) ->
if List.mem (Neg a) body then -1
else if List.mem (Pos a) body then 1
else 0
- ) next_cls,
- a) atoms in
+ ) unrequired_cls,
+ a) split_atoms in
let patterns = Aux.collect patterns in
+ let split_atoms = List.map
+ (fun (_,atoms) -> List.hd atoms) patterns in
(* {{{ log entry *)
if !debug_level > 2 then (
+ Printf.printf "rule_cases: case-split atoms = %s\n%!"
+ (String.concat " " (List.map atom_str split_atoms));
Printf.printf "rule_cases: patterns --\n%!";
let print_pat (pattern, atoms) =
Printf.printf "%a: %s\n%!"
@@ -689,34 +758,29 @@
List.iter print_pat patterns
);
(* }}} *)
- let patterns = List.filter (fun (pat, _) ->
- Aux.array_existsi (fun _ v-> v < 1) pat &&
- Aux.array_existsi (fun _ v-> v > -1) pat) patterns in
- let pos_choice = List.map (fun _ -> true) patterns in
- let neg_choice = List.map (fun _ -> false) patterns in
- let choices = Aux.product [pos_choice; neg_choice] in
+ let choices = Aux.power split_atoms [false; true] in
let rule_case choice =
let separation_cond =
- List.concat
- (List.map2 (fun b (_, atoms) ->
- if b then List.map (fun a -> Pos a) atoms
- else List.map (fun a -> Neg a) atoms) choice patterns) in
+ List.map (fun (a,b) -> if b then Pos a else Neg a) choice in
let case_cls =
List.filter (fun (_, body) ->
- List.for_all2 (fun b (_, atoms) ->
- if b then (* atoms not excluded *)
- List.for_all (fun a -> not (List.mem (Neg a) body)) atoms
- else (* atoms not included *)
- List.for_all (fun a -> not (List.mem (Pos a) body)) atoms
- ) choice patterns
- ) next_cls in
+ List.for_all (fun (a,b) ->
+ if b then (* atom not excluded *)
+ not (List.mem (Neg a) body)
+ else (* atom not included *)
+ not (List.mem (Pos a) body)
+ ) choice
+ ) unrequired_cls in
+ let case_cls = case_cls @ required_cls in
let case_rhs, case_conds = List.split case_cls in
- case_cls, case_rhs, separation_cond @ List.concat case_conds in
+ let case_rhs = Aux.list_remove ignore_rhs case_rhs in
+ Aux.unique_sorted case_rhs,
+ Aux.unique_sorted (separation_cond @ List.concat case_conds) in
let res = List.map rule_case choices in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "rule_cases: next clauses partitioned into rules\n%!";
- let print_case i (_, case_rhs, case_cond) =
+ let print_case i (case_rhs, case_cond) =
Printf.printf "\nRCAND: #%d\nRHS: %s\nLHS: %s\n%!" i
(String.concat " " (List.map term_str case_rhs))
(String.concat " " (List.map literal_str case_cond)) in
@@ -737,9 +801,9 @@
if !debug_level > 2 then (
Printf.printf
"process_rule_cands: move tuples before adding erasure cls--\n%!";
- let nclause_str (rhs, is_frame, body) =
+ let nclause_str (rhs, (is_frame, required), body) =
Printf.printf
- "%s <=fr:%b= %s\n%!"(term_str rhs) is_frame
+ "%s <=fr:%B;req:%B= %s\n%!"(term_str rhs) is_frame required
(String.concat " "(List.map literal_str body)) in
let print_tup i (legal_tup, n_cls) =
Printf.printf "CAND: #%d\nlegal_tup: %s\n%!" i
@@ -753,12 +817,12 @@
let add_legal_cond (legal_tup, next_cls) =
- let legal_tup, legal_cond = List.split legal_tup in
- let legal_cond = List.concat legal_cond in
- List.map (fun (case_cls, case_rhs, case_cond) ->
- legal_tup, Aux.unique_sorted case_rhs,
- Aux.unique_sorted (case_cond @ legal_cond)
- ) (rule_cases next_cls)
+ let legal_tup, legal_conds = List.split legal_tup in
+ let legal_cls = List.map (* required clauses *)
+ (fun body -> ignore_rhs, true, body) legal_conds in
+ List.map
+ (fun (case_rhs, case_cond) -> legal_tup, case_rhs, case_cond)
+ (rule_cases (legal_cls @ next_cls))
let turnbased_rule_cases loc_noops used_vars f_paths next_cls
@@ -1037,11 +1101,16 @@
rule_names := Aux.Strings.add rname !rule_names;
let label =
{Arena.lb_rule = rname; time_in = 0.1, 0.1; parameters_in = []} in
- let precond =
- Formula.And
- (synch_precond @
- (* singleton disjunct, i.e. no disjunction *)
- [TranslateFormula.translate transl_data [case_cond]]) in
+ let case_precond =
+ (* singleton disjunct, i.e. no disjunction *)
+ TranslateFormula.translate transl_data [case_cond] in
+ let precond = Formula.And (synch_precond @ [case_precond]) in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "build_toss_rule: synch precond = %s; main precond = %s\n%!"
+ (Formula.str (Formula.And synch_precond)) (Formula.str case_precond)
+ );
+ (* }}} *)
let rhs_add = Aux.concat_map
(fun sterm ->
let s_subterms =
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-13 21:19:21 UTC (rev 1539)
@@ -272,11 +272,12 @@
TranslateGame.generate_test_case := None
let a () =
- regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer";
+ regenerate ~debug:true ~game_name:"tictactoe" ~player:"xplayer";
(* regenerate ~debug:false ~game_name:"connect5" ~player:"x"; *)
(* regenerate ~debug:true ~game_name:"breakthrough" ~player:"white"; *)
(* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
(* regen_with_debug ~game_name:"connect4" ~player:"white"; *)
+ (* failwith "generated"; *)
()
let exec () =
Modified: trunk/Toss/GGP/tests/tictactoe-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-raw.toss 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/tests/tictactoe-raw.toss 2011-08-13 21:19:21 UTC (rev 1539)
@@ -192,43 +192,65 @@
_opt_cell_2b (control__BLANK_);
_opt_cell_2o {cell_x6_y__BLANK_; control__BLANK_};
_opt_cell_2x {cell_x6_y__BLANK_; control__BLANK_};
- _opt_control_0oplayer {cell_x6_y__BLANK_; control__BLANK_};
- _opt_control_0xplayer {cell_x6_y__BLANK_; control__BLANK_};
- cell_2b (cell_x6_y__BLANK_);
- cell__BLANK___BLANK___BLANK_ (cell_x6_y__BLANK_)
+ _opt_control_0oplayer (cell_x6_y__BLANK_);
+ _opt_control_0xplayer (cell_x6_y__BLANK_); cell_2b (cell_x6_y__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_x6_y__BLANK_);
+ control_0xplayer (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
[cell_x6_y__BLANK_, control__BLANK_ |
+ cell_2x (cell_x6_y__BLANK_); control_0oplayer (control__BLANK_) |
+ ]
+ emb cell_2b, cell_2o, cell_2x, control_0oplayer, control_0xplayer
+RULE mark_x6_y_noop0:
+ [cell_x6_y__BLANK_, control__BLANK_ |
+ _opt_cell_2b (control__BLANK_);
+ _opt_cell_2o {cell_x6_y__BLANK_; control__BLANK_};
+ _opt_cell_2x {cell_x6_y__BLANK_; control__BLANK_};
+ _opt_control_0oplayer (cell_x6_y__BLANK_);
+ _opt_control_0xplayer (cell_x6_y__BLANK_); cell_2b (cell_x6_y__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_x6_y__BLANK_);
+ control_0oplayer (control__BLANK_); control_0xplayer (control__BLANK_);
+ control__BLANK_ (control__BLANK_)
+ |
+ ] ->
+ [cell_x6_y__BLANK_, control__BLANK_ |
cell_2x (cell_x6_y__BLANK_); control_0oplayer (control__BLANK_);
control_0xplayer (control__BLANK_)
|
] emb cell_2b, cell_2o, cell_2x, control_0oplayer, control_0xplayer
- pre
- (not (cell_0x6(cell_x6_y__BLANK_) and cell_1y(cell_x6_y__BLANK_)) and
- ex control__BLANK_
- (control_0oplayer(control__BLANK_) and
- control_0xplayer(control__BLANK_) and control__BLANK_(control__BLANK_)))
RULE noop_mark_x7_y0:
[cell_x7_y0__BLANK_, control__BLANK_ |
_opt_cell_2b (control__BLANK_);
_opt_cell_2o {cell_x7_y0__BLANK_; control__BLANK_};
_opt_cell_2x {cell_x7_y0__BLANK_; control__BLANK_};
- _opt_control_0oplayer {cell_x7_y0__BLANK_; control__BLANK_};
- _opt_control_0xplayer {cell_x7_y0__BLANK_; control__BLANK_};
- cell_2b (cell_x7_y0__BLANK_);
- cell__BLANK___BLANK___BLANK_ (cell_x7_y0__BLANK_)
+ _opt_control_0oplayer (cell_x7_y0__BLANK_);
+ _opt_control_0xplayer (cell_x7_y0__BLANK_); cell_2b (cell_x7_y0__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_x7_y0__BLANK_);
+ control_0oplayer (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
[cell_x7_y0__BLANK_, control__BLANK_ |
+ cell_2o (cell_x7_y0__BLANK_); control_0xplayer (control__BLANK_) |
+ ]
+ emb cell_2b, cell_2o, cell_2x, control_0oplayer, control_0xplayer
+RULE noop_mark_x7_y00:
+ [cell_x7_y0__BLANK_, control__BLANK_ |
+ _opt_cell_2b (control__BLANK_);
+ _opt_cell_2o {cell_x7_y0__BLANK_; control__BLANK_};
+ _opt_cell_2x {cell_x7_y0__BLANK_; control__BLANK_};
+ _opt_control_0oplayer (cell_x7_y0__BLANK_);
+ _opt_control_0xplayer (cell_x7_y0__BLANK_); cell_2b (cell_x7_y0__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_x7_y0__BLANK_);
+ control_0oplayer (control__BLANK_); control_0xplayer (control__BLANK_);
+ control__BLANK_ (control__BLANK_)
+ |
+ ] ->
+ [cell_x7_y0__BLANK_, control__BLANK_ |
cell_2o (cell_x7_y0__BLANK_); control_0oplayer (control__BLANK_);
control_0xplayer (control__BLANK_)
|
] emb cell_2b, cell_2o, cell_2x, control_0oplayer, control_0xplayer
- pre
- (not (cell_0x7(cell_x7_y0__BLANK_) and cell_1y0(cell_x7_y0__BLANK_)) and
- ex control__BLANK_
- (control_0oplayer(control__BLANK_) and
- control_0xplayer(control__BLANK_) and control__BLANK_(control__BLANK_)))
LOC 0 {
PLAYER xplayer {
@@ -236,7 +258,7 @@
100. * :((true and line__x() and true)) +
50. *
:((true and not line__x() and not line__o() and not open() and true))
- MOVES [mark_x6_y_noop -> 1] }
+ MOVES [mark_x6_y_noop -> 1]; [mark_x6_y_noop0 -> 1] }
PLAYER oplayer {
PAYOFF
100. * :((true and line__o() and true)) +
@@ -257,7 +279,7 @@
100. * :((true and line__o() and true)) +
50. *
:((true and not line__x() and not line__o() and not open() and true))
- MOVES [noop_mark_x7_y0 -> 0] }
+ MOVES [noop_mark_x7_y0 -> 0]; [noop_mark_x7_y00 -> 0] }
}
MODEL
[cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_, cell_2_1__BLANK_,
Modified: trunk/Toss/GGP/tests/tictactoe-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-simpl.toss 2011-08-13 01:47:40 UTC (rev 1538)
+++ trunk/Toss/GGP/tests/tictactoe-simpl.toss 2011-08-13 21:19:21 UTC (rev 1539)
@@ -1,427 +1,228 @@
+REL column__b(v0) =
+ ex cell_1_n4__BLANK_, cell_2_n4__BLANK_, cell_3_n4__BLANK_
+ (EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_2_n4__BLANK_) and
+ cell_03(cell_3_n4__BLANK_) and cell_02(cell_2_n4__BLANK_) and
+ cell_01(cell_1_n4__BLANK_) and cell_2b(cell_1_n4__BLANK_) and
+ cell_2b(cell_2_n4__BLANK_) and cell_2b(cell_3_n4__BLANK_) and
+ v0 = cell_1_n4__BLANK_ and not control__BLANK_(cell_1_n4__BLANK_) and
+ not control__BLANK_(cell_2_n4__BLANK_) and
+ not control__BLANK_(cell_3_n4__BLANK_))
+REL column__o(v0) =
+ ex cell_1_n4__BLANK_, cell_2_n4__BLANK_, cell_3_n4__BLANK_
+ (EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_2_n4__BLANK_) and
+ cell_03(cell_3_n4__BLANK_) and cell_02(cell_2_n4__BLANK_) and
+ cell_01(cell_1_n4__BLANK_) and cell_2o(cell_1_n4__BLANK_) and
+ cell_2o(cell_2_n4__BLANK_) and cell_2o(cell_3_n4__BLANK_) and
+ v0 = cell_1_n4__BLANK_ and not control__BLANK_(cell_1_n4__BLANK_) and
+ not control__BLANK_(cell_2_n4__BLANK_) and
+ not control__BLANK_(cell_3_n4__BLANK_))
+REL column__x(v0) =
+ ex cell_1_n4__BLANK_, cell_2_n4__BLANK_, cell_3_n4__BLANK_
+ (EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_3_n4__BLANK_) and
+ EQ___cell_1__cell_1(cell_1_n4__BLANK_, cell_2_n4__BLANK_) and
+ cell_03(cell_3_n4__BLANK_) and cell_02(cell_2_n4__BLANK_) and
+ cell_01(cell_1_n4__BLANK_) and cell_2x(cell_1_n4__BLANK_) and
+ cell_2x(cell_2_n4__BLANK_) and cell_2x(cell_3_n4__BLANK_) and
+ v0 = cell_1_n4__BLANK_ and not control__BLANK_(cell_1_n4__BLANK_) and
+ not control__BLANK_(cell_2_n4__BLANK_) and
+ not control__BLANK_(cell_3_n4__BLANK_))
+REL diagonal__b() =
+ ex cell_1_1__BLANK_, cell_2_2__BLANK_, cell_3_3__BLANK_
+ (R(cell_1_1__BLANK_) and R0(cell_2_2__BLANK_) and R1(cell_3_3__BLANK_) and
+ cell_2b(cell_1_1__BLANK_) and cell_2b(cell_2_2__BLANK_) and
+ cell_2b(cell_3_3__BLANK_) and not control__BLANK_(cell_1_1__BLANK_) and
+ not control__BLANK_(cell_2_2__BLANK_) and
+ not control__BLANK_(cell_3_3__BLANK_)) or
+ ex cell_1_3__BLANK_, cell_2_2__BLANK_, cell_3_1__BLANK_
+ (R2(cell_1_3__BLANK_) and R0(cell_2_2__BLANK_) and
+ R3(cell_3_1__BLANK_) and cell_2b(cell_1_3__BLANK_) and
+ cell_2b(cell_2_2__BLANK_) and cell_2b(cell_3_1__BLANK_) and
+ not control__BLANK_(cell_1_3__BLANK_) and
+ not control__BLANK_(cell_2_2__BLANK_) and
+ not control__BLANK_(cell_3_1__BLANK_))
+REL diagonal__o() =
+ ex cell_1_1__BLANK_, cell_2_2__BLANK_, cell_3_3__BLANK_
+ (R(cell_1_1__BLANK_) and R0(cell_2_2__BLANK_) and R1(cell_3_3__BLANK_) and
+ cell_2o(cell_1_1__BLANK_) and cell_2o(cell_2_2__BLANK_) and
+ cell_2o(cell_3_3__BLANK_) and not control__BLANK_(cell_1_1__BLANK_) and
+ not control__BLANK_(cell_2_2__BLANK_) and
+ not control__BLANK_(cell_3_3__BLANK_)) or
+ ex cell_1_3__BLANK_, cell_2_2__BLANK_, cell_3_1__BLANK_
+ (R2(cell_1_3__BLANK_) and R0(cell_2_2__BLANK_) and
+ R3(cell_3_1__BLANK_) and cell_2o(cell_1_3__BLANK_) and
+ cell_2o(cell_2_2__BLANK_) and cell_2o(cell_3_1__BLANK_) and
+ not control__BLANK_(cell_1_3__BLANK_) and
+ not control__BLANK_(cell_2_2__BLANK_) and
+ not control__BLANK_(cell_3_1__BLANK_))
+REL diagonal__x() =
+ ex cell_1_1__BLANK_, cell_2_2__BLANK_, cell_3_3__BLANK_
+ (R(cell_1_1__BLANK_) and R0(cell_2_2__BLANK_) and R1(cell_3_3__BLANK_) and
+ cell_2x(cell_1_1__BLANK_) and cell_2x(cell_2_2__BLANK_) and
+ cell_2x(cell_3_3__BLANK_) and not control__BLANK_(cell_1_1__BLANK_) and
+ not control__BLANK_(cell_2_2__BLANK_) and
+ not control__BLANK_(cell_3_3__BLANK_)) or
+ ex cell_1_3__BLANK_, cell_2_2__BLANK_, cell_3_1__BLANK_
+ (R2(cell_1_3__BLANK_) and R0(cell_2_2__BLANK_) and
+ R3(cell_3_1__BLANK_) and cell_2x(cell_1_3__BLANK_) and
+ cell_2x(cell_2_2__BLANK_) and cell_2x(cell_3_1__BLANK_) and
+ not control__BLANK_(cell_1_3__BLANK_) and
+ not control__BLANK_(cell_2_2__BLANK_) and
+ not control__BLANK_(cell_3_1__BLANK_))
+REL line__b() =
+ diagonal__b() or
+ ex cell__BLANK__m6__BLANK_ column__b(cell__BLANK__m6__BLANK_) or
+ ex cell_m5__BLANK___BLANK_ row__b(cell_m5__BLANK___BLANK_)
+REL line__o() =
+ diagonal__o() or
+ ex cell__BLANK__m6__BLANK_ column__o(cell__BLANK__m6__BLANK_) or
+ ex cell_m5__BLANK___BLANK_ row__o(cell_m5__BLANK___BLANK_)
+REL line__x() =
+ diagonal__x() or
+ ex cell__BLANK__m6__BLANK_ column__x(cell__BLANK__m6__BLANK_) or
+ ex cell_m5__BLANK___BLANK_ row__x(cell_m5__BLANK___BLANK_)
+REL open() =
+ ex cell_m7_n5__BLANK_
+ (cell_2b(cell_m7_n5__BLANK_) and not control__BLANK_(cell_m7_n5__BLANK_))
+REL row__b(v0) =
+ ex cell_m4_1__BLANK_, cell_m4_2__BLANK_, cell_m4_3__BLANK_
+ (EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_3__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_2__BLANK_) and
+ cell_13(cell_m4_3__BLANK_) and cell_12(cell_m4_2__BLANK_) and
+ cell_11(cell_m4_1__BLANK_) and cell_2b(cell_m4_1__BLANK_) and
+ cell_2b(cell_m4_2__BLANK_) and cell_2b(cell_m4_3__BLANK_) and
+ v0 = cell_m4_1__BLANK_ and not control__BLANK_(cell_m4_1__BLANK_) and
+ not control__BLANK_(cell_m4_2__BLANK_) and
+ not control__BLANK_(cell_m4_3__BLANK_))
+REL row__o(v0) =
+ ex cell_m4_1__BLANK_, cell_m4_2__BLANK_, cell_m4_3__BLANK_
+ (EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_3__BLANK_) and
+ EQ___cell_0__cell_0(cell_m4_1__BLANK_, cell_m4_2__BLANK_) and
+ cell_13(cell_m4_3__BLANK_) and cell_12(cell_m4_2__BLANK_) and
+ cell_11(cell_m4_1__BLANK_) and cell_2o(cell_m4_1__BLANK_) and
+...
[truncated message content] |
|
From: <luk...@us...> - 2011-08-16 11:29:36
|
Revision: 1540
http://toss.svn.sourceforge.net/toss/?rev=1540&view=rev
Author: lukstafi
Date: 2011-08-16 11:29:29 +0000 (Tue, 16 Aug 2011)
Log Message:
-----------
GDL translation: Continuation Passing Style Prolog interpreter (saturation based code left for comparisons).
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-08-13 21:19:21 UTC (rev 1539)
+++ trunk/Toss/Formula/Aux.ml 2011-08-16 11:29:29 UTC (rev 1540)
@@ -128,8 +128,39 @@
let list_diff a b = List.filter (fun e -> not (List.mem e b)) a
+let sorted_diff xs ys =
+ let rec aux acc = function
+ | [], _ -> acc
+ | xs, [] -> List.rev_append xs acc
+ | (x::xs' as xs), (y::ys' as ys) ->
+ let c = Pervasives.compare x y in
+ if c = 0 then aux acc (xs', ys')
+ else if c < 0 then aux (x::acc) (xs', ys)
+ else aux acc (xs, ys') in
+ List.rev (aux [] (xs, ys))
+
let list_inter a b = List.filter (fun e -> List.mem e b) a
+let sorted_inter xs ys =
+ let rec aux acc = function
+ | [], _ | _, [] -> acc
+ | (x::xs' as xs), (y::ys' as ys) ->
+ let c = Pervasives.compare x y in
+ if c = 0 then aux (x::acc) (xs', ys')
+ else if c < 0 then aux acc (xs', ys)
+ else aux acc (xs, ys') in
+ List.rev (aux [] (xs, ys))
+
+let sorted_merge xs ys =
+ let rec aux acc = function
+ | [], xs | xs, [] -> List.rev_append xs acc
+ | (x::xs' as xs), (y::ys' as ys) ->
+ let c = Pervasives.compare x y in
+ if c = 0 then aux (x::acc) (xs', ys')
+ else if c < 0 then aux (x::acc) (xs', ys)
+ else aux (y::acc) (xs, ys') in
+ List.rev (aux [] (xs, ys))
+
let rec rev_assoc l x = match l with
[] -> raise Not_found
| (a,b)::l -> if b = x then a else rev_assoc l x
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-08-13 21:19:21 UTC (rev 1539)
+++ trunk/Toss/Formula/Aux.mli 2011-08-16 11:29:29 UTC (rev 1540)
@@ -79,12 +79,24 @@
inequality. *)
val list_remove : 'a -> 'a list -> 'a list
-(** Difference: [List.filter (fun e -> not (List.mem e b)) a]. *)
+(** Set difference: [List.filter (fun e -> not (List.mem e b)) a]. *)
val list_diff : 'a list -> 'a list -> 'a list
+(** Set difference of lists of unique increasing elements (as returned
+ by {!Aux.unique_sorted}). *)
+val sorted_diff : 'a list -> 'a list -> 'a list
+
(** Intersection: [list_inter a b = List.filter (fun e -> List.mem e b) a]. *)
val list_inter : 'a list -> 'a list -> 'a list
+(** Set intersection of lists of unique increasing elements (as returned
+ by {!Aux.unique_sorted}). *)
+val sorted_inter : 'a list -> 'a list -> 'a list
+
+(** Set union of lists of unique increasing elements (as returned
+ by {!Aux.unique_sorted}). *)
+val sorted_merge : 'a list -> 'a list -> 'a list
+
(** Return first key with the given value from the key-value pairs,
using structural equality. *)
val rev_assoc : ('a * 'b) list -> 'b -> 'a
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-13 21:19:21 UTC (rev 1539)
+++ trunk/Toss/GGP/GDL.ml 2011-08-16 11:29:29 UTC (rev 1540)
@@ -5,12 +5,11 @@
(* ************************************************************ *)
(* ************************************************************ *)
-(** {3 Datalog programs: Type definitions and saturation.} *)
+(** {3 Datalog programs: Type definitions, saturation, Prolog interpreter.} *)
open Aux.BasicOperators
let debug_level = ref 0
-let aggregate_drop_negative = ref true
let playout_fixpoint = ref true
type term =
@@ -147,6 +146,10 @@
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map gdl_rule_vars (rules_of_clause cl))
+let clauses_vars cls =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map clause_vars cls)
+
let defs_of_rules rules =
Aux.map_reduce (fun ((rel, args), body, neg_body) ->
rel, (args, body, neg_body)) (fun y x->x::y) [] rules
@@ -232,8 +235,8 @@
(List.map (subst_one sb1) terms2)
| _ -> raise Not_found
-let unify_args args1 args2 =
- unify [] (Array.to_list args1) (Array.to_list args2)
+let unify_args ?(sb=[]) args1 args2 =
+ unify sb (Array.to_list args1) (Array.to_list args2)
let rec subst sb = function
| Var y as t ->
@@ -262,8 +265,8 @@
try ignore (unify [] [term1] [term2]); true
with Not_found -> false
-let unify_rels (rel1, args1) (rel2, args2) =
- if rel1 = rel2 then unify_args args1 args2
+let unify_rels ?sb (rel1, args1) (rel2, args2) =
+ if rel1 = rel2 then unify_args ?sb args1 args2
else raise Not_found
let rels_unify atom1 atom2 =
@@ -456,8 +459,190 @@
instantiate base
(List.map rules_of_defs (stratify [] (defs_of_rules rules)))
+
+
(* ************************************************************ *)
(* ************************************************************ *)
+(** {3 Continuation-based Prolog interpreter} *)
+
+(** The interpreter can reinterpret "does" atoms as "legal" atoms for
+ aggregate playout. For random playout, remember to compute legal
+ moves, select randomly one for each player and add "does" atoms to
+ the program. *)
+let run_prolog_aggregate = ref false
+
+(* In the future, [prolog_program] could implement deeper hashing to
+ be used by [assoc_clauses]. *)
+type prolog_program = clause list Aux.StrMap.t
+
+(** Push negative literals to the right. *)
+let preprocess_cl_body body =
+ let posi, nega = List.partition
+ (function Neg _ | Pos (Distinct _) -> false | _ -> true)
+ body in
+ posi @ nega
+
+let preprocess_program clauses =
+ let clauses = List.map
+ (fun ((rel,args as head), body) ->
+ rel, (head, preprocess_cl_body body)) clauses in
+ let clauses = Aux.collect clauses in
+ Aux.strmap_of_assoc clauses
+
+let replace_rel_in_program rel clauses p =
+ Aux.StrMap.add rel clauses p
+
+let used_vars = ref Aux.Strings.empty
+
+let assoc_clauses (rel,_ as a) p =
+ let cls =
+ try Aux.StrMap.find rel p
+ with Not_found ->
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "assoc_clauses: %s not found among:" rel;
+ Aux.StrMap.iter (fun r _ -> print_string (" "^r)) p;
+ Printf.printf "\n%!";
+ );
+ (* }}} *)
+ [] in
+ let freshen_cl cl =
+ let cl_vars = clause_vars cl in
+ let sb = List.map
+ (fun v ->
+ let nv = Aux.not_conflicting_name ~truncate:true !used_vars v in
+ used_vars := Aux.Strings.add nv !used_vars;
+ v, nv)
+ (Aux.Strings.elements cl_vars) in
+ let sb = List.map (fun (v,t) -> v, Var t) sb in
+ subst_clause sb cl in
+ let cls = List.map freshen_cl cls in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf
+ "assoc_clauses: trying %s with:\n%s\n%!"
+ (rel_atom_str a)
+ (String.concat "\n"(List.map clause_str cls))
+ );
+ (* }}} *)
+ cls
+
+let rec run_clauses a p sc fc sb =
+ match a with
+ | Distinct ts ->
+ (try
+ let ts_l = Array.to_list (Array.map (subst sb) ts) in
+ ignore (unify_all sb ts_l);
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "run_clauses: not distinct %s\n%!"
+ (String.concat ", " (List.map term_str ts_l))
+ );
+ (* }}} *)
+ fc ()
+ with Not_found -> sc fc sb)
+ | Does (pl, lt) when !run_prolog_aggregate ->
+ let a = subst_rel sb ("legal", [|pl; lt|]) in
+ run_clseq (assoc_clauses a p) a p sc fc sb
+ | a ->
+ let a = subst_rel sb (rel_of_atom a) in
+ run_clseq (assoc_clauses a p) a p sc fc sb
+
+and run_clseq l a p sc fc sb =
+ match l with
+ | [] -> fc ()
+ | [cl] -> run_clause cl a p sc fc sb
+ | cl::l ->
+ run_clause cl a p sc (fun () -> run_clseq l a p sc fc sb) sb
+
+and run_clause (h, g) a p sc fc sb =
+ (* We could use the [let try] construct, but this is more transparent. *)
+ let sb = (* [assoc_clauses] freshened vars *)
+ try Some (unify_rels ~sb (subst_rel sb h) a)
+ with Not_found -> None in
+ match sb with
+ | Some sb ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "run_clause: succeeded with %s\n%!"
+ (clause_str (subst_clause sb (h, g)))
+ );
+ (* }}} *)
+ run_goal g p sc fc sb
+ | None -> fc ()
+
+and run_goal g p sc fc sb =
+ match g with [] -> sc fc sb
+ | lit::g -> run_gseq lit g p sc fc sb
+
+and run_gseq lit g p sc fc sb =
+ match g with [] -> run_lit lit p sc fc sb
+ | lit'::g -> run_lit lit p (run_gseq lit' g p sc) fc sb
+
+and run_lit lit p sc fc sb =
+ match lit with
+ | Pos a -> run_clauses a p sc fc sb
+ | Neg a ->
+ run_clauses a p (fun _ _ -> fc ()) (fun () -> sc fc sb) sb
+ | Disj [] -> fc ()
+ | Disj [lit] -> run_lit lit p sc fc sb
+ | Disj (lit::lits) ->
+ run_lit lit p sc (fun () -> run_lit (Disj lits) p sc fc sb) sb
+
+let run_prolog_atom (rel, args as q : rel_atom) (p : prolog_program) =
+ used_vars := Aux.StrMap.fold (fun _ cls acc ->
+ Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;
+ used_vars := Aux.Strings.union !used_vars (terms_vars args);
+ let sc_init fc sb = fun m ->
+ let ans = subst_rel sb q in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "run_prolog_atom: returning %s\n%!"
+ (rel_atom_str ans)
+ );
+ (* }}} *)
+ fc () (ans::m) in
+ let fc_init () = fun m -> m in
+ let extract res = res [] in
+ let res =
+ Aux.unique_sorted (
+ extract (run_clauses (Rel (rel, args)) p sc_init fc_init [])) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "run_prolog_atom: returned %d distinct results.\n%!"
+ (List.length res)
+ );
+ (* }}} *)
+ res
+
+let run_prolog_goal (g : literal list) (p : prolog_program) =
+ used_vars := Aux.StrMap.fold (fun _ cls acc ->
+ Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;
+ used_vars := Aux.Strings.union !used_vars (clause_vars (("",[||]),g));
+ let sc_init fc sb = fun m -> fc () (sb::m) in
+ let fc_init () = fun m -> m in
+ let extract res = res [] in
+ extract (run_goal g p sc_init fc_init [])
+
+let run_prolog_check_atom (rel, args) (p : prolog_program) =
+ used_vars := Aux.StrMap.fold (fun _ cls acc ->
+ Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;
+ used_vars := Aux.Strings.union !used_vars (terms_vars args);
+ let sc_init fc _ = true in
+ let fc_init () = false in
+ run_clauses (Rel (rel, args)) p sc_init fc_init []
+
+let run_prolog_check_goal (g : literal list) (p : prolog_program) =
+ used_vars := Aux.StrMap.fold (fun _ cls acc ->
+ Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;
+ used_vars := Aux.Strings.union !used_vars (clause_vars (("",[||]),g));
+ let sc_init fc _ = true in
+ let fc_init () = false in
+ run_goal g p sc_init fc_init []
+
+
+(* ************************************************************ *)
+(* ************************************************************ *)
(** {3 Transformations of GDL clauses: inlining, negation.} *)
(** Expand branches of a definition inlining the provided definitions,
@@ -646,8 +831,10 @@
(Aux.unique_sorted !all_rels) in
all_rels, clauses in
fix clauses
-
+let state_cls terms =
+ List.map (fun t -> ("true", [|t|]), []) terms
+
(* ************************************************************ *)
(* ************************************************************ *)
(** {3 GDL whole-game operations.}
@@ -660,7 +847,7 @@
(* [~aggregate:true] performs an aggregate ply, [~aggregate:false]
performs a random ply. *)
-let ply ~aggregate players static current rules =
+let ply_satur ~aggregate players static current rules =
let base =
Aux.map_prepend static (fun term -> "true", [|term|]) current in
let base = saturate (base @ static) rules in
@@ -732,15 +919,15 @@
into static and dynamic. Note that the list of playout states is
one longer than that of playout actions.
- When [aggregate_drop_negative] is true, to keep monotonicity,
- besides removing negative literals from "legal" clauses, we also
- add old terms to the state. (Only when [~aggregate:true].)
+ To keep monotonicity, besides removing negative literals from
+ "legal" clauses, we also add old terms to the state. (Only when
+ [~aggregate:true].)
[~aggregate:true] performs an aggregate ply, [~aggregate:false]
performs a random ply. Aggregate playouts are "deprecated",
especially for uses other than generating all possible state
terms. *)
-let playout ~aggregate players horizon rules =
+let playout_satur ~aggregate players horizon rules =
(* separate and precompute the static part *)
let rec separate static_rels state_rels =
let static, more_state =
@@ -761,8 +948,7 @@
List.map (function
| ("legal", [|player; _|] as head), body, neg_body ->
head, ("role", [|player|])::body,
- if aggregate && !aggregate_drop_negative
- then [] else neg_body
+ if aggregate then [] else neg_body
| ("does", _ (* as head *)), body, _ -> assert false
(* head, body, [] *)
| rule -> rule) dynamic_rules in
@@ -773,7 +959,7 @@
);
(* }}} *)
(let try actions, next =
- ply ~aggregate players static_base state state_rules in
+ ply_satur ~aggregate players static_base state state_rules in
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "playout: state %s\n%!"
@@ -781,8 +967,7 @@
);
(* }}} *)
let next =
- if aggregate && !aggregate_drop_negative then state @ next
- else next in
+ if aggregate then state @ next else next in
if step < horizon then
loop (actions::actions_accu) (state::state_accu) (step+1) next
else
@@ -806,6 +991,136 @@
+(* [~aggregate:true] performs an aggregate ply, [~aggregate:false]
+ performs a random ply. *)
+let ply_prolog ~aggregate players current program =
+ let program =
+ replace_rel_in_program "true"
+ (List.map (fun term -> ("true", [|term|]), []) current) program in
+ let legal_terms = List.map snd
+ (run_prolog_atom ("legal", [|Var "x"; Var "y"|]) program) in
+ let program =
+ if aggregate then (run_prolog_aggregate := true; program)
+ else (
+ run_prolog_aggregate := false;
+ let legal_by_player = Aux.collect
+ (List.map
+ (function [|pl; lterm|] -> pl, lterm | _ -> assert false)
+ legal_terms) in
+ let does_cls = List.map
+ (fun (player, lterms) ->
+ ("does", [|player; Aux.random_elem lterms|]), [])
+ legal_by_player in
+ replace_rel_in_program "does" does_cls program) in
+ if (* no move *)
+ Aux.array_existsi (fun _ player ->
+ not (run_prolog_check_goal
+ [Pos (Rel ("legal", [|player; Var "y"|]))] program))
+ players
+ then (
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ let players_nomove =
+ Aux.array_find_all (fun player ->
+ List.for_all (function [|actor; _|] -> player <> actor
+ | _ -> true)
+ legal_terms) players in
+ Printf.printf
+ "GDL.ply_prolog: playout over due to no move for %s\n%!"
+ (String.concat ", " (List.map term_str players_nomove))
+ );
+ (* }}} *)
+ raise Playout_over)
+ else
+ let step = run_prolog_atom ("next", [|Var "x"|]) program in
+ let step_state = Aux.map_some
+ (function ("next", [|arg|]) -> Some arg
+ | _ -> None) step in
+ if !playout_fixpoint && (* fixpoint reached *)
+ Aux.sorted_diff step_state current = [] &&
+ (aggregate || Aux.sorted_diff current step_state = [])
+ then (
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "GDL.ply: playout over due to fixpoint\n%!";
+ );
+ (* }}} *)
+ raise Playout_over)
+ else if not aggregate && (* terminal position reached *)
+ run_prolog_check_goal
+ [Pos (Rel ("terminal", [||]))] program
+ then (
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.ply: playout over due to terminal position\n%!";
+ );
+ (* }}} *)
+ raise Playout_over)
+ else
+ legal_terms, step_state
+
+let remove_neg_lits cls =
+ let rec neg_lit = function
+ | Neg _ | Pos (Distinct _) -> true
+ | Disj disj when List.exists neg_lit disj -> true
+ | _ -> false in
+ List.map (fun (h, b) -> h, List.filter (Aux.neg neg_lit) b) cls
+
+(* Note that the list of playout states is
+ one longer than that of playout actions.
+
+ To keep monotonicity, besides removing negative literals from
+ "legal" clauses, we also add old terms to the state. (Only when
+ [~aggregate:true].)
+
+ [~aggregate:true] performs an aggregate ply, [~aggregate:false]
+ performs a random ply. Aggregate playouts are "deprecated",
+ especially for uses other than generating all possible state
+ terms. *)
+let playout_prolog ~aggregate players horizon program =
+ let program =
+ if aggregate then
+ let next_cls = assoc_clauses ("next",[|Var "x"|]) program in
+ let legal_cls = assoc_clauses ("legal",[|Var "x"|]) program in
+ replace_rel_in_program "next" (remove_neg_lits next_cls)
+ (replace_rel_in_program "legal" (remove_neg_lits legal_cls) program)
+ else program in
+
+ let rec loop actions_accu state_accu step state =
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "playout_prolog: step %d...\n%!" step
+ );
+ (* }}} *)
+ (let try actions, next =
+ ply_prolog ~aggregate players state program in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "playout: state %s\n%!"
+ (String.concat " " (List.map term_str next))
+ );
+ (* }}} *)
+ let next =
+ if aggregate then Aux.sorted_merge state next else next in
+ if step < horizon then
+ loop (actions::actions_accu) (state::state_accu) (step+1) next
+ else
+ List.rev (actions::actions_accu),
+ List.rev (next::state::state_accu)
+ with Playout_over ->
+ List.rev actions_accu, List.rev (state::state_accu)) in
+ let init_state = List.map (fun (_,args) -> args.(0))
+ (run_prolog_atom ("init", [|Var "x"|]) program) in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "playout: init %s\n%!"
+ (String.concat " " (List.map term_str init_state))
+ );
+ (* }}} *)
+ loop [] [] 0 init_state
+
+
+
let find_cycle cands =
(* {{{ log entry *)
if !debug_level > 0 then (
@@ -864,12 +1179,14 @@
(** Partition relations into static (not depending, even indirectly,
on "true") and remaining ones. *)
let static_rels defs =
+ let base_dyn =
+ ["init"; "does"; "true"; "next"; "terminal"; "goal"] in
let rec aux nonstatic remaining =
let more = Aux.map_some (fun (rel, branches) ->
if List.exists
(fun (_, body, neg_body) ->
let called = List.map fst (body @ neg_body) in
- List.exists (fun rel -> rel = "true" ||
+ List.exists (fun rel -> List.mem rel base_dyn ||
List.mem rel nonstatic) called
) branches
then Some rel else None
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-13 21:19:21 UTC (rev 1539)
+++ trunk/Toss/GGP/GDL.mli 2011-08-16 11:29:29 UTC (rev 1540)
@@ -2,7 +2,6 @@
Type definitions, helper functions. *)
val debug_level : int ref
-val aggregate_drop_negative : bool ref
val playout_fixpoint : bool ref
(** {3 Datalog programs: Type definitions and saturation.} *)
@@ -53,6 +52,7 @@
val term_vars : term -> Aux.Strings.t
val terms_vars : term array -> Aux.Strings.t
val clause_vars : clause -> Aux.Strings.t
+val clauses_vars : clause list -> Aux.Strings.t
val defs_of_rules : gdl_rule list -> gdl_defs
val rules_of_clause : clause -> gdl_rule list
@@ -77,6 +77,33 @@
val saturate :
rel_atom list -> gdl_rule list -> rel_atom list
+(** {3 Continuation-based Prolog interpreter} *)
+
+(** The interpreter can reinterpret "does" atoms as "legal" atoms for
+ aggregate playout. For random playout, remember to compute legal
+ moves, select randomly one for each player and add "does" atoms to
+ the program. *)
+val run_prolog_aggregate : bool ref
+
+type prolog_program
+val preprocess_program : clause list -> prolog_program
+val replace_rel_in_program :
+ string -> clause list -> prolog_program -> prolog_program
+
+(** Compute all implied instantiations of the given atom, return
+ sorted unique instances. *)
+val run_prolog_atom : rel_atom -> prolog_program -> rel_atom list
+(** Compute all variable substitutions that satisfy the given
+ conjunction of literals. The substitutions are not unique (there
+ is as many of them as there are different proofs of the goal). *)
+val run_prolog_goal : literal list -> prolog_program -> substitution list
+(** Just check if the atom / conjunction of literals is
+ satisfiable. Should be faster than checking non-emptiness of
+ [run_prolog_goal] result. *)
+val run_prolog_check_atom : rel_atom -> prolog_program -> bool
+val run_prolog_check_goal : literal list -> prolog_program -> bool
+
+
(** {3 Transformations of GDL clauses: inlining, negation.} *)
(** Expand branches of a definition inlining the provided definitions,
@@ -103,6 +130,8 @@
val elim_ground_args :
string list -> clause list -> string list * clause list
+val state_cls : term list -> clause list
+
(** {3 GDL translation helpers.} *)
val blank : term
@@ -128,9 +157,9 @@
val static_rels : gdl_defs -> string list * string list
-(** Besides the aggregate playout, also return the separation of rules
- into static and dynamic. Note that the list of playout states is
- one longer than that of playout actions.
+(** Besides the aggregate or random playout, also return the
+ separation of rules into static and dynamic. Note that the list of
+ playout states is one longer than that of playout actions.
When [aggregate_drop_negative] is true, to keep monotonicity,
besides removing negative literals from "legal" clauses, we also
@@ -140,12 +169,16 @@
performs a random ply. Aggregate playouts are "deprecated",
especially for uses other than generating all possible state
terms. *)
-val playout :
+val playout_satur :
aggregate:bool -> term array -> int -> gdl_rule list ->
gdl_rule list * gdl_rule list *
rel_atom list * term list *
(term array list list * term list list)
+val playout_prolog :
+ aggregate:bool -> term array -> int -> prolog_program ->
+ term array list list * term list list
+
val find_cycle : term option list -> term option list
val expand_players : clause list -> clause list
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-08-13 21:19:21 UTC (rev 1539)
+++ trunk/Toss/GGP/GDLTest.ml 2011-08-16 11:29:29 UTC (rev 1540)
@@ -103,11 +103,78 @@
(String.concat " "
(List.map GDL.rel_atom_str res));
);
+
+ "run_prolog" >::
+ (fun () ->
+ let descr = parse_game_descr
+ "
+(<= (alpha ?X) (beta ?X) (not (theta ?X)))
+(<= (zeta ?X) (beta ?X) (not (gamma ?X)))
+(<= (beta ?X) (gamma ?X))
+(gamma paper)
+(beta rock)
+(theta scisors) (gamma scisors)" in
+ (* GDL.debug_level := 3; *)
+ let program = GDL.preprocess_program descr in
+ let res = GDL.run_prolog_atom ("alpha", [|Var "X"|]) program in
+ assert_equal ~printer:(fun x->x) ~msg:"run_prolog alpha"
+ "(alpha paper) (alpha rock)"
+ (String.concat " "
+ (List.map GDL.rel_atom_str res));
+ let res = GDL.run_prolog_atom ("zeta", [|Var "X"|]) program in
+ assert_equal ~printer:(fun x->x) ~msg:"run_prolog alpha"
+ "(zeta rock)"
+ (String.concat " "
+ (List.map GDL.rel_atom_str res));
- "playout simple" >::
+ let descr = parse_game_descr
+ "
+(<= (two-of-three ?X ?Y) (a ?X) (a ?Y) (distinct ?X ?Y))
+(a 1) (a 2) (a 3)" in
+ (* GDL.debug_level := 3; *)
+ let program = GDL.preprocess_program descr in
+ let res =
+ GDL.run_prolog_atom ("two-of-three", [|Var "X"; Var "Y"|])
+ program in
+ assert_equal ~printer:(fun x->x) ~msg:"simple distinct"
+ "(two-of-three 1 2) (two-of-three 1 3) (two-of-three 2 1) (two-of-three 2 3) (two-of-three 3 1) (two-of-three 3 2)"
+ (String.concat " "
+ (List.map GDL.rel_atom_str res));
+ );
+
+ "run_prolog recursive" >::
(fun () ->
let descr = parse_game_descr
"
+(<= (lte 0 ?x)
+ (number ?x))
+(<= (lte ?x ?x)
+ (number ?x))
+(<= (lte ?x ?z)
+ (succ ?y ?z)
+ (lte ?x ?y))
+(<= (lte ?x ?y)
+ (succ ?x ?y))
+(number 0) (number 1) (number 2) (number 3)
+(number 4) (number 5) (number 6) (number 7) (number 8)
+(succ 0 1) (succ 1 2) (succ 2 3) (succ 3 4)
+(succ 4 5) (succ 5 6) (succ 6 7) (succ 7 8)
+" in
+ (* GDL.debug_level := 3; *)
+ let program = GDL.preprocess_program descr in
+ let res =
+ GDL.run_prolog_atom ("lte", [|Var "x"; Var "y"|])
+ program in
+ assert_equal ~printer:(fun x->x) ~msg:"simple stratified"
+ "(lte 0 0) (lte 0 1) (lte 0 2) (lte 0 3) (lte 0 4) (lte 0 5) (lte 0 6) (lte 0 7) (lte 0 8) (lte 1 1) (lte 1 2) (lte 1 3) (lte 1 4) (lte 1 5) (lte 1 6) (lte 1 7) (lte 1 8) (lte 2 2) (lte 2 3) (lte 2 4) (lte 2 5) (lte 2 6) (lte 2 7) (lte 2 8) (lte 3 3) (lte 3 4) (lte 3 5) (lte 3 6) (lte 3 7) (lte 3 8) (lte 4 4) (lte 4 5) (lte 4 6) (lte 4 7) (lte 4 8) (lte 5 5) (lte 5 6) (lte 5 7) (lte 5 8) (lte 6 6) (lte 6 7) (lte 6 8) (lte 7 7) (lte 7 8) (lte 8 8)"
+ (String.concat " "
+ (List.map GDL.rel_atom_str res));
+ );
+
+ "playout_satur simple" >::
+ (fun () ->
+ let descr = parse_game_descr
+ "
(role x)
(role o)
(init (cell a a b))
@@ -132,7 +199,7 @@
" in
let _, _, _, _, (agg_actions, _) =
- GDL.playout ~aggregate:true [|GDL.Const "x"; GDL.Const "o"|]
+ GDL.playout_satur ~aggregate:true [|GDL.Const "x"; GDL.Const "o"|]
10 (Aux.concat_map GDL.rules_of_clause descr) in
let actions = List.map (List.map (fun a->"does", a)) agg_actions in
assert_equal ~printer:(fun x->x) ~msg:"aggregate"
@@ -142,7 +209,7 @@
(List.map GDL.rel_atom_str step)) actions));
let _, _, _, _, (rand_actions, _) =
- GDL.playout ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
+ GDL.playout_satur ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
10 (Aux.concat_map GDL.rules_of_clause descr) in
let actions = List.map (List.map (fun a->"does", a)) rand_actions in
let res =
@@ -156,6 +223,59 @@
(does o (mark b a)) (does x noop)"])
);
+ "playout_prolog simple" >::
+ (fun () ->
+ let descr = parse_game_descr
+ "
+(role x)
+(role o)
+(init (cell a a b))
+(init (cell b a b))
+(init (control x))
+(<= (next (control ?r))
+ (does ?r noop))
+(<= (next (cell ?x ?y ?r))
+ (does ?r (mark ?x ?y)))
+(<= (next (cell ?x ?y ?c))
+ (true (cell ?x ?y ?c))
+ (does ?r (mark ?x1 ?y1))
+ (or (distinct ?x ?x1)
+ (distinct ?y ?y1)))
+(<= (legal ?r (mark ?x ?y))
+ (true (control ?r))
+ (true (cell ?x ?y b))
+ )
+(<= (legal ?r noop)
+ (role ?r)
+ (not (true (control ?r))))
+" in
+
+ let program = GDL.preprocess_program descr in
+ let agg_actions, _ =
+ GDL.playout_prolog ~aggregate:true [|GDL.Const "x"; GDL.Const "o"|]
+ 10 program in
+ let actions = List.map (List.map (fun a->"does", a)) agg_actions in
+ assert_equal ~printer:(fun x->x) ~msg:"aggregate"
+ "(does o noop) (does x noop) (does x (mark a a)) (does x (mark b a));
+(does o noop) (does o (mark a a)) (does o (mark b a)) (does x noop) (does x (mark a a)) (does x (mark b a))"
+ (String.concat ";\n" (List.map (fun step -> String.concat " "
+ (List.map GDL.rel_atom_str step)) actions));
+
+ let rand_actions, _ =
+ GDL.playout_prolog ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
+ 10 program in
+ let actions = List.map (List.map (fun a->"does", a)) rand_actions in
+ let res =
+ String.concat ";\n" (List.map (fun step -> String.concat " "
+ (List.map GDL.rel_atom_str step)) actions) in
+ assert_bool (
+ "random (see expected result in the test source): got " ^ res)
+ (List.mem res ["(does o noop) (does x (mark a a)) (does x (mark b a));
+(does o (mark a a)) (does x noop)";
+"(does o noop) (does x (mark a a)) (does x (mark b a));
+(does o (mark b a)) (does x noop)"])
+ );
+
"expand players connect5" >::
(fun () ->
let descr = load_rules ("./GGP/examples/connect5.gdl") in
@@ -279,9 +399,14 @@
(fun () ->
let descr = load_rules ("./GGP/examples/connect5.gdl") in
let clauses = expand_players descr in
+ (*
let _, _, _, _, (rand_actions, _) =
- GDL.playout ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
+ GDL.playout_satur ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
10 (Aux.concat_map GDL.rules_of_clause clauses) in
+ *)
+ let rand_actions, _ =
+ GDL.playout_prolog ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
+ 10 (GDL.preprocess_program clauses) in
let noop_actions = Aux.take_n 9
(List.map
(Aux.map_some
@@ -301,5 +426,7 @@
let a () =
GDL.debug_level := 5
+let a () =
+ ()
let exec = Aux.run_test_if_target "G...
[truncated message content] |
|
From: <luk...@us...> - 2011-08-18 09:30:32
|
Revision: 1542
http://toss.svn.sourceforge.net/toss/?rev=1542&view=rev
Author: lukstafi
Date: 2011-08-18 09:30:20 +0000 (Thu, 18 Aug 2011)
Log Message:
-----------
GDL translation: reverting to saturation-based solver for aggregate playout; optimized saturation (better data structures, matching instead of unification).
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/Formula/Aux.ml 2011-08-18 09:30:20 UTC (rev 1542)
@@ -81,6 +81,10 @@
[] -> tl
| a::l -> let r = f a in r :: map_prepend tl f l
+let rec map_rev_prepend tl f = function
+ [] -> tl
+ | a::l -> let r = f a in map_rev_prepend (r::tl) f l
+
let map_some f l =
let rec maps_f accu = function
| [] -> accu
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/Formula/Aux.mli 2011-08-18 09:30:20 UTC (rev 1542)
@@ -54,7 +54,11 @@
(** Map a second list and prepend the result to the first list, by
single traversal. Not tail-recursive. *)
val map_prepend : 'a list -> ('b -> 'a) -> 'b list -> 'a list
+(** Map a second list and prepend the result to the first list, in
+ reverse order. Tail-recursive. *)
+val map_rev_prepend : 'a list -> ('b -> 'a) -> 'b list -> 'a list
+
(** Map a list filtering out some elements. *)
val map_some : ('a -> 'b option) -> 'a list -> 'b list
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/GGP/GDL.ml 2011-08-18 09:30:20 UTC (rev 1542)
@@ -258,7 +258,25 @@
(List.map (subst_one sb1) terms2)
| _ -> raise Not_found
+(* Yet another variant, for fast saturation. *)
+let rec match_nonvar sb terms1 terms2 =
+ match terms1, terms2 with
+ | [], [] -> sb
+ | Const a::terms1, Const b::terms2 when a=b ->
+ match_nonvar sb terms1 terms2
+ | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
+ match_nonvar sb (Array.to_list args1 @ terms1)
+ (Array.to_list args2 @ terms2)
+ | _::terms1, Var _::terms2 ->
+ match_nonvar sb terms1 terms2
+ | Var x::terms1, c::terms2 ->
+ let sb1 = x, c in
+ match_nonvar (sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb)
+ (List.map (subst_one sb1) terms1)
+ (List.map (subst_one sb1) terms2)
+ | _ -> raise Not_found
+
let unify_args ?(sb=[]) args1 args2 =
unify sb (Array.to_list args1) (Array.to_list args2)
@@ -289,6 +307,10 @@
try ignore (unify [] [term1] [term2]); true
with Not_found -> false
+let try_match_nonvar terms1 terms2 =
+ try ignore (match_nonvar [] terms1 terms2); true
+ with Not_found -> false
+
let unify_rels ?sb (rel1, args1) (rel2, args2) =
if rel1 = rel2 then unify_args ?sb args1 args2
else raise Not_found
@@ -387,35 +409,79 @@
rel ^"(" ^ String.concat ", " args ^")"
-(* TODO: optimize by using rel-indexing (also in [aggregate_playout]).
- TODO: optimize by using constant-time append data structure. *)
-(* Variables still left after saturation have universal interpretation! *)
-let saturate base rules =
+(** {4 Saturation-based solver.} *)
- let instantiate_one (tot_base : rel_atom list)
- (cur_base : rel_atom list) irules =
- Aux.concat_map (function
- | head, [], neg_body ->
- if List.mem head tot_base then []
- else if List.exists (fun (rel,args as neg_atom) ->
+module Tuples = Set.Make(struct
+ type t = term array
+ let compare = Pervasives.compare
+end)
+type graph = Tuples.t Aux.StrMap.t
+
+let add_tuples nvs vs =
+ List.fold_left (fun vs nv -> Tuples.add nv vs) vs nvs
+let tuples_of_list nvs =
+ add_tuples nvs Tuples.empty
+
+let merge_graphs graph1 graph2 =
+ Aux.StrMap.fold
+ (fun rel tups1 graph ->
+ let tups2 =
+ try Aux.StrMap.find rel graph2 with Not_found -> Tuples.empty in
+ Aux.StrMap.add rel (Tuples.union tups1 tups2) graph)
+ graph1 graph2
+
+let build_graph atoms =
+ List.fold_left
+ (fun graph (rel,tups) ->
+ Aux.StrMap.add rel (tuples_of_list tups) graph)
+ Aux.StrMap.empty (Aux.collect atoms)
+
+let graph_to_atoms graph =
+ List.rev
+ (Aux.StrMap.fold (fun rel tups atoms ->
+ Aux.map_rev_prepend atoms (fun tup -> rel, tup)
+ (Tuples.elements tups)) graph [])
+
+let graph_mem rel tup graph =
+ try
+ Tuples.mem tup (Aux.StrMap.find rel graph)
+ with Not_found -> false
+
+let instantiate_one tot_base cur_base irules =
+ Aux.concat_map (function
+ | (hrel, hargs as head), [], neg_body ->
+ if (try Tuples.mem hargs (Aux.StrMap.find hrel tot_base)
+ with Not_found -> false)
+ then []
+ else if List.exists (fun (rel,args) ->
+ let rel_tups =
+ try Aux.StrMap.find rel tot_base with Not_found -> Tuples.empty in
+ Tuples.mem args rel_tups ||
rel = "distinct" && Aux.not_unique (Array.to_list args) ||
- (* faster option: *)
- (* List.mem neg_atom tot_base *)
- (* accurate option: *)
- List.exists (rels_unify neg_atom) tot_base
- ) neg_body then []
- else [Aux.Left head]
- | head, cond1::body, neg_body ->
- Aux.map_try (fun fact ->
+ let neg_tup = Array.to_list args in
+ Tuples.exists
+ (fun tup -> try_match_nonvar neg_tup (Array.to_list tup))
+ rel_tups
+ ) neg_body then []
+ else [Aux.Left head]
+ | (hrel, hargs as head), (rel,args as pos_atom)::body, neg_body ->
+ if (try Tuples.mem hargs (Aux.StrMap.find hrel tot_base)
+ with Not_found -> false)
+ then []
+ else
+ let pos_tup = Array.to_list args in
+ let cur_tups =
+ try Tuples.elements (Aux.StrMap.find rel cur_base)
+ with Not_found -> [] in
+ Aux.map_try
+ (fun rel_tup ->
(* {{{ log entry *)
-
if !debug_level > 5 then (
- Printf.printf "instantiate_one: trying to unify %s and %s\n%!"
- (rel_atom_str fact) (rel_atom_str cond1)
+ Printf.printf "instantiate_one: trying to match %s and %s\n%!"
+ (rel_atom_str (rel, rel_tup)) (rel_atom_str pos_atom)
);
-
(* }}} *)
- let sb = unify_rels fact cond1 in
+ let sb = match_nonvar [] pos_tup (Array.to_list rel_tup) in
(* {{{ log entry *)
if !debug_level > 5 then (
Printf.printf "instantiate_one: succeeded with %s\n%!"
@@ -425,21 +491,26 @@
let irule =
subst_rel sb head,
subst_rels sb body, subst_rels sb neg_body in
- Aux.Right irule
- ) cur_base) irules in
+ Aux.Right irule)
+ cur_tups)
+ irules
+(* TODO: optimize by using rel-indexing (also in [aggregate_playout]). *)
+(* Variables still left after saturation have universal interpretation! *)
+let saturate base rules =
+
let rec inst_stratum old_base old_irules cur_base cur_irules =
(* {{{ log entry *)
if !debug_level > 4 then (
- Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!"
- (rel_atoms_str old_base) (rel_atoms_str cur_base);
+ (*Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!"
+ (rel_atoms_str old_base) (rel_atoms_str cur_base);*)
Printf.printf
"inst_stratum: #old_irules = %d, #cur_irules = %d\n%!"
(List.length old_irules) (List.length cur_irules)
);
(* }}} *)
- let base = Aux.unique_sorted (cur_base @ old_base)
- and irules = Aux.unique_sorted (cur_irules @ old_irules) in
+ let base = merge_graphs cur_base old_base
+ and irules = Aux.sorted_merge cur_irules old_irules in
let new_base1, new_irules1 =
Aux.partition_choice (instantiate_one base cur_base cur_irules) in
(* {{{ log entry *)
@@ -464,24 +535,24 @@
(rel_atoms_str new_base3)
);
(* }}} *)
- let new_base = Aux.unique_sorted (new_base1 @ new_base2 @ new_base3)
+ let new_base = build_graph
+ (new_base1 @ new_base2 @ new_base3)
and new_irules = Aux.unique_sorted
(new_irules1 @ new_irules2 @ new_irules3) in
- let new_base =
- List.filter (fun f->not (List.mem f base)) new_base in
- let new_irules =
- List.filter (fun f->not (List.mem f irules)) new_irules in
- if new_base = [] && new_irules = []
+ (* [new_base] is already disjoint from [base] *)
+ let new_irules = Aux.sorted_diff new_irules irules in
+ if Aux.StrMap.is_empty new_base && new_irules = []
then base
else inst_stratum base irules new_base new_irules in
let rec instantiate base = function
| [] -> base
| stratum::strata ->
- instantiate (inst_stratum [] [] base stratum) strata in
+ instantiate (inst_stratum Aux.StrMap.empty [] base stratum) strata in
- instantiate base
- (List.map rules_of_defs (stratify [] (defs_of_rules rules)))
+ instantiate (*build_graph*) base
+ (List.map (Aux.unique_sorted -| rules_of_defs)
+ (stratify [] (defs_of_rules rules)))
@@ -872,35 +943,34 @@
(* [~aggregate:true] performs an aggregate ply, [~aggregate:false]
performs a random ply. *)
let ply_satur ~aggregate players static current rules =
- let base =
- Aux.map_prepend static (fun term -> "true", [|term|]) current in
- let base = saturate (base @ static) rules in
+ let base = Aux.StrMap.add "true" current
+ (*tuples_of_list (List.map (fun term -> [|term|]) current)*) static in
+ let base = saturate base rules in
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "GDL.ply: updated base -- %s\n%!"
- (rel_atoms_str base)
+ (rel_atoms_str (graph_to_atoms base))
);
(* }}} *)
- let does = Aux.map_some (fun (rel, args) ->
- if rel = "legal" then Some ("does", args) else None) base in
+ let does = Tuples.elements (Aux.StrMap.find "legal" base) in
let does =
if aggregate then does
else
List.map (Aux.random_elem -| snd)
- (Aux.collect (List.map (fun (_,args as atom) ->
- args.(0), atom) does)) in
+ (Aux.collect (List.map (fun args ->
+ args.(0), args) does)) in
if (* no move *)
Aux.array_existsi (fun _ player ->
List.for_all (function
- |_, [|Var _; _ |] -> false
- | _, [|actor; _ |] -> player <> actor | _ -> true)
+ | [|Var _; _ |] -> false
+ | [|actor; _ |] -> player <> actor | _ -> true)
does) players
then (
(* {{{ log entry *)
if !debug_level > 0 then (
let players_nomove =
Aux.array_find_all (fun player ->
- List.for_all (function _, [|actor; _|] -> player <> actor
+ List.for_all (function [|actor; _|] -> player <> actor
| _ -> true)
does) players in
Printf.printf
@@ -910,16 +980,11 @@
(* }}} *)
raise Playout_over)
else
- let step = saturate (does @ base) rules in
- let step_state = Aux.map_some
- (function ("next", [|arg|]) -> Some arg
- | _ -> None) step in
+ let step = saturate
+ (Aux.StrMap.add "does" (tuples_of_list does) base) rules in
+ let step_state = Aux.StrMap.find "next" step in
if !playout_fixpoint && (* fixpoint reached *)
- List.for_all (function
- | Func (_,[|arg|]) when
- Aux.array_existsi (fun _ player -> arg=player) players -> true
- | term -> List.mem term current
- ) step_state
+ Tuples.subset step_state current
then (
(* {{{ log entry *)
if !debug_level > 0 then (
@@ -928,7 +993,8 @@
(* }}} *)
raise Playout_over)
else if not aggregate && (* terminal position reached *)
- List.mem_assoc "terminal" step
+ (try not (Tuples.is_empty (Aux.StrMap.find "terminal" step))
+ with Not_found -> false)
then (
(* {{{ log entry *)
if !debug_level > 0 then (
@@ -937,8 +1003,11 @@
(* }}} *)
raise Playout_over)
else
- List.map snd does, step_state
+ does, step_state
+let state_of_tups ts =
+ List.map (fun s->s.(0)) (Tuples.elements ts)
+
(* Besides the playout, also return the separation of rules
into static and dynamic. Note that the list of playout states is
one longer than that of playout actions.
@@ -967,7 +1036,7 @@
["init"; "does"; "true"; "next"; "terminal"; "goal"] in
let static_rules, dynamic_rules = List.partition
(fun ((rel,_),_,_) -> List.mem rel static_rels) rules in
- let static_base = saturate [] static_rules in
+ let static_base = saturate Aux.StrMap.empty static_rules in
let state_rules =
List.map (function
| ("legal", [|player; _|] as head), body, neg_body ->
@@ -987,30 +1056,33 @@
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "playout: state %s\n%!"
- (String.concat " " (List.map term_str next))
+ (String.concat " "
+ (List.map term_str (state_of_tups next)))
);
(* }}} *)
let next =
- if aggregate then state @ next else next in
+ if aggregate then (Tuples.union state next) else next in
if step < horizon then
loop (actions::actions_accu) (state::state_accu) (step+1) next
else
+ let states = List.rev (next::state::state_accu) in
List.rev (actions::actions_accu),
- List.rev (next::state::state_accu)
+ List.map (fun ts->state_of_tups ts) states
with Playout_over ->
- List.rev actions_accu, List.rev (state::state_accu)) in
+ List.rev actions_accu,
+ List.map (fun ts->state_of_tups ts)
+ (List.rev (state::state_accu))) in
(* FIXME: this is identity, right? remove *)
let init_base = saturate static_base state_rules in
- let init_state =
- Aux.map_some (function ("init", [|arg|]) -> Some arg
- | _ -> None) init_base in
+ let init_state = Aux.StrMap.find "init" init_base in
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "playout: init %s\n%!"
- (String.concat " " (List.map term_str init_state))
+ (String.concat " "
+ (List.map term_str (state_of_tups init_state)))
);
(* }}} *)
- static_rules, dynamic_rules, static_base, init_state,
+ static_rules, dynamic_rules, static_base, (state_of_tups init_state),
loop [] [] 0 init_state
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/GGP/GDL.mli 2011-08-18 09:30:20 UTC (rev 1542)
@@ -76,9 +76,12 @@
val subst_clause : substitution -> clause -> clause
val subst_consts_clause : substitution -> clause -> clause
+module Tuples : Set.S with type elt = term array
+type graph = Tuples.t Aux.StrMap.t
+val graph_mem : string -> term array -> graph -> bool
+val graph_to_atoms : graph -> rel_atom list
(** Saturation currently exposed for testing purposes. *)
-val saturate :
- rel_atom list -> gdl_rule list -> rel_atom list
+val saturate : graph -> gdl_rule list -> graph
(** {3 Continuation-based Prolog interpreter} *)
@@ -175,7 +178,7 @@
val playout_satur :
aggregate:bool -> term array -> int -> gdl_rule list ->
gdl_rule list * gdl_rule list *
- rel_atom list * term list *
+ graph * term list *
(term array list list * term list list)
val playout_prolog :
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/GGP/GDLTest.ml 2011-08-18 09:30:20 UTC (rev 1542)
@@ -57,24 +57,24 @@
(beta rock)
(theta scisors) (gamma scisors)" in
(* GDL.debug_level := 3; *)
- let res = GDL.saturate []
+ let res = GDL.saturate Aux.StrMap.empty
(Aux.concat_map GDL.rules_of_clause descr) in
assert_equal ~printer:(fun x->x) ~msg:"simple stratified"
"(alpha paper) (alpha rock) (beta paper) (beta rock) (beta scisors) (gamma paper) (gamma scisors) (theta scisors) (zeta rock)"
(String.concat " "
- (List.map GDL.rel_atom_str res));
+ (List.map GDL.rel_atom_str (GDL.graph_to_atoms res)));
let descr = parse_game_descr
"
(<= (two-of-three ?X ?Y) (a ?X) (a ?Y) (distinct ?X ?Y))
(a 1) (a 2) (a 3)" in
(* GDL.debug_level := 3; *)
- let res = GDL.saturate []
+ let res = GDL.saturate Aux.StrMap.empty
(Aux.concat_map GDL.rules_of_clause descr) in
assert_equal ~printer:(fun x->x) ~msg:"simple distinct"
"(a 1) (a 2) (a 3) (two-of-three 1 2) (two-of-three 1 3) (two-of-three 2 1) (two-of-three 2 3) (two-of-three 3 1) (two-of-three 3 2)"
(String.concat " "
- (List.map GDL.rel_atom_str res));
+ (List.map GDL.rel_atom_str (graph_to_atoms res)));
);
"saturate recursive" >::
@@ -96,12 +96,12 @@
(succ 4 5) (succ 5 6) (succ 6 7) (succ 7 8)
" in
(* GDL.debug_level := 3; *)
- let res = GDL.saturate []
+ let res = GDL.saturate Aux.StrMap.empty
(Aux.concat_map GDL.rules_of_clause descr) in
assert_equal ~printer:(fun x->x) ~msg:"simple stratified"
"(lte 0 0) (lte 0 1) (lte 0 2) (lte 0 3) (lte 0 4) (lte 0 5) (lte 0 6) (lte 0 7) (lte 0 8) (lte 1 1) (lte 1 2) (lte 1 3) (lte 1 4) (lte 1 5) (lte 1 6) (lte 1 7) (lte 1 8) (lte 2 2) (lte 2 3) (lte 2 4) (lte 2 5) (lte 2 6) (lte 2 7) (lte 2 8) (lte 3 3) (lte 3 4) (lte 3 5) (lte 3 6) (lte 3 7) (lte 3 8) (lte 4 4) (lte 4 5) (lte 4 6) (lte 4 7) (lte 4 8) (lte 5 5) (lte 5 6) (lte 5 7) (lte 5 8) (lte 6 6) (lte 6 7) (lte 6 8) (lte 7 7) (lte 7 8) (lte 8 8) (number 0) (number 1) (number 2) (number 3) (number 4) (number 5) (number 6) (number 7) (number 8) (succ 0 1) (succ 1 2) (succ 2 3) (succ 3 4) (succ 4 5) (succ 5 6) (succ 6 7) (succ 7 8)"
(String.concat " "
- (List.map GDL.rel_atom_str res));
+ (List.map GDL.rel_atom_str (GDL.graph_to_atoms res)));
);
"run_prolog" >::
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-18 09:30:20 UTC (rev 1542)
@@ -250,14 +250,18 @@
) clauses in
let players = Array.of_list players in
let rules = Aux.concat_map rules_of_clause clauses in
- (*
+ (* Turns out the saturation-based solver is sometimes far better for
+ performing aggregate playout, which is very much
+ saturation-like. *)
let static_rel_defs, nonstatic_rel_defs,
static_base, init_state, (agg_actions, agg_states) =
playout_satur ~aggregate:true players !playout_horizon rules in
- *)
+ (* *)
+ (*
let program = preprocess_program clauses in
let agg_actions, agg_states =
playout_prolog ~aggregate:true players !playout_horizon program in
+ *)
let init_state = List.hd agg_states in
let static_rels, nonstatic_rels =
static_rels (defs_of_rules rules) in
@@ -345,8 +349,8 @@
Aux.fold_left_try (fun struc etup ->
let tup = Array.of_list (List.map2 at_path etup ptup) in
if rel = "EQ_" && arity = 2 && tup.(0) = tup.(1) ||
- (* List.mem (rel, tup) static_base *)
- rel <> "EQ_" && run_prolog_check_atom (rel, tup) program
+ rel <> "EQ_" && graph_mem rel tup static_base
+ (* rel <> "EQ_" && run_prolog_check_atom (rel, tup) program *)
then (
stable_rels := Aux.Strings.add fact_rel !stable_rels;
Structure.add_rel_named_elems struc fact_rel
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-16 14:49:54 UTC (rev 1541)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-18 09:30:20 UTC (rev 1542)
@@ -172,7 +172,7 @@
"control__blank_", "control_MV1"]
~loc1_noop:"noop" ~loc1_move:"(mark f g)"
);
-(*
+
"breakthrough" >::
(fun () ->
game_test_case ~game_name:"breakthrough" ~player:"white"
@@ -211,11 +211,11 @@
"control__blank_", "control_MV1"]
~loc1_noop:"noop" ~loc1_move:"(mark f g)"
);
-*)
+
]
let a () =
- (* GDL.debug_level := 4; *)
+ GDL.debug_level := 4;
TranslateGame.debug_level := 4;
GameSimpl.debug_level := 4;
DiscreteRule.debug_level := 4;
@@ -223,18 +223,20 @@
let a () =
- game_test_case ~game_name:"tictactoe" ~player:"xplayer"
+ game_test_case ~game_name:"breakthrough" ~player:"white"
~own_plnum:0 ~opponent_plnum:1
- ~loc0_rule_name:"mark_x6_y_noop"
+ ~loc0_rule_name:"move_x239_y257_x238_y256_0"
~loc0_emb:[
- "cell_x6_y__BLANK_", "cell_2_2__BLANK_";
- "control__BLANK_", "control__BLANK_"]
- ~loc0_move:"(mark 2 2)" ~loc0_noop:"noop"
- ~loc1:1 ~loc1_rule_name:"noop_mark_x7_y0"
+ "cellholds_x239_y257__blank_", "cellholds_2_2_MV1";
+ "cellholds_x238_y256__blank_", "cellholds_1_3_MV1";
+ "control__blank_", "control_MV1"]
+ ~loc0_move:"(move 2 2 1 3)" ~loc0_noop:"noop" ~loc1:1
+ ~loc1_rule_name:"move_x467_y497_x466_y496_1"
~loc1_emb:[
- "cell_x7_y0__BLANK_", "cell_1_1__BLANK_";
- "control__BLANK_", "control__BLANK_"]
- ~loc1_noop:"noop" ~loc1_move:"(mark 1 1)"
+ "cellholds_x467_y497__blank_", "cellholds_7_7_MV1";
+ "cellholds_x466_y496__blank_", "cellholds_6_6_MV1";
+ "control__blank_", "control_MV1"]
+ ~loc1_noop:"noop" ~loc1_move:"(move 7 7 6 6)"
let a () =
@@ -270,9 +272,9 @@
TranslateGame.generate_test_case := None
let a () =
- regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer";
+ (* regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer"; *)
(* regenerate ~debug:false ~game_name:"connect5" ~player:"x"; *)
- (* regenerate ~debug:true ~game_name:"breakthrough" ~player:"white"; *)
+ regenerate ~debug:true ~game_name:"breakthrough" ~player:"white";
(* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
(* regen_with_debug ~game_name:"connect4" ~player:"white"; *)
(* failwith "generated"; *)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-08-21 10:27:44
|
Revision: 1543
http://toss.svn.sourceforge.net/toss/?rev=1543&view=rev
Author: lukstafi
Date: 2011-08-21 10:27:37 +0000 (Sun, 21 Aug 2011)
Log Message:
-----------
GDL translation: revised specification of translating as defined relations; fix in GDL.ml related to finding fluents; literal translation handling Distinct.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/GDL.ml 2011-08-21 10:27:37 UTC (rev 1543)
@@ -749,9 +749,10 @@
let br_vars = gdl_defs_vars ["",brs] in
let sb = List.map
(fun v ->
- v, Aux.not_conflicting_name ~truncate:true !used_vars v)
+ let nv = Aux.not_conflicting_name ~truncate:true !used_vars v in
+ used_vars := Aux.Strings.add nv !used_vars;
+ v, nv)
(Aux.Strings.elements br_vars) in
- used_vars := Aux.add_strings (List.map snd sb) !used_vars;
let sb = List.map (fun (v,t) -> v, Var t) sb in
List.map (subst_br sb) brs in
let expand_atom (rel, args as atom)
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-08-21 10:27:37 UTC (rev 1543)
@@ -58,7 +58,7 @@
(* Whether $i$th argument is a $\mathrm{DefSide}$ or a
$\mathrm{CallSide}$, and the $p_{R,i}$ path for a relation $R$. *)
-type defrel_arg_type = (bool * path) array
+type defrel_arg_mode = (bool * path) array
type transl_data = {
f_paths : path_set; (* fluent paths *)
@@ -66,8 +66,8 @@
all_paths : path_set; (* sum of f_paths and m_paths *)
mask_reps : term list; (* mask terms *)
defined_rels : string list;
- defrel_arg_type : (string * defrel_arg_type) list ref;
- (* late binding to store $ArgType# data *)
+ defrel_arg_mode : (string * defrel_arg_mode) list ref;
+ (* late binding to store $ArgMode# data *)
term_arities : (string * int) list;
rel_default_path : (string * path option array) list;
}
@@ -78,7 +78,7 @@
all_paths = empty_path_set;
mask_reps = [];
defined_rels = [];
- defrel_arg_type = ref [];
+ defrel_arg_mode = ref [];
term_arities = [];
rel_default_path = [];
}
@@ -159,9 +159,30 @@
| Neg (Rel (rel, args)) -> transl_posdefrel false rel args
| Pos (Does _ | Role _) | Neg (Does _ | Role _) ->
[]
+ | Pos (Distinct ts) ->
+ let res =
+ Array.mapi (fun i t_i ->
+ if i = 0 then []
+ else aux (Neg (Rel ("EQ_", [|ts.(0); t_i|])))) ts in
+ List.concat (Array.to_list res)
+ | Neg (Distinct ts) ->
+ (* they shouldn't do it but since they did... *)
+ let res =
+ Array.mapi (fun i t_i ->
+ if i = 0 then []
+ else aux (Pos (Rel ("EQ_", [|ts.(0); t_i|])))) ts in
+ List.concat (Array.to_list res)
| Disj lits ->
- [Formula.Or (Aux.concat_map (fun l -> aux l) lits)]
- | _ -> assert false in (* FIXME: what about Distinct? *)
+ [Formula.Or (Aux.concat_map aux lits)]
+ | lit ->
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "transl_rels: Unhandled literal %s\n%!"
+ (literal_str lit)
+ );
+ (* }}} *)
+ [] (* assert false *)
+ in
Formula.And (Aux.concat_map aux rels_phi)
let transl_state data phi =
@@ -211,6 +232,11 @@
let neg_terms = state_terms neg_state_phi in
let neg_vars =
Aux.list_diff (List.map (var_of_term data) neg_terms) pos_vars in
+ let neg_ext, pos_ext = List.partition
+ (fun conj ->
+ List.exists (fun v->List.mem v (neg_vars :> Formula.var list))
+ (FormulaOps.free_vars conj))
+ ext_phi in
let all_terms = pos_terms @ neg_terms in
let phi_vars = clause_vars
(("", [| |]),
@@ -225,7 +251,7 @@
(clause_str (("rels_phi", [||]),rels_phi))
(clause_str (("pos_state_phi", [||]),pos_state_phi))
(clause_str (("neg_state_phi", [||]),neg_state_phi))
- ("ext_phi="^Formula.str ext_phi)
+ ("ext_phi="^Formula.str (Formula.And ext_phi))
);
(* }}} *)
let negated_neg_state_transl =
@@ -233,21 +259,23 @@
Formula.Or (
List.map (transl_state data) (nnf_dnf neg_state_phi)) in
let negated_part =
- Formula.And [
- (* positive because they form a "premise" *)
- transl_rels data rels_eqs all_terms neg_terms;
- (* the universal "conclusion" *)
- negated_neg_state_transl] in
+ Formula.And (
+ neg_ext @
+ [
+ (* positive because they form a "premise" *)
+ transl_rels data rels_eqs all_terms neg_terms;
+ (* the universal "conclusion" *)
+ negated_neg_state_transl]) in
let universal_part =
- if neg_terms = [] then []
+ if neg_terms = [] && neg_ext = [] then []
else if neg_vars = []
then [Formula.Not negated_part]
else [Formula.Not (
Formula.Ex ((neg_vars :> Formula.var list), negated_part))] in
let base_part =
Formula.And (
- [ ext_phi;
- transl_rels data rels_eqs pos_terms pos_terms;
+ pos_ext @
+ [ transl_rels data rels_eqs pos_terms pos_terms;
transl_state data pos_state_phi] @
universal_part) in
if pos_vars = [] then base_part
@@ -259,7 +287,7 @@
let translate data disj =
let disj = separate_disj disj in
Formula.Or (List.map (fun (rels_phi, pos_state, neg_state) ->
- transl_disjunct data rels_phi pos_state neg_state (Formula.And [])
+ transl_disjunct data rels_phi pos_state neg_state []
) disj)
@@ -269,7 +297,7 @@
let select_defrel_argpaths data all_branches =
(* TODO: code-review this and [build_defrel] functions *)
let select_for_defrel rel =
- (* searching for ArgType = DefSide,S,p *)
+ (* searching for ArgMode = DefSide,S,p *)
let branches = Aux.assoc_all rel all_branches in
(* {{{ log entry *)
if !debug_level > 2 then (
@@ -306,7 +334,7 @@
) sterms))
args p_defside in
let s_defside = List.map branch_sterms branches in
- (* now computing the ArgType(R,i) = CallSide,p variant *)
+ (* now computing the ArgMode(R,i) = CallSide,p variant *)
let call_branches = Aux.concat_map
(fun (_,(_, (phi, _, _ as body))) ->
let calls = Aux.assoc_all rel (rel_atoms phi) in
@@ -341,7 +369,7 @@
match defside, callside with
| Some p, _ | None, Some p -> p
| None, None ->
- (* the ArgType(R,i) = NoSide,p variant is precomputed *)
+ (* the ArgMode(R,i) = NoSide,p variant is precomputed *)
try
match (List.assoc rel data.rel_default_path).(i) with
| Some p -> p
@@ -352,11 +380,11 @@
"TranslateFormula.build_defrels: could not \
determine path for relation %s argument %d" rel i)
) p_defside in
- let defrel_arg_type = Aux.array_map2
+ let defrel_arg_mode = Aux.array_map2
(fun defside path -> defside <> None, path)
p_defside arg_paths in
- data.defrel_arg_type :=
- (rel, defrel_arg_type) :: !(data.defrel_arg_type);
+ data.defrel_arg_mode :=
+ (rel, defrel_arg_mode) :: !(data.defrel_arg_mode);
rel, (p_defside, s_defside, arg_paths) in
List.map select_for_defrel data.defined_rels
@@ -386,7 +414,7 @@
Formula.Eq (v, s_i)
else Formula.Eq (v, var_of_subterm data arg_paths.(i) args.(i)))
defvars in
- let arg_eqs = Formula.And (Array.to_list arg_eqs) in
+ let arg_eqs = Array.to_list arg_eqs in
let callside_sterms = (* $S_{j,l}$ *)
Aux.array_mapi_some
(fun i path ->
@@ -411,20 +439,20 @@
(rel_atom_str (rel, args)) sign
);
(* }}} *)
- let arg_type = List.assoc rel !(data.defrel_arg_type) in
+ let arg_mode = List.assoc rel !(data.defrel_arg_mode) in
(* the $s \tpos_{p_{R,i}} = t_i$ state terms *)
let arg_sterms = Array.mapi
(fun i (defside, path) -> if defside then None else
try Some (
List.find (fun s -> at_path s path = args.(i)) sterms_all)
with Not_found -> None)
- arg_type in
+ arg_mode in
let var_args = Array.mapi
(fun i (_, path) ->
match arg_sterms.(i) with
| None -> var_of_subterm data path args.(i) (* in J *)
| Some sterm -> var_of_term data sterm)
- arg_type in
+ arg_mode in
let defrel_phi = Formula.Rel (rel, var_args) in
let defrel_phi =
if sign then defrel_phi else Formula.Not defrel_phi in
@@ -432,7 +460,7 @@
(Aux.array_mapi_some (fun i (_,path) ->
if arg_sterms.(i) = None
then Some (var_of_subterm data path args.(i))
- else None) arg_type) in
+ else None) arg_mode) in
let in_J_eq_transl i (_,path) =
if arg_sterms.(i) = None
then
@@ -441,7 +469,7 @@
Some (transl_rels data eq_phi (v::sterms_all) [v])
else None in
let eqs_phi = Array.to_list
- (Aux.array_mapi_some in_J_eq_transl arg_type) in
+ (Aux.array_mapi_some in_J_eq_transl arg_mode) in
let base =
if eqs_phi = [] then defrel_phi
else Formula.And (defrel_phi::eqs_phi) in
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-08-21 10:27:37 UTC (rev 1543)
@@ -2,7 +2,7 @@
(* Whether $i$th argument is a $\mathrm{DefSide}$ or a
$\mathrm{CallSide}$, and the $p_{R,i}$ path for a relation $R$. *)
-type defrel_arg_type = (bool * GDL.path) array
+type defrel_arg_mode = (bool * GDL.path) array
type transl_data = {
f_paths : GDL.path_set; (** fluent paths *)
@@ -10,8 +10,8 @@
all_paths : GDL.path_set; (** sum of f_paths and m_paths *)
mask_reps : GDL.term list; (** mask terms *)
defined_rels : string list;
- defrel_arg_type : (string * defrel_arg_type) list ref;
- (** late binding to store $ArgType$ data *)
+ defrel_arg_mode : (string * defrel_arg_mode) list ref;
+ (** late binding to store $ArgMode$ data *)
term_arities : (string * int) list;
rel_default_path : (string * GDL.path option array) list;
}
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2011-08-21 10:27:37 UTC (rev 1543)
@@ -66,7 +66,7 @@
all_paths = all_paths;
mask_reps = mask_reps;
defined_rels = defined_rels;
- defrel_arg_type = ref [];
+ defrel_arg_mode = ref [];
term_arities = term_arities;
rel_default_path = rel_default_path;
}
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-08-21 10:27:37 UTC (rev 1543)
@@ -26,11 +26,6 @@
let debug_level = ref 0
let generate_test_case = ref None
-(** Translate static relations that otherwise would be translated as
- structure relations, but have arity above the threshold, as
- defined relations. *)
-let defined_arity_above = ref 2
-
(** Treat "next" clauses which introduce a fluent position for a
variable-variable mismatch, as non-erasing frame clauses (to be
ignored). ("Wave" refers to the process of "propagating the frame
@@ -38,6 +33,13 @@
[nonerasing_frame_wave] is set to [true].) *)
let nonerasing_frame_wave = ref true
+(** two heuristics for selecting defined relations: select relations
+ with arity smaller than three; or, select relations that have ground
+ defining clauses (i.e. defining clauses with empty bodies). *)
+type as_defined_rels =
+ Many_by_arity | Few_by_ground_def | Fewer_by_all_ground
+let as_defined_rels = ref Few_by_ground_def
+
(** When translating as turn-based, filter-out moves composed only of
actions such that each is a "noop" action of some player at some
location. Assumes that players do not use their "noop" actions
@@ -326,9 +328,16 @@
let m_pathl = paths_to_list m_paths in
let f_pathl = paths_to_list f_paths in
(* adding subterm equality relations and fact relations *)
- let struc_rels, defined_rels =
- List.partition (fun rel ->
- List.assoc rel arities <= !defined_arity_above) static_rels in
+ let struc_rels, defined_rels = List.partition
+ (fun rel ->
+ if !as_defined_rels = Few_by_ground_def
+ then List.exists
+ (fun ((rc,args),body) -> rel=rc && body = []) clauses
+ else if !as_defined_rels = Fewer_by_all_ground
+ then List.for_all
+ (fun ((rc,args),body) -> rel=rc && body = []) clauses
+ else List.assoc rel arities < 3)
+ static_rels in
let struc_rels = "EQ_"::struc_rels in
let defined_rels = defined_rels @ nonstatic_rels in
(* {{{ log entry *)
@@ -1473,7 +1482,7 @@
all_paths = paths_union f_paths m_paths;
mask_reps = mask_reps;
defined_rels = defined_rels;
- defrel_arg_type = ref []; (* built in TranslateFormula *)
+ defrel_arg_mode = ref []; (* built in TranslateFormula *)
term_arities = term_arities;
rel_default_path =
transl_arg_type_no_side defined_rel_arities init_state program
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-08-21 10:27:37 UTC (rev 1543)
@@ -2,6 +2,13 @@
val debug_level : int ref
val generate_test_case : string option ref
+(** two heuristics for selecting defined relations: select relations
+ with arity smaller than three; or, select relations that have ground
+ defining clauses (i.e. defining clauses with empty bodies). *)
+type as_defined_rels =
+ Many_by_arity | Few_by_ground_def | Fewer_by_all_ground
+val as_defined_rels : as_defined_rels ref
+
(** Limit on plys for both aggregate and random playouts. *)
val playout_horizon : int ref
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-08-21 10:27:37 UTC (rev 1543)
@@ -215,8 +215,9 @@
]
let a () =
- GDL.debug_level := 4;
+ (* GDL.debug_level := 4; *)
TranslateGame.debug_level := 4;
+ TranslateFormula.debug_level := 4;
GameSimpl.debug_level := 4;
DiscreteRule.debug_level := 4;
()
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-08-18 09:30:20 UTC (rev 1542)
+++ trunk/Toss/www/reference/reference.tex 2011-08-21 10:27:37 UTC (rev 1543)
@@ -1330,8 +1330,8 @@
state. Since an approximation is sufficient, we check only the
positive part of the legality condition of each move.
-In the future, instead of an aggregate playout we
-might use a form of type inference to approximate $\calS$.
+% In the future, instead of an aggregate playout we
+% might use a form of type inference to approximate $\calS$.
To construct the elements of the structure from state terms,
and to make that structure a good representation of the game in Toss,
@@ -1628,11 +1628,11 @@
% formulas.
%\end{definition}
-\subsection{Expanding the GDL Game Definition}
+\subsection{Expanding the GDL Game Definition}\label{expanding-gamedef}
Prior to further processing, we modify the wave clauses of the
game. Let $\calN \in \mathrm{Next}_{W}$, we add to the body of $\calN$
-a \texttt{true} atom $(\mathtt{true} \ BL(s_\calN)$ (where
+a \texttt{true} atom $(\mathtt{true} \ BL(s_\calN))$ (where
$\mathtt{BL}(t)=t\big[\calP_f \ot \mathtt{BLANK}\big]$). The added
state term will be the corresponding LHS element of the RHS element
introduced by the clause.
@@ -1669,6 +1669,10 @@
replace the atom by a disjunction of corresponding atoms, or if it is
a negative literal, by a conjunction of negated atoms.
+For simplicity, we still refer to the transformed definition as $G$,
+but it is to be understood as the result of transformation $G'$
+equivalent to the original game definition $G$.
+
\subsection{Structure Rewriting Rules}
To create the structure rewriting rule for the Toss game,
@@ -1958,12 +1962,16 @@
\subsection{Translating Formulas} \label{subsec-translate}
-First we describe translation in the case all GDL relations other than
-\texttt{next} are stable, \ie do not even indirectly depend on
-\texttt{true}. A stable GDL relation is translated as multiple stable
-Toss relations. Then we approach the GDL relations (other than
-\texttt{next}) that depend on \texttt{true} by translating them as
-defined relations in Toss.
+We translate a GDL relation as either multiple Toss stable relations
+(\ie structure relations that do not change during the game), or as
+Toss defined relation (\ie a relation given by its defining formula).
+All GDL relations that even indirectly depend on \texttt{true} need to
+be translated as defined relations. Of the remaining relations, we
+select the ones to be translated as structure (stable) relations
+heuristically. Currently, a parameter of the translation allows to:
+select relations with arity smaller than three; or, select relations
+whose (some, or all) defining clauses are ground (\ie with empty
+bodies).
\subsubsection{Stable Relations and Fluents}
@@ -1993,23 +2001,22 @@
is translated as:
\begin{align*}
- \mathrm{Tr}(\Phi_i,E) :=
+ \mathrm{Tr}(\Phi_i) :=
\exists \mathtt{BL}(\mathtt{ST}(ST^{+}_i)) \big( &
- E \wedge
+ \wedge
\TrRels(eqs_i \wedge G_i, \mathtt{ST}(ST^{+}_i), \mathtt{ST}(ST^{+}_i))
\wedge \TrST(ST^{+}_i) \wedge \\ &
- \neg \exists \big( \mathtt{BL}(\mathtt{ST}(ST^{-}_i)) \setminus
- \mathtt{BL}(\mathtt{ST}(ST^{+}_i)) \big) \big( \\ &
-\ \ \ \ \ \ \ \
-\TrRels(eqs_i \wedge G_i, \mathtt{ST}(ST^{+}_i) \cup
+ \neg \exists V^{-} \big(
+ \wedge \TrRels(eqs_i \wedge G_i, \mathtt{ST}(ST^{+}_i) \cup
\mathtt{ST}(ST^{-}_i), \mathtt{ST}(ST^{-}_i)) \wedge \\ &
\ \ \ \ \ \ \ \
-\TrST(\mathtt{NNF}(\neg ST^{-}_i)) \big) \big)
+\TrST(\mathtt{NNF}(\neg ST^{-}_i)) \big) \big) \\
+V^{-} & := \big( \mathtt{BL}(\mathtt{ST}(ST^{-}_i)) \setminus
+ \mathtt{BL}(\mathtt{ST}(ST^{+}_i)) \big)
\end{align*}
The result of translation is $\mathrm{Tr}(\Phi) :=
-\mathrm{Tr}(\Phi_1,T) \vee \ldots \vee \mathrm{Tr}(\Phi_n,T)$
-(argument $E$ is for later use).
+\mathrm{Tr}(\Phi_1) \vee \ldots \vee \mathrm{Tr}(\Phi_n)$.
We now proceed to define $\TrRels$ and $\TrST$. For an atom $r$, let
$\pm r$ mean either $r$ or $\neg r$ when on the left-hand-side, and
@@ -2027,7 +2034,7 @@
v_1 = \mathtt{BL}(s_1) \wedge \ldots \wedge v_n = \mathtt{BL}(s_n) \wedge \\
& p_1, \ldots, p_n \in \calP_m \wedge
s_1 \tpos_{p_1} = t_1 \wedge \ldots \wedge s_n \tpos_{p_n} = t_n \big\} \\
- & \textit{(when $R$ is a stable relation)} \\
+ & \textit{(when $R$ is not translated as defined relation)} \\
\TrST (\phi_1 \wedge \phi_2) = &
\TrST (\phi_1) \wedge \TrST(\phi_2) \\
\TrST (\phi_1 \vee \phi_2) = &
@@ -2044,109 +2051,113 @@
Mask_m(v) \; \big| \; v = \mathtt{BL}(t) \wedge t \in m \big\}
\end{align*}
-The case of $\TrRels$ for non-stable relations will be covered in the
-next section.
+The case of $\TrRels$ for relations intended to be translated as
+defined relations will be covered in the next section.
\subsubsection{Introducing and Using Defined Relations}
+Prior to translating formulas that use the defined relations, we need
+to transform the game definition, iteratively for each defined
+relation in the partial order of the ``call graph'', \ie whenever
+possible doing the transformation for a relation before doing it for
+relations used to define it. (We keep the convention from
+Section~\ref{expanding-gamedef}, that $G$ is substituted with the
+transformed definitions.)
+
+\paragraph{State Terms to Transfer Arguments}
+
Consider generating defined relation for relation $R$ with GDL defining clauses
-\[ \mathtt{(<= (R \ t^1_1 \ldots t^1_n) \ b_1)},
- \ldots, \mathtt{(<= (R \ t^k_1 \ldots t^k_n) \ b_k)}.\]
-For the $i$th argument of $R$ ($i \in \{1,\ldots,n\}$) we will find
-$\mathtt{ArgType}(R,i)$ with possible values
-$(\mathtt{DefSide},\calS_i,p_i)$, $(\mathtt{CallSide},p_i)$ and $(\mathtt{NoSide},p_i)$, with a mapping $\calS_i$ into state terms
-corresponding to the argument in a given context and a path $p_i \in
-\calP_m$ corresponding to the subterm position selected to
-``transfer'' the argument.
+\[ \mathtt{(<= (R \ t^1_1 \ldots t^1_n) \ b_1)}, \ldots, \mathtt{(<=
+ (R \ t^k_1 \ldots t^k_n) \ b_k)}.\] Let all atoms of $R$ in $G$
+(including both the heads $(R \ t^j_1 \ldots t^j_n)$, and inside of
+$b_j$ above) be $\calR=\big\{(R \ r^1_1 \ldots r^1_n),\ldots,(R \
+r^K_1 \ldots r^K_n)\big\}$. Based on $\calR$ we will find a partition
+of argument positions and an assignment of mask paths to positions
+$(a_1,p_1),\ldots,(a_n,p_n)$ such that $a_1=1$, $a_{i+1}-a_i \in \{0,1\}$, for any partition $\calI = \{i
+\ | \ a_i = I\}$, the paths $(p_i \ | \ i \in \calI)$ are distinct and
+do not conflict, \ie $(\exists s) (\forall p_i \ | \ i \in \calI) \
+s\tpos_{p_i}$. GDL arguments of a single partition will be passed as a
+single defined relation argument.
-Let $\mathrm{TrDistr}(b_j) = \Phi^j_1 \vee \ldots \vee \Phi^j_{m_j}$
-where $\Phi^j_l = G^j_l \wedge ST^{j+}_l \wedge ST^{j-}_l$. Let
-$\calS_i$ be a mapping from $(j,l)$ to $s^i_{j,l} \in
-\mathtt{ST}(ST^{j+}_l)$ and $p_i \in \calP_m$ a path such that
-$s^i_{j,l} \tpos_{p_i} = t^j_i$. If such a path and (total for $j,l$)
-mapping exist, then $\mathtt{ArgType}(R,i) =
-(\mathtt{DefSide},\calS_i,p_i)$.
+To find the paths and the partition, consider a clause body
+$\mathtt{b}$, any occurrence of relation $R$ atom $(R \ r^j_1 \ldots
+r^j_n)$ in $\mathtt{b}$ and positive literal $(\mathtt{true} \ s) \in
+\mathtt{b}$ (where the literal is not under disjunction). Let $\{p,i \
+| \ s \tpos_p = r^j_i \}$. We count such sets of paths for all
+$\mathtt{b}$ and positive $(\mathtt{true} \ s) \in \mathtt{b}$. We
+greedily select sets that together cover all argument positions, with
+highest size, and of equally sized with highest count. Of these, we
+build the partition by removing from the sets the path-position pairs
+where the position is already present in remaining path-position
+pairs, in order reverse to the selection criterion.
-Otherwise, let $r = R(u_1,\ldots,u_n)$ be an atom of $R$ occurring in
-a $\Phi_d = G \wedge ST^{+} \wedge ST^{-}$ disjunct of
-$\mathrm{TrDistr}$ result for arbitrary clause of the GDL game
-definition. Let $\calS_i(p)$ be a mapping from $\Phi_d$ to
-$s^i_{\Phi_d} \in \mathtt{ST}(ST^{+})$ with $p \in \calP_m$ a path
-such that $s^i_{\Phi_d} \tpos_p = u_i$, whenever such $s^i_{\Phi_d}
-\in \mathtt{ST}(ST^{+})$ exists. Let $p_i$ be such that the size of
-the domain of $\calS_i(p_i)$ is maximal. Set $\mathtt{ArgType}(R,i) =
-(\mathtt{CallSide},p_i)$.
+In case no set of paths contains a path for the $i$th argument, we set
+the path $p_i \in \calP_m$ (with a unique $a_i$) so that the
+intersection of the projection of the graph of $R$ for the initial
+game state $g_{R,i} = \{s | G \vdash R(t_1,\ldots,t_n) \textit{ for
+ any } \ol{t} \textit{ s.t. } t_i = s\}$, and the set of subterms of
+state terms at path $p_i$, $g_{p_i} = \{s \tpos_{p_i} | s \in
+\calS\}$, is maximal w.r.t. cardinality ($p_i = \arg \max_{p \in
+ \calP_m} \left| g_{R,i} \cap g_p \right|$).
-In case neither $\mathtt{DefSide}$ nor $\mathtt{CallSide}$ approach is
-satisfactory, we set $\mathtt{ArgType}(R,i) = (\mathtt{NoSide},p_i)$,
-where the path $p_i \in \calP_m$ is selected so that the intersection
-of the projection of the graph of $R$ for the initial game state
-$g_{R,i} = \{s | G \vdash R(t_1,\ldots,t_n) \textit{ for any }
-\ol{t} \textit{ s.t. } t_i = s\}$, and the set of subterms of state
-terms at path $p_i$, $g_{p_i} = \{s \tpos_{p_i} | s \in \calS\}$, is
-maximal w.r.t. cardinality ($p_i = \arg \max_{p \in \calP_m} \left|
- g_{R,i} \cap g_p \right|$).
+Ideally, $p_i \in \calP_m$ should be a path whose domain, \ie the set
+$\big\{t \big| s\tpos_{p_i} = t, s \in \calS\big\}$, contains the
+domain of the $i$th argument of $R$, \ie the sum of projections of $R$
+on $i$th argument for all possible game states. We do not guarantee
+this.
-For correctness, $p_i \in \calP_m$ should be a path whose domain, \ie
-the set $\big\{t \big| s\tpos_{p_i} = t, s \in \calS\big\}$, contains
-the domain of the $i$th argument of $R$, \ie the sum of projections of
-$R$ on $i$th argument for all possible game states. The current
-definition above does not guarantee this; the exact implementation may
-further evolve as $\mathtt{ArgType}$ is relevant for the quality of
-translation (\ie both for correctness and how many simplifications can
-be applied, see Section~\ref{sec-game-simpl}).
+Once the paths for arguments have been selected, we make sure that a
+clause in $G$ that has an atom $(R \ r^1_1 \ldots r^1_n)$, has the
+positive literals $(\mathtt{true} \ s_\calI)$ such that $\bigwedge_{i
+ \in \calI} s_\calI \tpos_{p_i} = r^j_i$. For every $\calI$ for which
+such a positive literal does not occur in the clause body, we add an
+atom $\big(\mathtt{true} \ \mathtt{BL}(\{p_i \ot r^j_i \ | \ i \in
+\calI\})\big)$ to the clause. The notation $\mathtt{BL}(\{p_i \ot t_i \ | \
+i \in \calI\})$ for a paths $p_i$ and terms $t_i$ denotes a state term
+containing $t_i$ at path $p_i$, and $\mathtt{BLANK}$ as subterms at
+all its positions that are not on any path $p_i$ (\ie are not prefixes
+of any $p_i$).
-We are ready to provide the translated definition $R_{def}$. Let
-$v_1,\ldots,v_n$ be fresh Toss variables, let $\calI_R = \big\{i
-\big| \mathtt{ArgType}(R,i) =
-(\mathtt{DefSide},\calS_i,p_i)\big\}$ and $p_{R,i}$ be such that
-$\mathtt{ArgType}(R,i) =
-(\mathtt{DefSide},\calS_i,p_{R,i})$ or $\mathtt{ArgType}(R,i) =
-(\mathtt{CallSide},p_{R,i})$. Let $\mathtt{BL}(p \ot t)$ for
-a path $p$ and term $t$ be a state term containing $t$ at path $p$,
-and $\mathtt{BLANK}$ as subterms at all its positions that are not on
-path $p$ (\ie are not prefixes of $p$). Using notation introduced
-above, let
+\paragraph{Translating Defined Relations}
+Recall the definitions introduced above to generate state terms to
+transfer arguments for translating a relation $R$ as defined
+relation. Let $(a_1,p_1),\ldots,(a_n,p_n)$ be the partition of $R$
+arguments and their paths, $a_n = N$, and $\calI_m = \{i \ | \ a_i = m\}$ (for $m \in \{1,\ldots,N\}$). Let
+$v_1,\ldots,v_N$ be fresh Toss variables.
+
+Recall that each $(R \ t^l_1 \ldots t^l_n)$ is also a $(R \ r^{j_l}_1
+\ldots r^{j_l}_n) \in \calR$ for some $j_l$. Therefore, there exist
+positive \texttt{true} literals $(\mathtt{true} \
+s^l_1),\ldots,(\mathtt{true} \ s^l_N)$ in the body $b_l$ such that
+$(\forall p_i \ | \ i \in \calI_m) \ s^l_m\tpos_{p_i}$. Let $V^l =
+\{\mathtt{BL}(s^l_1),\ldots,\mathtt{BL}(s^l_N)\}$. The translated definition
+$R_{def}$ is:
+
\begin{align*}
-E_{j,l} = &
- \bigwedge \big\{v_i=s^i_{j,l} \big| i \in \calI\big\} \wedge
- \bigwedge\big\{v_i=\mathtt{BL}(p_i \ot t^j_i) \big|
- i \in \{1,\ldots,n\} \setminus \calI\big\} \\
-S_{j,l} = &
-\bigwedge\big\{\mathtt{true}\big(\mathtt{BL}(p_i \ot t^j_i)\big) \big|
-i \in \{1,\ldots,n\} \setminus \calI\big\}
+ R_{def}(v_1,\ldots,v_N) = &
+ \mathrm{TrDefR}((<= (R \ t^1_1 \ldots t^1_n) \ b_1)) \\
+ & \vee \ldots \vee \\
+ & \mathrm{TrDefR}((<= (R \ t^k_1 \ldots t^k_n) \ b_k)) \\
+ \mathrm{TrDefR}((<= (R \ t_1 \ldots t_n) \ b)) = & (\exists{V^l})\big(
+ v_1=\mathtt{BL}(s_1) \wedge \ldots \wedge v_N=\mathtt{BL}(s_N) \wedge
+ \mathtt{Erase}_{V^l} (\mathtt{Tr}(b_l)) \big)
\end{align*}
+where $\mathtt{Erase}_V(\phi)$ erases all quantification over
+variables from $V$ in formula $\phi$.
-The translation is:
+It remains to define $\TrRels$ for the case of defined relations. Let
+$R$ be $N$, $p_1,\ldots,p_n$, $\calI_1,\ldots,\calI_N$ be as
+introduced for $R$. Since $(R \ r_1 \ldots r_n) \in \calR$, there
+exist $s_1,\ldots,s_N \in \calS_1$ such that $(\forall p_i \ | \ i \in
+\calI_m) \ s_m\tpos_{p_i}$. Put
\[
-R_{def}(v_1,\ldots,v_n) =
-\mathrm{Tr}(S_{1,1} \wedge \Phi^1_1,E_{1,1}) \vee \ldots
-\vee \mathrm{Tr}(S_{k,m_k} \wedge \Phi^k_{m_k},E_{k,m_k})
+ \TrRels (\pm R(r_1, \ldots, r_n), S_1, S_2) =
+ \pm R_{def}(\mathtt{BL}(s_1),\ldots,\mathtt{BL}(s_N)).
\]
-It remains to define $\TrRels$ for the case of non-stable GDL relations:
-\begin{align*}
- \TrRels (\pm R(t_1, \ldots, t_n), S_1, S_2) = &
- \exists \{v_i \ | \ i \in \calJ \} \big(
- \pm R_{def}(v_1, \ldots, v_n) \wedge \\ &
- \Land \big\{
- \TrRels (\mathtt{EQ}(t_i,t_i),
- S_1 \cup \{v_i\}, \{v_i\})
- \ \big| \ i \in \calJ \big\} \big) \\ &
- \textit{(when $R$ is not a stable relation)} \\
- \textit{where} \\
- \calJ = &
- \big\{i \ \big| \ i \in \calI_R \vee
- \neg \exists s \in S_1 (s\tpos_{p_{R,i}} = t_i) \big\} \\
- v_i = \mathtt{BL}(p_{R,i}\ot t_i) & \textit{ if } i \in \calJ \\
- v_i = \mathtt{BL}(s) & \textit{ if } i \not\in \calJ
- \textit{ where $s$ such that } s \in S_1 \wedge s\tpos_{p_{R,i}} = t_i
-\end{align*}
-
-
\subsection{Concurrent Moves and Toss Locations} \label{subsec-concurrency}
In Section~\ref{subsec-rules}, we described the creation of
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
Thanks for helping keep SourceForge clean.
X