Thread: [Toss-devel-svn] SF.net SVN: toss:[1282] trunk/Toss (Page 3)
Status: Beta
Brought to you by:
lukaszkaiser
From: <luk...@us...> - 2011-01-19 20:57:23
|
Revision: 1282 http://toss.svn.sourceforge.net/toss/?rev=1282&view=rev Author: lukaszkaiser Date: 2011-01-19 20:57:15 +0000 (Wed, 19 Jan 2011) Log Message: ----------- Some more html corrections. Modified Paths: -------------- trunk/Toss/WebClient/Login.js trunk/Toss/WebClient/Style.css trunk/Toss/WebClient/contact.html trunk/Toss/WebClient/index.html trunk/Toss/WebClient/profile.html trunk/Toss/WebClient/register.html trunk/Toss/www/index.php Modified: trunk/Toss/WebClient/Login.js =================================================================== --- trunk/Toss/WebClient/Login.js 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/WebClient/Login.js 2011-01-19 20:57:15 UTC (rev 1282) @@ -110,6 +110,10 @@ } } +function login_onenter () { + if (window.event && window.event.keyCode == 13) { login() } +} + // Logout function logout () { clear_view (); @@ -208,3 +212,19 @@ if (resp != "OK") { alert(resp); } window.location.reload (); } + + +// Email address obfuscation to prevent some spamming. +function begin_mailto (name, domain, title) { + var address = name + '@' + domain; + if(title) { + document.write("<a class='mail' href='mailto:" + address + "'>" + "<span>"); + } else { + document.write("<a class='mail' href='mailto:" + address + "'>" + + address + "<span style='display: none;'>"); + } +} + +function end_mailto() { + document.write("</span></a>"); +} Modified: trunk/Toss/WebClient/Style.css =================================================================== --- trunk/Toss/WebClient/Style.css 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/WebClient/Style.css 2011-01-19 20:57:15 UTC (rev 1282) @@ -345,12 +345,12 @@ /* Content */ -.mail { +.mail, .ta { color: #260314; text-decoration: underline; } -.mail:hover { +.mail:hover, .ta:hover { cursor: pointer; text-decoration: none; } @@ -404,6 +404,15 @@ left: 1em; } +.welcome-list { + list-style: square; + padding-left: 1.5em; +} + +.welcome-list li { + margin-top: 0.5em; +} + #users-list { list-style: none; padding-left: 1.5em; @@ -475,14 +484,14 @@ #welcome { text-align: justify; - margin-top: 3.5em; - margin-left: 1em; + margin-top: 5em; + margin-left: 2em; } #welcome-top { font-size: 1.2em; font-weight: bold; - padding-left: 1.25em; + padding-left: 0em; } #game-disp { Modified: trunk/Toss/WebClient/contact.html =================================================================== --- trunk/Toss/WebClient/contact.html 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/WebClient/contact.html 2011-01-19 20:57:15 UTC (rev 1282) @@ -3,24 +3,11 @@ <head> <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" /> <title>tPlay — Contact</title> - <meta http-equiv="X-UA-Compatible" content="chrome=1"> + <meta http-equiv="X-UA-Compatible" content="chrome=1" /> <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" /> <link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" /> <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/> - <script type="text/javascript"> - function begin_mailto (name, domain, title) { - var address = name + '@' + domain; - if(title) { - document.write("<a class='mail' href='mailto:" + address + "'>" + "<span>"); - } else { - document.write("<a class='mail' href='mailto:" + address + "'>" + - address + "<span style='display: none;'>"); - } - } - function end_mailto() { - document.write("</span></a>"); - } - </script> + <script type="text/javascript" src="Login.js"> </script> </head> <body> @@ -40,6 +27,14 @@ tossplay [AT] gmail [DOT] com <script type="text/javascript">end_mailto();</script> +<h2>Links</h2> + +<ul> +<li><a class="ta" href="http://toss.sourceforge.net/">Toss Homepage</a></li> +<li><a class="ta" href="http://www.playok.com/">Online games on PlayOK</a></li> +<li><a class="ta" href="http://apronus.com/chess/index.htm">Chess on Apronus</a></li> +</ul> + </div> <div id="bottom"> Modified: trunk/Toss/WebClient/index.html =================================================================== --- trunk/Toss/WebClient/index.html 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/WebClient/index.html 2011-01-19 20:57:15 UTC (rev 1282) @@ -3,7 +3,9 @@ <head> <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" /> <title>tPlay</title> - <meta http-equiv="X-UA-Compatible" content="chrome=1"> + <meta name="Description" + content="Play the best strategic games online with a nice interface." /> + <meta http-equiv="X-UA-Compatible" content="chrome=1" /> <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" /> <link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" /> <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/> @@ -22,7 +24,7 @@ <div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div> <div id="topbar"> <span id="topuser"></span> -<form id="loginform" style="display: inline;"> +<form id="loginform" style="display: inline;" action=""> <div id="login1"> <p class="loginsmall">Username:</p> <input class="loginput" type="text" name="username" id="username" size="15" /> @@ -30,14 +32,13 @@ <div id="login2"> <p class="loginsmall">Password:</p> <input class="loginput" type="password" name="password" id="password" size="15" - onkeypress="if (window.event && window.event.keyCode == 13) { login() }" - /> + onkeypress="login_onenter()" /> </div> <div id="login3"> <p class="loginchk"> <input type="checkbox" id="remember" value="r" - checked="yes"><span id="rememberspan">Remember me</span> - </input> + checked="checked" /> + <span id="rememberspan">Remember me</span> </p> <button type="button" id="loginbt" onclick="login()"> <span id="loginspan">Login</span> @@ -60,7 +61,7 @@ onclick="window.location.reload()">Find New</a> <button class="bt" id="opponents-cancel" onclick="window.location.reload()">Cancel</button> - <ul id="opponents-list"></ul> + <ul id="opponents-list"><li style="display: none;"/></ul> <button class="bt" id="opponents-prev" onclick="opponents_prev()">Prev</button> <button class="bt" id="opponents-next" @@ -68,16 +69,25 @@ </div> <div id="welcome"> -<p id="welcome-top">Enjoy games on <span class="logo-in">tPlay</span></p> +<p id="welcome-top">Enjoy the best games on <span class="logo-in">tPlay</span> for free</p> <p> Strategic games are fun! - <a href="register.html">Register</a>, login and enjoy - <span class="logo-in">tPlay</span>!</p> + <a href="register.html">Register</a>, login and enjoy quality games + with our best interface on <span class="logo-in">tPlay</span>! +</p> +<ul class="welcome-list"> +<li>Play Breakthrough, Checkers, Chess, Gomoku and many other board games</li> +<li>Challenge your friends or play a fast game against the computer for fun</li> +<li>Focus fully on the game thanks to our intuitive clean interface</li> +<li>Keep and analyze your games to improve your strength</li> +<li>Invent new games with <a href="http://toss.sourceforge.net/">Toss</a> + and play them online here</li> +</ul> </div> <div id="nosvg" style="border: 1px solid #260314; padding-left: 1em; display: none;"> -<p style="padding-left: 1.2em; font-size: 1.2em;"<b>SVG Support Missing</b></p> +<p style="padding-left: 1.2em; font-size: 1.2em;"><b>SVG Support Missing</b></p> <p>Your browser does not seem to support SVG, which is <b>necessary</b> to enjoy tPlay. To correct this problem install the following plugin.</p> @@ -100,38 +110,50 @@ class="boldobt">Breakthrough</button> (<a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)">info</a>) </p> - <ul class="plays-list" id="plays-list-Breakthrough"></ul> + <ul class="plays-list" id="plays-list-Breakthrough"> + <li style="display: none;"/> + </ul> <p class="game-par"> <button onclick="new_play('Checkers')" class="boldobt">Checkers</button> (<a href="http://en.wikipedia.org/wiki/English_draughts">info</a>) </p> - <ul class="plays-list" id="plays-list-Checkers"></ul> + <ul class="plays-list" id="plays-list-Checkers"> + <li style="display: none;"/> + </ul> <p class="game-par"> <button onclick="new_play('Chess')" class="boldobt">Chess</button> (<a href="http://en.wikipedia.org/wiki/Chess">info</a>) </p> - <ul class="plays-list" id="plays-list-Chess"></ul> + <ul class="plays-list" id="plays-list-Chess"> + <li style="display: none;"/> + </ul> <p class="game-par"> <button onclick="new_play('Entanglement')" class="boldobt">Entanglement</button> (<a href="http://en.wikipedia.org/wiki/Entanglement_(graph_measure)" >info</a>) </p> - <ul class="plays-list" id="plays-list-Entanglement"></ul> + <ul class="plays-list" id="plays-list-Entanglement"> + <li style="display: none;"/> + </ul> <p class="game-par"> <button onclick="new_play('Gomoku')" class="boldobt">Gomoku</button> (<a href="http://en.wikipedia.org/wiki/Gomoku">info</a>) </p> - <ul class="plays-list" id="plays-list-Gomoku"></ul> + <ul class="plays-list" id="plays-list-Gomoku"> + <li style="display: none;"/> + </ul> <p class="game-par"> <button onclick="new_play('Tic-Tac-Toe')" class="boldobt">Tic-Tac-Toe</button> (<a href="http://en.wikipedia.org/wiki/Tic-tac-toe">info</a>) </p> - <ul class="plays-list" id="plays-list-Tic-Tac-Toe"></ul> + <ul class="plays-list" id="plays-list-Tic-Tac-Toe"> + <li style="display: none;"/> + </ul> </div> @@ -151,7 +173,7 @@ <button id="sugbt" class="bt" onclick="suggest_move()"> Suggest (weak, fast) </button> - <button id="sugbt" class="bt" onclick="suggest_move_better()"> + <button id="sugbts" class="bt" onclick="suggest_move_better()"> Suggest (stronger, slow) </button> </p> Modified: trunk/Toss/WebClient/profile.html =================================================================== --- trunk/Toss/WebClient/profile.html 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/WebClient/profile.html 2011-01-19 20:57:15 UTC (rev 1282) @@ -3,7 +3,7 @@ <head> <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" /> <title>tPlay — Profile</title> - <meta http-equiv="X-UA-Compatible" content="chrome=1"> + <meta http-equiv="X-UA-Compatible" content="chrome=1" /> <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" /> <link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" /> <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/> @@ -15,11 +15,14 @@ </head> <body onload="startup_profile()"> + +<div id="main"> + <div id="top"> <div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div> <div id="topbar"> <span id="topuser"></span> -<form id="loginform" style="display: inline;"> +<form id="loginform" style="display: inline;" action=""> <div id="login1"> <p class="loginsmall">Username:</p> <input class="loginput" type="text" name="username" id="username" size="15" /> @@ -27,14 +30,13 @@ <div id="login2"> <p class="loginsmall">Password:</p> <input class="loginput" type="password" name="password" id="password" size="15" - onkeypress="if (window.event && window.event.keyCode == 13) { login() }" - /> + onkeypress="login_onenter()" /> </div> <div id="login3"> <p class="loginchk"> <input type="checkbox" id="remember" value="r" - checked="yes"><span id="rememberspan">Remember me</span> - </input> + checked="checked"/> + <span id="rememberspan">Remember me</span> </p> <button type="button" id="loginbt" onclick="login()"> <span id="loginspan">Login</span> @@ -49,10 +51,7 @@ <a href="register.html">Register</a> </span> </div> -</div> -<div id="main"> - <div id="welcome"> <p id="welcome-top">To edit your <span class="logo-in">tPlay</span> profile please login above or <a href="register.html">register</a> first. @@ -62,7 +61,7 @@ <div id="main-profile" style="display: none;"> <h2>Your Profile</h2> -<form id="changeprofileform"> +<form id="changeprofileform" action=""> <p> <span class="reglabel">Name:</span> <input class="forminput" type="text" name="name" id="name" /> </p> @@ -72,30 +71,30 @@ <p> <span class="reglabel">Email:</span> <input class="forminput" type="text" name="email" id="email" /> </p> -<button class="bt" id="changebt" type="button" - onclick="change_profile()">Change</button> +<p><button class="bt" id="changebt" type="button" + onclick="change_profile()">Change</button></p> </form> <h2>Your Current Opponents</h2> <div id="opponents-profile"> - <ul id="opponents-list"></ul> + <ul id="opponents-list"><li style="display: none;"/></ul> </div> <h2>Suggested New Opponents</h2> <div id="users-profile"> - <ul id="users-list"></ul> + <ul id="users-list"><li style="display: none;"/></ul> </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> </div> +</div> + </body> </html> Modified: trunk/Toss/WebClient/register.html =================================================================== --- trunk/Toss/WebClient/register.html 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/WebClient/register.html 2011-01-19 20:57:15 UTC (rev 1282) @@ -3,7 +3,7 @@ <head> <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" /> <title>tPlay — Registration</title> - <meta http-equiv="X-UA-Compatible" content="chrome=1"> + <meta http-equiv="X-UA-Compatible" content="chrome=1" /> <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" /> <link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" /> <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/> @@ -13,17 +13,18 @@ </head> <body> + +<div id="main"> + <div id="top"> <div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div> </div> -<div id="main"> - <div id="register-content"> <h2>Register on tPlay</h2> -<form id="registerform"> +<form id="registerform" action=""> <p> <span class="reglabel">Username:</span> <input class="forminput" type="text" name="username" id="username" /> </p> <p> <span class="reglabel">Password:</span> @@ -42,17 +43,17 @@ <p> <span class="reglabel">Email:</span> <input class="forminput" type="text" name="email" id="email" /> </p> -<button class="bt" id="registerbt" type="button" onclick="register()">Register</button> +<p><button class="bt" id="registerbt" type="button" onclick="register()">Register</button></p> </form> </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> </div> +</div> + </body> </html> Modified: trunk/Toss/www/index.php =================================================================== --- trunk/Toss/www/index.php 2011-01-13 19:33:52 UTC (rev 1281) +++ trunk/Toss/www/index.php 2011-01-19 20:57:15 UTC (rev 1282) @@ -1,6 +1,7 @@ <?php @include "site_template.php"; $prefix = ""; +$style = ""; $url = "index.php"; $title = "Toss Home Page"; @@ -13,6 +14,9 @@ did you ever wonder how your favorite game would feel if you removed the middle of the board? With Toss, it is easy to experiment!</p> <ul> +<li style="margin: 0.5em"><b>Play</b> Toss games online at + <a href="http://tplay.org"> + tPlay.org</a>.</li> <li style="margin: 0.5em"><b>Download</b> Toss from the <a href="http://sourceforge.net/project/showfiles.php?group_id=115606"> Sourceforge Download Page</a>.</li> This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-21 20:46:19
|
Revision: 1283 http://toss.svn.sourceforge.net/toss/?rev=1283&view=rev Author: lukaszkaiser Date: 2011-01-21 20:46:12 +0000 (Fri, 21 Jan 2011) Log Message: ----------- Extending structure parser to add positions in line when requested, using it to shorten game descriptions. Modified Paths: -------------- trunk/Toss/Solver/Structure.ml trunk/Toss/Solver/Structure.mli trunk/Toss/Solver/StructureParser.mly trunk/Toss/Solver/StructureTest.ml trunk/Toss/examples/Breakthrough.toss trunk/Toss/examples/Checkers.toss trunk/Toss/examples/Chess.toss trunk/Toss/examples/Gomoku.toss trunk/Toss/examples/Pawns.toss trunk/Toss/examples/Tic-Tac-Toe.toss Modified: trunk/Toss/Solver/Structure.ml =================================================================== --- trunk/Toss/Solver/Structure.ml 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/Solver/Structure.ml 2011-01-21 20:46:12 UTC (rev 1283) @@ -312,6 +312,14 @@ | None -> empty_structure () | Some s -> s in add_from_lists struc els rels funs + +let create_from_lists_position ?struc els rels = + let s = create_from_lists ?struc els rels [] in + let elems = Elems.elements s.elements in + let zero = List.map (fun e -> (e, 0.)) elems in + let next = List.map (fun e -> (e, cBOARD_DX*. (float_of_int (e-1)))) elems in + let afuns s (fn, asg) = add_funs s fn asg in + List.fold_left afuns s [("x", next); ("y", zero); ("vx", zero); ("vy", zero)] (* ---------- REMOVING RELATION TUPLES AND ELEMENTS FROM A STRUCTURE -------- *) Modified: trunk/Toss/Solver/Structure.mli =================================================================== --- trunk/Toss/Solver/Structure.mli 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/Solver/Structure.mli 2011-01-21 20:46:12 UTC (rev 1283) @@ -172,7 +172,10 @@ (string * int option * string array list) list -> (string * (string * float) list) list -> structure +val create_from_lists_position : ?struc:structure -> string list -> + (string * int option * string array list) list -> structure + (** {2 Removing relation tuples and elements from a structure} *) (** Remove the tuple [tp] from relation [rn] in structure [struc]. May Modified: trunk/Toss/Solver/StructureParser.mly =================================================================== --- trunk/Toss/Solver/StructureParser.mly 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/Solver/StructureParser.mly 2011-01-21 20:46:12 UTC (rev 1283) @@ -69,6 +69,12 @@ { fun struc -> create_from_lists ~struc elems rels funs } | OPENSQ + elems = separated_list (COMMA, id_int) + MID + rels = separated_list (SEMICOLON, rel_expr) + MID MINUS CLOSESQ + { fun struc -> create_from_lists_position ~struc elems rels } + | OPENSQ separated_list (COMMA, id_int) MID separated_list (SEMICOLON, rel_expr) Modified: trunk/Toss/Solver/StructureTest.ml =================================================================== --- trunk/Toss/Solver/StructureTest.ml 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/Solver/StructureTest.ml 2011-01-21 20:46:12 UTC (rev 1283) @@ -54,6 +54,9 @@ ~result:"[a | P (a) | f {a->1.3}]" "[ a | P{a} | f { a-> 1.3 } ]"; test_parse + ~result:"[a | P (a) | vx {a->0.}; vy {a->0.}; x {a->0.}; y {a->0.}]" + "[ a | P{a} | - ]"; + test_parse ~result:"[a, b, c | | f {a->1.3, b->2., c->2.}]" "[ | | f { a-> 1.3, b->2, c->3.3 } ; f { c -> 2 } ]"; test_parse Modified: trunk/Toss/examples/Breakthrough.toss =================================================================== --- trunk/Toss/examples/Breakthrough.toss 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/examples/Breakthrough.toss 2011-01-21 20:46:12 UTC (rev 1283) @@ -3,12 +3,10 @@ REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y))) REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y))) RULE WhiteDiag: - [ a, b | W { a }; _opt_B { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | W { a }; _opt_B { b } | - ] -> - [ a, b | W { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x)) + [ a, b | W { b } | - ] + emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x)) RULE WhiteStraight: [ | B:1 {}; R:2 {} | ] " @@ -23,12 +21,10 @@ . " emb W, B pre not ex x (B(x) and not ex y C(y, x)) RULE BlackDiag: - [ a, b | B { a }; _opt_W { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | B { a }; _opt_W { b } | - ] -> - [ a, b | B { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y)) + [ a, b | B { b } | - ] + emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y)) RULE BlackStraight: [ | R:2 {}; W:1 {} | ] " Modified: trunk/Toss/examples/Checkers.toss =================================================================== --- trunk/Toss/examples/Checkers.toss 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/examples/Checkers.toss 2011-01-21 20:46:12 UTC (rev 1283) @@ -22,167 +22,67 @@ REL BJumps() = ex x, y ((B(x) and BeatsB (x, y)) or (Bq(x) and BeatsBX (x, y))) REL WJumps() = ex x, y ((W(x) and BeatsW (x, y)) or (Wq(x) and BeatsWX (x, y))) RULE RedMove: - [ a, b | W { a } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - -> - [ a, b | W { b } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) - and not WJumps() + [ a, b | W { a } | - ] -> [ a, b | W { b } | - ] emb w, b + pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps() RULE WhiteMove: - [ a, b | B { a } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - -> - [ a, b | B { b } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) - and not BJumps() + [ a, b | B { a } | - ] -> [ a, b | B { b } | - ] emb w, b + pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps() RULE RedPromote: - [ a, b | W { a } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - -> - [ a, b | Wq { b } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) - and not WJumps() + [ a, b | W { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b + pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps() RULE WhitePromote: - [ a, b | B { a } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - -> - [ a, b | Bq { b } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) - and not BJumps() + [ a, b | B { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b + pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps() RULE RedQMove: - [ a, b | Wq { a } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - -> - [ a, b | Wq { b } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre AnyDiag (a, b) and not WJumps() + [ a, b | Wq { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b + pre AnyDiag (a, b) and not WJumps() RULE WhiteQMove: - [ a, b | Bq { a } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - -> - [ a, b | Bq { b } | - vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre AnyDiag (a, b) and not BJumps() + [ a, b | Bq { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b + pre AnyDiag (a, b) and not BJumps() RULE RedBeat: - [ a, b, c | W { a }; b { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | W { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre DiagW2 (a, b, c) and not IsEight(c) - post not ex x, y (_new_W(x) and BeatsWX (x, y)) + [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b + pre DiagW2 (a, b, c) and not IsEight(c) + post not ex x, y (_new_W(x) and BeatsWX (x, y)) RULE WhiteBeat: - [ a, b, c | B { a }; w { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | B { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre DiagB2 (a, b, c) and not IsFirst(c) - post not ex x, y (_new_B(x) and BeatsBX (x, y)) + [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b + pre DiagB2 (a, b, c) and not IsFirst(c) + post not ex x, y (_new_B(x) and BeatsBX (x, y)) RULE RedBeatBoth: - [ a, b, c | W { a }; b { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | W { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c) - post not ex x, y (_new_W(x) and BeatsWX (x, y)) + [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b + pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c) + post not ex x, y (_new_W(x) and BeatsWX (x, y)) RULE WhiteBeatBoth: - [ a, b, c | B { a }; w { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | B { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c) - post not ex x, y (_new_B(x) and BeatsBX (x, y)) + [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b + pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c) + post not ex x, y (_new_B(x) and BeatsBX (x, y)) RULE RedBeatPromote: - [ a, b, c | W { a }; b { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | Wq { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre DiagW2 (a, b, c) and IsEight(c) + [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b + pre DiagW2 (a, b, c) and IsEight(c) RULE WhiteBeatPromote: - [ a, b, c | B { a }; w { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | Bq { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre DiagB2 (a, b, c) and IsFirst(c) + [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b + pre DiagB2 (a, b, c) and IsFirst(c) RULE RedBeatCont: - [ a, b, c | W { a }; b { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | W { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre DiagW2 (a, b, c) and not IsEight(c) - post ex x, y (_new_W(x) and BeatsWX (x, y)) + [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b + pre DiagW2 (a, b, c) and not IsEight(c) + post ex x, y (_new_W(x) and BeatsWX (x, y)) RULE WhiteBeatCont: - [ a, b, c | B { a }; w { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | B { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre DiagB2 (a, b, c) and not IsFirst(c) - post ex x, y (_new_B(x) and BeatsBX (x, y)) + [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b + pre DiagB2 (a, b, c) and not IsFirst(c) + post ex x, y (_new_B(x) and BeatsBX (x, y)) RULE RedBeatBothCont: - [ a, b, c | W { a }; b { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | W { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c) - post ex x, y (_new_W(x) and BeatsWX (x, y)) + [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b + pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c) + post ex x, y (_new_W(x) and BeatsWX (x, y)) RULE WhiteBeatBothCont: - [ a, b, c | B { a }; w { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | B { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c) - post ex x, y (_new_B(x) and BeatsBX (x, y)) + [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b + pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c) + post ex x, y (_new_B(x) and BeatsBX (x, y)) RULE RedQBeat: - [ a, b, c | Wq { a }; b { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | Wq { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre Diag2 (a, b, c) + [ a, b, c | Wq { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b + pre Diag2 (a, b, c) RULE WhiteQBeat: - [ a, b, c | Bq { a }; w { b } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - -> - [ a, b, c | Bq { c } | - vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.}; - x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ] - emb w, b pre Diag2 (a, b, c) + [ a, b, c | Bq { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b + pre Diag2 (a, b, c) LOC 0 { PLAYER 1 PAYOFF { Modified: trunk/Toss/examples/Chess.toss =================================================================== --- trunk/Toss/examples/Chess.toss 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/examples/Chess.toss 2011-01-21 20:46:12 UTC (rev 1283) @@ -231,103 +231,75 @@ bQ " emb w, b pre IsFirst(a1) post not CheckB() RULE WhiteKnight: - [ a, b | wN { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wN { a }; _opt_b { b } | - ] -> - [ a, b | wN { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Knight(a, b) post not CheckW() + [ a, b | wN { b } | - ] + emb w, b pre Knight(a, b) post not CheckW() RULE BlackKnight: - [ a, b | bN { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bN { a }; _opt_w { b } | - ] -> - [ a, b | bN { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Knight(a, b) post not CheckB() + [ a, b | bN { b } | - ] + emb w, b pre Knight(a, b) post not CheckB() RULE WhiteBishop: - [ a, b | wB { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wB { a }; _opt_b { b } | - ] -> - [ a, b | wB { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Diag(a, b) post not CheckW() + [ a, b | wB { b } | - ] + emb w, b pre Diag(a, b) post not CheckW() RULE BlackBishop: - [ a, b | bB { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bB { a }; _opt_w { b } | - ] -> - [ a, b | bB { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Diag(a, b) post not CheckB() + [ a, b | bB { b } | - ] + emb w, b pre Diag(a, b) post not CheckB() RULE WhiteRook: - [ a, b | wR { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wR { a }; _opt_b { b } | - ] -> - [ a, b | wR { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre not IsA1(a) and not IsH1(a) and Line(a, b) post not CheckW() + [ a, b | wR { b } | - ] + emb w, b pre not IsA1(a) and not IsH1(a) and Line(a, b) post not CheckW() RULE WhiteRookA1: - [ a, b | wR { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wR { a }; _opt_b { b } | - ] -> - [ a, b | wR { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre IsA1(a) and Line(a, b) post not CheckW() + [ a, b | wR { b } | - ] + emb w, b pre IsA1(a) and Line(a, b) post not CheckW() RULE WhiteRookH1: - [ a, b | wR { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wR { a }; _opt_b { b } | - ] -> - [ a, b | wR { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre IsH1(a) and Line(a, b) post not CheckW() + [ a, b | wR { b } | - ] + emb w, b pre IsH1(a) and Line(a, b) post not CheckW() RULE BlackRook: - [ a, b | bR { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bR { a }; _opt_w { b } | - ] -> - [ a, b | bR { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre not IsA8(a) and not IsH8(a) and Line(a, b) post not CheckB() + [ a, b | bR { b } | - ] + emb w, b pre not IsA8(a) and not IsH8(a) and Line(a, b) post not CheckB() RULE BlackRookA8: - [ a, b | bR { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bR { a }; _opt_w { b } | - ] -> - [ a, b | bR { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre IsA8(a) and Line(a, b) post not CheckB() + [ a, b | bR { b } | - ] + emb w, b pre IsA8(a) and Line(a, b) post not CheckB() RULE BlackRookH8: - [ a, b | bR { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bR { a }; _opt_w { b } | - ] -> - [ a, b | bR { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre IsH8(a) and Line(a, b) post not CheckB() + [ a, b | bR { b } | - ] + emb w, b pre IsH8(a) and Line(a, b) post not CheckB() RULE WhiteQueen: - [ a, b | wQ { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wQ { a }; _opt_b { b } | - ] -> - [ a, b | wQ { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW() + [ a, b | wQ { b } | - ] + emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW() RULE BlackQueen: - [ a, b | bQ { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bQ { a }; _opt_w { b } | - ] -> - [ a, b | bQ { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB() + [ a, b | bQ { b } | - ] + emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB() RULE WhiteKing: - [ a, b | wK { a }; _opt_b { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | wK { a }; _opt_b { b } | - ] -> - [ a, b | wK { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Near(a, b) post not CheckW() + [ a, b | wK { b } | - ] + emb w, b pre Near(a, b) post not CheckW() RULE BlackKing: - [ a, b | bK { a }; _opt_w { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | bK { a }; _opt_w { b } | - ] -> - [ a, b | bK { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Near(a, b) post not CheckB() + [ a, b | bK { b } | - ] + emb w, b pre Near(a, b) post not CheckB() RULE WhiteLeftCastle: [ | | ] " ... ... ... Modified: trunk/Toss/examples/Gomoku.toss =================================================================== --- trunk/Toss/examples/Gomoku.toss 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/examples/Gomoku.toss 2011-01-21 20:46:12 UTC (rev 1283) @@ -15,14 +15,14 @@ REL WinP() = ex x,y,z,v,w (P(x) and P(y) and P(z) and P(v) and P(w) and Conn5(x,y,z,v,w)) RULE Cross: - [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] + [a1 | P:1 {}; Q:1 {} | - ] -> - [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] + [a1 | P (a1); Q:1 {} | - ] emb Q, P pre not WinQ() RULE Circle: - [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] + [a1 | P:1 {}; Q:1 {} | - ] -> - [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] + [a1 | P:1 {}; Q (a1) | - ] emb Q, P pre not WinP() LOC 0 { PLAYER 1 Modified: trunk/Toss/examples/Pawns.toss =================================================================== --- trunk/Toss/examples/Pawns.toss 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/examples/Pawns.toss 2011-01-21 20:46:12 UTC (rev 1283) @@ -7,12 +7,10 @@ REL IsEight(x) = not ex z C(x, z) REL IsSeventh(x) = ex y (C(x, y) and IsEight(y)) RULE WhiteDiag: - [ a, b | W { a }; B { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | W { a }; B { b } | - ] -> - [ a, b | W { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x)) + [ a, b | W { b } | - ] + emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x)) RULE WhiteStraight: [ | B:1 {}; R:2 {} | ] " @@ -76,12 +74,10 @@ .... " emb W, B RULE BlackDiag: - [ a, b | B { a }; W { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + [ a, b | B { a }; W { b } | - ] -> - [ a, b | B { b } | - vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y)) + [ a, b | B { b } | - ] + emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y)) RULE BlackStraight: [ | R:2 {}; W:1 {} | ] " Modified: trunk/Toss/examples/Tic-Tac-Toe.toss =================================================================== --- trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-19 20:57:15 UTC (rev 1282) +++ trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-21 20:46:12 UTC (rev 1283) @@ -11,15 +11,9 @@ REL WinQ() = ex x, y, z (Q(x) and Q(y) and Q(z) and Conn3(x, y, z)) REL WinP() = ex x, y, z (P(x) and P(y) and P(z) and Conn3(x, y, z)) RULE Cross: - [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] - -> - [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] - emb Q, P pre not WinQ() + [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P pre not WinQ() RULE Circle: - [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] - -> - [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] - emb Q, P pre not WinP() + [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not WinP() LOC 0 { PLAYER 1 PAYOFF { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-29 00:22:20
|
Revision: 1285 http://toss.svn.sourceforge.net/toss/?rev=1285&view=rev Author: lukstafi Date: 2011-01-29 00:22:13 +0000 (Sat, 29 Jan 2011) Log Message: ----------- GDL translation work in progress: preparing GDL rules to be translated as Toss rules. Modified Paths: -------------- trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/Formula/AuxTest.ml trunk/Toss/Play/GDL.ml trunk/Toss/Play/GDL.mli trunk/Toss/Play/GDLTest.ml Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-01-23 21:35:16 UTC (rev 1284) +++ trunk/Toss/Formula/Aux.ml 2011-01-29 00:22:13 UTC (rev 1285) @@ -15,6 +15,10 @@ (c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') || (c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9') +let fst3 (a,_,_) = a +let snd3 (_,a,_) = a +let trd3 (_,_,a) = a + (* {2 Helper functions on lists and other functions lacking from the standard library.} *) let concat_map f l = @@ -47,6 +51,17 @@ List.rev (List.map (fun (k,vs) -> k, List.fold_left redf red0 vs) ((k0,vs)::l)) +let collect l = + match List.sort (fun x y -> compare (fst x) (fst y)) l with + | [] -> [] + | (k0, v0)::tl -> + let k0, vs, l = List.fold_left (fun (k0, vs, l) (kn, vn) -> + if k0 = kn then k0, vn::vs, l + else kn, [vn], (k0,List.rev vs)::l) + (k0, [v0], []) tl in + List.rev ((k0,List.rev vs)::l) + + let list_remove v l = List.filter (fun w->v<>w) l let rec rev_assoc l x = match l with @@ -60,6 +75,13 @@ if b = x then aux (a::acc) l else aux acc l in aux [] l +let assoc_all x l = + let rec aux acc = function + | [] -> acc + | (a,b)::l -> + if a = x then aux (b::acc) l else aux acc l in + aux [] l + let rec replace_assoc k v = function | [] -> [k, v] | (a, b as pair) :: l -> Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2011-01-23 21:35:16 UTC (rev 1284) +++ trunk/Toss/Formula/Aux.mli 2011-01-29 00:22:13 UTC (rev 1285) @@ -9,6 +9,10 @@ val is_digit : char -> bool +val fst3 : 'a * 'b * 'c -> 'a +val snd3 : 'a * 'b * 'c -> 'b +val trd3 : 'a * 'b * 'c -> 'c + (** {2 Helper functions on lists and other functions lacking from the standard library.} *) @@ -28,6 +32,10 @@ val map_reduce : ('a -> 'b * 'c) -> ('d -> 'c -> 'd) -> 'd -> 'a list -> ('b * 'd) list +(** Collects elements by key. Same as + [map_reduce (fun x -> x) (fun y x->x::y) []]. *) +val collect : ('a * 'b) list -> ('a * 'b list) list + (** Remove all elements equal to the argument, using structural inequality. *) val list_remove : 'a -> 'a list -> 'a list @@ -40,6 +48,9 @@ value (using structural equality). Returns elements in reverse order. *) val rev_assoc_all : ('a * 'b) list -> 'b -> 'a list +(** Return all values of a key. *) +val assoc_all : 'a -> ('a * 'b) list -> 'b list + (** Replace the value of a first occurrence of a key, or place it at the end of the assoc list. *) val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list Modified: trunk/Toss/Formula/AuxTest.ml =================================================================== --- trunk/Toss/Formula/AuxTest.ml 2011-01-23 21:35:16 UTC (rev 1284) +++ trunk/Toss/Formula/AuxTest.ml 2011-01-29 00:22:13 UTC (rev 1285) @@ -4,6 +4,9 @@ let print_alist f l = String.concat ", " (List.map (fun (k,v) -> k^": "^f v) l) +let print_list f l = + "["^String.concat "; " (List.map f l)^"]" + let tests = "Aux" >::: [ "concat_map, map_some, array_map_some" >:: (fun () -> @@ -26,7 +29,7 @@ (Aux.array_map_some f [|`A;`B;`C;`D|]); ); - "map_reduce" >:: + "map_reduce, collect" >:: (fun () -> let mapf = function `A -> "1", ["a";"b"] | `B -> "2", ["c"] | `C -> "1", [] | `D -> "2", ["d";"e"] in @@ -39,6 +42,11 @@ ["abra",3; "bra", 1; "cada",2] (Aux.map_reduce (fun k->k,1) (+) 0 ["abra"; "cada"; "abra"; "bra"; "cada"; "abra"]); + + assert_equal ~msg:"collect" + ~printer:(print_alist (print_list string_of_int)) + ["1",[2;3;2]; "2",[1;5;3]; "3",[7]] + (Aux.collect ["1",2;"1",3;"2",1;"2",5;"1",2;"3",7;"2",3]) ); "rev_assoc, rev_assoc_all" >:: @@ -205,6 +213,12 @@ ["a";"c";"e";"b";"d"] (Aux.unique (=) ["a";"c";"e"; "b"; "d"; "e"; "c"; "e"]); + assert_bool "not unique" + (Aux.not_unique ["a";"c";"b"; "d"; "c"]); + + assert_bool "unique" + (not (Aux.not_unique ["a";"c";"b";"d"])); + assert_equal ~printer:(String.concat "; ") ~msg:"should remove duplicates" ["a";"b";"c";"d";"e"] Modified: trunk/Toss/Play/GDL.ml =================================================================== --- trunk/Toss/Play/GDL.ml 2011-01-23 21:35:16 UTC (rev 1284) +++ trunk/Toss/Play/GDL.ml 2011-01-29 00:22:13 UTC (rev 1285) @@ -38,7 +38,7 @@ state. For this we need to locate the "noop" arguments to "legal" and "does" relations. A noop action in a location is the only action in the corresponding state of an aggregate playout for the - player that is additionally constant. + player that is also constant. (2b) We determine the player of a location by requiring that at most one player has a non-noop action in an aggregate @@ -111,19 +111,16 @@ over the tuple of subterms selected from the element terms by the corresponding paths. - (Relations that do not hold for any tuple of element terms in the - whole aggregate playout can be removed.) - (4b) (Equality relations.) For each mask-path, introduce a binary relation that holds over elements which have the same subterm at the mask-path position. (Because of mask-paths definition, same for all element terms in element's equivalence class.) - (4c) (Anchor predicates.) Collect all terms under "true" and - "next" predicates in the game definition. For each mask-path - pointing to a constant in some of the terms and that constant, - introduce a new predicate with semantics: "matches the mask and - has the constant at the path position". + (4c) (Anchor predicates.) Add a predicate for being derived from a + mask. For each mask-path pointing to a constant in some of the + elements and that constant, introduce a new predicate with + semantics: "matches the mask and has the constant at the path + position". (5) (Mostly) dynamic relations ("fluents": their tuples change during the game), relations derived from all below-meta-variable @@ -131,13 +128,12 @@ initial state. (Some relations introduced in this step might not be fluents.) - Collect all terms under "true" and "next" predicates in the game - definition. For each term, find the element mask it matches, and - introduce relations for each meta-variable of the element mask, - associated with the subterm that matches the meta-variable. The - semantic is that the relation selects the element terms that match - the mask with the associated subterm subsituted for the - corresponding meta-variable, with existential + (See also (7k).) For each element term, find the element mask it + matches, and introduce relations for each meta-variable of the + element mask, associated with the subterm that matches the + meta-variable. The semantic is that the relation selects the + element terms that match the mask with the associated subterm + subsituted for the corresponding meta-variable, with existential interpretation. A relation holds initially over an element, if in the initial set of element terms at least one from the element's equivalence class is selected by the relation. An occurrence of @@ -202,77 +198,122 @@ (7a) We translate each branch of the "legal" relation definition as one or more rewrite rules. Currently, we base availability of - rules in a location solely on the player in the location and in - the "legal" definition (currently, we do not allow simultaneous - moves). Consequently, we define rules on a per-player basis rather - than a per-location basis. If the branch of "legal" definition has - a variable for a player, it is instantiated for each player in the - game, and the variable substituted in the body of the "legal" - branch. + rules in a location on the player in the location and noop actions + of other players in it, compared to the the "legal" definition + branch (currently, we do not allow simultaneous moves). If the + branch of "legal" definition has a variable for a player, it is + instantiated for each player in the game, and the variable + substituted in the body of the "legal" branch. A rewrite rule is + associated with a single "lead legal" branch of the location's + player. (7b) We collect all the branches of the "next" relation definition - for which the selected branch of "legal" unifies with all (usually - one, but we allow zero or more) occurrences of "does" with a - single unifier per "next" branch. Split the unifiers into - equivalence classes (w.r.t. substitution), each class will be a - different rewrite rule (or set of rules). Associate negation of - equalities specific to the unifiers strictly less general than the - equivalence class with it, so that the resulting conditions form a - partition of the space of substitutions for the "legal" branch - processed. + for which the selected branches of "lead legal" and "noop legal" + (the "joint legal" actions) unify with all (usually one, but we + allow zero or more) occurrences of "does" with a single unifier + per "next" branch. (A "noop legal" actually only matches and + substitutes the local variables of "next" branches.) Split the + unifiers into equivalence classes (w.r.t. substitution), each + class will be a different rewrite rule (or set of rules). (Note + that equivalent unifiers turn out to be those that when truncated + to variables of the "legal" branch are renamings of each other.) + (7b1) Since the "noop legals" are constants (by current + assumption), we do not need to construct equivalence classes for + them. Their branches will join every rule generated for the "joint + legal" choice. + (7c) Find a single MGU that unifies the "legal" atom argument and all the "does" atoms arguments into a single instance, and apply - it to all "next" branches of the rule. We remember all variables - in the "legal"/"does" instantiation as "fixed variables". We - replace all occurrences of "does" with the body of the selected - "legal" branch. + it to all "next" branches of the rule (i.e. after applying the + original unifier, apply a renaming that makes the unifier equal to + all other unifiers in the equiv. class). We replace all + occurrences of "does" with the body of the selected "legal" + branch. - (7d) We seggregate "next" atoms into these that contain some fixed - variables or no variables at all, and other containing only - unfixed variables. Eliminate unfixed variables from "next" - atoms with fixed variables by enumerating their domains and - duplicating whole "next" branches with each instantiation. (They - will not have unfixed variables.) + (7d) Add all branches of equiv classes smaller than a given equiv + class to its branch set. - (This perhaps could be done in a better way by better integrating - (7d) and (7e)...) + Implementation TODO (reason for unsoundness): currently, we + discard non-maximal equivalence classes, because negation (7e) is + not implemented, and with negation it would still be preferable to + have exhaustiveness check so as to not generate spurious + (unapplicable) rules. - (7e) Branches with (only) unfixed variables in "next" atoms are - the "frame" branches. Check that each "frame" branch is an - identity: the "next" atom is equal to one of the positive "true" - atoms. If not, expand all variables (as they are unfixed) - duplicating that branch for each instantiation (the duplicated - branches become regular branches -- with constant "next" - atoms). + (7e) Associate negation of equalities specific to the unifiers + strictly less general than the equivalence class with it, so that + the resulting conditions form a partition of the space of + substitutions for the "legal" branch processed. - (7e1) Transform the remaining proper "frame" branches into - "erasure" branches: negate the body, push negation inside (using - de Morgan laws etc.), reduce to DNF and split into separate - "erasure" branch for each disjunct, place the original "next" atom - but with meta-variable positions replaced by _BLANK_ as the head - of the "erasure" branch, apply (and remove) unification atoms - resulting from negating the "distinct" relation. + (7f) We remember all variables in the "legal"/"does" instantiation + as "fixed variables". We seggregate "next" atoms into these that + contain some fixed variables or no variables at all, and other + containing only unfixed variables. - (7f) Introduce a new element variable for each class of "next" and + (7f1) Branches with (only) unfixed variables in "next" atoms that + are "identities" are the "frame" branches. "Identity" here means + the "next" atom is equal to one of the positive "true" atoms. + + (7f2) Transform the "frame" branches into "erasure" branches: + distribute them into equivalence classes of head terms + (w.r.t. substitution but treating fixed variables as constants), + add smaller elements and negation of larger elements (in the same + manner as in (7b) and (7d) for the "legal" term), disjoin bodies + in each class (a "multi-body"), then: + + implementation TODO: currently, we only use maximal equivalence + classes (see note at 7d) + + (7f3) negate the multi-body, push negation inside (using de Morgan + laws etc.), split into separate "erasure" branch for each + disjunct, place the original "next" atom but with meta-variable + positions replaced by _BLANK_ as the head of the "erasure" branch, + apply (and remove) unification atoms resulting from negating the + "distinct" relation. + + (7f4) Drop the erasure branches that contradict the "legal" + condition of their rule. + + (7f5) Redistribute the erasure branches in case they were + substituted with the "not distinct" unifier to proper equivalence + classes (remove equivalence classes that become empty). + + (7g) Instantiate remaining unfixed variables. Implementation TODO. + + (7h) Introduce a new element variable for each class of "next" and "true" terms equal modulo mask (i.e. there is a mask matching them and they differ only at-or-below metavariables). (Remember the - atoms "corresponding variable".) + atoms "corresponding variable".) From now on until (7m1) we keep + both the (partially) Toss-translated versions and the (complete) + GDL-originals of branches (so to use GDL atoms for "subsumption + checking" in (7m)). - (7g) Add an appropriate equality relation of (4b) for each case - of variable shared by terms corresponding to different element - variables (regardless if the element terms are in positive or - negative literals). - - (7h) For all subterms of "next" and "true" atoms, identify the + (7i-4a) For all subterms of "next" and "true" atoms, identify the sets of <mask-path, element variable> they "inhabit". Replace a static fact relation by relations built over a cartesian product of <mask-path, element variable> sets derived for each static - fact's argument by applying corresponding (4a) relations. (For a - negative literal the result will be equivalent to a disjunction of - negations of generated atoms.) + fact's argument by applying corresponding (4a) relations. For a + negative literal generate result equivalent to a conjunction of + negations of generated atoms (FIXME: why disjunction is wrong?). - (7i) Identify variables in "next" & "true" terms that are + (7i-4c) Include the (4c) relations for "next" and "true" positive + atoms. Negative atoms are added with (5) relations since they are + under a common negation. + + (7i-4b) Add an appropriate equality relation of (4b) for each case + of variable shared by terms corresponding to different element + variables (regardless if the element terms are in positive or + negative literals). FIXME: any shared subterm, not limited to + variables, right? + + Implementation: instead of all subterms we currently only consider + subterms that instantiate (ordinary) variables in the mask + corresponding to the "next"/"true" atom. + + (7i1) Remove branches that are unsatisfiable by their static + relations (4a), (4b) and (4c) alone. + + (7j) Identify variables in "next" & "true" terms that are at-or-below meta-variables in the corresponding mask. (Most of such variables should be already removed as belonging to "frame" branches.) Expand them by duplicating given branch for all @@ -280,11 +321,13 @@ position). (Note that since branches do not have unfixed variables anymore, we do not rename variables during duplication.) - (7j) Now we build rewrite rules for a refinement of an equivalence - class of (7b): from the branches with unifiers in the equiv class, - from branches with unifiers more general than the equiv class, and - from the disjointness conditions (and the terminal condition, see - below). Build a pre-lattice of branch bodies w.r.t. subsumption, + (7k) Replace the "next" and "true" atoms by the conjunction of + (4c) and (5) predicates over their corresponding variable. (For + negative "true" literals this will be equivalent to a disjunction + of negations of the predicates.) Note that positive static + relations are already added in (7i-4c). + + (7l) Build a pre-lattice of branch bodies w.r.t. subsumption, in a manner similar to (7b). The subsumption test has to say "no" when there exists a game state where the antecedent holds but the consequent does not, but does not need to always say "yes" @@ -296,12 +339,20 @@ necessary so that all applicable changes are applied in the translated game when making a move). - (7k) Replace the "next" and "true" atoms by the conjunction of - (4c) and (5) predicates over their corresponding variable. (For - negative "true" literals this will be equivalent to a disjunction - of negations of the predicates.) + (7l1) Since all variables are fixed, the lattice is built by + summing rule bodies. To avoid contradictions and have a complete + partition, we construct the set of all bit vectors indexed by all + atoms occurring in the bodies. With every index-bit value we + associate the set of branches that do not allow such literal. For + every vector we calculate the complement of the sum of branch sets + associated with every bit. The unique resulting sets are exactly + the Toss rules precursors. - (7l) Include translated negation of the terminal condition. + (7m) Include translated negation of the terminal condition. (Now we + build rewrite rules for a refinement of an equivalence class of + (7b): from the branches with unifiers in the equiv class, from + branches with unifiers more general than the equiv class, and from + the disjointness conditions and the terminal condition.) The rewrite rule is generated by joining the derived conjunctions from "next" atoms as RHS, and from bodies as the @@ -317,8 +368,8 @@ "goal" value times the characterisic function of the "goal" body. We do not translate the body if the value is zero (we drop the zero goal branches from the definition). Translate the body - using (7f)-(7k), but treating "goal" branches separately -- when - (7i) duplicates a branch, new branches add new sum elements. + using (7h)-(7m), but treating "goal" branches separately -- when + (7k) duplicates a branch, new branches add new sum elements. *) @@ -381,6 +432,20 @@ 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 + | Func (f, args) -> terms_vars args +and terms_vars args = + List.fold_left Aux.Strings.union Aux.Strings.empty + (List.map term_vars args) + let fact_of_atom = function | Distinct args -> assert false | Rel (rel, args) -> rel, args @@ -410,6 +475,13 @@ type exp_def = string * exp_def_branch list +module Terms = Set.Make ( + struct type t = term let compare = Pervasives.compare end) + +(* +let branch_vars (args, body, neg_body) = +*) + let rules_of_entry = function | Datalog (rel, args, body) -> let head = rel, args in @@ -495,12 +567,6 @@ | stratum, rules -> stratify (stratum::strata) rules -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 subst_one (x, term as sb) = function | Var y when x=y -> term | MVar y when x=y -> term @@ -524,7 +590,7 @@ (List.map (subst_one sb1) terms1) (List.map (subst_one sb1) terms2) | (Var x::_, term::_ | term::_, Var x::_) - when List.mem x (vars term) -> + when Aux.Strings.mem x (term_vars term) -> raise Not_found | Var x::terms1, term::terms2 | term::terms1, Var x::terms2 -> let sb1 = x, term in @@ -539,8 +605,9 @@ let rec match_meta sb m_sb terms1 terms2 = match terms1, terms2 with | [], [] -> sb, m_sb - | (Const a | Var a)::terms1, (Const b | Var b)::terms2 when a=b -> - match_meta sb m_sb terms1 terms2 + | (Const _ (* | Var _ *) as a)::terms1, + (Const _ (* | Var _ *) as b)::terms2 + when a=b -> match_meta sb m_sb terms1 terms2 | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g -> match_meta sb m_sb (args1 @ terms1) (args2 @ terms2) | term::terms1, MVar x::terms2 -> @@ -609,8 +676,19 @@ let subst_rel sb (rel, args) = rel, List.map (subst sb) args let subst_rels sb body = List.map (subst_rel sb) body -let compose_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb +let extend_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb +let compose_sb sb1 sb2 = + let vars1, terms1 = List.split sb1 in + let vars2, terms2 = List.split sb2 in + 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, + List.map (subst_rel sb) body, + List.map (List.map (subst_rel sb)) neg_body + let fact_str (rel, args) = "("^rel^" "^String.concat " " (List.map term_str args) ^")" @@ -621,11 +699,11 @@ let facts_str facts = String.concat " " (List.map fact_str facts) +let neg_facts_str negs = + String.concat " " + (List.map (fun d -> "(not (and "^facts_str d^"))") negs) let def_str (rel, branches) = - let neg_facts_str negs = - String.concat " " - (List.map (fun d -> "(not (and "^facts_str d^"))") negs) in String.concat "\n" (List.map (fun (args, body, neg_body) -> "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^ " " ^ neg_facts_str neg_body ^ ")" @@ -651,14 +729,16 @@ | head, cond1::body, neg_body -> Aux.map_try (fun fact -> (* {{{ log entry *) - if !debug_level > 4 then ( + + if !debug_level > 5 then ( Printf.printf "instantiate_one: trying to unify %s and %s\n%!" (fact_str fact) (fact_str cond1) ); + (* }}} *) let sb = unify_rels fact cond1 in (* {{{ log entry *) - if !debug_level > 4 then ( + if !debug_level > 5 then ( Printf.printf "instantiate_one: succeeded with %s\n%!" (sb_str sb) ); @@ -671,20 +751,22 @@ let rec inst_stratum old_base old_irules cur_base cur_irules = (* {{{ log entry *) - if !debug_level > 3 then ( + + if !debug_level > 4 then ( Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!" (facts_str old_base) (facts_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 new_base1, new_irules1 = Aux.partition_choice (instantiate_one base cur_base cur_irules) in (* {{{ log entry *) - if !debug_level > 3 then ( + if !debug_level > 4 then ( Printf.printf "inst_stratum: cur-cur = %s\n%!" (facts_str new_base1) ); @@ -692,7 +774,7 @@ let new_base2, new_irules2 = Aux.partition_choice (instantiate_one base cur_base old_irules) in (* {{{ log entry *) - if !debug_level > 3 then ( + if !debug_level > 4 then ( Printf.printf "inst_stratum: cur-old = %s\n%!" (facts_str new_base2) ); @@ -700,7 +782,7 @@ let new_base3, new_irules3 = Aux.partition_choice (instantiate_one base old_base cur_irules) in (* {{{ log entry *) - if !debug_level > 3 then ( + if !debug_level > 4 then ( Printf.printf "inst_stratum: old-cur = %s\n%!" (facts_str new_base3) ); @@ -740,32 +822,48 @@ (* 6 *) +(* Need a global access so that the count can be reset between + different translations. (Generalization uses a local [fresh_count] + state.) *) +let freshen_count = ref 0 + (* TODO: do proper elegant renaming... *) +let freshen_branch (args, body, neg_body) = + incr freshen_count; + let rec map_vnames = function + | Var x -> Var (x^string_of_int !freshen_count) + | MVar x -> MVar (x^string_of_int !freshen_count) + | Const _ as t -> t + | Func (f, args) -> + Func (f, List.map map_vnames args) in + let map_rel (rel, args) = + rel, List.map map_vnames args in + List.map map_vnames args, + List.map map_rel body, + List.map (List.map map_rel) neg_body + let freshen_def_branches = - let fresh_count = ref 0 in - let map_branch (args, body, neg_body) = - incr fresh_count; - let rec map_vnames = function - | Var x -> Var (x^string_of_int !fresh_count) - | MVar x -> MVar (x^string_of_int !fresh_count) - | Const _ as t -> t - | Func (f, args) -> - Func (f, List.map map_vnames args) in - let map_rel (rel, args) = - rel, List.map map_vnames args in - List.map map_vnames args, - List.map map_rel body, - List.map (List.map map_rel) neg_body in - List.map map_branch + List.map freshen_branch (* assumption: [defs] bodies are already clean of defined relations *) let subst_def_branch (defs : exp_def list) - (head, body, neg_body : exp_def_branch) : exp_def_branch list = + (head, body, neg_body as br : exp_def_branch) : exp_def_branch list = + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "Expanding branch %s\n%!" (def_str ("BRANCH", [br])); + ); + (* }}} *) (* 6a *) let sols = List.fold_left (fun sols (rel, args as atom) -> (let try def = freshen_def_branches (List.assoc rel defs) in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "Expanding positive %s by %s\n%!" rel + (def_str (rel, def)) + ); + (* }}} *) Aux.concat_map (fun (pos_sol, neg_sol, sb) -> let args = List.map (subst sb) args in Aux.map_some (fun (dparams, dbody, dneg_body) -> @@ -774,7 +872,7 @@ Some ( subst_rels sb1 (dbody @ pos_sol), List.map (subst_rels sb1) (dneg_body @ neg_sol), - compose_sb sb1 sb) + extend_sb sb1 sb) with Not_found -> None ) def ) sols @@ -823,70 +921,40 @@ loop (base @ step) strata in match stratify ~def:true [] (defs_of_rules rules) with | [] -> [] - | [no_defined_rels] -> - if more_defs = [] then no_defined_rels - else List.map (fun (rel, branches) -> - rel, Aux.concat_map (subst_def_branch more_defs) branches) - no_defined_rels - | def_base::def_strata -> loop def_base def_strata + | [no_defined_rels] when more_defs=[] -> no_defined_rels + | def_base::def_strata when more_defs=[] -> loop def_base def_strata + | def_strata -> loop more_defs def_strata (* As [subst_def_branch], but specifically for "legal" definition and result structured by "legal" definition branches. *) - (* -let subst_legal_rule (legal_defs : exp_def_branch list) - (head, body, neg_body : exp_def_branch) : exp_def_branch list = - (* 6a *) - let sols = - List.fold_left (fun sols (rel, args as atom) -> - (let try def = - freshen_def_branches (List.assoc rel defs) in - Aux.concat_map (fun (pos_sol, neg_sol, sb) -> - let args = List.map (subst sb) args in - Aux.map_some (fun (dparams, dbody, dneg_body) -> - try - let sb1 = unify [] dparams args in - Some ( - subst_rels sb1 (dbody @ pos_sol), - List.map (subst_rels sb1) (dneg_body @ neg_sol), - compose_sb sb1 sb) - with Not_found -> None - ) def - ) sols - with Not_found -> - List.map (fun (pos_sol, neg_sol, sb) -> - subst_rel sb atom::pos_sol, neg_sol, sb) sols)) - ([[],[],[]]) body in - (* 6b *) - let sols = - List.fold_left (fun sols -> function [rel, args as atom] -> - (let try def = - freshen_def_branches (List.assoc rel defs) in - List.map (fun (pos_sol, neg_sol, sb) -> - let args = List.map (subst sb) args in - let more_neg = - Aux.map_some (fun (dparams, dbody, dneg_body) -> - if dneg_body <> [] then - failwith - ("GDL.subst_def_branch: negation in negatively used" ^ - " defined rels not supported yet, relation "^rel); - try - let sb1 = unify [] dparams args in - Some (subst_rels sb1 dbody) - with Not_found -> None - ) def in - pos_sol, more_neg @ neg_sol, sb - ) sols - with Not_found -> - List.map (fun (pos_sol, neg_sol, sb) -> - pos_sol, [subst_rel sb atom]::neg_sol, sb) sols) - | _ -> failwith - "GDL.subst_def_branch: unimplemented, see (6b1) of spec") - sols neg_body in - Aux.map_some (fun (pos_sol, neg_sol, sb) -> - if List.mem [] neg_sol then None - else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols - *) +(* 7b *) +let subst_legal_rule + (legal_args, legal_body, legal_neg_body : exp_def_branch) + (head, body, neg_body : exp_def_branch) + : (exp_def_branch * exp_def_branch) option = + if List.exists (List.exists (fun (rel,_)->rel="does")) neg_body + then failwith + "GDL.translate_game: negated \"does\" conditions not implemented yet"; + try + let body, more_neg_body, sb = + List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) -> + if rel = "does" then + List.rev_append legal_body body, + List.rev_append legal_neg_body more_neg_body, + unify sb legal_args args + else atom::body, more_neg_body, sb) ([],[],[]) body in + + Some ( + (List.map (subst sb) legal_args, + List.map (subst_rel sb) legal_body, + List.map (List.map (subst_rel sb)) legal_neg_body), + (List.map (subst sb) head, + List.map (subst_rel sb) (List.rev body), + List.map (List.map (subst_rel sb)) + (List.rev_append more_neg_body neg_body))) + with Not_found -> None + (* 1 *) (* Collect the aggregate playout, but also the actions available in @@ -946,17 +1014,21 @@ else dynamic_rules in let rec loop actions_accu state_accu step state = (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "aggregate_playout: step %d...\n%!" step ); + (* }}} *) (let try actions, next = aggregate_ply players static_base state state_rules in (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "aggregate_playout: state %s\n%!" (String.concat " " (List.map term_str next)) ); + (* }}} *) if step < horizon then loop (actions::actions_accu) (state::state_accu) (step+1) next @@ -976,7 +1048,8 @@ (String.concat " " (List.map term_str init_state)) ); (* }}} *) - static_rules, dynamic_rules, static_base, loop [] [] 0 init_state + static_rules, dynamic_rules, static_base, init_state, + loop [] [] 0 init_state let find_cycle cands = @@ -1000,13 +1073,49 @@ 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 rec blank_out = function + | Const a as c, Const b when a = b -> c + | (*Var _ as*) v, Var _ -> v + | t, MVar _ -> Const "_BLANK_" + | Func (f, f_args), Func (g, g_args) when f = g -> + Func (f, List.map blank_out (List.combine f_args g_args)) + | a, b -> + Printf.printf "blank_out mismatch: term %s, mask %s\n%!" + (term_str a) (term_str b); + assert false + let translate_game game_descr = + freshen_count := 0; let player_terms = Array.of_list (Aux.map_some (function Role p -> Some p | _ -> None) game_descr) in + let players_n = Array.length player_terms in + let find_player player = + Aux.array_argfind (fun p->p=player) player_terms in let rules = Aux.concat_map rules_of_entry game_descr in - let static_rules, dynamic_rules, static_base, (agg_actions, agg_states) = + let static_rules, dynamic_rules, static_base, init_state, + (agg_actions, agg_states) = aggregate_playout player_terms 30 rules in (* (8) -- drop zero goal branches, "first round" *) let dynamic_rules = List.filter @@ -1022,7 +1131,8 @@ (* 2a *) List.map (function | player, [Const _ as noop] -> player, Some noop - | player, _ -> player, None) actions) agg_actions in + | player, _ -> player, None) actions + ) agg_actions in let control_cands = List.map (fun noop_cands -> List.fold_left (fun accu -> function | player, None -> @@ -1032,15 +1142,59 @@ ("GDL.initialize_game: branching arena graphs"^ " or simultaneous moves not supported yet")) | _, 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 + | _ -> failwith + "GDL.initialize_game: simultaneous moves not supported yet" + ) control_cands noop_cands in + let control_cands, noop_cands = + List.split control_noop_cands in (* 2b *) - let cycle = find_cycle control_cands in + let loc_players = find_cycle control_cands in (* {{{ log entry *) if !debug_level > 0 then ( Printf.printf "translate_game: location players %s\n%!" (String.concat " " - (List.map (function Some t->term_str t | None->"None") cycle)) + (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 -> player_terms.(0)) + loc_players) in + let loc_n = Array.length loc_players in + let find_player_locs player = + Aux.array_argfind_all (fun p->p=player) loc_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 + (* 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 failwith + "GDL.translate_game: noop-driven location splits unimplemented") + (List.hd !noops); + incr i; if !i = loc_n then i := 0; + noops := List.tl !noops + done; + loc_noops in (* 6 *) let static_rules, exp_static_rules = List.partition (fun ((rel,args), _, _) -> @@ -1049,10 +1203,12 @@ | _ -> false) static_rules ) static_rules in (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "translate_game: expanded static rules: %s\n%!" (String.concat ", " (List.map (fun ((r,_),_,_)->r) exp_static_rules)); ); + (* }}} *) let static_exp_defs = expand_def_rules exp_static_rules in let static_rules = @@ -1076,10 +1232,12 @@ let exp_next = Aux.concat_map (subst_def_branch ["does", legal_rules]) next_rules in (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "translate_game: \"next\" rules with \"does\"<-\"legal\":\n%s\n%!" (def_str ("next", exp_next)) ); + (* }}} *) (* 3c *) let masks = List.map (function @@ -1110,11 +1268,8 @@ (String.concat " " (List.map term_str masks)) ); (* }}} *) - let cmp_masks t1 t2 = - Printf.printf "cmp_masks: %s <= %s .. " (term_str t1) (term_str t2); - try ignore (match_meta [] [] [t1] [t2]); Printf.printf "true\n%!"; true - with Not_found -> Printf.printf "false\n%!"; false in - let masks = Aux.maximal cmp_masks masks in + (* find minimal *) + let masks = Aux.maximal (fun t1 t2->cmp_masks t2 t1) masks in (* {{{ log entry *) if !debug_level > 1 then ( Printf.printf "translate_game: Masks:\n%s\n%!" @@ -1167,72 +1322,75 @@ let mask_paths = Aux.concat_map (function _, [] -> assert false | mask, (sb,_)::_ -> List.map (fun (v,_)->mask, v) sb) elements in (* 4a *) - (* TODO: move generation of static rels graphs to the end and - filter to only generate used relations *) let static_rels = Aux.unique_sorted (List.map (fun ((rname,args),_,_) -> rname, List.map (fun _ -> ()) args) static_rules) in let static_rels = List.map (fun (rel,args) -> - rel, + rel, List.length args, Aux.all_tuples_for args mask_paths) static_rels in - let static_base = - Aux.map_reduce (fun x->x) (fun x y->y::x) [] static_base in + let static_base = Aux.collect static_base in (* TODO: optimize by indexing elements by path position terms (currently, substitution values) *) - let struc = List.fold_left (fun struc (brel, path_tups) -> - let brel_tups = List.assoc brel static_base in - (* {{{ log entry *) - if !debug_level > 0 then ( - Printf.printf "Translating static relation %s with %d tuples:\n%s\n%!" - brel (List.length brel_tups) (tuples_str brel_tups); - ); - (* }}} *) - List.fold_left (fun struc ptup -> - let rname = brel ^ "__" ^ String.concat "__" - (List.map (fun (mask,v)-> - term_to_name mask ^ "_" ^ v) ptup) in - let struc = - Structure.add_rel_name rname (List.length ptup) struc in + let struc = + List.fold_left (fun struc (brel, arity, path_tups) -> + let brel_tups = List.assoc brel static_base in (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf "static-rel: %s, of... %!" rname; + if !debug_level > 0 then ( + Printf.printf "Translating static relation %s with %d tuples:\n%s\n%!" + brel (List.length brel_tups) (tuples_str brel_tups); ); (* }}} *) - let elem_sets = - List.map (fun (mask,v)-> - List.map (fun (sb,elem)-> - try List.assoc v sb, elem - with Not_found -> assert false) - (List.assoc mask elements)) ptup in - (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf "%s ... %!" (String.concat "x" ( - List.map (fun x-> string_of_int (List.length x)) elem_sets)); - ); - (* }}} *) - let elem_tups = - Aux.concat_map (fun ttup -> - let elem_sets = List.map2 (fun term elems -> - Aux.map_some (fun (tcand, e) -> - if tcand=term then Some e else None) elems - ) ttup elem_sets in - List.map Array.of_list (Aux.product elem_sets) - ) brel_tups in - (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups); - ); - (* }}} *) - let res = Structure.unsafe_add_rels struc rname elem_tups in - (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf " done\n%!"; - ); - (* }}} *) - res - ) struc path_tups) struc static_rels in + List.fold_left (fun struc ptup -> + let rname = brel ^ "__" ^ String.concat "__" + (List.map (fun (mask,v)-> + term_to_name mask ^ "_" ^ v) ptup) in + let struc = + Structure.add_rel_name rname (List.length ptup) struc in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "static-rel: %s, of... %!" rname; + ); + (* }}} *) + let elem_sets = + List.map (fun (mask,v)-> + List.map (fun (sb,elem)-> + try List.assoc v sb, elem + with Not_found -> assert false) + (List.assoc mask elements)) ptup in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "%s ... %!" (String.concat "x" ( + List.map (fun x-> string_of_int (List.length x)) elem_sets)); + ); + (* }}} *) + let elem_tups = + Aux.concat_map (fun ttup -> + let elem_sets = List.map2 (fun term elems -> + Aux.map_some (fun (tcand, e) -> + if tcand=term then Some e else None) elems + ) ttup elem_sets in + List.map Array.of_list (Aux.product elem_sets) + ) brel_tups in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "%d tuples, adding to struc...%!" + (List.length elem_tups); + ); + (* }}} *) + let res = Structure.unsafe_add_rels struc rname elem_tups in + (* {{{ log entry *) + + if !debug_level > 1 then ( + Printf.printf " done\n%!"; + ); + + (* }}} *) + res + ) struc path_tups + ) struc static_rels in + (* 4b *) let struc = List.fold_left (fun struc (mask,v) -> let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in @@ -1255,53 +1413,553 @@ with Not_found -> assert false ) tups elems ) [] elems in - (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups); - ); - (* }}} *) - let res = Structure.unsafe_add_rels struc rname elem_tups in - (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf " done\n%!"; - ); - (* }}} *) - res + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups); + ); + (* }}} *) + let res = Structure.unsafe_add_rels struc rname elem_tups in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf " done\n%!"; + ); + (* }}} *) + res ) struc mask_paths in - (* 4c: TODO -- see laziness TODO 4 *) - (* 5: TODO *) + (* 4c *) + let struc = List.fold_left (fun struc mask -> + let rname = term_to_name mask in + let struc = + Structure.add_rel_name rname 1 struc in + let elems = List.assoc mask elements in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "Adding mask anchor predicate %s over %d elements.\n%!" + rname (List.length elems); + ); + (* }}} *) + let elem_tups = + List.map (fun (sb, e) -> [|e|]) elems in + Structure.unsafe_add_rels struc rname elem_tups + ) struc masks in + let struc = List.fold_left (fun struc (mask, elems) -> + List.fold_left (fun struc (sb, elem) -> + List.fold_left (fun struc (v,t as v_sb) -> + let rname = term_to_name (subst_one v_sb mask) in + Structure.add_rel struc rname [|elem|]) struc sb) struc elems + ) struc elements in + (* 5 *) + let term_to_blank next_arg = + let mask_cands = + Aux.map_try (fun mask -> + mask, match_meta [] [] [next_arg] [mask] + ) masks in + let mask, sb, m_sb = match mask_cands with + | [mask, (sb, m_sb)] -> mask, sb, m_sb + | _ -> assert false in + mask, sb, m_sb, blank_out (next_arg, mask) in + let struc = List.fold_left (fun struc term -> + let mask, sb, m_sb, blanked = term_to_blank term in + let e = + let elems = List.assoc mask elements in + List.assoc sb elems in + List.fold_left (fun struc (v,t as v_sb) -> + let rname = term_to_name (subst_one v_sb mask) in + if List.mem term init_state then + Structure.add_rel struc rname [|e|] + else Structure.add_rel_name rname 1 struc) struc m_sb + ) struc element_terms in + (* 7a *) let legal_rules = Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule] | [Var v; lterm], body, neg_body -> Array.to_list - (Array.map (fun player -> [player; lterm], body, neg_body) + (Array.map (fun player -> + let sb = [v, player] in + [player; subst sb lterm], + List.map (subst_rel sb) body, + List.map (List.map (subst_rel sb)) neg_body) player_terms) | [Func _; lterm], _, _ -> (* TODO: easy to fix *) failwith "GDL.translate_game: bigger player terms not handled yet" | _ -> assert false) legal_rules in - (* indexed by players, then "legal" branches, then by MGUs for - unifier equivalence classes *) - (* - let player_next = - Aux.map_reduce (fun ()) in - *) + (* expanded "next" branches indexed by locations, then "legal" + branches, then by MGUs for unifier equivalence classes *) + let loc_lead_legal, loc_noop_legal = + (* actions of the player *of the location* *) + let loc_lead_legal = Array.make loc_n [] in + (* noop actions in locations -- cannot have choice *) + let loc_noop_legal = + Array.make_matrix loc_n players_n None in + List.iter (function + | [player; action], _, _ as legal -> + for i=0 to loc_n - 1 do + if List.mem i (find_player_locs player) + then + if not (List.mem legal loc_lead_legal.(i)) + then loc_lead_legal.(i) <- legal :: loc_lead_legal.(i); + for p=0 to players_n - 1 do + match loc_noops.(i).(p) with None -> () + | Some noop -> + if p = find_player player && ( + try ignore (match_meta [] [] [noop] [action]); true + with Not_found -> false) + then + if loc_noop_legal.(i).(p) <> None + && loc_noop_legal.(i).(p) <> Some legal + then ( + Printf.printf "Multiple noops: %s, %s\n%!" + (term_str (Func ("legal", Aux.fst3 legal))) + (term_str (Func ("legal", Aux.fst3 + (Aux.unsome loc_noop_legal.(i).(p))))); + assert false) + else loc_noop_legal.(i).(p) <- Some legal + done + done + | _ -> assert false + ) legal_rules; + loc_lead_legal, loc_noop_legal in + (* the joint actions available in a location *) + let loc_joint_legal = + Array.mapi (fun i lead -> + let cur_player = find_player loc_players.(i) in + let p_acts = Array.to_list + (Array.mapi + (fun p noop -> + if p = cur_player then lead + else match noop with + | Some noop -> [noop] | None -> assert false) + loc_noop_legal.(i)) in + Aux.product p_acts + ) loc_lead_legal in + (* 7b *) + let grtr ((lead1,_,_), _) ((lead2,_,_), _) = cmp_masks lead2 lead1 in + let loc_next_classes = + Array.mapi (fun loc joint_legal_branches -> + Aux.concat_map (fun joint_legal -> + let lead_legal, noop_legals = + List.partition (function + | [player; action],_,_ -> player=loc_players.(loc) + | _ -> assert false) joint_legal in + let lead_legal = + match lead_legal with [lead_legal] -> lead_legal + | _ -> assert false in + (* 7b1 *) + let noop_branches = Aux.concat_map (fun legal -> + Aux.map_some + (fun next_br -> + subst_legal_rule legal (freshen_branch next_br)) + next_rules) noop_legals in + let noop_branches = + List.map snd noop_branches in + (* now, continue with the lead player *) + let unifs = Aux.map_some (* and substituted legal br-es *) + (fun next_br -> + match + subst_legal_rule lead_legal (freshen_branch next_br) + with None -> None + | Some (([_; lead],lead_body,lead_neg_body), br) -> + Some ((lead,lead_body,lead_neg_body), br) + | _ -> assert false) + next_rules in + (* building "Hasse layers" imperatively *) + let unifs = ref unifs in + let hasse_layer () = + let minimal = Aux.maximal grtr !unifs in + (* 7c *) + List.map (fun (min_head, _, _ as min_lead, _) -> + let branches = + Aux.map_try (fun ((head, _, _), br as lbr) -> + let renaming, _ = + match_meta [] [] [min_head] [head] in + unifs := Aux.list_remove lbr !unifs; + subst_br renaming br) !unifs in + min_lead, branches + ) minimal in + let layers = ref [] in + while !unifs <> [] do + layers := hasse_layer () :: !layers + done; + let layers = List.rev !layers in + (* 7d *) + let rules_brs = List.fold_left + (* folding reverses order so the maximal layer will + generate the returned classes *) + (fun rules_brs layer -> + List.map + (fun (new_lead, new_brs as nrule) -> + let smaller = List.filter (grtr nrule) rules_brs in + new_lead, + List.concat (new_brs::List.map snd smaller) + ) layer + ) [] layers in + (* 7b1 continued *) + let rules_brs = List.map (fun (lead, brs) -> + lead, noop_branches @ brs) rules_brs in + (* 7e -- TODO (together with non-maximal (7d) classes) *) + (* 7f *) + let rules_brs = + List.map (fun (lead_head, lead_body, lead_neg_body as lead, + branches) -> + let fixed_vars = term_vars lead_head in + let fixed_brs, other_brs = List.partition + (function + | [next_arg],_,_ -> + Aux.Strings.subset (term_vars next_arg) fixed_vars + | _ -> assert false) branches in + let frame_brs, to_expand = List.partition + (function + | [next_arg],_,_ -> + Aux.Strings.is_empty + (Aux.Strings.inter (term_vars next_arg) fixed_vars) + | _ -> assert false) other_brs in + (* 7f1 *) + let frame_brs, more_to_expand = List.partition + (fun (args, body, neg_body) -> + List.exists + (fun (rel, r_args) -> rel="true" && r_args=args) body + ) frame_brs in + let unfixed_brs = + to_expand @ more_to_expand in + if unfixed_brs <> [] then failwith + ("GDL.translate_game: parametric non-frame actions "^ + "not implemented yet (7g):\n" ^ + def_str ("action",unfixed_brs)); + (* 7f2 *) + let leq3 (head1, _, _) (head2, _, _) = + try + let sb, _ = match_meta [] [] head2 head1 in + List.for_all (fun (v,_)-> + not (Aux.Strings.mem v fixed_vars)) sb + with Not_found -> false in + let frames = + Aux.maximal leq3 frame_brs in + let frames = + List.map (fun repr -> + List.filter (fun cl->leq3 cl repr) frame_brs) + frames in + (* collect and rename multi-bodies *) + let frames = List.map (function + | [] -> assert false + | [head, body, neg_body] -> head, [body, neg_body] + | (head, body, neg_body)::f_brs -> + let multi_body = List.map + (fun (head2, body2, neg_body2) -> + let sb, _ = match_meta [] [] head head2 in + List.map (subst_rel sb) body2, + List.map (List.map (subst_rel sb)) neg_body2 + ) f_brs in + head, (body, neg_body)::multi_body + ) frames in + (* 7f3 *) + let erasure_brs = Aux.concat_map + (function + | [next_arg] as next_args,multi_body -> + let mask, _, _, blank_arg = term_to_blank next_arg in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Blanking-out of %s by %s\n%!" + (term_str next_arg) (term_str mask) + ); + (* }}} *) + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Frame multibody:\n%s\n%!" + ( String.concat "\n" (List.map ( + fun (body, neg_body) -> + "("^ facts_str body ^ + " " ^ neg_facts_str neg_body ^ ")" + ) multi_body)) + ); + (* }}} *) + let multi_body = List.map (fun (body, neg_body) -> + let body = + Aux.map_some (fun (rel, args) -> + if rel <> "role" && + (rel <> "true" || args <> next_args) + then Some (Aux.Left (rel, args)) + else None) body in + let neg_body = + List.map + (function + | ["distinct", []] -> assert false + | ["distinct", arg::more_args] -> + let _, sb = + List.fold_left (fun (base, sb) arg -> + let sb = unify sb [base] [arg] in + subst sb base, sb) + (arg, []) more_args in + (* inverting unfixed-to-fixed *) + let sb = List.map (function + | v1, Var v2 + when Aux.Strings.mem v1 fixed_vars + -> v2, Var v1 + | vsb -> vsb) sb in + Aux.Right (Aux.Right sb) + | conj when List.mem_assoc "distinct" conj -> + assert false + | conj -> + Aux.Right (Aux.Left conj)) + neg_body in + body @ neg_body) multi_body in + let erasures = List.map Aux.partition_choice + (Aux.unique_sorted (Aux.product multi_body)) in + let erasures = + Aux.map_some (fun (neg_body, body) -> + try + let body, sbs = Aux.partition_choice body in + let body = List.concat body in + let sb = List.fold_left compose_sb [] sbs in + if List.exists (fun (v,_)-> + Aux.Strings.mem v fixed_vars) sb + then None + else + let body = List.map (subst_rel sb) body in + let neg_body = + List.map (fun a -> [subst_rel sb a]) neg_body in + let head = subst sb blank_arg in + if + (* TODO: (7g) instead *) + Aux.Strings.subset (term_vars head) + fixed_vars && + (* (7f4) *) + not (List.exists (fun pos -> + List.mem [pos] lead_neg_body + ) body) && + not (List.exists (fun neg -> + List.for_all + (fun neg->List.mem neg lead_body) neg + ) neg_body) + then Some ([head], body, neg_body) + else None + with Not_found -> None) erasures in + let erasures = Aux.unique_sorted + (List.map (fun (head, body, neg_body) -> + head, Aux.unique_sorted body, + Aux.unique_sorted neg_body) erasures) in + erasures + (* TODO: (7g) *) + | _ -> assert false) frames in + (* TODO: (7f5) we ignore the possibility that "lead" is + instantiated by some of erasure substitutions, since + we already ignore non-maximal "legal" classes *) + lead, fixed_brs @ erasure_brs + ) rules_brs in + (* let rules_inds = Array.of_list rules_brs in *) + rules_brs + ) joint_legal_branches + ) loc_joint_legal in + (* {{{ log entry *) + if !debug_level > 1 then ( + Array.iteri (fun loc rules_brs -> + Printf.printf "Rule precursors for loc %d:\n%!" loc; + List.iter (fun ((lead,_,_), brs) -> + Printf.printf "Rule-precursor: player %s move %s\n%s\n%!" + (term_str loc_players.(loc)) (term_str lead) + (def_str ("action", brs)) + ) rules_brs; + ) loc_next_classes; + ); + (* }}} *) + (* 7h *) + let toss_var term = + let mask, _, _, blank = term_to_blank term in + mask, Formula.fo_var_of_string (term_to_name blank) in + (* 7i *) + let state_terms = + Array.fold_left (fun acc rules_brs -> + List.fold_left (fun acc (lead, brs) -> + List.fold_left (fun acc -> function + | [next_arg], body, neg_body -> + let res = + ... [truncated message content] |
From: <luk...@us...> - 2011-01-29 16:49:59
|
Revision: 1287 http://toss.svn.sourceforge.net/toss/?rev=1287&view=rev Author: lukaszkaiser Date: 2011-01-29 16:49:51 +0000 (Sat, 29 Jan 2011) Log Message: ----------- Rearangement for ggp testing, added automated test with java gamecontroller. Modified Paths: -------------- trunk/Toss/.cvsignore trunk/Toss/Makefile trunk/Toss/Play/GameTest.ml trunk/Toss/Toss.py trunk/Toss/TossTest.ml Added Paths: ----------- trunk/Toss/GGP/ trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDL.mli trunk/Toss/GGP/GDLParser.mly trunk/Toss/GGP/GDLTest.ml trunk/Toss/GGP/KIFLexer.mll trunk/Toss/GGP/Makefile trunk/Toss/GGP/examples/ trunk/Toss/GGP/examples/breakthrough.gdl trunk/Toss/GGP/examples/checkers.gdl trunk/Toss/GGP/examples/chess.gdl trunk/Toss/GGP/examples/connect5.gdl trunk/Toss/GGP/examples/tictactoe.gdl trunk/Toss/GGP/gamecontroller-cli.jar trunk/Toss/Server/ trunk/Toss/Server/Makefile trunk/Toss/Server/Server.ml trunk/Toss/Server/ServerGDLTest.in trunk/Toss/Server/ServerGDLTest.out trunk/Toss/Server/ServerTest.in trunk/Toss/Server/ServerTest.ml trunk/Toss/Server/ServerTest.out Removed Paths: ------------- trunk/Toss/Play/GDL.ml trunk/Toss/Play/GDL.mli trunk/Toss/Play/GDLParser.mly trunk/Toss/Play/GDLTest.ml trunk/Toss/Play/KIFLexer.mll trunk/Toss/Play/Server.ml trunk/Toss/Play/ServerGDLTest.in trunk/Toss/Play/ServerGDLTest.out trunk/Toss/Play/ServerTest.in trunk/Toss/Play/ServerTest.out trunk/Toss/examples/breakthrough.gdl trunk/Toss/examples/checkers.gdl trunk/Toss/examples/chess.gdl trunk/Toss/examples/connect5.gdl Property Changed: ---------------- trunk/Toss/ Property changes on: trunk/Toss ___________________________________________________________________ Modified: svn:ignore - # We are still using .cvsignore files as we find them easier to manage # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . Toss.docdir _build Server *.native *Profile.log gmon.out *~ *.annot *.cmx *.cmi *.o *.cmo *.a *.cmxa log.* + # We are still using .cvsignore files as we find them easier to manage # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . Toss.docdir _build TossServer *.native *Profile.log gmon.out *~ *.annot *.cmx *.cmi *.o *.cmo *.a *.cmxa log.* Modified: trunk/Toss/.cvsignore =================================================================== --- trunk/Toss/.cvsignore 2011-01-29 13:11:29 UTC (rev 1286) +++ trunk/Toss/.cvsignore 2011-01-29 16:49:51 UTC (rev 1287) @@ -4,7 +4,7 @@ Toss.docdir _build -Server +TossServer *.native *Profile.log gmon.out Copied: trunk/Toss/GGP/GDL.ml (from rev 1286, trunk/Toss/Play/GDL.ml) =================================================================== --- trunk/Toss/GGP/GDL.ml (rev 0) +++ trunk/Toss/GGP/GDL.ml 2011-01-29 16:49:51 UTC (rev 1287) @@ -0,0 +1,2123 @@ +(** {2 Game Description Language.} + + Type definitions, helper functions, game specification + translation. + + The translation is not complete (yet), and not yet guaranteed to + be sound (but aiming at it) -- report any cases where the + algorithm does not fail explicitly but does not preserve + semantics. + + (1) Aggregate playout: generate successive states as if all moves + legal in the previous state were performed. Do not check the + termination predicate. + + (1a) Reason for unsoundness: "legal" or "next" preconditions can + depend negatively on state, preventing further moves in the + aggregate state that would be possible in some of valid game + states; the aggregate state does not have enough terms as a + result. Workaround: remove negative literals from "legal"/"next" + conditions for generating aggregate playout. + + (1b) Saturation works on definitions stratified + w.r.t. negation. Positive literals are instantiated one by one, + then negative literals are checked over the facts derived from + previous strata. To avoid redundancy, new facts and new + instantiations are kept separate for the next iteration within a + stratum. + + (1c) Heuristic reason for unsoundness: while we check for fixpoint + in the playout, we rule out state terms "F(X)" where X is a player + (assuming that "F" means "control"). Workaround: turn off fixpoint + checking [aggregate_fixpoint]. + + (2) Arena graph: currently, only a simple cycle is allowed. The + succession of players is determined from the aggregate playout. + + (2a) We need to recognize which player actually makes a move in a + state. For this we need to locate the "noop" arguments to "legal" + and "does" relations. A noop action in a location is the only + action in the corresponding state of an aggregate playout for the + player that is also constant. + + (2b) We determine the player of a location by requiring that at + most one player has a non-noop action in an aggregate + state. When all players are noops we select the control player so + that the smallest "game cycle" is preserved. Otherwise (more than + one no-noop move) we fail (simultaneous moves not supported). We + remember the noop actions for each location and player. + + (3) Currently, a constant number of elements is assumed. The rules + processed in (3a)-(3b) are already expanded by (6). + + (3a) Element terms are collected from the aggregate playout: the + sum of state terms (the "control" function could be dropped but we + are not taking the effort to identify it). + + (3b) Element masks are generated by generalization from all "next" + rules where the "does" relations are expanded by all unifying + "legal" rules (see also (7a)). + + (3c) Generalization in a single expanded "next" rule is by finding + for the "next" term the closest "true" term in the lexicographic + ordering of (# of matched variables, # of other matched leaves), + but in case the closest term is found in the negative part, it is + further processed. + + (3c1) Unmatched subterms are replaced by meta-variables. + + (3c2) When the generalization comes from the negative part, we + replace all constant leaves with meta-variables. Warning: this + heuristic is a reason for unsoundness -- search for a workaround + once a real counterexample is encountered. + + (3d) The masks are all the minimal w.r.t. matching (substitution) + of the generalized terms, with only meta-variable positions of the + mask matching meta-variable positions of a generalized + term. + + (3e) The elements are the equivalence classes of element terms, + where terms are equivalent when they both match a single mask and + their matching substitutions differ only at + meta-variables. (I.e. for t1 and t2 there exists a mask m and + substitutions s1 and s2 such that s1(m)=t1 and s2(m)=t2 and + s1(x)=/=s2(x) implies that x is/contains a meta-variable.) + + (Note that there is "nothing wrong" with a given equiv class not + having any member in the initial state or some other state. The + element is still there in the structure, still participating in + the "static" relations, but not in the "dynamic" predicates in + that particular state. We use a special _BLANK_ term/predicate to + faciliate operations on such "absent" elements.) + + (4) Static relations (their tuples do not change during the game) + are derived from static facts with subterms common with element + terms but not below meta-variables. + + Define mask-paths as the set of a mask together with a path in it + to a position that is not below (or at) a meta-variable. + + Implementation: currently we approximate paths by only taking the + positions of variables in the mask. + + (4a) (Fact relations.) For a static fact (a relation that does not + depend on "true" or "init") (unless it is expanded -- see (6)), + introduce a relation for each mask-paths tuple with arity of the + relation (i.e., introduced relations are a dependent product of + static fact relations and a cartesian n-th power of the mask-paths + set where n is the arity of the relation). An introduced relation + holds over a tuple of elements, iff the corresponding element + terms match the respective masks, and the original relation holds + over the tuple of subterms selected from the element terms by the + corresponding paths. + + (4b) (Equality relations.) For each mask-path, introduce a binary + relation that holds over elements which have the same subterm at + the mask-path position. (Because of mask-paths definition, same + for all element terms in element's equivalence class.) + + (4c) (Anchor predicates.) Add a predicate for being derived from a + mask. For each mask-path pointing to a constant in some of the + elements and that constant, introduce a new predicate with + semantics: "matches the mask and has the constant at the path + position". + + (5) (Mostly) dynamic relations ("fluents": their tuples change + during the game), relations derived from all below-meta-variable + subterms of element terms, initialized by those that appear in the + initial state. (Some relations introduced in this step might not + be fluents.) + + (See also (7k).) For each element term, find the element mask it + matches, and introduce relations for each meta-variable of the + element mask, associated with the subterm that matches the + meta-variable. The semantic is that the relation selects the + element terms that match the mask with the associated subterm + subsituted for the corresponding meta-variable, with existential + interpretation. A relation holds initially over an element, if in + the initial set of element terms at least one from the element's + equivalence class is selected by the relation. An occurrence of + "true" or "next" relation is replaced by a conjunction of + relations whose substituted-masks match the relation's term. + + When generating predicates that hold over an element term, no + predicate is generated for any its meta-variable position that + contains _BLANK_. + + (6) Currently how to introduce defined relations in translation is + not yet solved in the presented framework. Currently, we simply + expand relations that are not static, or (optionally) are static + but do not contain ground facts, by duplicating the branch in + which body an atom of the relation occurs, for each branch of the + relation definition, unifying and applying the unifier. (If the + duplication turns out prohibitive, this will be a *huge* TODO for + this translation framework.) + + (6a) The definition: + + [(r, params1) <= body1 ... (r, params_n) <= body_n] + + provides a DNF defining formula (using negation-as-failure): + + [(r, args) <=> exist vars1 (args = params1 /\ body1) \/ ... + \/ exist vars_n (args = params_n /\ body_n)] + + which expands in a natural way for positive occurrences. We + duplicate the branch where [(r, args)] is substitued for each + disjunct and apply the unifier of [args = params_i] in the whole + [i]th cloned branch. We freshen each [vars_i] to avoid capture. If + unification fails, we drop the corresponding branch clone. + + (6b) For negative occurrences we transform the defining formula + to: + + [not (r, args) <=> not exist vars1 (args = params1 /\ body1) /\ ... + /\ not exist vars_n (args = params_n /\ body_n)] + + Currently we do not allow defined dynamic relations with negative + occurrences to have negative literals (or atoms of defined + relations with negative part) in any of [body_i]. (The limitation + can be lifted but it would further complicate the implementation.) + We therefore allow conjunctions of atoms to be negated (not only + literals) in a branch. We expand [not (r, args)] (in general, [not + (and (...(r args)...))]) into the conjunction of negations, with + no branch duplication (in general, duplicating the negated + subformula inside a branch). We only apply the unifier of [args = + params_i] to [body_i] (in general, the whole negated + subformula). Still, we freshen each [vars_i] to avoid capture. If + unification fails, we drop the corresponding negated + subformula. If unification succeeds but the corresponding [body_i] + is empty (and, in general, no other disjuncts in the negated + subformula are left), we drop the branch. + + (6b1) The general case is not implemented yet since it slightly + complicates the code, and expressivity gain is very small. + + (7) Generation of rewrite rules when the dynamic relations are not + recursive and are expanded in the GDL definition. + + (7a) We translate each branch of the "legal" relation definition + as one or more rewrite rules. Currently, we base availability of + rules in a location on the player in the location and noop actions + of other players in it, compared to the the "legal" definition + branch (currently, we do not allow simultaneous moves). If the + branch of "legal" definition has a variable for a player, it is + instantiated for each player in the game, and the variable + substituted in the body of the "legal" branch. A rewrite rule is + associated with a single "lead legal" branch of the location's + player. + + (7b) We collect all the branches of the "next" relation definition + for which the selected branches of "lead legal" and "noop legal" + (the "joint legal" actions) unify with all (usually one, but we + allow zero or more) occurrences of "does" with a single unifier + per "next" branch. (A "noop legal" actually only matches and + substitutes the local variables of "next" branches.) Split the + unifiers into equivalence classes (w.r.t. substitution), each + class will be a different rewrite rule (or set of rules). (Note + that equivalent unifiers turn out to be those that when truncated + to variables of the "legal" branch are renamings of each other.) + + (7b1) Since the "noop legals" are constants (by current + assumption), we do not need to construct equivalence classes for + them. Their branches will join every rule generated for the "joint + legal" choice. + + (7c) Find a single MGU that unifies the "legal" atom argument and + all the "does" atoms arguments into a single instance, and apply + it to all "next" branches of the rule (i.e. after applying the + original unifier, apply a renaming that makes the unifier equal to + all other unifiers in the equiv. class). We replace all + occurrences of "does" with the body of the selected "legal" + branch. + + (7d) Add all branches of equiv classes smaller than a given equiv + class to its branch set. + + Implementation TODO (reason for unsoundness): currently, we + discard non-maximal equivalence classes, because negation (7e) is + not implemented, and with negation it would still be preferable to + have exhaustiveness check so as to not generate spurious + (unapplicable) rules. + + (7e) Associate negation of equalities specific to the unifiers + strictly less general than the equivalence class with it, so that + the resulting conditions form a partition of the space of + substitutions for the "legal" branch processed. + + (7f) We remember all variables in the "legal"/"does" instantiation + as "fixed variables". We seggregate "next" atoms into these that + contain some fixed variables or no variables at all, and other + containing only unfixed variables. + + (7f1) Branches with (only) unfixed variables in "next" atoms that + are "identities" are the "frame" branches. "Identity" here means + the "next" atom is equal to one of the positive "true" atoms. + + (7f2) Transform the "frame" branches into "erasure" branches: + distribute them into equivalence classes of head terms + (w.r.t. substitution but treating fixed variables as constants), + add smaller elements and negation of larger elements (in the same + manner as in (7b) and (7d) for the "legal" term), disjoin bodies + in each class (a "multi-body"), then: + + implementation TODO: currently, we only use maximal equivalence + classes (see note at 7d) + + (7f3) negate the multi-body, push negation inside (using de Morgan + laws etc.), split into separate "erasure" branch for each + disjunct, place the original "next" atom but with meta-variable + positions replaced by _BLANK_ as the head of the "erasure" branch, + apply (and remove) unification atoms resulting from negating the + "distinct" relation. + + (7f4) Drop the erasure branches that contradict the "legal" + condition of their rule. + + (7f5) Redistribute the erasure branches in case they were + substituted with the "not distinct" unifier to proper equivalence + classes (remove equivalence classes that become empty). + + (7g) Instantiate remaining unfixed variables. Implementation TODO. + + (7h) Introduce a new element variable for each class of "next" and + "true" terms equal modulo mask (i.e. there is a mask matching them + and they differ only at-or-below metavariables). (Remember the + atoms "corresponding variable".) From now on until (7m1) we keep + both the (partially) Toss-translated versions and the (complete) + GDL-originals of branches (so to use GDL atoms for "subsumption + checking" in (7m)). + + (7i-4a) For all subterms of "next" and "true" atoms, identify the + sets of <mask-path, element variable> they "inhabit". Replace a + static fact relation by relations built over a cartesian product + of <mask-path, element variable> sets derived for each static + fact's argument by applying corresponding (4a) relations. For a + negative literal generate result equivalent to a conjunction of + negations of generated atoms (FIXME: why disjunction is wrong?). + + (7i-4c) Include the (4c) relations for "next" and "true" positive + atoms. Negative atoms are added with (5) relations since they are + under a common negation. + + (7i-4b) Add an appropriate equality relation of (4b) for each case + of variable shared by terms corresponding to different element + variables (regardless if the element terms are in positive or + negative literals). FIXME: any shared subterm, not limited to + variables, right? + + Implementation: instead of all subterms we currently only consider + subterms that instantiate (ordinary) variables in the mask + corresponding to the "next"/"true" atom. + + (7i1) Remove branches that are unsatisfiable by their static + relations (4a), (4b) and (4c) alone. + + (7j) Identify variables in "next" & "true" terms that are + at-or-below meta-variables in the corresponding mask. (Most of + such variables should be already removed as belonging to "frame" + branches.) Expand them by duplicating given branch for all + instantiations (all (5) predicates derived from the considered + position). (Note that since branches do not have unfixed variables + anymore, we do not rename variables during duplication.) + + (7k) Replace the "next" and "true" atoms by the conjunction of + (4c) and (5) predicates over their corresponding variable. (For + negative "true" literals this will be equivalent to a disjunction + of negations of the predicates.) Note that positive static + relations are already added in (7i-4c). + + (7l) Build a pre-lattice of branch bodies w.r.t. subsumption, + in a manner similar to (7b). The subsumption test has to say "no" + when there exists a game state where the antecedent holds but the + consequent does not, but does not need to always say "yes" + otherwise. Build a rewrite rule for each equivalence class + w.r.t. subsumption, including also branches that are below the + equiv class, and including negation of conditions that make the + branches strictly above more specific -- so that the classes form + a partition of the nonterminal game states (it is semantically + necessary so that all applicable changes are applied in the + translated game when making a move). + + (7l1) Since all variables are fixed, the lattice is built by + summing rule bodies. To avoid contradictions and have a complete + partition, we construct the set of all bit vectors indexed by all + atoms occurring in the bodies. With every index-bit value we + associate the set of branches that do not allow such literal. For + every vector we calculate the complement of the sum of branch sets + associated with every bit. The unique resulting sets are exactly + the Toss rules precursors. + + (7m) Include translated negation of the terminal condition. (Now we + build rewrite rules for a refinement of an equivalence class of + (7b): from the branches with unifiers in the equiv class, from + branches with unifiers more general than the equiv class, and from + the disjointness conditions and the terminal condition.) + + The rewrite rule is generated by joining the derived conjunctions + from "next" atoms as RHS, and from bodies as the + precondition. Exactly the RHS variables are listed in the LHS + (other variables are existentially closed in the precondition). + + (8) We use a single payoff matrix for all locations. Goal patterns + are expanded to regular goals by instantiating the value variable + by all values in its domain (for example, as gathered from the + aggregate playout), and expanding all atoms that contained value + variables (both static and dynamic) using (6); fail if a goal + value cannot be determined. The payoff formula is the sum of + "goal" value times the characterisic function of the "goal" + body. We do not translate the body if the value is zero (we drop + the zero goal branches from the definition). Translate the body + using (7h)-(7m), but treating "goal" branches separately -- when + (7k) duplicates a branch, new branches add new sum elements. + +*) + +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 and have + arity above the threshold. *) +let expand_arity_above = ref 0 + +type term = + | Const of string + | Var of string + | MVar of string (* meta-variable, not used in GDL *) + | Func of string * term list + +type atom = + | Distinct of term list + | Rel of string * term list + | Currently of term + | Does of term * term + +type literal = + | Pos of atom + | 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 request = + | Start of string * term * game_descr_entry 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 *) + | Stop of string * term list + (* 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 + | Func (f, args) -> terms_vars args +and terms_vars args = + List.fold_left Aux.Strings.union Aux.Strings.empty + (List.map term_vars args) + +let fact_of_atom = function + | Distinct args -> assert false + | Rel (rel, args) -> rel, args + | Currently arg -> "true", [arg] + | Does (arg1, arg2) -> "does", [arg1; arg2] + +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)] + | 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 expanded definitions: expansion of a negated + relation brings negated conjunctions. *) +type exp_def_branch = + term list * gdl_atom list * 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) + +(* +let branch_vars (args, body, neg_body) = +*) + +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 : (string * exp_def_branch list) list = + Aux.map_reduce + (fun ((drel, params), body, neg_body) -> + drel,(params, body, List.map (fun a->[a]) neg_body)) + (fun x y->y::x) [] rules + +(* Only use [rules_of_defs] when sure that no multi-premise negative + literal has been expanded. *) +let rules_of_defs (defs : exp_def list) = + Aux.concat_map (fun (rel, branches) -> + List.map (fun (args, body, neg_body) -> + let neg_body = + List.map (function [a]->a | _ -> assert false) neg_body in + (rel, args), body, neg_body) 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 : exp_def list) = + match + 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 defs)) + (if def then body @ List.concat neg_body + else List.concat neg_body)) branches) defs + with + | [], [] -> List.rev strata + | stratum, [] -> List.rev (stratum::strata) + | [], _ -> + if def then 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 -> stratify (stratum::strata) 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 + | Func (f, args) -> + Func (f, List.map (subst_one sb) args) + +let rec unify sb terms1 terms2 = + match terms1, terms2 with + | [], [] -> sb + | 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) + | Var x::terms1, Var y::terms2 when x=y -> + unify sb terms1 terms2 + | (Var x::terms1, (Var _ | Const _ as term)::terms2 + | (Const _ as term)::terms1, Var x::terms2) -> + let sb1 = x, term in + unify (sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb) + (List.map (subst_one sb1) terms1) + (List.map (subst_one sb1) terms2) + | (Var x::_, term::_ | term::_, Var x::_) + when Aux.Strings.mem x (term_vars term) -> + raise Not_found + | Var x::terms1, term::terms2 | term::terms1, Var x::terms2 -> + let sb1 = x, term in + unify (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 + +(* 3d *) +(* Match the first argument as term against the second argument as + pattern. Allow nonlinear (object) variables. *) +let rec match_meta 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 sb m_sb terms1 terms2 + | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g -> + match_meta sb m_sb (args1 @ terms1) (args2 @ terms2) + | term::terms1, MVar x::terms2 -> + (* we don't substitute because metavariables are linear *) + match_meta sb ((x, term)::m_sb) terms1 terms2 + | MVar _::_, _ -> 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 sb m_sb terms1 terms2 + | _ -> raise Not_found + + +(* 3c1 *) +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), gens = loop pf terms1 terms2 in + (good_vars, good_csts+1), cst::gens + | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g -> + let (good_vars1, good_csts1), gen_args = loop f args1 args2 in + let (good_vars2, good_csts2), gens = loop pf terms1 terms2 in + (good_vars1+good_vars2, good_csts1+good_csts2), + (Func (f,gen_args))::gens + | (Var x as var)::terms1, Var y::terms2 when x=y -> + let (good_vars, good_csts), gens = loop pf terms1 terms2 in + (good_vars+1, good_csts), var::gens + | _::terms1, _::terms2 -> + let measure, gens = loop pf terms1 terms2 in + incr fresh_count; + measure, MVar ("MV"^string_of_int !fresh_count)::gens + | _::_, [] | [], _::_ -> raise + (Lexer.Parsing_error + ("GDL.generalize: arity mismatch at function "^pf)) in + let measure, gens = loop "impossible" [term1] [term2] in + measure, !fresh_count, List.hd gens + +(* 3c2 *) +let abstract_consts fresh_count term = + let fresh_count = ref fresh_count in + let rec loop = function + | Const _ -> incr fresh_count; MVar ("MV"^string_of_int !fresh_count) + | Func (f,args) -> Func (f, List.map loop args) + | term -> term in + loop term + +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) + +let unify_rels (rel1, args1) (rel2, args2) = + if rel1 = rel2 then unify [] args1 args2 + else raise Not_found + +let subst_rel sb (rel, args) = rel, List.map (subst sb) args +let subst_rels sb body = List.map (subst_rel sb) body +let extend_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb + +let compose_sb sb1 sb2 = + let vars1, terms1 = List.split sb1 in + let vars2, terms2 = List.split sb2 in + 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, + List.map (subst_rel sb) body, + List.map (List.map (subst_rel sb)) neg_body + +let fact_str (rel, args) = + "("^rel^" "^String.concat " " (List.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 facts_str facts = + String.concat " " (List.map fact_str facts) +let neg_facts_str negs = + String.concat " " + (List.map (fun d -> "(not (and "^facts_str d^"))") negs) + +let 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) + +(* 1b *) + +(* TODO: optimize by using rel-indexing (also in [aggregate_playout]). + TODO: optimize by using constant-time append data structure. *) +let saturate base rules = + + let instantiate_one tot_base cur_base 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 || + List.mem neg_atom tot_base) neg_body then [] + else [Aux.Left head] + | head, cond1::body, neg_body -> + Aux.map_try (fun fact -> + (* {{{ log entry *) + + if !debug_level > 5 then ( + Printf.printf "instantiate_one: trying to unify %s and %s\n%!" + (fact_str fact) (fact_str cond1) + ); + + (* }}} *) + let sb = unify_rels fact cond1 in + (* {{{ log entry *) + if !debug_level > 5 then ( + Printf.printf "instantiate_one: succeeded with %s\n%!" + (sb_str sb) + ); + (* }}} *) + let irule = + subst_rel sb head, + subst_rels sb body, subst_rels sb neg_body in + Aux.Right irule + ) cur_base) irules in + + 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%!" + (facts_str old_base) (facts_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 new_base1, new_irules1 = + Aux.partition_choice (instantiate_one base cur_base cur_irules) in + (* {{{ log entry *) + if !debug_level > 4 then ( + Printf.printf "inst_stratum: cur-cur = %s\n%!" + (facts_str new_base1) + ); + (* }}} *) + let new_base2, new_irules2 = + Aux.partition_choice (instantiate_one base cur_base old_irules) in + (* {{{ log entry *) + if !debug_level > 4 then ( + Printf.printf "inst_stratum: cur-old = %s\n%!" + (facts_str new_base2) + ); + (* }}} *) + let new_base3, new_irules3 = + Aux.partition_choice (instantiate_one base old_base cur_irules) in + (* {{{ log entry *) + if !debug_level > 4 then ( + Printf.printf "inst_stratum: old-cur = %s\n%!" + (facts_str new_base3) + ); + (* }}} *) + let new_base = Aux.unique_sorted (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 = [] + 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 base + (List.map rules_of_defs (stratify [] (defs_of_rules rules))) + + +let playing_as = ref (Const "uninitialized") +let game_description = ref [] +let player_terms = ref [| |] + +let state_of_file s = + Printf.printf "GDL: Loading file %s...\n%!" s; + let f = open_in s in + let res = + ArenaParser.parse_game_state Lexer.lex + (Lexing.from_channel f) in + Printf.printf "GDL: File %s loaded.\n%!" s; + res + +(* 6 *) + +(* Need a global access so that the count can be reset between + different translations. (Generalization uses a local [fresh_count] + state.) *) +let freshen_count = ref 0 + +(* TODO: do proper elegant renaming... *) +let freshen_branch (args, body, neg_body) = + incr freshen_count; + let rec map_vnames = function + | Var x -> Var (x^string_of_int !freshen_count) + | MVar x -> MVar (x^string_of_int !freshen_count) + | Const _ as t -> t + | Func (f, args) -> + Func (f, List.map map_vnames args) in + let map_rel (rel, args) = + rel, List.map map_vnames args in + List.map map_vnames args, + List.map map_rel body, + List.map (List.map map_rel) neg_body + +let freshen_def_branches = + List.map freshen_branch + +(* assumption: [defs] bodies are already clean of defined relations *) +let subst_def_branch (defs : exp_def list) + (head, body, neg_body as br : exp_def_branch) : exp_def_branch list = + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "Expanding branch %s\n%!" (def_str ("BRANCH", [br])); + ); + (* }}} *) + (* 6a *) + let sols = + List.fold_left (fun sols (rel, args as atom) -> + (let try def = + freshen_def_branches (List.assoc rel defs) in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "Expanding positive %s by %s\n%!" rel + (def_str (rel, def)) + ); + (* }}} *) + Aux.concat_map (fun (pos_sol, neg_sol, sb) -> + let args = List.map (subst sb) args in + Aux.map_some (fun (dparams, dbody, dneg_body) -> + try + let sb1 = unify [] dparams args in + Some ( + subst_rels sb1 (dbody @ pos_sol), + List.map (subst_rels sb1) (dneg_body @ neg_sol), + extend_sb sb1 sb) + with Not_found -> None + ) def + ) sols + with Not_found -> + List.map (fun (pos_sol, neg_sol, sb) -> + subst_rel sb atom::pos_sol, neg_sol, sb) sols)) + ([[],[],[]]) body in + (* 6b *) + let sols = + List.fold_left (fun sols -> function [rel, args as atom] -> + (let try def = + freshen_def_branches (List.assoc rel defs) in + List.map (fun (pos_sol, neg_sol, sb) -> + let args = List.map (subst sb) args in + let more_neg = + Aux.map_some (fun (dparams, dbody, dneg_body) -> + if dneg_body <> [] then + failwith + ("GDL.subst_def_branch: negation in negatively used" ^ + " defined rels not supported yet, relation "^rel); + try + let sb1 = unify [] dparams args in + Some (subst_rels sb1 dbody) + with Not_found -> None + ) def in + pos_sol, more_neg @ neg_sol, sb + ) sols + with Not_found -> + List.map (fun (pos_sol, neg_sol, sb) -> + pos_sol, [subst_rel sb atom]::neg_sol, sb) sols) + | _ -> failwith + "GDL.subst_def_branch: unimplemented, see (6b1) of spec") + sols neg_body in + Aux.map_some (fun (pos_sol, neg_sol, sb) -> + if List.mem [] neg_sol then None + else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols + +(* Stratify and expand all relations in the given set. *) +let expand_def_rules ?(more_defs=[]) rules = + let rec loop base = function + | [] -> base + | stratum::strata -> + let step = List.map (fun (rel, branches) -> + rel, Aux.concat_map + (subst_def_branch (more_defs@base)) branches) stratum in + loop (base @ step) strata in + match stratify ~def:true [] (defs_of_rules rules) with + | [] -> [] + | [no_defined_rels] when more_defs=[] -> no_defined_rels + | def_base::def_strata when more_defs=[] -> loop def_base def_strata + | def_strata -> loop more_defs def_strata + + +(* As [subst_def_branch], but specifically for "legal" definition and + result structured by "legal" definition branches. *) +(* 7b *) +let subst_legal_rule + (legal_args, legal_body, legal_neg_body : exp_def_branch) + (head, body, neg_body : exp_def_branch) + : (exp_def_branch * exp_def_branch) option = + if List.exists (List.exists (fun (rel,_)->rel="does")) neg_body + then failwith + "GDL.translate_game: negated \"does\" conditions not implemented yet"; + try + let body, more_neg_body, sb = + List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) -> + if rel = "does" then + List.rev_append legal_body body, + List.rev_append legal_neg_body more_neg_body, + unify sb legal_args args + else atom::body, more_neg_body, sb) ([],[],[]) body in + + Some ( + (List.map (subst sb) legal_args, + List.map (subst_rel sb) legal_body, + List.map (List.map (subst_rel sb)) legal_neg_body), + (List.map (subst sb) head, + List.map (subst_rel sb) (List.rev body), + List.map (List.map (subst_rel sb)) + (List.rev_append more_neg_body neg_body))) + with Not_found -> None + +(* 1 *) + +(* Collect the aggregate playout, but also the actions available in + the state. *) +let aggregate_ply players static current rules = + let base = + Aux.map_prepend static (fun term -> "true", [term]) current in + let base = saturate (base @ static) rules in + let does = Aux.map_some (fun (rel, args) -> + if rel = "legal" then Some ("does", args) else None) base in + if (* no move *) + Aux.array_existsi (fun _ player -> + List.for_all (function _, (actor::_) -> player <> actor | _ -> true) + does) players + then raise Not_found + else + let step = saturate (does @ base) rules in + 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 + Aux.array_existsi (fun _ player -> arg=player) players -> true + | term -> List.mem term current + ) step + then raise Not_found + else + List.map snd does, step + +(* 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. *) +let aggregate_playout players horizon rules = + (* separate and precompute the static part *) + let rec separate static_rels state_rels = + let static, more_state = + List.partition (fun rel -> + List.for_all (fun ((rule,_), body, neg_body) -> + rule <> rel || List.for_all (fun srel -> + not (List.mem_assoc srel (neg_body @ body))) state_rels) + rules) static_rels in + if more_state = [] then static_rels, state_rels + else separate static (more_state @ state_rels) in + let static_rels, state_rels = + separate (List.map (fun ((r,_),_,_)->r) rules) + ["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 state_rules = + (* 1a *) + if !aggregate_drop_negative then + List.map (function + | ("legal", _ as head), body, _ -> head, body, [] + | ("does", _ as head), body, _ -> head, body, [] + | rule -> rule) dynamic_rules + else dynamic_rules in + let rec loop actions_accu state_accu step state = + (* {{{ log entry *) + + if !debug_level > 0 then ( + Printf.printf "aggregate_playout: step %d...\n%!" step + ); + + (* }}} *) + (let try actions, next = + aggregate_ply players static_base state state_rules in + (* {{{ log entry *) + + if !debug_level > 0 then ( + Printf.printf "aggregate_playout: state %s\n%!" + (String.concat " " (List.map term_str next)) + ); + + (* }}} *) + 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 Not_found -> + List.rev actions_accu, 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 + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "aggregate_playout: init %s\n%!" + (String.concat " " (List.map term_str init_state)) + ); + (* }}} *) + static_rules, dynamic_rules, static_base, init_state, + loop [] [] 0 init_state + + +let find_cycle cands = + let rec loop cycle trav pref rem path = + if cycle = [] then + let ini = [List.hd path] in + loop ini ini ini [] (List.tl path) + else match path, rem with + | _, [] -> loop cycle trav [] cycle path + | [], _ -> cycle (* consumed the whole path *) + | x::tail, y::rem when x=y || x = None-> + (* either elements agree or indifferent path element *) + loop cycle (x::trav) (y::pref) rem tail + | x::tail, None::rem -> + (* instantiating undecided cycle element *) + loop (List.rev pref @ [x] @ rem) (x::trav) (x::pref) rem tail + | x::tail, _::_ -> + (* mismatch: grow the cycle to current point *) + let trav = x::trav in + let cycle = List.rev trav in + 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 rec blank_out = function + | Const a as c, Const b when a = b -> c + | (*Var _ as*) v, Var _ -> v + | t, MVar _ -> Const "_BLANK_" + | Func (f, f_args), Func (g, g_args) when f = g -> + Func (f, List.map blank_out (List.combine f_args g_args)) + | a, b -> + Printf.printf "blank_out mismatch: term %s, mask %s\n%!" + (term_str a) (term_str b); + assert false + +let translate_game game_descr = + freshen_count := 0; + let player_terms = + Array.of_list + (Aux.map_some (function Role p -> Some p | _ -> None) game_descr) in + let players_n = Array.length player_terms in + let find_player player = + Aux.array_argfind (fun p->p=player) player_terms in + let rules = Aux.concat_map rules_of_entry game_descr in + let static_rules, dynamic_rules, static_base, init_state, + (agg_actions, agg_states) = + aggregate_playout player_terms 30 rules in + (* (8) -- drop zero goal branches, "first round" *) + let dynamic_rules = List.filter + (function ("goal", [_; Const "0"]), _, _ -> false | _ -> true) + dynamic_rules in + let element_terms : term list = + List.fold_left (fun acc st -> Aux.unique_sorted (st @ acc)) [] + agg_states 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 + (* 2a *) + 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 + (Lexer.Parsing_error + ("GDL.initialize_game: branching arena graphs"^ + " or simultaneous moves not supported yet")) + | _, 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 + | _ -> failwith + "GDL.initialize_game: simultaneous moves not supported yet" + ) control_cands noop_cands in + let control_cands, noop_cands = + List.split control_noop_cands in + (* 2b *) + let loc_players = find_cycle control_cands in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "translate_game: 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 -> player_terms.(0)) + loc_players) in + let loc_n = Array.length loc_players in + let find_player_locs player = + Aux.array_argfind_all (fun p->p=player) loc_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 + (* 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 failwith + "GDL.translate_game: noop-driven location splits unimplemented") + (List.hd !noops); + incr i; if !i = loc_n then i := 0; + noops := List.tl !noops + done; + loc_noops in + (* 6 *) + let static_rules, exp_static_rules = + List.partition (fun ((rel,args), _, _) -> + List.length args <= !expand_arity_above || + List.exists (function ((r,_),[],[]) when rel=r-> true + | _ -> false) static_rules + ) static_rules in + (* {{{ log entry *) + + if !debug_level > 0 then ( + Printf.printf "translate_game: expanded static rules: %s\n%!" + (String.concat ", " (List.map (fun ((r,_),_,_)->r) exp_static_rules)); + ); + + (* }}} *) + let static_exp_defs = expand_def_rules exp_static_rules in + let static_rules = + if static_exp_defs = [] then static_rules + else rules_of_defs + (List.map (fun (rel,branches) -> + rel, Aux.concat_map (subst_def_branch static_exp_defs) branches) + (defs_of_rules static_rules)) in + let exp_defs = + expand_def_rules ~more_defs:static_exp_defs dynamic_rules in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "translate_game: All expanded dynamic rules:\n%s\n%!" + (String.concat "\n" (List.map def_str exp_defs)) + ); + (* }}} *) + (* 3 *) + let legal_rules = List.assoc "legal" exp_defs in + let next_rules = List.assoc "next" exp_defs in + (* 3b *) + let exp_next = + Aux.concat_map (subst_def_branch ["does", legal_rules]) next_rules in + (* {{{ log entry *) + + if !debug_level > 0 then ( + Printf.printf "translate_game: \"next\" rules with \"does\"<-\"legal\":\n%s\n%!" + (def_str ("next", exp_next)) + ); + + (* }}} *) + (* 3c *) + let masks = List.map (function + | [next_arg], body, neg_body -> + let collect = Aux.map_some + (function "true", [arg] -> Some arg + | "true", _ -> raise + (Lexer.Parsing_error + ("GDL.initialize_game: invalid arity of \"true\" atom")) + | _ -> None) in + let pos_cands = collect body in + let neg_cands = Aux.concat_map collect neg_body in + let pos_gens = List.map (generalize next_arg) pos_cands in + let neg_gens = List.map (generalize next_arg) neg_cands in + (* using the fact that Pervasives.compare is lexicographic *) + let pos_gen = List.fold_left max ((-1,0),0,Const "") pos_gens in + let neg_gen = List.fold_left max ((-1,0),0,Const "") neg_gens in + let (_, fresh_count, mask as gen) = max pos_gen neg_gen in + if gen == pos_gen then mask + else abstract_consts fresh_count mask + | _ -> raise + (Lexer.Parsing_error + ("GDL.initialize_game: invalid arity of \"next\" atom"))) + exp_next in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "translate_game: Generalized element terms (mask candidates):\n%s\n%!" + (String.concat " " (List.map term_str masks)) + ); + (* }}} *) + (* find minimal *) + let masks = Aux.maximal (fun t1 t2->cmp_masks t2 t1) masks in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "translate_game: Masks:\n%s\n%!" + (String.concat " " (List.map term_str masks)) + ); + (* }}} *) + (* 3e *) + let elements = List.fold_left (fun elements term -> + let mask, sb, m_sb = + match + Aux.map_try (fun mask -> + mask, match_meta [] [] [term] [mask]) masks + with [mask, (sb, m_sb)] -> mask, sb, m_sb + | _ -> assert false in (* masks are minimal *) + let sbs, elements = + try Aux.pop_assoc mask elements + with Not_found -> [], elements in + (mask, if List.mem sb sbs then sbs else sb::sbs)::elements + ) [] element_terms in + let struc = Structure.empty_structure () in + let struc, elements = + List.fold_left (fun (struc, elements) (mask, sbs) -> + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "mask-elements:"; + ); + (* }}} *) + let struc, m_elements = + List.fold_left (fun (struc, m_elements) sb -> + let e_term = subst sb mask in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf ", %s%!" (term_to_name e_term) + ); + (* }}} *) + let struc, elem = + Structure.add_new_elem struc ~name:(term_to_name e_term) () in + struc, (sb, elem)::m_elements + ) (struc, []) sbs in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "\n%!"; + ); + (* }}} *) + struc, (mask, m_elements)::elements + ) (struc, []) elements in + (* 4 *) + (* currently, position paths are approximated by variables + (non-variable positions are ignored) *) + let mask_paths = Aux.concat_map (function _, [] -> assert false + | mask, (sb,_)::_ -> List.map (fun (v,_)->mask, v) sb) elements in + (* 4a *) + let static_rels = + Aux.unique_sorted + (List.map (fun ((rname,args),_,_) -> + rname, List.map (fun _ -> ()) args) static_rules) in + let static_rels = + List.map (fun (rel,args) -> + rel, List.length args, + Aux.all_tuples_for args mask_paths) static_rels in + let static_base = Aux.collect static_base in + (* TODO: optimize by indexing elements by path position + terms (currently, substitution values) *) + let struc = + List.fold_left (fun struc (brel, arity, path_tups) -> + let brel_tups = List.assoc brel static_base in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "Translating static relation %s with %d tuples:\n%s\n%!" + brel (List.length brel_tups) (tuples_str brel_tups); + ); + (* }}} *) + List.fold_left (fun struc ptup -> + let rname = brel ^ "__" ^ String.concat "__" + (List.map (fun (mask,v)-> + term_to_name mask ^ "_" ^ v) ptup) in + let struc = + Structure.add_rel_name rname (List.length ptup) struc in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "static-rel: %s, of... %!" rname; + ); + (* }}} *) + let elem_sets = + List.map (fun (mask,v)-> + List.map (fun (sb,elem)-> + try List.assoc v sb, elem + with Not_found -> assert false) + (List.assoc mask elements)) ptup in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "%s ... %!" (String.concat "x" ( + List.map (fun x-> string_of_int (List.length x)) elem_sets)); + ); + (* }}} *) + let elem_tups = + Aux.concat_map (fun ttup -> + let elem_sets = List.map2 (fun term elems -> + Aux.map_some (fun (tcand, e) -> + if tcand=term then Some e else None) elems + ) ttup elem_sets in + List.map Array.of_list (Aux.product elem_sets) + ) brel_tups in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "%d tuples, adding to struc...%!" + (List.length elem_tups); + ); + (* }}} *) + let res = Structure.unsafe_add_rels struc rname elem_tups in + (* {{{ log entry *) + + if !debug_level > 1 then ( + Printf.printf " done\n%!"; + ); + + (* }}} *) + res + ) struc path_tups + ) struc static_rels in + + (* 4b *) + let struc = List.fold_left (fun struc (mask,v) -> + let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in + let struc = + Structure.add_rel_name rname 2 struc in + let elems = List.assoc mask elements in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "Adding static EQ relation %s over %d elements.\n%!" + rname (List.length elems); + ); + (* }}} *) + let elem_tups = + List.fold_left (fun tups (sb1, e1) -> + List.fold_left (fun tups (sb2, e2) -> + try + if List.assoc v sb1 = List.assoc v sb2 + then [|e1; e2|]::[|e2; e1|]::tups + else tups + with Not_found -> assert false + ) tups elems + ) [] elems in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups); + ); + (* }}} *) + l... [truncated message content] |
From: <luk...@us...> - 2011-01-30 00:49:15
|
Revision: 1288 http://toss.svn.sourceforge.net/toss/?rev=1288&view=rev Author: lukaszkaiser Date: 2011-01-30 00:49:08 +0000 (Sun, 30 Jan 2011) Log Message: ----------- Manual translation of pawn whopping and connect4, game detection. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDL.mli trunk/Toss/GGP/Makefile trunk/Toss/Server/Server.ml Added Paths: ----------- trunk/Toss/GGP/examples/connect4.gdl trunk/Toss/GGP/examples/pawn_whopping.gdl Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-01-29 16:49:51 UTC (rev 1287) +++ trunk/Toss/GGP/GDL.ml 2011-01-30 00:49:08 UTC (rev 1288) @@ -1967,7 +1967,13 @@ let manual_translation = ref true let manual_game = ref "tictactoe" let top_exec_path = ref "." (* path to top Toss directory *) +let tictactoe_descr = ref None +let breakthrough_descr = ref None +let connect5_descr = ref None +let connect4_descr = ref None +let pawn_whopping_descr = ref None + let initialize_game_tictactoe state player game_descr startcl = state := state_of_file (!top_exec_path ^ "/examples/Tic-Tac-Toe.toss"); playing_as := player; @@ -1986,6 +1992,15 @@ 2, 100, 4.0 in effort, horizon, heur_adv_ratio +let initialize_game_connect4 state player game_descr startcl = + state := state_of_file (!top_exec_path ^ "/examples/Connect4.toss"); + playing_as := player; + game_description := game_descr; + player_name_terms := [|Const "WHITE"; Const "RED"|]; + let effort, horizon, heur_adv_ratio = + 2, 100, 4.0 in + effort, horizon, heur_adv_ratio + let initialize_game_breakthrough state player game_descr startcl = state := state_of_file (!top_exec_path ^ "/examples/Breakthrough.toss"); playing_as := player; @@ -1995,14 +2010,32 @@ 2, 100, 2.0 in effort, horizon, heur_adv_ratio +let initialize_game_pawn_whopping state player game_descr startcl = + state := state_of_file (!top_exec_path ^ "/examples/PawnWhopping.toss"); + playing_as := player; + game_description := game_descr; + player_name_terms := [|Const "X"; Const "O"|]; + let effort, horizon, heur_adv_ratio = + 2, 100, 2.0 in + effort, horizon, heur_adv_ratio + let initialize_game state player game_descr startcl = + if (Some game_descr) = !tictactoe_descr then manual_game := "tictactoe"; + if (Some game_descr) = !breakthrough_descr then manual_game := "breakthrough"; + if (Some game_descr) = !connect5_descr then manual_game := "connect5"; + if (Some game_descr) = !connect4_descr then manual_game := "connect4"; + if (Some game_descr) = !pawn_whopping_descr then manual_game:="pawn_whopping"; match !manual_translation, !manual_game with | true, "tictactoe" -> initialize_game_tictactoe state player game_descr startcl | true, "connect5" -> initialize_game_gomoku state player game_descr startcl + | true, "connect4" -> + initialize_game_connect4 state player game_descr startcl | true, "breakthrough" -> initialize_game_breakthrough state player game_descr startcl + | true, "pawn_whopping" -> + initialize_game_pawn_whopping state player game_descr startcl | true, game -> failwith ("GDL: manual translation of unknown game "^game) | false, _ -> @@ -2034,6 +2067,23 @@ "Circle", ["a1", ((String.lowercase col) ^ (number_of_letter row.[0]))] | _ -> assert false +let translate_last_action_connect4 struc actions = + let int2col i = let s = String.create 1 in s.[0] <- Char.chr (i + 96); s in + let elem2i elem_s = Structure.StringMap.find elem_s struc.Structure.names in + let pair2i (i, j) = elem2i ((int2col i) ^ (string_of_int j)) in + let check rel p = Structure.check_rel struc rel [|pair2i p|] in + let is_free p = not (check "P" p || check "Q" p) in + let first_free i = List.find (fun j -> is_free (i, j)) [1;2;3;4;5;6] in + match actions with + | [] -> + (* start of game -- Server will handle this answer as NOOP *) + "", [] + | [Func ("DROP", [Const col]); Const "NOOP"] -> + "Cross", ["a", (int2col (s2i col))^(string_of_int(first_free (s2i col)))] + | [ Const "NOOP"; Func ("DROP", [Const col])] -> + "Circle", ["a", (int2col (s2i col))^(string_of_int(first_free (s2i col)))] + | _ -> assert false + let translate_last_action_breakthrough actions = match actions with | [] -> @@ -2062,14 +2112,46 @@ "b", Structure.board_coords_name (s2i x2, s2i y2)] | _ -> assert false -let translate_last_action actions = +let translate_last_action_pawn_whopping actions = + match actions with + | [] -> + (* start of game -- Server will handle this answer as NOOP *) + "", [] + | [Func ("MOVE", [Const x1; Const y1; Const x2; Const y2]); + Const "NOOP"] when x1 = x2 && (s2i y2) - (s2i y1) = 1 -> + "WhiteStraight", + ["a1", Structure.board_coords_name (s2i x1, s2i y1); + "a2", Structure.board_coords_name (s2i x2, s2i y2)] + | [Func ("CAPTURE", [Const x1; Const y1; Const x2; Const y2]); + Const "NOOP"] -> + "WhiteDiag", + ["a", Structure.board_coords_name (s2i x1, s2i y1); + "b", Structure.board_coords_name (s2i x2, s2i y2)] + | [Const "NOOP"; + Func ("MOVE", [Const x1; Const y1; Const x2; Const y2])] + when x1 = x2 && (s2i y1) - (s2i y2) = 1 -> + "BlackStraight", + ["a2", Structure.board_coords_name (s2i x1, s2i y1); + "a1", Structure.board_coords_name (s2i x2, s2i y2)] + | [Const "NOOP"; + Func ("CAPTURE", [Const x1; Const y1; Const x2; Const y2])] -> + "BlackDiag", + ["a", Structure.board_coords_name (s2i x1, s2i y1); + "b", Structure.board_coords_name (s2i x2, s2i y2)] + | _ -> assert false + +let translate_last_action struc actions = match !manual_translation, !manual_game with | true, "tictactoe" -> translate_last_action_tictactoe actions | true, "connect5" -> translate_last_action_gomoku actions + | true, "connect4" -> + translate_last_action_connect4 struc actions | true, "breakthrough" -> translate_last_action_breakthrough actions + | true, "pawn_whopping" -> + translate_last_action_pawn_whopping actions | true, game -> failwith ("GDL: manual translation of unknown game "^game) | false, _ -> @@ -2097,6 +2179,13 @@ let cs, rs = Char.chr (c + 64), Char.chr (r + 64) in Printf.sprintf "(MARK %c %c)" cs rs +let translate_move_connect4 rule emb new_state = + let struc = new_state.Arena.struc in + let elem = snd (List.hd emb) in + let c, _ = + Structure.board_elem_coords (Structure.elem_str struc elem) in + Printf.sprintf "(DROP %d)" c + let translate_move_breakthrough rule emb new_state = let struc = new_state.Arena.struc in match emb with @@ -2109,14 +2198,39 @@ Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2 | _ -> assert false +let translate_move_pawn_whopping rule emb new_state = + let struc = new_state.Arena.struc in + match emb with + | [(_,a); (_,b)] -> + let x1, y1 = + Structure.board_elem_coords (Structure.elem_str struc a) + and x2, y2 = + Structure.board_elem_coords (Structure.elem_str struc b) in + if x1 = x2 then + Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2 + else + Printf.sprintf "(CAPTURE %d %d %d %d)" x1 y1 x2 y2 + | [(_,a); (_,b); (_, c)] -> + let a, b = if rule = "BlackStraightTwo" then a, c else a, c in + let x1, y1 = + Structure.board_elem_coords (Structure.elem_str struc a) + and x2, y2 = + Structure.board_elem_coords (Structure.elem_str struc b) in + Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2 + | _ -> assert false + let translate_move rule emb new_state = match !manual_translation, !manual_game with | true, "tictactoe" -> translate_move_tictactoe rule emb new_state | true, "connect5" -> translate_move_gomoku rule emb new_state + | true, "connect4" -> + translate_move_connect4 rule emb new_state | true, "breakthrough" -> translate_move_breakthrough rule emb new_state + | true, "pawn_whopping" -> + translate_move_pawn_whopping rule emb new_state | true, game -> failwith ("GDL: manual translation of unknown game "^game) | false, _ -> Modified: trunk/Toss/GGP/GDL.mli =================================================================== --- trunk/Toss/GGP/GDL.mli 2011-01-29 16:49:51 UTC (rev 1287) +++ trunk/Toss/GGP/GDL.mli 2011-01-30 00:49:08 UTC (rev 1288) @@ -38,6 +38,12 @@ | Initial of term * literal list | Atomic of string * term list +val tictactoe_descr : game_descr_entry list option ref +val breakthrough_descr : game_descr_entry list option ref +val connect5_descr : game_descr_entry list option ref +val connect4_descr : game_descr_entry list option ref +val pawn_whopping_descr : game_descr_entry list option ref + type request = | Start of string * term * game_descr_entry list * int * int (** prepare game: match id, role, game, startclock, playclock *) @@ -76,7 +82,7 @@ int * int * float val translate_last_action : - term list -> string * (string * string) list + Structure.structure -> term list -> string * (string * string) list (** Whether the current player is the one being played as. *) val our_turn : Arena.game_state -> bool Modified: trunk/Toss/GGP/Makefile =================================================================== --- trunk/Toss/GGP/Makefile 2011-01-29 16:49:51 UTC (rev 1287) +++ trunk/Toss/GGP/Makefile 2011-01-30 00:49:08 UTC (rev 1288) @@ -16,7 +16,7 @@ GDLTestDebug: %.ggp: examples/%.gdl ../TossServer - ../TossServer -gdl $(basename $@) -v & + ../TossServer -gdl unset -v & java -jar gamecontroller-cli.jar play $< 120 30 1 -legal 1 -remote 2 toss localhost 8110 1 | grep results killall -v TossServer Added: trunk/Toss/GGP/examples/connect4.gdl =================================================================== --- trunk/Toss/GGP/examples/connect4.gdl (rev 0) +++ trunk/Toss/GGP/examples/connect4.gdl 2011-01-30 00:49:08 UTC (rev 1288) @@ -0,0 +1,268 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Connect 4 +;;; +;;; +;;; modified 2007-06-05 by dhaley: made line rules more efficient +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (role white) + (role red) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (init (cell 1 0 dirt)) + (init (cell 2 0 dirt)) + (init (cell 3 0 dirt)) + (init (cell 4 0 dirt)) + (init (cell 5 0 dirt)) + (init (cell 6 0 dirt)) + (init (cell 7 0 dirt)) + + (init (cell 1 1 b)) + (init (cell 1 2 b)) + (init (cell 1 3 b)) + (init (cell 1 4 b)) + (init (cell 1 5 b)) + (init (cell 1 6 b)) + + (init (cell 2 1 b)) + (init (cell 2 2 b)) + (init (cell 2 3 b)) + (init (cell 2 4 b)) + (init (cell 2 5 b)) + (init (cell 2 6 b)) + + (init (cell 3 1 b)) + (init (cell 3 2 b)) + (init (cell 3 3 b)) + (init (cell 3 4 b)) + (init (cell 3 5 b)) + (init (cell 3 6 b)) + + (init (cell 4 1 b)) + (init (cell 4 2 b)) + (init (cell 4 3 b)) + (init (cell 4 4 b)) + (init (cell 4 5 b)) + (init (cell 4 6 b)) + + (init (cell 5 1 b)) + (init (cell 5 2 b)) + (init (cell 5 3 b)) + (init (cell 5 4 b)) + (init (cell 5 5 b)) + (init (cell 5 6 b)) + + (init (cell 6 1 b)) + (init (cell 6 2 b)) + (init (cell 6 3 b)) + (init (cell 6 4 b)) + (init (cell 6 5 b)) + (init (cell 6 6 b)) + + (init (cell 7 1 b)) + (init (cell 7 2 b)) + (init (cell 7 3 b)) + (init (cell 7 4 b)) + (init (cell 7 5 b)) + (init (cell 7 6 b)) + + (init (control white)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (<= (empty ?c ?h) + (true (cell ?c ?h b))) + + (<= (filled ?c ?h) + (true (cell ?c ?h dirt))) + (<= (filled ?c ?h) + (true (cell ?c ?h w))) + (<= (filled ?c ?h) + (true (cell ?c ?h r))) + + (<= (next (cell ?c ?h2 w)) + (does white (drop ?c)) + (true (cell ?c ?h2 b)) + (filled ?c ?h1) + (succ ?h1 ?h2)) + + (<= (next (cell ?c ?h2 r)) + (does red (drop ?c)) + (true (cell ?c ?h2 b)) + (filled ?c ?h1) + (succ ?h1 ?h2)) + + (<= (next (cell ?x ?y ?z)) + (true (cell ?x ?y ?z)) + (distinct ?z b)) + + (<= (next (cell ?c2 ?y b)) + (does ?w (drop ?c1)) + (true (cell ?c2 ?y b)) + (distinct ?c1 ?c2)) + +;; (<= (next (cell ?c ?h3 b)) +;; (role ?r) +;; (does ?r (drop ?c)) +;; (true (cell ?c ?h2 b)) +;; (filled ?c ?h1) +;; (succ ?h1 ?h2) +;; (succ ?h2 ?h3)) + + (<= (next (cell ?c ?y2 b)) + (true (cell ?c ?y1 b)) + (distinct ?y1 6) + (succ ?y1 ?y2)) + + (<= (next (control white)) + (true (control red))) + + (<= (next (control red)) + (true (control white))) + + ;; horizontal + (<= (row ?z) (true (cell ?x1 ?y ?z)) + (distinct ?z b) + (distinct ?z dirt) + (succ ?x1 ?x2) + (true (cell ?x2 ?y ?z)) + (succ ?x2 ?x3) + (true (cell ?x3 ?y ?z)) + (succ ?x3 ?x4) + (true (cell ?x4 ?y ?z)) + ) + + ;; vertical + (<= (column ?z) (true (cell ?x ?y1 ?z)) + (distinct ?z b) + (succ ?y1 ?y2) + (true (cell ?x ?y2 ?z)) + (succ ?y2 ?y3) + (true (cell ?x ?y3 ?z)) + (succ ?y3 ?y4) + (true (cell ?x ?y4 ?z)) + ) + + ;; diagonal (north-east) + (<= (diag ?z) (true (cell ?x1 ?y1 ?z)) + (distinct ?z b) + (succ ?x1 ?x2) + (succ ?y1 ?y2) + (true (cell ?x2 ?y2 ?z)) + (succ ?x2 ?x3) + (succ ?y2 ?y3) + (true (cell ?x3 ?y3 ?z)) + (succ ?x3 ?x4) + (succ ?y3 ?y4) + (true (cell ?x4 ?y4 ?z)) + ) + + ;; diagonal (south-east) + (<= (diag ?z) (true (cell ?x1 ?y1 ?z)) + (distinct ?z b) + (succ ?x1 ?x2) + (succ ?y2 ?y1) + (true (cell ?x2 ?y2 ?z)) + (succ ?x2 ?x3) + (succ ?y3 ?y2) + (true (cell ?x3 ?y3 ?z)) + (succ ?x3 ?x4) + (succ ?y4 ?y3) + (true (cell ?x4 ?y4 ?z)) + ) + + (<= (line ?x) (row ?x)) + (<= (line ?x) (column ?x)) + (<= (line ?x) (diag ?x)) + + (<= open + (empty ?c ?h)) + + (<= terminal + (line r)) + + (<= terminal + (line w)) + + (<= terminal + (not open)) + + (<= (legal ?w (drop ?c)) + (true (cell ?c ?y2 b)) + (filled ?c ?y1) + (succ ?y1 ?y2) + (true (control ?w))) + + (<= (legal white noop) + (true (control red))) + + (<= (legal red noop) + (true (control white))) + + (<= (goal white 100) + (line w)) + + (<= (goal white 50) + (not (line r)) + (not (line w)) + (not open)) + + (<= (goal white 0) + (line r)) + + (<= (goal red 100) + (line r)) + + (<= (goal red 50) + (not (line r)) + (not (line w)) + (not open)) + + (<= (goal red 0) + (line w)) + + (<= (goal ?w 70) + (role ?w) + (not (line r)) + (not (line w)) + open) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; arithmetic +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(<= (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) + + + + Added: trunk/Toss/GGP/examples/pawn_whopping.gdl =================================================================== --- trunk/Toss/GGP/examples/pawn_whopping.gdl (rev 0) +++ trunk/Toss/GGP/examples/pawn_whopping.gdl 2011-01-30 00:49:08 UTC (rev 1288) @@ -0,0 +1,147 @@ +; Pawnville Pawn whopping from Learning to Play Chess with Fritz and Chesster. +; Goal is to either move a pawn to the opposite side or capture all the +; opponent's pawns. +; The game is played on a 8 x 8 board. This version ignores en passant. +(role x) +(role o) + +; Initial conditions +(init (cell 1 7 o)) +(init (cell 2 7 o)) +(init (cell 3 7 o)) +(init (cell 4 7 o)) +(init (cell 5 7 o)) +(init (cell 6 7 o)) +(init (cell 7 7 o)) +(init (cell 8 7 o)) +(init (cell 1 2 x)) +(init (cell 2 2 x)) +(init (cell 3 2 x)) +(init (cell 4 2 x)) +(init (cell 5 2 x)) +(init (cell 6 2 x)) +(init (cell 7 2 x)) +(init (cell 8 2 x)) +(init (control x)) + +; Legal moves +(<= (legal ?p noop) + (role ?p) + (not (true (control ?p)))) +(<= (legal ?p ?move) + (true (control ?p)) + (can_move ?p ?move)) +(<= (legal ?p noop) + (role ?p) + (not (can_move_somewhere ?p))) +; Move forward +(<= (can_move x (move ?x ?y1 ?x ?y2)) + (true (cell ?x ?y1 x)) + (succ ?y1 ?y2) + (not (occupied ?x ?y2))) +(<= (occupied ?x ?y) + (role ?r) + (true (cell ?x ?y ?r))) +(<= (can_move o (move ?x ?y1 ?x ?y2)) + (true (cell ?x ?y1 o)) + (succ ?y2 ?y1) + (not (occupied ?x ?y2))) +; First move can be a double. +(<= (can_move x (move ?x 2 ?x 4)) + (true (cell ?x 2 x)) + (not (occupied ?x 3)) + (not (occupied ?x 4))) +(<= (can_move o (move ?x 8 ?x 6)) + (true (cell ?x 8 o)) + (not (occupied ?x 7)) + (not (occupied ?x 6))) +; Capture diagonally +(<= (can_move x (capture ?x1 ?y1 ?x2 ?y2)) + (true (cell ?x1 ?y1 x)) + (true (cell ?x2 ?y2 o)) + (succ ?y1 ?y2) + (or (succ ?x1 ?x2) + (succ ?x2 ?x1))) +(<= (can_move o (capture ?x1 ?y1 ?x2 ?y2)) + (true (cell ?x1 ?y1 o)) + (true (cell ?x2 ?y2 x)) + (succ ?y2 ?y1) + (or (succ ?x1 ?x2) + (succ ?x2 ?x1))) + +; Transition rules +(<= (next (cell ?x ?y ?p)) + (true (cell ?x ?y ?p)) + (not (changes ?x ?y))) +(<= (next (cell ?x ?y ?p)) + (does ?p (move ?any_x ?any_y ?x ?y))) +(<= (next (cell ?x ?y ?p)) + (does ?p (capture ?any_x ?any_y ?x ?y))) + +(<= (changes ?x ?y) + (does ?r (move ?x ?y ?any_x ?any_y))) +(<= (changes ?x ?y) + (does ?r (capture ?x ?y ?any_x ?any_y))) +(<= (changes ?x ?y) + (does ?r (capture ?any_x ?any_y ?x ?y))) + +; Control +(<= (next (control o)) + (true (control x))) +(<= (next (control x)) + (true (control o))) + +; Goal +(<= (goal x 100) + xwins) + +(<= (goal o 100) + owins) + +(<= (has_pieces ?p) + (true (cell ?x ?y ?p))) + +(<= (goal ?p 50) + (role ?p) + (not (can_move_somewhere x)) + (not (can_move_somewhere o)) + (not xwins) + (not owins)) + +(<= (goal x 0) + owins) + +(<= (goal o 0) + xwins) + +(<= xwins + (true (cell ?any_x 8 x))) +(<= xwins + (not (has_pieces o))) + +(<= owins + (true (cell ?any_x 1 o))) +(<= owins + (not (has_pieces x))) + +; Terminal conditions +(<= terminal + (goal ?role 100)) + +(<= terminal + (not (can_move_somewhere x)) + (not (can_move_somewhere o))) + +(<= (can_move_somewhere ?p) + (can_move ?p ?m)) + +; Successor axioms +(succ 1 2) +(succ 2 3) +(succ 3 4) +(succ 4 5) +(succ 5 6) +(succ 6 7) +(succ 7 8) + + Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-01-29 16:49:51 UTC (rev 1287) +++ trunk/Toss/Server/Server.ml 2011-01-30 00:49:08 UTC (rev 1288) @@ -283,7 +283,7 @@ | Aux.Right (GDL.Play (_, actions)) -> let r_name, mtch = - GDL.translate_last_action actions in + GDL.translate_last_action !state.Arena.struc actions in if r_name <> "" then ( let {Arena.rules=rules; graph=graph} = !state.Arena.game in @@ -388,7 +388,7 @@ | Aux.Right (GDL.Stop (_, actions)) -> let r_name, mtch = - GDL.translate_last_action actions in + GDL.translate_last_action !state.Arena.struc actions in if r_name <> "" then ( let {Arena.rules=rules; graph=graph} = !state.Arena.game in @@ -532,5 +532,22 @@ (* so that the server is not started by the test suite. *) if not test_fname then ( GDL.top_exec_path := dir_from_path Sys.argv.(0); + let parse_game_descr s = + GDLParser.parse_game_description KIFLexer.lex (Lexing.from_string s) in + let input_file fname = + let lines, f = ref [], open_in fname in + try + while true; do lines := input_line f :: !lines done; "" + with End_of_file -> + close_in f; + String.concat "\n" (List.rev !lines) in + let load_rules fname = + let gdl = input_file (!GDL.top_exec_path ^ "/GGP/examples/" ^ fname) in + parse_game_descr (String.uppercase gdl) in + GDL.tictactoe_descr := Some (load_rules "tictactoe.gdl"); + GDL.breakthrough_descr := Some (load_rules "breakthrough.gdl"); + GDL.connect5_descr := Some (load_rules "connect5.gdl"); + GDL.connect4_descr := Some (load_rules "connect4.gdl"); + GDL.pawn_whopping_descr := Some (load_rules "pawn_whopping.gdl"); main () ) ;; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-30 02:54:06
|
Revision: 1290 http://toss.svn.sourceforge.net/toss/?rev=1290&view=rev Author: lukstafi Date: 2011-01-30 02:54:00 +0000 (Sun, 30 Jan 2011) Log Message: ----------- Display heuristics at lower logging level. Optionally turn off monotonicity check. Modified Paths: -------------- trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Server/Server.ml Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-01-30 02:27:25 UTC (rev 1289) +++ trunk/Toss/Play/Game.ml 2011-01-30 02:54:00 UTC (rev 1290) @@ -11,6 +11,7 @@ let set_debug_level i = (debug_level := i) let deterministic_suggest = ref false +let use_monotonic = ref true (* A global "hurry up!" switch triggered by the timer alarm. *) let timeout = ref false @@ -248,7 +249,8 @@ List.map (fun r -> (snd r).ContinuousRule.compiled) rules in let fluents = Aux.concat_map DiscreteRule.fluents drules in let frels = Aux.strings_of_list fluents in - let monotonic = List.for_all DiscreteRule.monotonic drules in + let monotonic = !use_monotonic && + List.for_all DiscreteRule.monotonic drules in let signat_struc = match struc with Some struc -> struc | None -> @@ -263,7 +265,7 @@ Array.mapi (fun i node -> Array.map (fun payoff -> (* {{{ log entry *) - if !debug_level > 5 then ( + if !debug_level > (* 5 *) 0 then ( Printf.printf "default_heuristic: Computing for loc %d of payoff %s...\n%!" i (Formula.sprint_real payoff); @@ -273,8 +275,16 @@ "default_heuristic: Computing for loc %d\n%!" i; ); (* }}} *) - Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio - frels payoff) + let res = + Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio + frels payoff in + (* {{{ log entry *) + if !debug_level > (* 6 *) 0 then ( + Printf.printf "default_heuristic: %s\n%!" + (Formula.sprint_real res) + ); + (* }}} *) + res) node.Arena.payoffs) graph Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-01-30 02:27:25 UTC (rev 1289) +++ trunk/Toss/Play/Game.mli 2011-01-30 02:54:00 UTC (rev 1290) @@ -4,8 +4,8 @@ (** A global "hurry up!" switch triggered by the timer alarm. *) val get_timeout : unit -> bool val cancel_timeout : unit -> unit +val use_monotonic : bool ref - (** History stored for a play, including caching of computations for further use. *) type memory Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-01-30 02:27:25 UTC (rev 1289) +++ trunk/Toss/Server/Server.ml 2011-01-30 02:54:00 UTC (rev 1290) @@ -503,7 +503,8 @@ ("-s", Arg.String (fun s -> (server := s)), " server (default: localhost)"); ("-gdl", Arg.String (fun s -> GDL.manual_game := s; GDL.manual_translation := true), - " GDL game for manual (i.e. hard-coded) translation (tictactoe, gomoku, breakthrough)"); + " GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)"); + ("-nm", Arg.Unit (fun () -> Game.use_monotonic := false), " turn monotonicity off"); ("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)"); ("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)"); ] in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-30 03:14:00
|
Revision: 1291 http://toss.svn.sourceforge.net/toss/?rev=1291&view=rev Author: lukaszkaiser Date: 2011-01-30 03:13:54 +0000 (Sun, 30 Jan 2011) Log Message: ----------- Increase debug for heuristic a bit, add -vv switch. Modified Paths: -------------- trunk/Toss/Play/Game.ml trunk/Toss/Server/Server.ml Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-01-30 02:54:00 UTC (rev 1290) +++ trunk/Toss/Play/Game.ml 2011-01-30 03:13:54 UTC (rev 1291) @@ -265,7 +265,7 @@ Array.mapi (fun i node -> Array.map (fun payoff -> (* {{{ log entry *) - if !debug_level > (* 5 *) 0 then ( + if !debug_level > (* 5 *) 1 then ( Printf.printf "default_heuristic: Computing for loc %d of payoff %s...\n%!" i (Formula.sprint_real payoff); @@ -279,7 +279,7 @@ Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio frels payoff in (* {{{ log entry *) - if !debug_level > (* 6 *) 0 then ( + if !debug_level > (* 6 *) 1 then ( Printf.printf "default_heuristic: %s\n%!" (Formula.sprint_real res) ); Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-01-30 02:54:00 UTC (rev 1290) +++ trunk/Toss/Server/Server.ml 2011-01-30 03:13:54 UTC (rev 1291) @@ -499,6 +499,7 @@ let (server, port) = (ref "localhost", ref 8110) in let opts = [ ("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose"); + ("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose"); ("-d", Arg.Int (fun i -> set_debug_level i), " Toss server debug log level"); ("-s", Arg.String (fun s -> (server := s)), " server (default: localhost)"); ("-gdl", Arg.String (fun s -> This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-30 20:30:08
|
Revision: 1294 http://toss.svn.sourceforge.net/toss/?rev=1294&view=rev Author: lukaszkaiser Date: 2011-01-30 20:30:02 +0000 (Sun, 30 Jan 2011) Log Message: ----------- Use non-monotone heuristic for connect4, other small corrections. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/Play/Game.ml trunk/Toss/examples/Connect4.toss trunk/Toss/examples/PawnWhopping.toss Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-01-30 14:40:55 UTC (rev 1293) +++ trunk/Toss/GGP/GDL.ml 2011-01-30 20:30:02 UTC (rev 1294) @@ -1989,6 +1989,7 @@ playing_as := player; game_description := game_descr; player_name_terms := [|Const "X"; Const "O"|]; + Game.use_monotonic := true; let effort, horizon, heur_adv_ratio = 2, 100, 4.0 in effort, horizon, heur_adv_ratio @@ -1998,8 +1999,9 @@ playing_as := player; game_description := game_descr; player_name_terms := [|Const "WHITE"; Const "RED"|]; + Game.use_monotonic := false; let effort, horizon, heur_adv_ratio = - 5, 100, 4.0 in + 6, 100, 4.0 in effort, horizon, heur_adv_ratio let initialize_game_breakthrough state player game_descr startcl = Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-01-30 14:40:55 UTC (rev 1293) +++ trunk/Toss/Play/Game.ml 2011-01-30 20:30:02 UTC (rev 1294) @@ -21,7 +21,7 @@ (* {{{ log entry *) if !debug_level > 0 then ( if !timeout then - Printf.printf "Computation finished during timeout.\n%!" + Printf.printf "Computation finished by timeout.\n%!" else Printf.printf "Computation finished with %d seconds left.\n%!" remaining Modified: trunk/Toss/examples/Connect4.toss =================================================================== --- trunk/Toss/examples/Connect4.toss 2011-01-30 14:40:55 UTC (rev 1293) +++ trunk/Toss/examples/Connect4.toss 2011-01-30 20:30:02 UTC (rev 1294) @@ -1,5 +1,5 @@ PLAYERS 1, 2 -DATA r1: circle, r2: line, adv_ratio: 4, depth: 1 +DATA r1: circle, r2: line, adv_ratio: 4, depth: 6 REL DiagA (x, y) = ex u (R(x, u) and C(u, y)) REL DiagB (x, y) = ex u (R(x, u) and C(y, u)) REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v) Modified: trunk/Toss/examples/PawnWhopping.toss =================================================================== --- trunk/Toss/examples/PawnWhopping.toss 2011-01-30 14:40:55 UTC (rev 1293) +++ trunk/Toss/examples/PawnWhopping.toss 2011-01-30 20:30:02 UTC (rev 1294) @@ -1,5 +1,5 @@ PLAYERS 1, 2 -DATA depth: 2, adv_ratio: 2 +DATA depth: 4, adv_ratio: 2 REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y))) REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y))) REL IsFirst(x) = not ex z C(z, x) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-31 01:29:51
|
Revision: 1295 http://toss.svn.sourceforge.net/toss/?rev=1295&view=rev Author: lukaszkaiser Date: 2011-01-31 01:29:45 +0000 (Mon, 31 Jan 2011) Log Message: ----------- Try increased depth. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/Server/Server.ml Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-01-30 20:30:02 UTC (rev 1294) +++ trunk/Toss/GGP/GDL.ml 2011-01-31 01:29:45 UTC (rev 1295) @@ -2001,7 +2001,7 @@ player_name_terms := [|Const "WHITE"; Const "RED"|]; Game.use_monotonic := false; let effort, horizon, heur_adv_ratio = - 6, 100, 4.0 in + 8, 100, 4.0 in effort, horizon, heur_adv_ratio let initialize_game_breakthrough state player game_descr startcl = @@ -2010,7 +2010,7 @@ game_description := game_descr; player_name_terms := [|Const "WHITE"; Const "BLACK"|]; let effort, horizon, heur_adv_ratio = - 3, 100, 2.0 in + 4, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game_pawn_whopping state player game_descr startcl = @@ -2019,7 +2019,7 @@ game_description := game_descr; player_name_terms := [|Const "X"; Const "O"|]; let effort, horizon, heur_adv_ratio = - 5, 100, 2.0 in + 6, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game state player game_descr startcl = Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-01-30 20:30:02 UTC (rev 1294) +++ trunk/Toss/Server/Server.ml 2011-01-31 01:29:45 UTC (rev 1295) @@ -494,7 +494,7 @@ let main () = Gc.set { (Gc.get()) with Gc.space_overhead = 300; (* 300% instead of 80% std *) - Gc.minor_heap_size = 64*1024; (* 2*std, opt ~= L2 cache/proc *) + Gc.minor_heap_size = 80*1024; (* 2*std, opt ~= L2 cache/proc *) Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) }; let (server, port) = (ref "localhost", ref 8110) in let opts = [ This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-01-31 20:53:00
|
Revision: 1297 http://toss.svn.sourceforge.net/toss/?rev=1297&view=rev Author: lukstafi Date: 2011-01-31 20:52:54 +0000 (Mon, 31 Jan 2011) Log Message: ----------- Terminal payoffs in alpha-beta hack. Minor progress in GDL translation. Modified Paths: -------------- trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/GGP/GDL.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/GameTest.ml Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-01-31 18:22:02 UTC (rev 1296) +++ trunk/Toss/Formula/Aux.ml 2011-01-31 20:52:54 UTC (rev 1297) @@ -11,6 +11,13 @@ let strings_of_list nvs = add_strings nvs Strings.empty +module Ints = Set.Make + (struct type t = int let compare x y = x - y end) +let add_ints nvs vs = + List.fold_left (fun vs nv -> Ints.add nv vs) vs nvs +let ints_of_list nvs = + add_ints nvs Ints.empty + let is_digit c = (c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') || (c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9') Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2011-01-31 18:22:02 UTC (rev 1296) +++ trunk/Toss/Formula/Aux.mli 2011-01-31 20:52:54 UTC (rev 1297) @@ -7,6 +7,10 @@ val add_strings : string list -> Strings.t -> Strings.t val strings_of_list : string list -> Strings.t +module Ints : Set.S with type elt = int +val add_ints : int list -> Ints.t -> Ints.t +val ints_of_list : int list -> Ints.t + val is_digit : char -> bool val fst3 : 'a * 'b * 'c -> 'a Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-01-31 18:22:02 UTC (rev 1296) +++ trunk/Toss/GGP/GDL.ml 2011-01-31 20:52:54 UTC (rev 1297) @@ -478,6 +478,8 @@ 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 branch_vars (args, body, neg_body) = @@ -1931,10 +1933,39 @@ Some (phi, br)) else None | _ -> assert false) brs in - (* to be continued... *) + (* 7j: TODO *) + (* 7k: TODO *) + (* 7l *) + let atoms = + List.fold_left (fun acc (_,(_,body,neg_body))-> + List.fold_right Atoms.add body + (List.fold_right (List.fold_right Atoms.add) + neg_body acc) + ) Atoms.empty brs in + let atoms = Atoms.elements atoms in + let brs = Array.of_list brs in (* indexing branches *) + let table = List.map (fun atom -> + let positives = Array.mapi (fun i (_,(_,body,_)) -> + if List.mem atom body then Some i else None) brs in + let positives = Aux.map_some (fun x->x) + (Array.to_list positives) in + let negatives = Array.mapi (fun i (_,(_,_,neg_body)) -> + if List.exists (List.mem atom) neg_body then Some i + else None) brs in + let negatives = Aux.map_some (fun x->x) + (Array.to_list negatives) in + [Aux.Ints.empty; Aux.Ints.empty] (* TODO *) + ) atoms in + let cases = Aux.product table in + let full_set = Aux.ints_of_list + (Array.to_list (Array.mapi (fun i _ -> i) brs)) in + let cases = + List.map (List.fold_left Aux.Ints.inter full_set) cases in + [lead, brs] ) rules_brs ) loc_next_classes in + (* (* {{{ log entry *) if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> @@ -1948,6 +1979,7 @@ ) loc_toss_rules; ); (* }}} *) + *) struc (* Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-01-31 18:22:02 UTC (rev 1296) +++ trunk/Toss/Play/Game.ml 2011-01-31 20:52:54 UTC (rev 1297) @@ -727,15 +727,17 @@ | Maximax_evgame (subgames, cooperative, depth, use_pruning) -> (* {{{ log entry *) + let nodes_count = ref 0 in let size_count = ref 1 in let depth0 = depth in let debug_playclock = ref 0. in if !debug_level > 1 && depth > 1 || !debug_level > 3 then ( - printf "toss: %s%s ev game, timer started...\n%!" + printf "toss: %s ev game, timer started...\n%!" (if use_pruning then "alpha_beta_ord" else "maximax"); debug_playclock := Sys.time ()); + (* }}} *) (* full tree search of limited depth by plain recursive calls, with optional alpha-beta pruning *) @@ -767,12 +769,17 @@ printf ", leaf %d heur: %F %!" player res.(player) ); (* }}} *) - res + res ) else let location = graph.(loc) in let moves = gen_moves grid_size rules model location in - if moves = [| |] || !timeout then (* terminal position *) + if moves = [| |] then (* terminal position *) + Array.map (fun expr -> + 100000. *. + Solver.M.get_real_val expr state.struc) + location.Arena.payoffs_pp (* see [let payoff] above *) + else if !timeout then play_evgame grid_size model time subgames.(loc) else let models = Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-01-31 18:22:02 UTC (rev 1296) +++ trunk/Toss/Play/GameTest.ml 2011-01-31 20:52:54 UTC (rev 1297) @@ -857,11 +857,11 @@ let a () = run_test_tt ~verbose:true experiments let a () = - Server.set_debug_level 1 + Game.set_debug_level 1 let a () = match test_filter - ["Game:0:misc:1:server: ServerGDLTest.in GDL Tic-Tac-Toe"] + [""] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-02 00:00:32
|
Revision: 1305 http://toss.svn.sourceforge.net/toss/?rev=1305&view=rev Author: lukstafi Date: 2011-02-02 00:00:24 +0000 (Wed, 02 Feb 2011) Log Message: ----------- GDL translation: in progress (final assignment of GDL branches to Toss rules but not filtered yet). Minor fixes in iterative deepening. Restored Server tests. Modified Paths: -------------- trunk/Toss/Formula/Aux.ml trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDLTest.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/GameTest.ml trunk/Toss/Server/Server.ml trunk/Toss/Server/ServerGDLTest.in trunk/Toss/Server/ServerGDLTest.out trunk/Toss/Server/ServerTest.ml Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Formula/Aux.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -457,8 +457,8 @@ let strip_spaces s = let (b, e) = (ref 0, ref ((String.length s) - 1)) in - while !b < !e && is_space (s.[!b]) do b := !b + 1 done; - while !b <= !e && is_space (s.[!e]) do e := !e - 1 done; + while !b < !e && is_space (s.[!b]) do incr b done; + while !b <= !e && is_space (s.[!e]) do decr e done; if !e < !b then "" else String.sub s !b (!e - !b + 1) let rec input_http_message file = Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/GGP/GDL.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -349,7 +349,10 @@ associated with every bit. The unique resulting sets are exactly the Toss rules precursors. - (7m) Include translated negation of the terminal condition. (Now we + (7m) Filter the final rule candidates by satisfiability in at + least one of aggregate playout states. + + (7n) Include translated negation of the terminal condition. (Now we build rewrite rules for a refinement of an equivalence class of (7b): from the branches with unifiers in the equiv class, from branches with unifiers more general than the equiv class, and from @@ -712,6 +715,11 @@ " " ^ neg_facts_str neg_body ^ ")" ) branches) +let rule_pretransl_str (heads, bodies, neg_bodies) = + "("^ facts_str bodies ^ + " " ^ neg_facts_str neg_bodies ^ "==>" ^ + String.concat "; " (List.map term_str heads) ^ ")" + let sb_str sb = String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb) @@ -1772,71 +1780,69 @@ let toss_var term = let mask, _, _, blank = term_to_blank term in mask, Formula.fo_var_of_string (term_to_name blank) in - (* 7i *) - let state_terms = - Array.fold_left (fun acc rules_brs -> - List.fold_left (fun acc (lead, brs) -> - List.fold_left (fun acc -> function - | [next_arg], body, neg_body -> - let res = - List.fold_left (fun acc -> function - | "true", [true_arg] -> Terms.add true_arg acc - | "true", _ -> assert false - | _ -> acc) acc body in - let res = - List.fold_left (List.fold_left (fun acc -> function - | "true", [true_arg] -> Terms.add true_arg acc - | "true", _ -> assert false - | _ -> acc)) res neg_body in - Terms.add next_arg res - | _ -> assert false - ) acc brs - ) acc rules_brs) Terms.empty loc_next_classes in - let state_terms = Terms.elements state_terms in - (* {{{ log entry *) - if !debug_level > 2 then ( - Printf.printf "state_terms: %s\n%!" ( - String.concat ", " (List.map term_str state_terms)) - ); - (* }}} *) - let state_subterms = - Aux.concat_map (fun term -> - let mask, sb, m_sb, blanked = term_to_blank term in - List.map (fun (v,t) -> t, (mask, v, term)) sb - ) state_terms in - let conjs_4a rel args = - let ptups = List.map (fun arg -> - Aux.assoc_all arg state_subterms) args in - (* {{{ log entry *) - if !debug_level > 3 then ( - Printf.printf "conjs_4a: of %s = subterms %s\n%!" - (fact_str (rel,args)) (String.concat "; " ( - List.map (fun l -> String.concat ", " - (List.map (fun (_,_,term)->term_str term) l)) ptups)) - ); - (* }}} *) - let ptups = Aux.product ptups in - let res = - List.map (fun ptup -> - let rname = rel ^ "__" ^ String.concat "__" - (List.map (fun (mask,v,_)-> - term_to_name mask ^ "_" ^ v) ptup) in - let tup = List.map (fun (_,_,term) -> - snd (toss_var term)) ptup in - Formula.Rel (rname, Array.of_list tup)) ptups in - let res = Aux.unique_sorted res in - (* {{{ log entry *) - if !debug_level > 3 then ( - Printf.printf "conjs_4a: of %s = %s\n%!" - (fact_str (rel,args)) (Formula.str (Formula.And res)) - ); - (* }}} *) - res in let loc_toss_rules = Array.mapi (fun loc rules_brs -> Aux.concat_map (fun (lead, brs) -> + (* 7i *) + (* Do not flatten the already built super-partition. *) + let state_terms = + List.fold_left (fun acc -> function + | [next_arg], body, neg_body -> + let res = + List.fold_left (fun acc -> function + | "true", [true_arg] -> Terms.add true_arg acc + | "true", _ -> assert false + | _ -> acc) acc body in + let res = + List.fold_left (List.fold_left (fun acc -> function + | "true", [true_arg] -> Terms.add true_arg acc + | "true", _ -> assert false + | _ -> acc)) res neg_body in + Terms.add next_arg res + | _ -> assert false + ) Terms.empty brs in + let state_terms = Terms.elements state_terms in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "state_terms: %s\n%!" ( + String.concat ", " (List.map term_str state_terms)) + ); + (* }}} *) + let state_subterms = + Aux.concat_map (fun term -> + let mask, sb, m_sb, blanked = term_to_blank term in + List.map (fun (v,t) -> t, (mask, v, term)) sb + ) state_terms in + let conjs_4a rel args = + let ptups = List.map (fun arg -> + Aux.assoc_all arg state_subterms) args in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "conjs_4a: of %s = subterms %s\n%!" + (fact_str (rel,args)) (String.concat "; " ( + List.map (fun l -> String.concat ", " + (List.map (fun (_,_,term)->term_str term) l)) ptups)) + ); + (* }}} *) + let ptups = Aux.product ptups in + let res = + List.map (fun ptup -> + let rname = rel ^ "__" ^ String.concat "__" + (List.map (fun (mask,v,_)-> + term_to_name mask ^ "_" ^ v) ptup) in + let tup = List.map (fun (_,_,term) -> + snd (toss_var term)) ptup in + Formula.Rel (rname, Array.of_list tup)) ptups in + let res = Aux.unique_sorted res in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "conjs_4a: of %s = %s\n%!" + (fact_str (rel,args)) (Formula.str (Formula.And res)) + ); + (* }}} *) + res in let brs = Aux.map_some (function - | [next_arg],body,neg_body as br -> + | [next_arg],body,neg_body -> let mask, sb, m_sb, blanked = term_to_blank next_arg in let rname = term_to_name mask in let _, svar = toss_var next_arg in @@ -1930,7 +1936,7 @@ Printf.printf "holds\n%!" ); (* }}} *) - Some (phi, br)) + Some (phi, (next_arg,body,neg_body))) else None | _ -> assert false) brs in (* 7j: TODO *) @@ -1942,8 +1948,13 @@ (List.fold_right (List.fold_right Atoms.add) neg_body acc) ) Atoms.empty brs in + Printf.printf "\na\n%!"; let atoms = Atoms.elements atoms in + Printf.printf "\nb\n%!"; let brs = Array.of_list brs in (* indexing branches *) + let full_set = Aux.ints_of_list + (Array.to_list (Array.mapi (fun i _ -> i) brs)) in + Printf.printf "\nc\n%!"; let table = List.map (fun atom -> let positives = Array.mapi (fun i (_,(_,body,_)) -> if List.mem atom body then Some i else None) brs in @@ -1954,32 +1965,72 @@ else None) brs in let negatives = Aux.map_some (fun x->x) (Array.to_list negatives) in - [Aux.Ints.empty; Aux.Ints.empty] (* TODO *) + Printf.printf "\nd\n%!"; + (* first those that allow "P" then those that allow "not P" *) + [Aux.Ints.diff full_set (Aux.ints_of_list negatives); + Aux.Ints.diff full_set (Aux.ints_of_list positives)] ) atoms in + Printf.printf "\ne\n%!"; let cases = Aux.product table in - let full_set = Aux.ints_of_list - (Array.to_list (Array.mapi (fun i _ -> i) brs)) in + Printf.printf "\nf\n%!"; let cases = List.map (List.fold_left Aux.Ints.inter full_set) cases in - - [lead, brs] + Printf.printf "\ng\n%!"; + let cases = + Aux.unique_sorted (List.map Aux.Ints.elements cases) in + Printf.printf "\nh\n%!"; + let cases = List.map (fun c_brs -> + let c_brs = List.map (Array.get brs) c_brs in + List.fold_left (fun (phis,heads,bodies,neg_bodies) + (phi,(head,body,neg_body)) -> + phi::phis,head::heads,body@bodies,neg_body@neg_bodies) + ([],[],[],[]) c_brs + ) cases in + Printf.printf "\ni\n%!"; + let cases = List.filter (fun (phis,heads,bodies,neg_bodies) -> + let phi = Formula.And phis in + let rphi = Solver.M.register_formula phi in + (* {{{ log entry *) + if !debug_level > 3 then ( + (* do not print, because it generates too many + answers -- too little constraints per number of + variables when considering a single branch *) + (* + let assgn = Solver.M.evaluate struc rphi in + let avars = List.map Formula.var_str + (FormulaOps.free_vars phi) in + let atups = + AssignmentSet.tuples struc.Structure.elements + avars assgn in *) + Printf.printf "evaluating: %s -- simpl %s\n%!" + (Formula.str phi) + (Solver.M.formula_str rphi) + (* (List.length atups) *) + ); + (* }}} *) + let res = Solver.M.check_formula struc rphi in + (* {{{ log entry *) + if !debug_level > 3 && res then ( + Printf.printf "holds\n%!" + ); + (* }}} *) + res) cases in + Printf.printf "\nj\n%!"; + List.map (fun case -> lead, case) cases ) rules_brs ) loc_next_classes in - (* (* {{{ log entry *) if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> Printf.printf "Rule translations for loc %d:\n%!" loc; - List.iter (fun ((lead,_,_), brs) -> - let brs = List.map snd brs in + List.iter (fun ((lead,_,_), (phis,heads,bodies,neg_bodies)) -> Printf.printf "Rule-translation: player %s move %s\n%s\n%!" (term_str loc_players.(loc)) (term_str lead) - (def_str ("action", brs)) + (rule_pretransl_str (heads,bodies,neg_bodies)) ) rules_brs; ) loc_toss_rules; ); (* }}} *) - *) struc (* @@ -2060,6 +2111,12 @@ if (Some game_descr) = !connect5_descr then manual_game := "connect5"; if (Some game_descr) = !connect4_descr then manual_game := "connect4"; if (Some game_descr) = !pawn_whopping_descr then manual_game:="pawn_whopping"; + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "GDL.initialize_game: player=%s, game=%s, startcl=%d\n%!" + (term_str player) !manual_game startcl + ); + (* }}} *) match !manual_translation, !manual_game with | true, "tictactoe" -> initialize_game_tictactoe state player game_descr startcl @@ -2209,10 +2266,18 @@ let loc = state.Arena.cur_loc in let loc_player = state.Arena.game.Arena.graph.(loc).Arena.player in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf + "GDL.our_turn: loc=%d, loc_player=%d, playing_as=%s, player_name=%s, res=%b\n%!" + loc loc_player (term_str !playing_as) + (term_str !player_name_terms.(loc_player)) + (!player_name_terms.(loc_player) = !playing_as) + ); + (* }}} *) !player_name_terms.(loc_player) = !playing_as let translate_move_tictactoe rule emb new_state = - print_endline "Translate"; let struc = new_state.Arena.struc in let elem = snd (List.hd emb) in let c, r = @@ -2270,6 +2335,7 @@ | _ -> assert false let translate_move rule emb new_state = + let res = match !manual_translation, !manual_game with | true, "tictactoe" -> translate_move_tictactoe rule emb new_state @@ -2285,3 +2351,10 @@ failwith ("GDL: manual translation of unknown game "^game) | false, _ -> failwith "GDL: automatic translation not finished yet" + in + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "GDL.translate_move: %s\n%!" res + ); + (* }}} *) + res Modified: trunk/Toss/GGP/GDLTest.ml =================================================================== --- trunk/Toss/GGP/GDLTest.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/GGP/GDLTest.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -78,7 +78,8 @@ "connect5" >:: (fun () -> - GDL.debug_level := 3; + todo "Only log would be interesting at this point."; + (* GDL.debug_level := 3; *) let connect5 = load_rules "./GGP/examples/connect5.gdl" in let gdef = GDL.translate_game connect5 in () @@ -86,6 +87,7 @@ "breakthrough" >:: (fun () -> + todo "Only log would be interesting at this point."; let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in let gdef = GDL.translate_game breakthrough in () @@ -95,7 +97,7 @@ ] -let a () = +let a = Aux.run_test_if_target "GDLTest" tests let a () = @@ -106,7 +108,7 @@ | Some tests -> ignore (run_test_tt ~verbose:true tests) | None -> () -let a = +let a () = GDL.debug_level := 4; let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in let gdef = GDL.translate_game breakthrough in Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Play/Game.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -757,7 +757,9 @@ ("\n"^Str.first_chars "|||||||||||" (depth0-depth)) ("\n" ^ Structure.str model)); (* }}} *) - if depth < 1 || !timeout then ( (* leaf position *) + if !timeout then (* will be handled by i.deep. *) + Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs + else if depth < 1 then ( (* leaf position *) let res = match pre_heur with | Some h -> h @@ -769,21 +771,21 @@ printf ", leaf %d heur: %F %!" player res.(player) ); (* }}} *) - res + res ) else let location = graph.(loc) in let moves = gen_moves grid_size rules model location in if moves = [| |] then (* terminal position *) let res = - (* *) + (* * Array.map (fun expr -> 100000. *. Solver.M.get_real_val expr model) location.Arena.payoffs_pp (* see [let payoff] above *) - (* * + * *) play_evgame grid_size model time subgames.(loc) - * *) + (* *) in (* {{{ log entry *) if !debug_level > 4 then ( @@ -793,22 +795,24 @@ (* }}} *) res else if !timeout then - play_evgame grid_size model time subgames.(loc) + Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs else let models = gen_models rules defined_rels model time moves in let n = Array.length models in - if n = 0 then begin (* terminal after postconditions *) + if !timeout then + Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs + else if n = 0 then begin (* terminal after postconditions *) let res = (* play_evgame grid_size model time subgames.(loc) *) - (* *) - Array.map (fun expr -> - 100000. *. - Solver.M.get_real_val expr model) - location.Arena.payoffs_pp - (* * + (* * + Array.map (fun expr -> + 100000. *. + Solver.M.get_real_val expr model) + location.Arena.payoffs_pp + * *) play_evgame grid_size model time subgames.(loc) - * *) + (* *) in (* {{{ log entry *) if !debug_level > 4 then ( @@ -839,7 +843,7 @@ Some heuristics end else None in let rec aux best i = - if i < n && not !timeout then + if i < n && not !timeout then ( let pos = index.(i) in let state = models.(pos) in let sub_heur = @@ -859,18 +863,18 @@ sub_heur) else if sub_heur.(player) > best.(player) then aux sub_heur (i+1) - else aux best (i+1) - else if !timeout then best - else ( - betas.(player) <- best.(player); + else aux best (i+1)) + else if !timeout then best + else ( + betas.(player) <- best.(player); (* {{{ log entry *) - if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) && - (depth > 1 || !debug_level > 3) - then ( - printf ", best %d maximax: %F. %!" player - best.(player)); + if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) && + (depth > 1 || !debug_level > 3) + then ( + printf ", best %d maximax: %F. %!" player + best.(player)); (* }}} *) - best) in + best) in let alphas = Array.make num_players neg_infinity in aux alphas 0 in let betas = Array.make num_players infinity in @@ -885,23 +889,45 @@ Aux.Right payoff else let cur_depth = ref 0 in + (* {{{ log entry *) + if !debug_level > 1 && (depth > 2 || !debug_level > 3) then ( + Printf.printf "\n\nIterative-deepening: depth %d\n%!" + (!cur_depth + 1) + ); + (* }}} *) let scores = Array.map (maximax_tree None player betas !cur_depth) models in + incr cur_depth; while not !timeout && !cur_depth < depth do + (* {{{ log entry *) + if !debug_level > 1 && (depth > 2 || !debug_level > 3) then ( + Printf.printf "\n\nIterative-deepening: depth %d\n%!" + (!cur_depth + 1) + ); + (* }}} *) let index = Array.init (Array.length models) (fun i->i) in Array.sort (fun j i-> compare scores.(i).(player) scores.(j).(player)) index; let betas = Array.make num_players infinity in let new_scores = - Array.map (fun i -> - maximax_tree None player betas !cur_depth models.(i)) + Array.map (fun j -> + maximax_tree None player betas !cur_depth models.(j)) index in incr cur_depth; if not !timeout then Array.iteri (fun i j -> (* inverting the permutation *) - scores.(j) <- new_scores.(i)) index + scores.(j) <- new_scores.(i)) index; + (* {{{ log entry *) + if !debug_level > 1 && (depth > 2 || !debug_level > 3) then ( + Printf.printf "\nIterative-deepening: depth %d scores:\n%!" + !cur_depth; + Array.iteri (fun i score -> + Printf.printf "Structure:%s -- score %F\n" + (Structure.str models.(i).struc) score.(player)) scores + ); + (* }}} *) done; let _, best = find_best_score ~use_det_setting:true cooperative player scores Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Play/GameTest.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -806,6 +806,29 @@ (fun mov_s -> "Cross{1:d4}" = mov_s); ); + "connect4 simple" >:: + (fun () -> + let state = update_game connect4_game +"[ | | + ] \" + + . . . . . . . + + . . . . . . . + + . . . . . . . + + P . . . . . . + + P . . . . . . + + P Q Q +Q . . . +\"" 0 in + easy_case state 0 "should attack" + (fun mov_s -> "Cross{1:a4}" = mov_s); +); + + "connect4 endgame" >:: (fun () -> let state = update_game connect4_game @@ -888,9 +911,11 @@ let a () = Game.set_debug_level 10 -let a = +let a () = Game.use_monotonic := false + +let a () = match test_filter - ["Game:1:alpha_beta_ord:1:tictactoe suggest optimal single"] + ["Game:1:alpha_beta_ord:15:connect4 simple"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Server/Server.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -517,8 +517,6 @@ let _ = (* Test against being called from a test... *) - let target_name1 = "GameTest" - and target_name2 = "TossTest" in let file_from_path p = String.sub p (String.rindex p '/'+1) (String.length p - String.rindex p '/' - 1) in @@ -526,10 +524,9 @@ String.sub p 0 (String.rindex p '/') in let test_fname = let fname = file_from_path Sys.executable_name in - String.length fname >= String.length target_name1 && - String.sub fname 0 (String.length target_name1) = target_name1 || - String.length fname >= String.length target_name2 && - String.sub fname 0 (String.length target_name2) = target_name2 + Printf.printf "fname: %s\n%!" fname; + let len = String.length fname in + Str.string_match (Str.regexp ".*Test.*") fname 0 in (* so that the server is not started by the test suite. *) if not test_fname then ( Modified: trunk/Toss/Server/ServerGDLTest.in =================================================================== --- trunk/Toss/Server/ServerGDLTest.in 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Server/ServerGDLTest.in 2011-02-02 00:00:24 UTC (rev 1305) @@ -3,9 +3,9 @@ Sender: GAMEMASTER Receiver: GAMEPLAYER Content-type: text/acl -Content-length: 1589 +Content-length: 1661 -(START MATCH.3316980891 X ((ROLE X) (ROLE O) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL X)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL X)) (TRUE (CONTROL O))) (<= (NEXT (CONTROL O)) (TRUE (CONTROL X))) (<= (ROW ?X ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE X)) (NOT (LINE O)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= (GOAL ?PLAYER 0) (NOT (LINE X)) (NOT (LINE O)) OPEN) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30) +(START MATCH.3316980891 XPLAYER ((ROLE XPLAYER) (ROLE OPLAYER) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL XPLAYER)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL XPLAYER)) (TRUE (CONTROL OPLAYER))) (<= (NEXT (CONTROL OPLAYER)) (TRUE (CONTROL XPLAYER))) (<= (ROW ?X ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= (GOAL ?PLAYER 0) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) OPEN) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30) POST / HTTP/1.0 Accept: text/delim Modified: trunk/Toss/Server/ServerGDLTest.out =================================================================== --- trunk/Toss/Server/ServerGDLTest.out 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Server/ServerGDLTest.out 2011-02-02 00:00:24 UTC (rev 1305) @@ -27,7 +27,7 @@ Content-type: text/acl Content-length: 10 -(MARK 3 3) +(MARK 1 2) HTTP/1.0 200 OK Content-type: text/acl Content-length: 4 Modified: trunk/Toss/Server/ServerTest.ml =================================================================== --- trunk/Toss/Server/ServerTest.ml 2011-02-01 01:47:19 UTC (rev 1304) +++ trunk/Toss/Server/ServerTest.ml 2011-02-02 00:00:24 UTC (rev 1305) @@ -2,20 +2,22 @@ open Aux let tests = "server" >::: [ + "check ServerTest.in response" >:: (fun () -> let in_ch = open_in "./Server/ServerTest.in" in let out_ch = open_out "./Server/ServerTest.temp" in - (*(try while true do + (try while true do Server.req_handle in_ch out_ch done - with End_of_file -> ());*) + with End_of_file -> ()); close_in in_ch; close_out out_ch; let result = Aux.input_file (open_in "./Server/ServerTest.temp") in let target = Aux.input_file (open_in "./Server/ServerTest.out") in Sys.remove "./Server/ServerTest.temp"; - assert_equal ~printer:(fun x->x) target result + assert_equal ~printer:(fun x->x) + (strip_spaces target) (strip_spaces result) ); "ServerGDLTest.in GDL Tic-Tac-Toe" >:: @@ -27,9 +29,10 @@ GDL.manual_game := "tictactoe"; let in_ch = open_in "./Server/ServerGDLTest.in" in let out_ch = open_out "./Server/ServerGDLTest.temp" in - (* (try while true do + Game.deterministic_suggest := true; + (try while true do Server.req_handle in_ch out_ch done - with End_of_file -> ()); *) + with End_of_file -> ()); close_in in_ch; close_out out_ch; Game.deterministic_suggest := old_det_suggest; let result = @@ -37,9 +40,12 @@ let target = Aux.input_file (open_in "./Server/ServerGDLTest.out") in Sys.remove "./Server/ServerGDLTest.temp"; - assert_equal ~printer:(fun x->x) target result + assert_equal ~printer:(fun x->x) + (strip_spaces target) (strip_spaces result) ); + ] let a = + GDL.top_exec_path := "."; Aux.run_test_if_target "ServerTest" tests This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-03 19:36:56
|
Revision: 1308 http://toss.svn.sourceforge.net/toss/?rev=1308&view=rev Author: lukaszkaiser Date: 2011-02-03 19:36:49 +0000 (Thu, 03 Feb 2011) Log Message: ----------- Small parameter changes. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/examples/Checkers.toss trunk/Toss/examples/Gomoku.toss Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-02 02:07:08 UTC (rev 1307) +++ trunk/Toss/GGP/GDL.ml 2011-02-03 19:36:49 UTC (rev 1308) @@ -2074,7 +2074,7 @@ player_name_terms := [|Const "X"; Const "O"|]; Game.use_monotonic := true; let effort, horizon, heur_adv_ratio = - 2, 100, 4.0 in + 4, 100, 4.0 in effort, horizon, heur_adv_ratio let initialize_game_connect4 state player game_descr startcl = @@ -2084,7 +2084,7 @@ player_name_terms := [|Const "WHITE"; Const "RED"|]; Game.use_monotonic := false; let effort, horizon, heur_adv_ratio = - 6, 100, 2.0 in + 8, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game_breakthrough state player game_descr startcl = @@ -2093,7 +2093,7 @@ game_description := game_descr; player_name_terms := [|Const "WHITE"; Const "BLACK"|]; let effort, horizon, heur_adv_ratio = - 3, 100, 2.0 in + 4, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game_pawn_whopping state player game_descr startcl = @@ -2102,7 +2102,7 @@ game_description := game_descr; player_name_terms := [|Const "X"; Const "O"|]; let effort, horizon, heur_adv_ratio = - 4, 100, 2.0 in + 8, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game state player game_descr startcl = Modified: trunk/Toss/examples/Checkers.toss =================================================================== --- trunk/Toss/examples/Checkers.toss 2011-02-02 02:07:08 UTC (rev 1307) +++ trunk/Toss/examples/Checkers.toss 2011-02-03 19:36:49 UTC (rev 1308) @@ -1,5 +1,5 @@ PLAYERS 1, 2 -DATA depth: 2, adv_ratio: 2 +DATA depth: 4, adv_ratio: 2 REL IsFirst(x) = not ex z C(z, x) REL IsEight(x) = not ex z C(x, z) REL w(x) = W(x) or Wq(x) Modified: trunk/Toss/examples/Gomoku.toss =================================================================== --- trunk/Toss/examples/Gomoku.toss 2011-02-02 02:07:08 UTC (rev 1307) +++ trunk/Toss/examples/Gomoku.toss 2011-02-03 19:36:49 UTC (rev 1308) @@ -1,5 +1,5 @@ PLAYERS 1, 2 -DATA r1: circle, r2: line, adv_ratio: 4, depth: 1 +DATA r1: circle, r2: line, adv_ratio: 4, depth: 2 REL DiagA (x, y) = ex u (R(x, u) and C(u, y)) REL DiagB (x, y) = ex u (R(x, u) and C(y, u)) REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-04 15:23:21
|
Revision: 1310 http://toss.svn.sourceforge.net/toss/?rev=1310&view=rev Author: lukstafi Date: 2011-02-04 15:23:14 +0000 (Fri, 04 Feb 2011) Log Message: ----------- GDL: progress (refactoring, terminal condition). Game: Reverting to payoff-scaled values in terminal nodes of alpha-beta. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/GameTest.ml Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-03 20:36:45 UTC (rev 1309) +++ trunk/Toss/GGP/GDL.ml 2011-02-04 15:23:14 UTC (rev 1310) @@ -284,10 +284,10 @@ (7h) Introduce a new element variable for each class of "next" and "true" terms equal modulo mask (i.e. there is a mask matching them and they differ only at-or-below metavariables). (Remember the - atoms "corresponding variable".) From now on until (7m1) we keep + atoms "corresponding variable".) From now on until (7l1) we keep both the (partially) Toss-translated versions and the (complete) GDL-originals of branches (so to use GDL atoms for "subsumption - checking" in (7m)). + checking" in (7l)). (7i-4a) For all subterms of "next" and "true" atoms, identify the sets of <mask-path, element variable> they "inhabit". Replace a @@ -349,8 +349,8 @@ associated with every bit. The unique resulting sets are exactly the Toss rules precursors. - (7m) Filter the final rule candidates by satisfiability in at - least one of aggregate playout states. + (7m) Filter the final rule candidates by satisfiability of the + static part (same as (7i1) conjoined). (7n) Include translated negation of the terminal condition. (Now we build rewrite rules for a refinement of an equivalence class of @@ -363,6 +363,10 @@ precondition. Exactly the RHS variables are listed in the LHS (other variables are existentially closed in the precondition). + (7o) After the rules are translated, perform an aggregated playout + of the Toss variant of the game. Remove the rules that were never + applied. + (8) We use a single payoff matrix for all locations. Goal patterns are expanded to regular goals by instantiating the value variable by all values in its domain (for example, as gathered from the @@ -1116,6 +1120,290 @@ (term_str a) (term_str b); assert false +let triang_matrix elems = + let rec aux acc = function + | [] -> acc + | hd::tl -> aux (List.map (fun e->[|hd; e|]) tl @ acc) tl in + aux [] elems + +let term_to_blank masks next_arg = + let mask_cands = + Aux.map_try (fun mask -> + mask, match_meta [] [] [next_arg] [mask] + ) masks in + let mask, sb, m_sb = match mask_cands with + | [mask, (sb, m_sb)] -> mask, sb, m_sb + | _ -> assert false in + mask, sb, m_sb, blank_out (next_arg, mask) + +let toss_var masks term = + let mask, _, _, blank = term_to_blank masks term in + mask, Formula.fo_var_of_string (term_to_name blank) + +let translate_branches struc masks static_rnames dyn_rels brs = + (* 7i *) + (* Do not flatten the already built super-partition. *) + let state_terms = + List.fold_left (fun acc -> function + | [next_arg], body, neg_body -> + let res = + List.fold_left (fun acc -> function + | "true", [true_arg] -> Terms.add true_arg acc + | "true", _ -> assert false + | _ -> acc) acc body in + let res = + List.fold_left (List.fold_left (fun acc -> function + | "true", [true_arg] -> Terms.add true_arg acc + | "true", _ -> assert false + | _ -> acc)) res neg_body in + if next_arg = Const "_TERMINAL_" + then res + else Terms.add next_arg res + | _ -> assert false + ) Terms.empty brs in + let state_terms = Terms.elements state_terms in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "state_terms: %s\n%!" ( + String.concat ", " (List.map term_str state_terms)) + ); + (* }}} *) + let state_subterms = + Aux.concat_map (fun term -> + let mask, sb, m_sb, blanked = term_to_blank masks term in + List.map (fun (v,t) -> t, (mask, v, term)) sb + ) state_terms in + let conjs_4a rel args = + let ptups = List.map (fun arg -> + Aux.assoc_all arg state_subterms) args in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "conjs_4a: of %s = subterms %s\n%!" + (fact_str (rel,args)) (String.concat "; " ( + List.map (fun l -> String.concat ", " + (List.map (fun (_,_,term)->term_str term) l)) ptups)) + ); + (* }}} *) + let ptups = Aux.product ptups in + let res = + List.map (fun ptup -> + let rname = rel ^ "__" ^ String.concat "__" + (List.map (fun (mask,v,_)-> + term_to_name mask ^ "_" ^ v) ptup) in + let tup = List.map (fun (_,_,term) -> + snd (toss_var masks term)) ptup in + Formula.Rel (rname, Array.of_list tup)) ptups in + let res = Aux.unique_sorted res in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "conjs_4a: of %s = %s\n%!" + (fact_str (rel,args)) (Formula.str (Formula.And res)) + ); + (* }}} *) + res in + (* 7i-4b *) + let path_subterms = + Aux.concat_map (fun term -> + let mask, sb, m_sb, blanked = term_to_blank masks term in + Aux.map_some (function + | v, Var t -> Some ((mask, v), (t, term)) + | _ -> None) sb + ) state_terms in + let path_subterms = Aux.collect path_subterms in + let conjs_4b = + Aux.concat_map (fun ((mask, v), terms) -> + let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in + let terms = Aux.collect terms in + Aux.concat_map (fun (_,terms) -> + let vars = List.map (fun t -> snd (toss_var masks t)) terms in + let tups = triang_matrix (Aux.unique_sorted vars) in + List.map (fun tup -> Formula.Rel (rname, tup)) tups + ) terms + ) path_subterms in + let conjs_4b = Aux.unique_sorted conjs_4b in + let brs = Aux.map_some (function + | [next_arg],body,neg_body -> + let phi, lvars = + if next_arg = Const "_TERMINAL_" then [], ref [] + else + let mask, sb, m_sb, blanked = term_to_blank masks next_arg in + let rname = term_to_name mask in + let _, svar = toss_var masks next_arg in + let phi = Formula.Rel (rname, [|svar|]) in + let lvars = ref [svar] in + [phi], lvars in + let conjs = + Aux.concat_map (fun (rel, args) -> + if rel = "true" then + (* 7i-4c *) + let true_arg = List.hd args in + let mask, sb, m_sb, blanked = term_to_blank masks true_arg in + let rname = term_to_name mask in + let _, svar = toss_var masks true_arg in + lvars := svar :: !lvars; + let phi = Formula.Rel (rname, [|svar|]) in + let conjs = + Aux.map_some (function + | _, Var _ -> None + | v, t as v_sb -> + let rname = term_to_name (subst_one v_sb mask) in + Some (Formula.Rel (rname, [|svar|]))) sb in + phi::conjs + else if List.mem rel static_rnames then + (* 7i-4a *) + conjs_4a rel args + else [] + ) body in + let neg_conjs = + Aux.concat_map ( + Aux.concat_map (fun (rel, args) -> + if rel = "true" then + (* lvars := svar :: !lvars; ??? *) + (* negated (4c) is calculated together with (5) *) + [] + (* + let true_arg = List.hd args in + let mask, sb, m_sb, blanked = term_to_blank masks true_arg in + let rname = term_to_name mask in + let _, svar = toss_var masks true_arg in + let phi = Formula.Rel (rname, [|svar|]) in + let conjs = + Aux.map_some (function + | _, Var _ -> None + | v, t as v_sb -> + let rname = term_to_name (subst_one v_sb mask) in + Some (Formula.Rel (rname, [|svar|]))) sb in + (* FIXME: make sure it's the right semantics *) + [phi; Formula.Not (Formula.And conjs)] + *) + else if List.mem rel static_rnames then + (* 7i-4a *) + List.map (fun c -> Formula.Not c) (conjs_4a rel args) + else [] + )) neg_body in + let all_conjs = phi @ conjs @ neg_conjs in + let phi = Formula.And all_conjs in + let lvars = (!lvars :> Formula.var list) in + let optim_conjs = List.filter (fun c-> + List.for_all (fun v->List.mem v lvars) + (FormulaOps.free_vars c)) (conjs_4b @ all_conjs) in + let rphi = Solver.M.register_formula + (Formula.And optim_conjs) in + (* {{{ log entry *) + if !debug_level > 3 then ( + (* do not print, because it generates too many + answers -- too little constraints per number of + variables when considering a single branch *) + (* + let assgn = Solver.M.evaluate struc rphi in + let avars = List.map Formula.var_str + (FormulaOps.free_vars phi) in + let atups = + AssignmentSet.tuples struc.Structure.elements + avars assgn in *) + Printf.printf "evaluating: %s -- simpl %s\n%!" + (Formula.str phi) + (Solver.M.formula_str rphi) + (* (List.length atups) *) + ); + (* }}} *) + if Solver.M.check_formula struc rphi + then ( + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "holds\n%!" + ); + (* }}} *) + Some (all_conjs, (next_arg,body,neg_body))) + else None + | _ -> assert false) brs in + (* 7j: TODO *) + + (* 7k *) + let brs = + List.map (fun (static_conjs, (next_arg,body,neg_body)) -> + let rhs_pos_preds, rhs_possneg_preds = + if next_arg = Const "_TERMINAL_" then [], [] + else + let mask, sb, m_sb, blanked = term_to_blank masks next_arg in + let rhs_elem = term_to_name blanked in + Aux.partition_map (fun (v,t as v_sb) -> + if t = Const "_BLANK_" then + let neg_rels = List.assoc (mask, v) dyn_rels in + Aux.Right (List.map (fun rel->rel, [|rhs_elem|]) neg_rels) + else + let rname = term_to_name (subst_one v_sb mask) in + Aux.Left (rname, [|rhs_elem|]) + ) m_sb in + let rhs_possneg_preds = List.flatten rhs_possneg_preds in + let dyn_conjs = + Aux.concat_map (fun (rel, args) -> + if rel = "true" then + (* 7i-4c *) + let true_arg = List.hd args in + let mask, sb, m_sb, blanked = term_to_blank masks true_arg in + let _, svar = toss_var masks true_arg in + + let lhs_pos_preds, lhs_possneg_preds = + Aux.partition_map (fun (v,t as v_sb) -> + if t = Const "_BLANK_" then + (* + let neg_rels = List.assoc (mask, v) dyn_rels in + Aux.Right (List.map (fun rel-> + Formula.Rel (rel, [|svar|])) neg_rels) + *) assert false + else + let rname = term_to_name (subst_one v_sb mask) in + Aux.Left (Formula.Rel (rname, [|svar|])) + ) m_sb in + (* + let lhs_possneg_preds = List.flatten lhs_possneg_preds in + *) + lhs_pos_preds + else if List.mem rel static_rnames + then [] + else ( + Printf.printf "\nunexpected_dynamic: %s\n%!" rel; + (* dynamic relations have been expanded *) + assert false) + ) body in + let neg_conjs = + Aux.concat_map ( + Aux.concat_map (fun (rel, args) -> + if rel = "true" then + let true_arg = List.hd args in + let mask, sb, m_sb, blanked = term_to_blank masks true_arg in + let rname = term_to_name mask in + let _, svar = toss_var masks true_arg in + let phi = Formula.Rel (rname, [|svar|]) in + let conjs_4c = + Aux.map_some (function + | _, Var _ -> None + | v, t as v_sb -> + let rname = term_to_name (subst_one v_sb mask) in + Some (Formula.Rel (rname, [|svar|]))) sb in + let conjs_5 = + List.map (fun (v,t as v_sb) -> + if t = Const "_BLANK_" then + assert false + else + (* t = Var _ have been expanded *) + let rname = term_to_name (subst_one v_sb mask) in + Formula.Rel (rname, [|svar|])) m_sb in + + (* FIXME: make sure it's the right semantics *) + [phi; Formula.Not (Formula.And (conjs_4c @ conjs_5))] + else if List.mem rel static_rnames + then [] + else + (* dynamic relations have been expanded *) + assert false + )) neg_body in + let all_conjs = static_conjs @ dyn_conjs @ neg_conjs in + (rhs_pos_preds, rhs_possneg_preds, static_conjs, all_conjs), + (next_arg, body, neg_body)) brs in + conjs_4b, brs + let translate_game game_descr = freshen_count := 0; let player_terms = @@ -1239,6 +1527,7 @@ (* 3 *) let legal_rules = List.assoc "legal" exp_defs in let next_rules = List.assoc "next" exp_defs in + let terminal_rules = List.assoc "terminal" exp_defs in (* 3b *) let exp_next = Aux.concat_map (subst_def_branch ["does", legal_rules]) next_rules in @@ -1462,27 +1751,21 @@ ) struc elements in (* 5 *) - let term_to_blank next_arg = - let mask_cands = - Aux.map_try (fun mask -> - mask, match_meta [] [] [next_arg] [mask] - ) masks in - let mask, sb, m_sb = match mask_cands with - | [mask, (sb, m_sb)] -> mask, sb, m_sb - | _ -> assert false in - mask, sb, m_sb, blank_out (next_arg, mask) in - let struc = List.fold_left (fun struc term -> - let mask, sb, m_sb, blanked = term_to_blank term in + let dyn_rels, struc = List.fold_left (fun (dyn_rels, struc) term -> + let mask, sb, m_sb, blanked = term_to_blank masks term in let e = let elems = List.assoc mask elements in List.assoc sb elems in - List.fold_left (fun struc (v,t as v_sb) -> + List.fold_left (fun (dyn_rels, struc) (v,t as v_sb) -> let rname = term_to_name (subst_one v_sb mask) in + ((mask, v), rname)::dyn_rels, if List.mem term init_state then Structure.add_rel struc rname [|e|] - else Structure.add_rel_name rname 1 struc) struc m_sb - ) struc element_terms in - + else Structure.add_rel_name rname 1 struc) (dyn_rels, struc) m_sb + ) ([], struc) element_terms in + let dyn_rels = + List.map (fun (path, subts) -> path, Aux.unique_sorted subts) + (Aux.collect dyn_rels) in (* 7a *) let legal_rules = Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule] @@ -1670,7 +1953,7 @@ let erasure_brs = Aux.concat_map (function | [next_arg] as next_args,multi_body -> - let mask, _, _, blank_arg = term_to_blank next_arg in + let mask, _, _, blank_arg = term_to_blank masks next_arg in (* {{{ log entry *) if !debug_level > 2 then ( Printf.printf "Blanking-out of %s by %s\n%!" @@ -1776,171 +2059,14 @@ ) loc_next_classes; ); (* }}} *) + let static_rnames = List.map (fun ((srel,_),_,_) -> srel) static_rules in (* 7h *) - let toss_var term = - let mask, _, _, blank = term_to_blank term in - mask, Formula.fo_var_of_string (term_to_name blank) in let loc_toss_rules = Array.mapi (fun loc rules_brs -> Aux.concat_map (fun (lead, brs) -> - (* 7i *) - (* Do not flatten the already built super-partition. *) - let state_terms = - List.fold_left (fun acc -> function - | [next_arg], body, neg_body -> - let res = - List.fold_left (fun acc -> function - | "true", [true_arg] -> Terms.add true_arg acc - | "true", _ -> assert false - | _ -> acc) acc body in - let res = - List.fold_left (List.fold_left (fun acc -> function - | "true", [true_arg] -> Terms.add true_arg acc - | "true", _ -> assert false - | _ -> acc)) res neg_body in - Terms.add next_arg res - | _ -> assert false - ) Terms.empty brs in - let state_terms = Terms.elements state_terms in - (* {{{ log entry *) - if !debug_level > 2 then ( - Printf.printf "state_terms: %s\n%!" ( - String.concat ", " (List.map term_str state_terms)) - ); - (* }}} *) - let state_subterms = - Aux.concat_map (fun term -> - let mask, sb, m_sb, blanked = term_to_blank term in - List.map (fun (v,t) -> t, (mask, v, term)) sb - ) state_terms in - let conjs_4a rel args = - let ptups = List.map (fun arg -> - Aux.assoc_all arg state_subterms) args in - (* {{{ log entry *) - if !debug_level > 3 then ( - Printf.printf "conjs_4a: of %s = subterms %s\n%!" - (fact_str (rel,args)) (String.concat "; " ( - List.map (fun l -> String.concat ", " - (List.map (fun (_,_,term)->term_str term) l)) ptups)) - ); - (* }}} *) - let ptups = Aux.product ptups in - let res = - List.map (fun ptup -> - let rname = rel ^ "__" ^ String.concat "__" - (List.map (fun (mask,v,_)-> - term_to_name mask ^ "_" ^ v) ptup) in - let tup = List.map (fun (_,_,term) -> - snd (toss_var term)) ptup in - Formula.Rel (rname, Array.of_list tup)) ptups in - let res = Aux.unique_sorted res in - (* {{{ log entry *) - if !debug_level > 3 then ( - Printf.printf "conjs_4a: of %s = %s\n%!" - (fact_str (rel,args)) (Formula.str (Formula.And res)) - ); - (* }}} *) - res in - let brs = Aux.map_some (function - | [next_arg],body,neg_body -> - let mask, sb, m_sb, blanked = term_to_blank next_arg in - let rname = term_to_name mask in - let _, svar = toss_var next_arg in - let phi = Formula.Rel (rname, [|svar|]) in - let lvars = ref [svar] in - let conjs = - Aux.concat_map (fun (rel, args) -> - if rel = "true" then - (* 7i-4c *) - let true_arg = List.hd args in - let mask, sb, m_sb, blanked = term_to_blank true_arg in - let rname = term_to_name mask in - let _, svar = toss_var true_arg in - lvars := svar :: !lvars; - let phi = Formula.Rel (rname, [|svar|]) in - let conjs = - Aux.map_some (function - | _, Var _ -> None - | v, t as v_sb -> - let rname = term_to_name (subst_one v_sb mask) in - Some (Formula.Rel (rname, [|svar|]))) sb in - phi::conjs - else if List.exists (fun ((srel,_),_,_) -> rel=srel) - static_rules then - (* 7i-4a *) - conjs_4a rel args - else - (* TODO: 7i-4b *) - [] - ) body in - let neg_conjs = - Aux.concat_map ( - Aux.concat_map (fun (rel, args) -> - if rel = "true" then - (* lvars := svar :: !lvars; ??? *) - (* negated (4c) is calculated together with (5) *) - [] - (* - let true_arg = List.hd args in - let mask, sb, m_sb, blanked = term_to_blank true_arg in - let rname = term_to_name mask in - let _, svar = toss_var true_arg in - let phi = Formula.Rel (rname, [|svar|]) in - let conjs = - Aux.map_some (function - | _, Var _ -> None - | v, t as v_sb -> - let rname = term_to_name (subst_one v_sb mask) in - Some (Formula.Rel (rname, [|svar|]))) sb in - (* FIXME: make sure it's the right semantics *) - [phi; Formula.Not (Formula.And conjs)] - *) - else if List.exists (fun ((srel,_),_,_) -> rel=srel) - static_rules then - (* 7i-4a *) - List.map (fun c -> Formula.Not c) (conjs_4a rel args) - else - (* TODO: 7i-4b *) - [] - )) neg_body in - let all_conjs = phi::conjs @ neg_conjs in - let phi = Formula.And all_conjs in - let lvars = (!lvars :> Formula.var list) in - let optim_conjs = List.filter (fun c-> - List.for_all (fun v->List.mem v lvars) - (FormulaOps.free_vars c)) all_conjs in - let rphi = Solver.M.register_formula - (Formula.And optim_conjs) in - (* {{{ log entry *) - if !debug_level > 3 then ( - (* do not print, because it generates too many - answers -- too little constraints per number of - variables when considering a single branch *) - (* - let assgn = Solver.M.evaluate struc rphi in - let avars = List.map Formula.var_str - (FormulaOps.free_vars phi) in - let atups = - AssignmentSet.tuples struc.Structure.elements - avars assgn in *) - Printf.printf "evaluating: %s -- simpl %s\n%!" - (Formula.str phi) - (Solver.M.formula_str rphi) - (* (List.length atups) *) - ); - (* }}} *) - if Solver.M.check_formula struc rphi - then ( - (* {{{ log entry *) - if !debug_level > 3 then ( - Printf.printf "holds\n%!" - ); - (* }}} *) - Some (phi, (next_arg,body,neg_body))) - else None - | _ -> assert false) brs in - (* 7j: TODO *) - (* 7k: TODO *) + let conjs_4b, brs = + translate_branches struc masks static_rnames dyn_rels brs in + (* 7l *) let atoms = List.fold_left (fun acc (_,(_,body,neg_body))-> @@ -1948,13 +2074,10 @@ (List.fold_right (List.fold_right Atoms.add) neg_body acc) ) Atoms.empty brs in - Printf.printf "\na\n%!"; let atoms = Atoms.elements atoms in - Printf.printf "\nb\n%!"; let brs = Array.of_list brs in (* indexing branches *) let full_set = Aux.ints_of_list (Array.to_list (Array.mapi (fun i _ -> i) brs)) in - Printf.printf "\nc\n%!"; let table = List.map (fun atom -> let positives = Array.mapi (fun i (_,(_,body,_)) -> if List.mem atom body then Some i else None) brs in @@ -1970,42 +2093,44 @@ [Aux.Ints.diff full_set (Aux.ints_of_list negatives); Aux.Ints.diff full_set (Aux.ints_of_list positives)] ) atoms in - Printf.printf "\ne\n%!"; let cases = Aux.product table in - Printf.printf "\nf\n%!"; let cases = List.map (List.fold_left Aux.Ints.inter full_set) cases in - Printf.printf "\ng\n%!"; let cases = Aux.unique_sorted (List.map Aux.Ints.elements cases) in - Printf.printf "\nh\n%!"; let cases = List.map (fun c_brs -> let c_brs = List.map (Array.get brs) c_brs in - List.fold_left (fun (phis,heads,bodies,neg_bodies) - (phi,(head,body,neg_body)) -> - phi::phis,head::heads,body@bodies,neg_body@neg_bodies) - ([],[],[],[]) c_brs + List.fold_left (fun + ((rhs_pos_acc, rhs_neg_acc, static_conjs_acc, conjs_acc), + heads, bodies, neg_bodies) + ((rhs_pos, rhs_neg, static_conjs, conjs), + (head, body, neg_body)) -> + (rhs_pos @ rhs_pos_acc, rhs_neg @ rhs_neg_acc, + static_conjs @ static_conjs_acc, conjs @ conjs_acc), + head::heads,body@bodies,neg_body@neg_bodies) + (([],[],conjs_4b,conjs_4b),[],[],[]) c_brs ) cases in - Printf.printf "\ni\n%!"; - let cases = List.filter (fun (phis,heads,bodies,neg_bodies) -> - let phi = Formula.And phis in + (* 7m *) + let cases = List.filter (fun ((_,_,static_phis,_), + heads,bodies,neg_bodies) -> + let phi = Formula.And static_phis in let rphi = Solver.M.register_formula phi in - (* {{{ log entry *) + (* {{{ log entry *) if !debug_level > 3 then ( - (* do not print, because it generates too many - answers -- too little constraints per number of - variables when considering a single branch *) - (* - let assgn = Solver.M.evaluate struc rphi in - let avars = List.map Formula.var_str - (FormulaOps.free_vars phi) in - let atups = - AssignmentSet.tuples struc.Structure.elements - avars assgn in *) + (* do not print, because it generates too many + answers -- too little constraints per number of + variables when considering a single branch *) + (* + let assgn = Solver.M.evaluate struc rphi in + let avars = List.map Formula.var_str + (FormulaOps.free_vars phi) in + let atups = + AssignmentSet.tuples struc.Structure.elements + avars assgn in *) Printf.printf "evaluating: %s -- simpl %s\n%!" (Formula.str phi) (Solver.M.formula_str rphi) - (* (List.length atups) *) + (* (List.length atups) *) ); (* }}} *) let res = Solver.M.check_formula struc rphi in @@ -2015,11 +2140,27 @@ ); (* }}} *) res) cases in - Printf.printf "\nj\n%!"; List.map (fun case -> lead, case) cases ) rules_brs ) loc_next_classes in - (* {{{ log entry *) + (* 7n *) + let terminal_brs = + List.map (function + | [], body, neg_body -> [Const "_TERMINAL_"], body, neg_body + | _ -> assert false) terminal_rules in + let terminal_4b, terminal_brs = + translate_branches struc masks static_rnames dyn_rels terminal_brs in + + (* let loc_toss_rules = *) + Array.mapi (fun loc rules_brs -> + List.map (fun (lead, brs) -> + + ignore (terminal_4b, terminal_brs) + + ) rules_brs + ) loc_toss_rules; + + (* {{{ log entry *) if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> Printf.printf "Rule translations for loc %d:\n%!" loc; @@ -2106,6 +2247,7 @@ effort, horizon, heur_adv_ratio let initialize_game state player game_descr startcl = + translate_game game_descr; if (Some game_descr) = !tictactoe_descr then manual_game := "tictactoe"; if (Some game_descr) = !breakthrough_descr then manual_game := "breakthrough"; if (Some game_descr) = !connect5_descr then manual_game := "connect5"; Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-03 20:36:45 UTC (rev 1309) +++ trunk/Toss/Play/Game.ml 2011-02-04 15:23:14 UTC (rev 1310) @@ -781,14 +781,14 @@ gen_moves grid_size rules model location in if moves = [| |] then (* terminal position *) let res = - (* * + (* *) Array.map (fun expr -> 100000. *. Solver.M.get_real_val expr model) location.Arena.payoffs_pp (* see [let payoff] above *) - * *) + (* * play_evgame grid_size model time subgames.(loc) - (* *) + * *) in (* {{{ log entry *) if !debug_level > 4 then ( @@ -808,14 +808,14 @@ else if n = 0 then begin (* terminal after postconditions *) let res = (* play_evgame grid_size model time subgames.(loc) *) - (* * + (* *) Array.map (fun expr -> 100000. *. Solver.M.get_real_val expr model) location.Arena.payoffs_pp - * *) + (* * play_evgame grid_size model time subgames.(loc) - (* *) + * *) in (* {{{ log entry *) if !debug_level > 4 then ( Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-03 20:36:45 UTC (rev 1309) +++ trunk/Toss/Play/GameTest.ml 2011-02-04 15:23:14 UTC (rev 1310) @@ -131,7 +131,7 @@ lazy (None, 4.0, state_of_file "./examples/Gomoku19x19.toss") let connect4_game = - lazy (None, 6.0, state_of_file "./examples/Connect4.toss") + lazy (None, 2.0, state_of_file "./examples/Connect4.toss") let chess_game = lazy (Some 400, 2.0, state_of_file "./examples/Chess.toss") @@ -843,7 +843,32 @@ Game.use_monotonic := true; ); + "connect4 avoid losing" >:: + (fun () -> + let state = update_game connect4_game +"[ | | + ] \" + ... ... ... + ... ... ... + ... ... ... ... + ... ... ... ... + ... ... ... + ... Q..Q ... + ... ... ... ... + ... ...P Q.. ... + ... ... ... + ... Q..P P.. + ... ... ... ... + ... Q..P P..P Q.. +\"" 0 in + Game.use_monotonic := false; + hard_case state 0 "should not attack" + (fun mov_s -> Printf.printf "avoid: %s\n" mov_s; + "Cross{1:f4}" <> mov_s && "Cross{1:f3}" <> mov_s); + Game.use_monotonic := true; +); + "connect4 endgame" >:: (fun () -> let state = update_game connect4_game @@ -933,7 +958,7 @@ let a () = match test_filter - ["Game:2:alpha_beta_ord-time 8 16 32:15:connect4 simple"] + ["Game:2:alpha_beta_ord-time 8 16 32:16:connect4 avoid losing"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-07 20:54:30
|
Revision: 1314 http://toss.svn.sourceforge.net/toss/?rev=1314&view=rev Author: lukaszkaiser Date: 2011-02-07 20:54:24 +0000 (Mon, 07 Feb 2011) Log Message: ----------- Setting parameters to play against Fluxplayer. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/Server/Server.ml trunk/Toss/examples/Connect4.toss Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-05 16:36:17 UTC (rev 1313) +++ trunk/Toss/GGP/GDL.ml 2011-02-07 20:54:24 UTC (rev 1314) @@ -2257,7 +2257,7 @@ game_description := game_descr; player_name_terms := [|Const "XPLAYER"; Const "OPLAYER"|]; let effort, horizon, heur_adv_ratio = - 5, 100, 4.0 in + 6, 100, 4.0 in effort, horizon, heur_adv_ratio let initialize_game_gomoku state player game_descr startcl = @@ -2277,7 +2277,7 @@ player_name_terms := [|Const "WHITE"; Const "RED"|]; Game.use_monotonic := false; let effort, horizon, heur_adv_ratio = - 8, 100, 4.0 in + 10, 100, 4.0 in effort, horizon, heur_adv_ratio let initialize_game_breakthrough state player game_descr startcl = @@ -2286,7 +2286,7 @@ game_description := game_descr; player_name_terms := [|Const "WHITE"; Const "BLACK"|]; let effort, horizon, heur_adv_ratio = - 4, 100, 2.0 in + 6, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game_pawn_whopping state player game_descr startcl = @@ -2295,7 +2295,7 @@ game_description := game_descr; player_name_terms := [|Const "X"; Const "O"|]; let effort, horizon, heur_adv_ratio = - 8, 100, 2.0 in + 10, 100, 2.0 in effort, horizon, heur_adv_ratio let initialize_game state player game_descr startcl = Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-05 16:36:17 UTC (rev 1313) +++ trunk/Toss/Server/Server.ml 2011-02-07 20:54:24 UTC (rev 1314) @@ -268,6 +268,7 @@ | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) -> (* GDL will store the player and the game in its state. *) + Random.init 1234; (* for repeatablity *) let effort, horizon, heur_adv_ratio = GDL.initialize_game state player game_descr startcl in (* TODO: handle timer (startclock) in Game.initialize_default*) Modified: trunk/Toss/examples/Connect4.toss =================================================================== --- trunk/Toss/examples/Connect4.toss 2011-02-05 16:36:17 UTC (rev 1313) +++ trunk/Toss/examples/Connect4.toss 2011-02-07 20:54:24 UTC (rev 1314) @@ -1,7 +1,5 @@ PLAYERS 1, 2 DATA r1: circle, r2: line, adv_ratio: 4, depth: 6 -REL DiagA (x, y) = ex u (R(x, u) and C(u, y)) -REL DiagB (x, y) = ex u (R(x, u) and C(y, u)) REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v) REL Col4 (x, y, z, v) = C(x, y) and C(y, z) and C(z, v) REL DiagA4 (x, y, z, v) = DiagA(x, y) and DiagA(y, z) and DiagA(z, v) @@ -49,4 +47,5 @@ ... ... ... ... ... ... ... ... ... ... ... -" +" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u)) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-10 12:16:14
|
Revision: 1316 http://toss.svn.sourceforge.net/toss/?rev=1316&view=rev Author: lukstafi Date: 2011-02-10 12:16:07 +0000 (Thu, 10 Feb 2011) Log Message: ----------- GDL translation work in progress: game rules fully translated into Toss semantics (but not generated yet, only as precondition + update). Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDL.mli trunk/Toss/GGP/GDLTest.ml trunk/Toss/Play/GameTest.ml Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-09 03:37:28 UTC (rev 1315) +++ trunk/Toss/GGP/GDL.ml 2011-02-10 12:16:07 UTC (rev 1316) @@ -154,6 +154,8 @@ duplication turns out prohibitive, this will be a huge TODO for this translation framework.) + First, we expand all uses of the built-in "role" predicate. + (6a) The definition: [(r, params1) <= body1 ... (r, params_n) <= body_n] @@ -190,14 +192,14 @@ eliminating the [params] (rather than the [args]) when possible. Still, we freshen each [vars_i] to avoid capture. We remember the (uneliminated) [vars_i] in the set of variables - quantified under the negation. If unification fails, we drop the - corresponding negated subformula. If unification succeeds but the - corresponding [body_i] is empty (and, in general, no other - disjuncts in the negated subformula are left), we drop the branch. + quantified existentially under the negation (since the free + variables occurring only under the negation are quantified + universally there -- it is a positive position). If unification + fails, we drop the corresponding negated subformula. If + unification succeeds but the corresponding [body_i] is empty (and, + in general, no other disjuncts in the negated subformula are + left), we drop the branch. - (6b1) The general case is not implemented yet since it slightly - complicates the code, and expressivity gain is very small. - (7) Generation of rewrite rules when the dynamic relations are not recursive and are expanded in the GDL definition. @@ -212,6 +214,9 @@ associated with a single "lead legal" branch of the location's player. + (7a1) Filter "lead legal" rules by satisfiability in the current + location plys of the aggregate playout. + (7b) We collect all the branches of the "next" relation definition for which the selected branches of "lead legal" and "noop legal" (the "joint legal" actions) unify with all (usually one, but we @@ -274,7 +279,10 @@ disjunct, place the original "next" atom but with meta-variable positions replaced by _BLANK_ as the head of the "erasure" branch, apply (and remove) unification atoms resulting from negating the - "distinct" relation. + "distinct" relation. The local variables of newly created negated + subformulas become existentially-quantified-under-negation + (i.e. universally quantified) (while the local variables of old + negated subformulas are "let free"). (7f4) Drop the erasure branches that contradict the "legal" condition of their rule. @@ -293,30 +301,43 @@ GDL-originals of branches (so to use GDL atoms for "subsumption checking" in (7l)). + (7i-7k) Variables corresponding to negated "true" atoms + that contain locally existentially quantified variables are + quantified universally (with a scope containing all their + occurrences). + + Implementation: we only introduce universal quantification after + filtering (7m), is it OK? + (7i-4a) For all subterms of "next" and "true" atoms, identify the sets of <mask-path, element variable> they "inhabit". Replace a static fact relation by relations built over a cartesian product of <mask-path, element variable> sets derived for each static fact's argument by applying corresponding (4a) relations. For a - negative literal generate result equivalent to a conjunction of - negations of generated atoms (FIXME: why disjunction is wrong?). + negative literal generate result equivalent to a *conjunction* of + negations of generated atoms, but deferred to (7k) to fall under a + common disjunction (unless there's only one disjunct). (7i-4c) Include the (4c) relations for "next" and "true" positive - atoms. Negative atoms are added with (5) relations since they are - under a common negation. + atoms. Negative atoms are added with (5) relations since they (the + (5) predicates and the mask-path anchors of (4c)) are under a + common negation. (7i-4b) Add an appropriate equality relation of (4b) for each case - of variable shared by terms corresponding to different element + of subterm shared by terms corresponding to different element variables (regardless if the element terms are in positive or - negative literals). FIXME: any shared subterm, not limited to - variables, right? + negative literals). Implementation: instead of all subterms we currently only consider subterms that instantiate (ordinary) variables in the mask corresponding to the "next"/"true" atom. + Reason for unsoundness: inclusion of negative "true" literals in + (4b) relations is a necessary "heuristic". Whether to extend it to + constant subterms (see above) is not clear. + (7i1) Remove branches that are unsatisfiable by their static - relations (4a), (4b) and (4c) alone. + relations (4a), (4b) and (positive) (4c) alone. (7j) Identify variables in "next" & "true" terms that are at-or-below meta-variables in the corresponding mask. (Most of @@ -326,11 +347,14 @@ position). (Note that since branches do not have unfixed variables anymore, we do not rename variables during duplication.) + Implementation: TODO. + (7k) Replace the "next" and "true" atoms by the conjunction of (4c) and (5) predicates over their corresponding variable. (For negative "true" literals this will be equivalent to a disjunction of negations of the predicates.) Note that positive static - relations are already added in (7i-4c). + relations are already added in (7i-4c). Handle negative literal + translations of (4a, 4c, 5) together. (7l) Build a pre-lattice of branch bodies w.r.t. subsumption, in a manner similar to (7b). The subsumption test has to say "no" @@ -351,8 +375,17 @@ associate the set of branches that do not allow such literal. For every vector we calculate the complement of the sum of branch sets associated with every bit. The unique resulting sets are exactly - the Toss rules precursors. + the Toss rules precursors. Heuristic (FIXME: needed?): We only use + atoms that are deterministically present or absent in at least + some branch for indexing. + (7l2) Filter rule candidates so that each has a "does"-specific + branch. + + (7l3) Filter out rule candidates that contradict all states + from the current location plys of aggregate playout (by their + "true" atoms -- "not true" are not valid in the aggregate playout). + (7m) Filter the final rule candidates by satisfiability of the static part (same as (7i1) conjoined). @@ -362,6 +395,9 @@ branches with unifiers more general than the equiv class, and from the disjointness conditions and the terminal condition.) + (7n1) Prior to translation, expand all variables under + meta-variables in "terminal" branches, as in (7j). Implementation TODO. + The rewrite rule is generated by joining the derived conjunctions from "next" atoms as RHS, and from bodies as the precondition. Exactly the RHS variables are listed in the LHS @@ -481,9 +517,10 @@ type gdl_atom = string * term list type gdl_rule = gdl_atom * gdl_atom list * gdl_atom list (* Definition with expanded definitions: expansion of a negated - relation brings negated conjunctions. *) + relation brings negated (possibly locally existentially quantified) + conjunctions. *) type exp_def_branch = - term list * gdl_atom list * gdl_atom list list + term list * gdl_atom list * (Aux.Strings.t * gdl_atom list) list type exp_def = string * exp_def_branch list @@ -493,8 +530,11 @@ struct type t = string * term list let compare = Pervasives.compare end) (* -let branch_vars (args, body, neg_body) = + let branch_vars (args, body, neg_body) = *) +let rels_vars body = + List.fold_left Aux.Strings.union Aux.Strings.empty + (List.map (fun (_,args)->terms_vars args) body) let rules_of_entry = function | Datalog (rel, args, body) -> @@ -542,10 +582,19 @@ head, pos_body, neg_body) bodies | Atomic (rel, args) -> [(rel, args), [], []] -let defs_of_rules rules : (string * exp_def_branch list) list = +let add_neg_body_vars global_vars neg_body = + List.map (fun (_, args as a)-> + let local_vs = Aux.Strings.diff (terms_vars args) global_vars in + local_vs, [a]) neg_body + +let defs_of_rules rules + : (string * exp_def_branch list) list = Aux.map_reduce (fun ((drel, params), body, neg_body) -> - drel,(params, body, List.map (fun a->[a]) 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 (* Only use [rules_of_defs] when sure that no multi-premise negative @@ -554,7 +603,7 @@ Aux.concat_map (fun (rel, branches) -> List.map (fun (args, body, neg_body) -> let neg_body = - List.map (function [a]->a | _ -> assert false) neg_body in + List.map (function _,[a]->a | _ -> assert false) neg_body in (rel, args), body, neg_body) branches) defs (* Stratify either w.r.t. the dependency graph ([~def:true]) or its @@ -563,11 +612,12 @@ match List.partition (fun (_, branches) -> List.for_all (fun (_, body, neg_body) -> + let neg_bodies = List.concat (List.map snd neg_body) in List.for_all (fun (rel1,_) -> rel1 = "distinct" || rel1 = "true" || rel1 = "does" || not (List.mem_assoc rel1 defs)) - (if def then body @ List.concat neg_body - else List.concat neg_body)) branches) defs + (if def then body @ neg_bodies + else neg_bodies)) branches) defs with | [], [] -> (* {{{ log entry *) @@ -615,6 +665,7 @@ | Func (f, args) -> Func (f, List.map (subst_one sb) args) +(* Eliminate [terms1] variables when possible. *) let rec unify sb terms1 terms2 = match terms1, terms2 with | [], [] -> sb @@ -715,6 +766,10 @@ if rel1 = rel2 then unify [] args1 args2 else raise Not_found +let unifies term1 term2 = + try ignore (unify [] [term1] [term2]); 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 let extend_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb @@ -727,8 +782,8 @@ let subst_br sb (head, body, neg_body) = List.map (subst sb) head, - List.map (subst_rel sb) body, - List.map (List.map (subst_rel sb)) neg_body + subst_rels sb body, + List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body let fact_str (rel, args) = "("^rel^" "^String.concat " " (List.map term_str args) ^")" @@ -738,26 +793,42 @@ "("^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) + let facts_str facts = String.concat " " (List.map fact_str facts) let neg_facts_str negs = String.concat " " - (List.map (fun d -> "(not (and "^facts_str d^"))") negs) + (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 ^ ")" + let 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 rule_pretransl_str (heads, bodies, neg_bodies) = - "("^ facts_str bodies ^ - " " ^ neg_facts_str neg_bodies ^ "==>" ^ - String.concat "; " (List.map term_str heads) ^ ")" - +(* +let rule_str (head, body, neg_body) = + String.concat "\n" (List.map (fun (args, body, neg_body) -> + "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^ + " " ^ String.concat " " + (List.map (fun f->"not "^fact_str f) neg_body) ^ ")" + ) branches) +*) let sb_str sb = 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) ^")" + (* 1b *) (* TODO: optimize by using rel-indexing (also in [aggregate_playout]). @@ -884,9 +955,14 @@ Func (f, List.map map_vnames args) in let map_rel (rel, args) = rel, List.map map_vnames args in + let map_neg (vs, atoms) = + Aux.strings_of_list + (List.map (fun x-> x^string_of_int !freshen_count) + (Aux.Strings.elements vs)), + List.map map_rel atoms in List.map map_vnames args, List.map map_rel body, - List.map (List.map map_rel) neg_body + List.map map_neg neg_body let freshen_def_branches = List.map freshen_branch @@ -917,7 +993,8 @@ let sb1 = unify [] dparams args in Some ( subst_rels sb1 (dbody @ pos_sol), - List.map (subst_rels sb1) (dneg_body @ neg_sol), + List.map (fun (vs,bs)->vs, subst_rels sb1 bs) + (dneg_body @ neg_sol), extend_sb sb1 sb) with Not_found -> None ) def @@ -928,32 +1005,46 @@ ([[],[],[]]) body in (* 6b *) let sols = - List.fold_left (fun sols -> function [rel, args as atom] -> - (let try def = - freshen_def_branches (List.assoc rel defs) in - List.map (fun (pos_sol, neg_sol, sb) -> - let args = List.map (subst sb) args in - let more_neg = - Aux.map_some (fun (dparams, dbody, dneg_body) -> - if dneg_body <> [] then - failwith - ("GDL.subst_def_branch: negation in negatively used" ^ - " defined rels not supported yet, relation "^rel); - try - let sb1 = unify [] dparams args in - Some (subst_rels sb1 dbody) - with Not_found -> None - ) def in - pos_sol, more_neg @ neg_sol, sb - ) sols - with Not_found -> - List.map (fun (pos_sol, neg_sol, sb) -> - pos_sol, [subst_rel sb atom]::neg_sol, sb) sols) - | _ -> failwith - "GDL.subst_def_branch: unimplemented, see (6b1) of spec") - sols neg_body in + (* no branch duplication, but each negation has its own substitution *) + List.map (fun (pos_sol, neg_sol, sb) -> + let more_neg_sol = + Aux.concat_map (fun (uni_vs, neg_conjs) -> + (* negated subformulas are duplicated instead *) + List.fold_left (fun neg_sol (rel, args as atom) -> + (let try def = + freshen_def_branches (List.assoc rel defs) in + Aux.concat_map (fun (uni_vs, neg_acc, sb) -> + let args = List.map (subst sb) args in + Aux.map_try (fun (dparams, dbody, dneg_body) -> + if dneg_body <> [] then + failwith + ("GDL.subst_def_branch: negation in negatively used" ^ + " defined rels not supported yet, relation "^rel); + (let sb1 = unify [] dparams args in + let param_vars = terms_vars dparams in + let body_vars = rels_vars dbody in + let dbody = subst_rels sb1 dbody in + let local_vs = + Aux.Strings.inter (Aux.Strings.diff body_vars param_vars) + (rels_vars dbody) in + let neg_acc = subst_rels sb1 neg_acc in + Aux.Strings.union uni_vs local_vs, + dbody @ neg_acc, + extend_sb sb1 sb) + ) def) neg_sol + with Not_found -> (* rel not in defs *) + List.map (fun (uni_vs, neg_acc, sb) -> + uni_vs, subst_rel sb atom::neg_acc, sb) neg_sol) + ) [uni_vs, [], sb] neg_conjs + ) neg_body in + let more_neg_sol = + List.map (fun (uni_vs, neg_conjs,_) -> uni_vs, neg_conjs) + more_neg_sol in + List.rev pos_sol, List.rev_append neg_sol more_neg_sol, sb + ) sols in Aux.map_some (fun (pos_sol, neg_sol, sb) -> - if List.mem [] neg_sol then None + if List.exists (function _,[] -> true | _ -> false) neg_sol + then None else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols (* Stratify and expand all relations in the given set. *) @@ -991,25 +1082,29 @@ (legal_args, legal_body, legal_neg_body : exp_def_branch) (head, body, neg_body : exp_def_branch) : (exp_def_branch * exp_def_branch) option = - if List.exists (List.exists (fun (rel,_)->rel="does")) neg_body + if List.exists (fun (_,neg_conjs) -> + List.exists (fun (rel,_)->rel="does") neg_conjs) neg_body then failwith "GDL.translate_game: negated \"does\" conditions not implemented yet"; try let body, more_neg_body, sb = List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) -> if rel = "does" then - List.rev_append legal_body body, + ("_DOES_PLACEHOLDER_", args) :: List.rev_append legal_body body, List.rev_append legal_neg_body more_neg_body, unify sb legal_args args else atom::body, more_neg_body, sb) ([],[],[]) body in - Some ( (List.map (subst sb) legal_args, - List.map (subst_rel sb) legal_body, - List.map (List.map (subst_rel sb)) legal_neg_body), + subst_rels sb legal_body, + List.map (fun (uni_vs,neg_conjs) -> + (* local variables so cannot be touched *) + uni_vs, subst_rels sb neg_conjs) + legal_neg_body), (List.map (subst sb) head, - List.map (subst_rel sb) (List.rev body), - List.map (List.map (subst_rel sb)) + subst_rels sb (List.rev body), + List.map (fun (uni_vs, neg_conjs) -> + uni_vs, subst_rels sb neg_conjs) (List.rev_append more_neg_body neg_body))) with Not_found -> None @@ -1072,21 +1167,17 @@ else dynamic_rules in let rec loop actions_accu state_accu step state = (* {{{ log entry *) - if !debug_level > 0 then ( Printf.printf "aggregate_playout: step %d...\n%!" step ); - (* }}} *) (let try actions, next = aggregate_ply players static_base state state_rules in (* {{{ log entry *) - if !debug_level > 0 then ( Printf.printf "aggregate_playout: state %s\n%!" (String.concat " " (List.map term_str next)) ); - (* }}} *) if step < horizon then loop (actions::actions_accu) (state::state_accu) (step+1) next @@ -1183,9 +1274,9 @@ let mask, _, _, blank = term_to_blank masks term in mask, Formula.fo_var_of_string (term_to_name blank) -let translate_branches struc masks static_rnames dyn_rels brs = +let translate_branches struc masks static_rnames dyn_rels + (brs : exp_def_branch list) = (* 7i *) - (* Do not flatten the already built super-partition. *) let state_terms = List.fold_left (fun acc -> function | [next_arg], body, neg_body -> @@ -1195,16 +1286,29 @@ | "true", _ -> assert false | _ -> acc) acc body in let res = - List.fold_left (List.fold_left (fun acc -> function - | "true", [true_arg] -> Terms.add true_arg acc - | "true", _ -> assert false - | _ -> acc)) res neg_body in - if next_arg = Const "_TERMINAL_" + List.fold_left (fun acc (_, neg_conjs) -> + List.fold_left (fun acc -> function + | "true", [true_arg] -> Terms.add true_arg acc + | "true", _ -> assert false + | _ -> acc) acc neg_conjs) res neg_body in + if next_arg = Const "_IGNORE_RHS_" then res else Terms.add next_arg res | _ -> assert false ) Terms.empty brs in let state_terms = Terms.elements state_terms in + let uni_gdl_vars = + List.fold_left (fun acc (_, _, neg_body) -> + Aux.Strings.union acc + (List.fold_left Aux.Strings.union Aux.Strings.empty + (List.map fst neg_body)) + ) Aux.Strings.empty brs in + let uni_toss_vars = + Aux.map_some (fun term -> + if Aux.Strings.is_empty + (Aux.Strings.inter uni_gdl_vars (term_vars term)) + then None + else Some (snd (toss_var masks term))) state_terms in (* {{{ log entry *) if !debug_level > 2 then ( Printf.printf "state_terms: %s\n%!" ( @@ -1220,7 +1324,7 @@ let ptups = List.map (fun arg -> Aux.assoc_all arg state_subterms) args in (* {{{ log entry *) - if !debug_level > 3 then ( + if !debug_level > 4 then ( Printf.printf "conjs_4a: of %s = subterms %s\n%!" (fact_str (rel,args)) (String.concat "; " ( List.map (fun l -> String.concat ", " @@ -1238,7 +1342,7 @@ Formula.Rel (rname, Array.of_list tup)) ptups in let res = Aux.unique_sorted res in (* {{{ log entry *) - if !debug_level > 3 then ( + if !debug_level > 4 then ( Printf.printf "conjs_4a: of %s = %s\n%!" (fact_str (rel,args)) (Formula.str (Formula.And res)) ); @@ -1267,7 +1371,7 @@ let brs = Aux.map_some (function | [next_arg],body,neg_body -> let phi, lvars = - if next_arg = Const "_TERMINAL_" then [], ref [] + if next_arg = Const "_IGNORE_RHS_" then [], ref [] else let mask, sb, m_sb, blanked = term_to_blank masks next_arg in let rname = term_to_name mask in @@ -1297,35 +1401,20 @@ conjs_4a rel args else [] ) body in + (* only to prune early *) let neg_conjs = - Aux.concat_map ( - Aux.concat_map (fun (rel, args) -> - if rel = "true" then - (* lvars := svar :: !lvars; ??? *) - (* negated (4c) is calculated together with (5) *) - [] - (* - let true_arg = List.hd args in - let mask, sb, m_sb, blanked = term_to_blank masks true_arg in - let rname = term_to_name mask in - let _, svar = toss_var masks true_arg in - let phi = Formula.Rel (rname, [|svar|]) in - let conjs = - Aux.map_some (function - | _, Var _ -> None - | v, t as v_sb -> - let rname = term_to_name (subst_one v_sb mask) in - Some (Formula.Rel (rname, [|svar|]))) sb in - (* FIXME: make sure it's the right semantics *) - [phi; Formula.Not (Formula.And/Or conjs)] - *) + Aux.concat_map (function + | _, [rel, args] -> + if rel = "true" then [] + else if rel = "_DOES_PLACEHOLDER_" + then [] else if List.mem rel static_rnames then - (* 7i-4a *) - (* FIXME: And / Or semantics? *) + (* 7i-4a *) List.map (fun c -> Formula.Not c) (conjs_4a rel args) - (* [Formula.Not (Formula.And (conjs_4a rel args))] *) - else [] - )) neg_body in + else + (* dynamic relations have been expanded *) + assert false + | _ -> []) neg_body in let all_conjs = phi @ conjs @ neg_conjs in let phi = Formula.And all_conjs in let lvars = (!lvars :> Formula.var list) in @@ -1335,6 +1424,7 @@ let rphi = Solver.M.register_formula (Formula.And optim_conjs) in (* {{{ log entry *) + if !debug_level > 4 then ( (* do not print, because it generates too many answers -- too little constraints per number of @@ -1350,11 +1440,12 @@ (Formula.str phi) (* (List.length atups) *) ); + (* }}} *) if Solver.M.check_formula struc rphi then ( (* {{{ log entry *) - if !debug_level > 3 then ( + if !debug_level > 4 then ( Printf.printf "holds\n%!" ); (* }}} *) @@ -1367,7 +1458,7 @@ let brs = List.map (fun (static_conjs, (next_arg,body,neg_body)) -> let rhs_pos_preds, rhs_possneg_preds = - if next_arg = Const "_TERMINAL_" then [], [] + if next_arg = Const "_IGNORE_RHS_" then [], [] else let mask, sb, m_sb, blanked = term_to_blank masks next_arg in let rhs_elem = term_to_name blanked in @@ -1404,7 +1495,7 @@ let lhs_possneg_preds = List.flatten lhs_possneg_preds in *) lhs_pos_preds - else if List.mem rel static_rnames + else if List.mem rel static_rnames || rel = "_DOES_PLACEHOLDER_" then [] else ( Printf.printf "\nunexpected_dynamic: %s\n%!" rel; @@ -1412,42 +1503,86 @@ assert false) ) body in let neg_conjs = - Aux.concat_map ( - Aux.concat_map (fun (rel, args) -> - if rel = "true" then - let true_arg = List.hd args in - let mask, sb, m_sb, blanked = term_to_blank masks true_arg in - let rname = term_to_name mask in - let _, svar = toss_var masks true_arg in - let phi = Formula.Rel (rname, [|svar|]) in - let conjs_4c = - Aux.map_some (function - | _, Var _ -> None - | v, t as v_sb -> - let rname = term_to_name (subst_one v_sb mask) in - Some (Formula.Rel (rname, [|svar|]))) sb in - let conjs_5 = - List.map (fun (v,t as v_sb) -> - if t = Const "_BLANK_" then - assert false - else - (* t = Var _ have been expanded *) - let rname = term_to_name (subst_one v_sb mask) in - Formula.Rel (rname, [|svar|])) m_sb in + Aux.map_some (fun (_, neg_conjs) -> + let disjs = + Aux.map_some (fun (rel, args) -> + if rel = "true" then + let true_arg = List.hd args in + let mask, sb, m_sb, blanked = term_to_blank masks true_arg in + let rname = term_to_name mask in + let _, svar = toss_var masks true_arg in + let phi = Formula.Rel (rname, [|svar|]) in + let conjs_4c = + Aux.map_some (function + | _, Var _ -> None + | v, t as v_sb -> + let rname = term_to_name (subst_one v_sb mask) in + Some (Formula.Rel (rname, [|svar|]))) sb in + let conjs_5 = + List.map (fun (v,t as v_sb) -> + if t = Const "_BLANK_" then + assert false + else + (* t = Var _ have been expanded *) + let rname = term_to_name (subst_one v_sb mask) in + Formula.Rel (rname, [|svar|])) m_sb in - (* FIXME: make sure it's the right semantics *) - [phi; Formula.Not (Formula.And (conjs_4c @ conjs_5))] - else if List.mem rel static_rnames - then [] - else - (* dynamic relations have been expanded *) - assert false - )) neg_body in + (* FIXME: make sure it's the right semantics *) + Some (Formula.Not (Formula.And (phi :: conjs_4c @ conjs_5))) + else if rel = "_DOES_PLACEHOLDER_" + then None + else if List.mem rel static_rnames then + (* 7i-4a *) + Some (Formula.And ( + List.map (fun c -> Formula.Not c) (conjs_4a rel args))) + else + (* dynamic relations have been expanded *) + assert false + ) neg_conjs in + match disjs with + | [] -> None + | [disj] -> Some disj + | _ -> Some (Formula.Or disjs)) neg_body in let all_conjs = static_conjs @ dyn_conjs @ neg_conjs in (rhs_pos_preds, rhs_possneg_preds, static_conjs, all_conjs), (next_arg, body, neg_body)) brs in - conjs_4b, brs + uni_toss_vars, conjs_4b, brs + +let lift_universal (uni_vars : Formula.fo_var list) conjs = + let rec flatten_ands = function + | Formula.And conjs -> Aux.concat_map flatten_ands conjs + | phi -> [phi] in + let conjs = Aux.unique_sorted (Aux.concat_map flatten_ands conjs) in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "lift_universal: vars %s -- conjs:\n%s\n%!" + (String.concat ", " + (List.map Formula.var_str (uni_vars :> Formula.var list))) + (Formula.sprint (Formula.And conjs)) + ); + (* }}} *) + let uni_vars = (uni_vars :> Formula.var list) in + let local, global = List.partition + (fun phi -> + let phi_vs = FormulaOps.free_vars phi in + List.exists (fun v -> List.mem v phi_vs) uni_vars) conjs in + let used_uni_vars = + List.filter (fun v -> List.mem v uni_vars) + (FormulaOps.free_vars (Formula.And local)) in + let res = + if local = [] then Formula.And global + else + Formula.And (global @ [ + Formula.All (used_uni_vars, Formula.And local)]) in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "lift_universal: result\n%s\n%!" + (Formula.sprint res) + ); + (* }}} *) + res + let translate_game game_descr = freshen_count := 0; let player_terms = @@ -1539,6 +1674,34 @@ done; loc_noops in (* 6 *) + let expand_roles rules = + Aux.concat_map (fun (head, body, neg_body as br) -> + let roles, body = + List.partition (fun (rel,_)->rel="role") body in + let neg_roles, neg_body = + List.partition (fun (rel,_)->rel="role") neg_body in + let pterms = Array.to_list player_terms in + let vs, roles = + Aux.partition_map + (function _,[Var v] -> Aux.Left v | _,[p] -> Aux.Right p + | _ -> assert false) roles in + let neg_roles = List.map (function _,[p] -> p + | _ -> assert false) neg_roles in + if List.exists (fun p -> not (List.mem p pterms)) roles + || List.exists (fun p -> List.mem p pterms) neg_roles + then [] + else if vs = [] then [br] + else + let sbs = Aux.product (List.map (fun _ -> pterms) vs) in + List.map (fun sb -> + let sb = List.combine vs sb in + subst_rel sb head, + subst_rels sb body, + subst_rels sb neg_body) sbs + ) rules in + let static_rules = (* Aux.unique_sorted *) (expand_roles static_rules) + and dynamic_rules = (* Aux.unique_sorted *) (expand_roles dynamic_rules) in + let static_rules, exp_static_rules = List.partition (fun ((rel,args), _, _) -> List.length args <= !expand_arity_above || @@ -1562,6 +1725,7 @@ (defs_of_rules static_rules)) in let exp_defs = expand_def_rules ~more_defs:static_exp_defs dynamic_rules in + (* {{{ log entry *) if !debug_level > 0 then ( Printf.printf "translate_game: All expanded dynamic rules:\n%s\n%!" @@ -1593,7 +1757,8 @@ ("GDL.initialize_game: invalid arity of \"true\" atom")) | _ -> None) in let pos_cands = collect body in - let neg_cands = Aux.concat_map collect neg_body in + let neg_cands = + Aux.concat_map (fun (_,neg) -> collect neg) neg_body in let pos_gens = List.map (generalize next_arg) pos_cands in let neg_gens = List.map (generalize next_arg) neg_cands in (* using the fact that Pervasives.compare is lexicographic *) @@ -1818,8 +1983,8 @@ (Array.map (fun player -> let sb = [v, player] in [player; subst sb lterm], - List.map (subst_rel sb) body, - List.map (List.map (subst_rel sb)) neg_body) + subst_rels sb body, + List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body) player_terms) | [Func _; lterm], _, _ -> (* TODO: easy to fix *) @@ -1851,9 +2016,9 @@ && loc_noop_legal.(i).(p) <> Some legal then ( Printf.printf "Multiple noops: %s, %s\n%!" - (term_str (Func ("legal", Aux.fst3 legal))) - (term_str (Func ("legal", Aux.fst3 - (Aux.unsome loc_noop_legal.(i).(p))))); + (branch_str "legal" legal) + (branch_str "legal" + (Aux.unsome loc_noop_legal.(i).(p))); assert false) else loc_noop_legal.(i).(p) <- Some legal done @@ -1861,6 +2026,43 @@ | _ -> assert false ) legal_rules; loc_lead_legal, loc_noop_legal in + let agg_actions = Array.of_list agg_actions in + (* 7a1 *) + let loc_lead_legal = Array.mapi (fun i legals -> + let loc_actions = ref [] in + Array.iteri (fun ply actions -> + if ply mod loc_n = i then + loc_actions := actions @ !loc_actions) agg_actions; + (* {{{ log entry *) + if !debug_level > 4 then ( + Printf.printf "Possible actions in location %d:\n%s\n%!" + i (String.concat "; " + (List.map (fun a -> term_str (Func ("legal", a))) !loc_actions)) + ); + (* }}} *) + let matches head = + List.exists (fun action -> + try ignore (match_meta [] [] action head); true + with Not_found -> false) !loc_actions in + let res = List.filter (fun (head, _, _) -> matches head) legals in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "Filtered actions in location %d:\n%s\n\n%!" + i (String.concat "; " + (List.map (fun (a,_,_) -> term_str (Func ("legal", a))) res)) + ); + (* }}} *) + res + ) loc_lead_legal in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Lead actions in locations:\n%!"; + Array.iteri (fun i lead -> + Printf.printf "loc: %d -- %s\n%!" i ( + String.concat "; " + (List.map (fun a -> branch_str "legal" a) lead))) loc_lead_legal + ); + (* }}} *) (* the joint actions available in a location *) let loc_joint_legal = Array.mapi (fun i lead -> @@ -1876,6 +2078,7 @@ ) loc_lead_legal in (* 7b *) let grtr ((lead1,_,_), _) ((lead2,_,_), _) = cmp_masks lead2 lead1 in + let agg_states = Array.of_list agg_states in let loc_next_classes = Array.mapi (fun loc joint_legal_branches -> Aux.concat_map (fun joint_legal -> @@ -1924,7 +2127,7 @@ done; let layers = List.rev !layers in (* 7d *) - let rules_brs = List.fold_left + let rules_brs : ('a * exp_def_branch list) list = List.fold_left (* folding reverses order so the maximal layer will generate the returned classes *) (fun rules_brs layer -> @@ -1988,13 +2191,14 @@ let multi_body = List.map (fun (head2, body2, neg_body2) -> let sb, _ = match_meta [] [] head head2 in - List.map (subst_rel sb) body2, - List.map (List.map (subst_rel sb)) neg_body2 + subst_rels sb body2, + List.map (fun (uni_vs,neg) -> + uni_vs, subst_rels sb neg) neg_body2 ) f_brs in head, (body, neg_body)::multi_body ) frames in (* 7f3 *) - let erasure_brs = Aux.concat_map + let erasure_brs : exp_def_branch list = Aux.concat_map (function | [next_arg] as next_args,multi_body -> let mask, _, _, blank_arg = term_to_blank masks next_arg in @@ -2024,8 +2228,8 @@ let neg_body = List.map (function - | ["distinct", []] -> assert false - | ["distinct", arg::more_args] -> + | _, ["distinct", []] -> assert false + | _, ["distinct", arg::more_args] -> let _, sb = List.fold_left (fun (base, sb) arg -> let sb = unify sb [base] [arg] in @@ -2038,9 +2242,9 @@ -> v2, Var v1 | vsb -> vsb) sb in Aux.Right (Aux.Right sb) - | conj when List.mem_assoc "distinct" conj -> + | _, conj when List.mem_assoc "distinct" conj -> assert false - | conj -> + | _, conj -> Aux.Right (Aux.Left conj)) neg_body in body @ neg_body) multi_body in @@ -2057,8 +2261,13 @@ then None else let body = List.map (subst_rel sb) body in + let global_vs = + Aux.Strings.union ( + Aux.Strings.union (term_vars next_arg) + (rels_vars body)) fixed_vars in let neg_body = - List.map (fun a -> [subst_rel sb a]) neg_body in + add_neg_body_vars global_vs + (subst_rels sb neg_body) in let head = subst sb blank_arg in if (* TODO: (7g) instead *) @@ -2066,9 +2275,10 @@ fixed_vars && (* (7f4) *) not (List.exists (fun pos -> - List.mem [pos] lead_neg_body + List.exists (fun (_,neg_conjs) -> + List.mem pos neg_conjs) lead_neg_body ) body) && - not (List.exists (fun neg -> + not (List.exists (fun (_,neg) -> List.for_all (fun neg->List.mem neg lead_body) neg ) neg_body) @@ -2108,31 +2318,67 @@ let loc_toss_rules = Array.mapi (fun loc rules_brs -> Aux.concat_map (fun (lead, brs) -> - let conjs_4b, brs = - translate_branches struc masks static_rnames dyn_rels brs in - - (* 7l *) + (* we build synthetic branches so as to get a proper partition *) let atoms = - List.fold_left (fun acc (_,(_,body,neg_body))-> + List.fold_left (fun acc (_,body,neg_body)-> List.fold_right Atoms.add body - (List.fold_right (List.fold_right Atoms.add) - neg_body acc) + (List.fold_right (function + | _, [neg] -> Atoms.add neg + | _ -> fun x -> x) neg_body acc) ) Atoms.empty brs in let atoms = Atoms.elements atoms in + let atoms = List.filter + (fun (rel,_)->rel<>"_DOES_PLACEHOLDER_") atoms in + let synth_brs = Aux.concat_map (fun atom -> + (* so that RHS are ignored *) + [[Const "_IGNORE_RHS_"], [atom], []; + [Const "_IGNORE_RHS_"], [], [Aux.Strings.empty, [atom]]] + ) atoms in + let uni_vars, conjs_4b, brs = + translate_branches struc masks static_rnames dyn_rels + (brs @ synth_brs) in + + (* 7l *) let brs = Array.of_list brs in (* indexing branches *) let full_set = Aux.ints_of_list (Array.to_list (Array.mapi (fun i _ -> i) brs)) in + (* 7l2 *) + let does_set = Aux.ints_of_list + (Aux.map_some (fun x->x) + (Array.to_list (Array.mapi (fun i (_,(_,body,_)) -> + if List.exists ( + function + | "_DOES_PLACEHOLDER_",args -> + (try ignore ( + unify [] [loc_players.(loc); Aux.fst3 lead] + args); true + with Not_found -> false) + | _ -> false) body + then Some i else None) brs))) in + let brs = Array.map (fun (lead,(head,body,neg_body))-> + let body = List.filter ( + function "_DOES_PLACEHOLDER_",_ -> false | _ -> true) body in + lead, (head, body, neg_body)) brs in let table = List.map (fun atom -> let positives = Array.mapi (fun i (_,(_,body,_)) -> if List.mem atom body then Some i else None) brs in let positives = Aux.map_some (fun x->x) (Array.to_list positives) in let negatives = Array.mapi (fun i (_,(_,_,neg_body)) -> - if List.exists (List.mem atom) neg_body then Some i + (* a disjunction is not enough a reason to exclude a branch *) + if List.exists (fun (_,neg)->[atom] = neg) neg_body + then Some i else None) brs in let negatives = Aux.map_some (fun x->x) (Array.to_list negatives) in - Printf.printf "\nd\n%!"; + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "Entry for atom %s:\npositives: %s\nnegatives: %s\n%!" + (fact_str atom) + (String.concat ", "(List.map string_of_int positives)) + (String.concat ", "(List.map string_of_int negatives)) + ); + (* }}} *) (* first those that allow "P" then those that allow "not P" *) [Aux.Ints.diff full_set (Aux.ints_of_list negatives); Aux.Ints.diff full_set (Aux.ints_of_list positives)] @@ -2140,23 +2386,66 @@ let cases = Aux.product table in let cases = List.map (List.fold_left Aux.Ints.inter full_set) cases in + let cases = List.filter (fun case -> + not (Aux.Ints.is_empty (Aux.Ints.inter does_set case))) + cases in + (* every partition point has different preconditions... *) let cases = - Aux.unique_sorted (List.map Aux.Ints.elements cases) in - let cases = List.map (fun c_brs -> + (* Aux.unique_sorted *) (List.map Aux.Ints.elements cases) in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "CASES:\n%s\n%!" (String.concat "\n" (List.map ( + fun l -> String.concat ", " (List.map string_of_int l)) cases)) + ); + (* }}} *) + (* 7l3 *) + + let check_branch body = + Aux.array_existsi (fun ply states -> + if ply mod loc_n = loc then ( + (* {{{ log entry *) + if !debug_level > 4 then ( + let posi = + Aux.map_some (function + | "true", [st_arg] -> Some st_arg + | _ -> None) body in + Printf.printf + "Checking branch at states:\n%s\npositives:\n%s\n" + (terms_str states) (terms_str posi) + ); + (* }}} *) + let res = + List.for_all (function + | "true", [st_arg] -> + List.exists (unifies st_arg) states + | _ -> true) body in + (* {{{ log entry *) + if !debug_level > 4 then ( + Printf.printf "result: %b\n%!" res + ); + (* }}} *) + res + ) else false) agg_states in + + let cases = Aux.map_try (fun c_brs -> let c_brs = List.map (Array.get brs) c_brs in List.fold_left (fun - ((rhs_pos_acc, rhs_neg_acc, static_conjs_acc, conjs_acc), - heads, bodies, neg_bodies) + (rhs_pos_acc, rhs_neg_acc, static_conjs_acc, conjs_acc) ((rhs_pos, rhs_neg, static_conjs, conjs), - (head, body, neg_body)) -> - (rhs_pos @ rhs_pos_acc, rhs_neg @ rhs_neg_acc, - static_conjs @ static_conjs_acc, conjs @ conjs_acc), - head::heads,body@bodies,neg_body@neg_bodies) - (([],[],conjs_4b,conjs_4b),[],[],[]) c_brs + (_,body,_)) -> + if not (check_branch body) + then raise Not_found; + rhs_pos @ rhs_pos_acc, rhs_neg @ rhs_neg_acc, + static_conjs @ static_conjs_acc, conjs @ conjs_acc) + ([],[],conjs_4b,conjs_4b) c_brs ) cases in (* 7m *) - let cases = List.filter (fun ((_,_,static_phis,_), - heads,bodies,neg_bodies) -> + let cases = Aux.map_some (fun (rhs_pos,rhs_neg,static_phis,phis) -> + if rhs_pos = [] && rhs_neg = [] then None + else Some ( + Aux.unique_sorted rhs_pos, Aux.unique_sorted rhs_neg, + static_phis, phis)) cases in + let cases = Aux.map_some (fun (rhs_pos,rhs_neg,static_phis,phis) -> let phi = Formula.And static_phis in let rphi = Solver.M.register_formula phi in (* {{{ log entry *) @@ -2178,25 +2467,32 @@ (* }}} *) let res = Solver.M.check_formula struc rphi in (* {{{ log entry *) - if !debug_level > 3 && res then ( + if !debug_level > 4 && res then ( Printf.printf "holds\n%!" ); (* }}} *) - res) cases in - List.map (fun case -> lead, case) cases + if res then Some (rhs_pos, rhs_neg, phis) + else None) cases in + List.map (fun (rhs_pos, rhs_neg, conjs) -> + lead, (rhs_pos, rhs_neg, lift_universal uni_vars conjs)) cases ) rules_brs ) loc_next_classes in (* 7n *) let terminal_brs = List.map (function - | [], body, neg_body -> [Const "_TERMINAL_"], body, neg_body + | [], body, neg_body -> [Const "_IGNORE_RHS_"], body, neg_body | _ -> assert false) terminal_rules in - let terminal_4b, terminal_brs = + let terminal_uni_vars, terminal_4b, terminal_brs = translate_branches struc masks static_rnames dyn_rels terminal_brs in + (* lifting will drop spurious (4b) premises *) let terminal_disjs = List.map (fun ((_,_,_,conjs),_) -> - Formula.And conjs) terminal_brs in - let terminal_phi = - Formula.And [Formula.And terminal_4b; Formula.Or terminal_disjs] in + let disj_vars = FormulaOps.free_vars (Formula.And conjs) in + let disj_4b = + List.filter (fun a -> List.exists (fun v->List.mem v disj_vars) + (FormulaOps.free_vars a)) terminal_4b in + lift_universal terminal_uni_vars + (disj_4b @ conjs)) terminal_brs in + let terminal_phi = Formula.Or terminal_disjs in (* {{{ log entry *) if !debug_level > 1 then ( Printf.printf "GDL.translate_game: terminal condition -- %s\n%!" @@ -2204,22 +2500,18 @@ ); (* }}} *) (* let loc_toss_rules = *) - Array.mapi (fun loc rules_brs -> - List.map (fun (lead, brs) -> - ignore (terminal_4b, terminal_brs) - - ) rules_brs - ) loc_toss_rules; - (* {{{ log entry *) if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> Printf.printf "Rule translations for loc %d:\n%!" loc; - List.iter (fun ((lead,_,_), (phis,heads,bodies,neg_bodies)) -> - Printf.printf "Rule-translation: player %s move %s\n%s\n%!" + List.iter (fun ((lead,_,_), (rhs_pos,rhs_neg,precond)) -> + Printf.printf + "Rule-translation: player %s move %s precond:\n%s\naction:\nADD %s... DEL %s\n%!" (term_str loc_players.(loc)) (term_str lead) - (rule_pretransl_str (heads,bodies,neg_bodies)) + (Formula.sprint precond) + (String.concat "; " (List.map proto_rel_str rhs_pos)) + (String.concat "; " (List.map proto_rel_str rhs_neg)) ) rules_brs; ) loc_toss_rules; ); Modified: trunk/Toss/GGP/GDL.mli =================================================================== --- trunk/Toss/GGP/GDL.mli 2011-02-09 03:37:28 UTC (rev 1315) +++ trunk/Toss/GGP/GDL.mli 2011-02-10 12:16:07 UTC (rev 1316) @@ -57,8 +57,10 @@ type gdl_rule = gdl_atom * gdl_atom list * gdl_atom list (** Definition with expanded definitions: expansion of a negated relation brings negated conjunctions. *) +type exp_def_branch = + term list * gdl_atom list * (Aux.Strings.t * gdl_atom list) list type exp_def = - string * (term list * gdl_atom list * gdl_atom list list) list + string * exp_def_branch list val func_graph : string -> term list -> term list list Modified: trunk/Toss/GGP/GDLTest.ml =================================================================== --- trunk/Toss/GGP/GDLTest.ml 2011-02-09 03:37:28 UTC (rev 1315) +++ trunk/Toss/GGP/GDLTest.ml 2011-02-10 12:16:07 UTC (rev 1316) @@ -111,5 +111,6 @@ let a () = GDL.debug_level := 4; let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in - let gdef = GDL.translate_game breakthrough in + let connect5 = load_rules "./GGP/examples/connect5.gdl" in + let gdef = GDL.translate_game connect5 in () Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-09 03:37:28 UTC (rev 1315) +++ trunk/Toss/Play/GameTest.ml 2011-02-10 12:16:07 UTC (rev 1316) @@ -863,8 +863,7 @@ \"" 0 in Game.use_monotonic := false; hard_case state 0 "should not attack" - (fun mov_s -> Printf.printf "avoid: %s\n" mov_s; - "Cross{1:f4}" <> mov_s && "Cross{1:f3}" <> mov_s); + (fun mov_s -> "Cross{1:f3}" <> mov_s); Game.use_monotonic := true; ); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-12 17:33:00
|
Revision: 1318 http://toss.svn.sourceforge.net/toss/?rev=1318&view=rev Author: lukstafi Date: 2011-02-12 17:32:53 +0000 (Sat, 12 Feb 2011) Log Message: ----------- GDL game translation (no action translation yet). Server GDL tictactoe test fix. Game connect-4 tests fix. Several helper functions. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/ArenaParser.mly trunk/Toss/Arena/DiscreteRule.ml trunk/Toss/Arena/DiscreteRule.mli trunk/Toss/Arena/DiscreteRuleTest.ml trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Formula/FormulaOps.mli trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDL.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Server/ServerGDLTest.in trunk/Toss/Server/ServerGDLTest.out trunk/Toss/Solver/Structure.ml trunk/Toss/Solver/Structure.mli Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Arena/Arena.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -222,8 +222,7 @@ Array.to_list (Array.mapi (fun i pname->pname, i) (Array.of_list players)) in let num_players = List.length player_names in - let signature = Structure.StringMap.fold - (fun rel ar si -> (rel, ar)::si) state.Structure.rel_signature [] in + let signature = Structure.rel_signature state in (* {{{ log entry *) if !debug_level > 2 then ( printf "process_definition: parsing new rules...%!"; @@ -486,9 +485,7 @@ | Left rn -> ( try let r = (List.assoc rn state.game.rules) in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) - state.struc.Structure.rel_signature [] in + let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) state.game.defined_rels in @@ -502,9 +499,7 @@ | Right rn -> try let r = (List.assoc rn state.game.rules) in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) - state.struc.Structure.rel_signature [] in + let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) state.game.defined_rels in @@ -714,9 +709,7 @@ | EvalRealExpr (rexpr) -> (state, "ERR eval real not yet implemented") | SetRule (r_name, r) -> ( try - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) - state.struc.Structure.rel_signature [] in + let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) state.game.defined_rels in @@ -761,9 +754,7 @@ let set_cond r = let d = r.ContinuousRule.discrete in let (dyn, upd)=(r.ContinuousRule.dynamics, r.ContinuousRule.update) in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) - state.struc.Structure.rel_signature [] in + let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) state.game.defined_rels in @@ -786,9 +777,7 @@ let pre = r.ContinuousRule.discrete.DiscreteRule.pre and inv = r.ContinuousRule.inv and post = r.ContinuousRule.post in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) - state.struc.Structure.rel_signature [] in + let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) state.game.defined_rels in @@ -814,9 +803,7 @@ let pre = r.ContinuousRule.discrete.DiscreteRule.pre and inv = r.ContinuousRule.inv and post = r.ContinuousRule.post in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) - state.struc.Structure.rel_signature [] in + let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) state.game.defined_rels in Modified: trunk/Toss/Arena/ArenaParser.mly =================================================================== --- trunk/Toss/Arena/ArenaParser.mly 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Arena/ArenaParser.mly 2011-02-12 17:32:53 UTC (rev 1318) @@ -9,10 +9,11 @@ %} -%start parse_game_state parse_request +%start parse_game_defs parse_game_state parse_request %type <Arena.request> parse_request request %type <Arena.struct_loc> struct_location %type <(string * int) list -> Arena.location> location +%type <Arena.definition> parse_game_defs %type <Arena.game_state> parse_game_state game_state %type <Arena.game_state -> Arena.game_state> extend_game_state @@ -239,6 +240,9 @@ | error { raise (Lexer.Parsing_error "Syntax error in Server request.") } +parse_game_defs: + game_defs EOF { $1 }; + parse_game_state: game_state EOF { $1 }; Modified: trunk/Toss/Arena/DiscreteRule.ml =================================================================== --- trunk/Toss/Arena/DiscreteRule.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Arena/DiscreteRule.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -857,6 +857,64 @@ List.map fst rels1 @ List.map fst rels2 @ acc)[] rules +let translate_from_precond ~precond ~add ~del = + let diff a b = List.filter (fun e -> not (List.mem e b)) a in + let del = diff del add in + let rhs_names = Aux.unique_sorted + (Aux.concat_map (fun (_,arg) -> Array.to_list arg) (add @ del)) in + let rewritable args = + Aux.array_for_all (fun v -> List.mem (Formula.var_str v) rhs_names) + args in + let conjs = FormulaOps.flatten_ands precond in + let literals, conjs = Aux.partition_map (function + | Formula.Rel (rel, args) when rewritable args -> + Left (Left (rel,args)) + | Not (Formula.Rel (rel, args)) when rewritable args -> + Left (Right (rel,args)) + | phi -> Right phi) conjs in + let posi, nega = Aux.partition_choice literals in + let precond = Formula.And conjs in + let fvars = FormulaOps.free_vars precond in + let local_vars = + List.filter (fun v-> + not (List.mem (Formula.var_str v) rhs_names)) fvars in + let precond = + if local_vars = [] then precond + else Formula.Ex (local_vars, precond) in + let emb_rels = Aux.unique_sorted + (List.map fst (add @ del) @ List.map fst nega) in + let posi_s = + List.map (fun (rel, args) -> rel, Array.map Formula.var_str args) + posi in + let nega_s = + List.map (fun (rel, args) -> rel, Array.map Formula.var_str args) + nega in + let posi_emb = + List.filter (fun (rel,_) -> List.mem rel emb_rels) posi_s in + let del = List.filter (fun d -> not (List.mem d nega_s)) del in + let rhs_struc, rhs_names = + List.fold_left (fun (rhs_struc, rhs_names) name -> + let rhs_struc, elem = + Structure.add_new_elem rhs_struc ~name () in + rhs_struc, (name, elem)::rhs_names) + (Structure.empty_structure (), []) rhs_names in + let add_rels = List.fold_left (fun struc (rel, args) -> + Structure.add_rel struc rel + (Array.map (fun n -> List.assoc n rhs_names) args)) in + let lhs_struc = rhs_struc in + let rhs_struc = add_rels rhs_struc (add @ diff posi_emb del) in + let lhs_struc = add_rels lhs_struc posi_s in + let lhs_struc = add_rels lhs_struc + (List.map (fun (rel,args) -> "_opt_"^rel, args) + (diff del (posi_emb @ nega_s))) in + { + lhs_struc = lhs_struc; + rhs_struc = rhs_struc; + emb_rels = emb_rels; + rule_s = []; + pre = precond; + } + (** {2 Printing and parsing.} *) let matching_str matching = Modified: trunk/Toss/Arena/DiscreteRule.mli =================================================================== --- trunk/Toss/Arena/DiscreteRule.mli 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Arena/DiscreteRule.mli 2011-02-12 17:32:53 UTC (rev 1318) @@ -112,6 +112,10 @@ val changeable_rels : rule_obj list -> string list +val translate_from_precond : + precond:Formula.formula -> add:(string * string array) list -> + del:(string * string array) list -> rule + (** {2 Printing.} *) val matching_str : matching -> string val matching_str_py : matching -> string Modified: trunk/Toss/Arena/DiscreteRuleTest.ml =================================================================== --- trunk/Toss/Arena/DiscreteRuleTest.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Arena/DiscreteRuleTest.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -64,8 +64,7 @@ struc_of_str "[ | P:1 {}; R:2 {}; Q{a} | ]" in let lhs_struc = struc_of_str "[ e | | ]" in let rhs_struc = struc_of_str "[ b, c | P{ (b) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -84,8 +83,7 @@ struc_of_str "[ | P{d}; Q{a} | ]" in let lhs_struc = struc_of_str "[ | Q{e} | ]" in let rhs_struc = struc_of_str "[ b, c | Q:1{}; _opt_Q{c}; P{b} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -105,8 +103,7 @@ let lhs_struc = struc_of_str "[ | Q{e} | ]" in let rhs_struc = struc_of_str "[ b, c | Q:1{}; P{b} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -125,8 +122,7 @@ struc_of_str "[ | P:1{ }; R{(a,b)}; C{(b,c)}; D{(a,c)} | ]" in let lhs_struc = struc_of_str "[ a,e | R{ (e,a) } | ]" in let rhs_struc = struc_of_str "[ a,b,c | P{ (b) }; R:2{}; _opt_R { (a,a); (a,b); (a,c); (b,b); (b,c); (c,b); (c,c) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -151,8 +147,7 @@ struc_of_str "[ | P:1 {}; R:2 {}; Q{1} | ]" in let lhs_struc = struc_of_str "[ 1 | | ]" in let rhs_struc = struc_of_str "[ 1, 2 | P{ (1) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -171,8 +166,7 @@ struc_of_str "[ | P{2}; Q{1} | ]" in let lhs_struc = struc_of_str "[ | Q{1} | ]" in let rhs_struc = struc_of_str "[ 1, 2 | Q:1{}; _opt_Q{2}; P{1} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -192,8 +186,7 @@ let lhs_struc = struc_of_str "[ | Q{1} | ]" in let rhs_struc = struc_of_str "[ 1, 2 | Q:1{}; P{1} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -212,8 +205,7 @@ struc_of_str "[ | P:1{ }; R{(1,2)}; C{(2,3)}; D{(1,3)} | ]" in let lhs_struc = struc_of_str "[ 1,2 | R{ (2,1) } | ]" in let rhs_struc = struc_of_str "[ 1,2,3 | P{ (2) }; R:2{}; _opt_R { (1,1); (1,2); (1,3); (2,2); (2,3); (3,2); (3,3) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -238,8 +230,7 @@ struc_of_str "[ | P{a}; Q{a} | ]" in let lhs_struc = struc_of_str "[ e | | ]" in let rhs_struc = struc_of_str "[ b,c | P{ (b) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -259,8 +250,7 @@ let lhs_struc = struc_of_str "[ | P{e} | ]" in let rhs_struc = struc_of_str "[ b,c | P{ (b) }; _opt_P{ (c) }; Q:1{}; _opt_Q{ (b) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -284,8 +274,7 @@ struc_of_str "[ | Q{a}; P:1{ }; R:2{}; D:2{} | ]" in let lhs_struc = struc_of_str "[ b | | ]" in let rhs_struc = struc_of_str "[ | P{ (b) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -304,8 +293,7 @@ struc_of_str "[ | P{d}; Q{a}; R:2{}; D:2{} | ]" in let lhs_struc = struc_of_str "[ | Q{e} | ]" in let rhs_struc = struc_of_str "[ | P{ (e) }; Q:1{} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -329,8 +317,7 @@ let lhs_struc = struc_of_str "[ b | | ]" in let rhs_struc = struc_of_str "[ b | P{ (b) }; Q{ (b) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -350,8 +337,7 @@ let lhs_struc = struc_of_str "[ | P{ (b) } | ]" in let rhs_struc = struc_of_str "[ | P{ (b) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -376,8 +362,7 @@ let lhs_struc = struc_of_str "[ b | P{b} | ]" in let rhs_struc = struc_of_str "[ b,c | _opt_P{c} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -401,8 +386,7 @@ let lhs_struc = struc_of_str "[ a | P {a} | ]" in let rhs_struc = struc_of_str "[ b | P:1{}; Q {b} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -421,8 +405,7 @@ let lhs_struc = struc_of_str "[ a,b | C {(a,b)} | ]" in let rhs_struc = struc_of_str "[ c,d | C:2{}; D {(c,d)} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -447,8 +430,7 @@ let lhs_struc = struc_of_str "[ a | P {a} | ]" in let rhs_struc = struc_of_str "[ b,c | P:1{}; Q {b}; R{(b,c)} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -468,8 +450,7 @@ let lhs_struc = struc_of_str "[ a,b | C {(a,b)} | ]" in let rhs_struc = struc_of_str "[ c | P {c} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -489,8 +470,7 @@ let lhs_struc = struc_of_str "[ a,b | C {(a,b)} | ]" in let rhs_struc = struc_of_str "[ c,d | C:2{}; D {(c,d)} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -514,8 +494,7 @@ struc_of_str "[ | P:1{};Q:1{};R{(a,a)} | ]" in let lhs_struc = struc_of_str "[ a,e | R{ (e,a) } | ]" in let rhs_struc = struc_of_str "[ a,e | R { (a,e) } | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -540,8 +519,7 @@ struc_of_str "[ | P{e}; Q:1{}; C{e} | ]" in let lhs_struc = struc_of_str "[ | P{a} | ]" in let rhs_struc = struc_of_str "[ | P:1{}; Q{b} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -559,8 +537,7 @@ let lhs_struc = struc_of_str "[ | P{a} | ]" in let rhs_struc = struc_of_str "[ | P:1{}; Q{b} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; @@ -582,8 +559,7 @@ let lhs_struc = struc_of_str "[a,b | P{a;b} | ]" in let rhs_struc = struc_of_str "[ | P:1{}; Q{c} | ]" in - let signat = Structure.StringMap.fold - (fun r ar si -> (r,ar)::si) model.Structure.rel_signature [] in + let signat = Structure.rel_signature model in let rule_obj = compile_rule signat [] {lhs_struc = lhs_struc; rhs_struc = rhs_struc; Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Formula/FormulaOps.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -627,6 +627,12 @@ | Not phi -> Not (flatten_formula phi) | (Rel _ | Eq _ | In _ | RealExpr _) as atom -> atom +(* Formula as a list of conjuncts. *) +let rec flatten_ands = function + | Formula.And conjs -> Aux.concat_map flatten_ands conjs + | phi -> [phi] + + (* Compute size of a formula (currently w/o descending the real part). *) let rec size = function | Or js | And js -> List.fold_left (+) 1 (List.map size js) Modified: trunk/Toss/Formula/FormulaOps.mli =================================================================== --- trunk/Toss/Formula/FormulaOps.mli 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Formula/FormulaOps.mli 2011-02-12 17:32:53 UTC (rev 1318) @@ -74,6 +74,9 @@ (** Flatten "and"s and "or"s in a formula -- i.e. associativity. *) val flatten_formula : formula -> formula +(** Formula as a list of conjuncts. *) +val flatten_ands : formula -> formula list + (** Compute size of a formula (currently w/o descending the real part). *) val size : formula -> int Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/GGP/GDL.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -412,13 +412,16 @@ by all values in its domain (for example, as gathered from the aggregate playout), and expanding all atoms that contained value variables (both static and dynamic) using (6); fail if a goal - value cannot be determined. The payoff formula is the sum of - "goal" value times the characterisic function of the "goal" - body. We do not translate the body if the value is zero (we drop - the zero goal branches from the definition). Translate the body - using (7h)-(7m), but treating "goal" branches separately -- when - (7k) duplicates a branch, new branches add new sum elements. + value cannot be determined. + (8a) The payoff formula is the sum of "goal" value times the + characterisic function of the corresponding "goal" bodies. We do + not translate the body if the value is zero (we drop the zero goal + branches from the definition). For each goal value we collect + bodies to form a disjunction. + +() + *) let debug_level = ref 0 @@ -1461,7 +1464,8 @@ if next_arg = Const "_IGNORE_RHS_" then [], [] else let mask, sb, m_sb, blanked = term_to_blank masks next_arg in - let rhs_elem = term_to_name blanked in + let rhs_elem = + (* Formula.fo_var_of_string *) (term_to_name blanked) in Aux.partition_map (fun (v,t as v_sb) -> if t = Const "_BLANK_" then let neg_rels = List.assoc (mask, v) dyn_rels in @@ -1550,10 +1554,8 @@ let lift_universal (uni_vars : Formula.fo_var list) conjs = - let rec flatten_ands = function - | Formula.And conjs -> Aux.concat_map flatten_ands conjs - | phi -> [phi] in - let conjs = Aux.unique_sorted (Aux.concat_map flatten_ands conjs) in + let conjs = Aux.unique_sorted + (Aux.concat_map FormulaOps.flatten_ands conjs) in (* {{{ log entry *) if !debug_level > 2 then ( Printf.printf "lift_universal: vars %s -- conjs:\n%s\n%!" @@ -1736,6 +1738,7 @@ let legal_rules = List.assoc "legal" exp_defs in let next_rules = List.assoc "next" exp_defs in let terminal_rules = List.assoc "terminal" exp_defs in + let goal_rules = List.assoc "goal" exp_defs in (* 3b *) let exp_next = Aux.concat_map (subst_def_branch ["does", legal_rules]) next_rules in @@ -2144,7 +2147,7 @@ (* 7e -- TODO (together with non-maximal (7d) classes) *) (* 7f *) let rules_brs = - List.map (fun (lead_head, lead_body, lead_neg_body as lead, + List.map (fun ((lead_head, lead_body, lead_neg_body), branches) -> let fixed_vars = term_vars lead_head in let fixed_brs, other_brs = List.partition @@ -2295,7 +2298,7 @@ (* TODO: (7f5) we ignore the possibility that "lead" is instantiated by some of erasure substitutions, since we already ignore non-maximal "legal" classes *) - lead, fixed_brs @ erasure_brs + lead_head, fixed_brs @ erasure_brs ) rules_brs in (* let rules_inds = Array.of_list rules_brs in *) rules_brs @@ -2305,7 +2308,7 @@ if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> Printf.printf "Rule precursors for loc %d:\n%!" loc; - List.iter (fun ((lead,_,_), brs) -> + List.iter (fun (lead, brs) -> Printf.printf "Rule-precursor: player %s move %s\n%s\n%!" (term_str loc_players.(loc)) (term_str lead) (def_str ("action", brs)) @@ -2350,7 +2353,7 @@ function | "_DOES_PLACEHOLDER_",args -> (try ignore ( - unify [] [loc_players.(loc); Aux.fst3 lead] + unify [] [loc_players.(loc); lead] args); true with Not_found -> false) | _ -> false) body @@ -2484,28 +2487,86 @@ | _ -> assert false) terminal_rules in let terminal_uni_vars, terminal_4b, terminal_brs = translate_branches struc masks static_rnames dyn_rels terminal_brs in - (* lifting will drop spurious (4b) premises *) let terminal_disjs = List.map (fun ((_,_,_,conjs),_) -> let disj_vars = FormulaOps.free_vars (Formula.And conjs) in let disj_4b = List.filter (fun a -> List.exists (fun v->List.mem v disj_vars) (FormulaOps.free_vars a)) terminal_4b in - lift_universal terminal_uni_vars - (disj_4b @ conjs)) terminal_brs in + Formula.Ex (disj_vars, + lift_universal terminal_uni_vars + (disj_4b @ conjs))) terminal_brs in let terminal_phi = Formula.Or terminal_disjs in + + let fluents = Aux.strings_of_list + (Aux.concat_map (fun (_,drels) -> drels) dyn_rels) in (* {{{ log entry *) if !debug_level > 1 then ( Printf.printf "GDL.translate_game: terminal condition -- %s\n%!" - (Formula.sprint terminal_phi) + (Formula.sprint terminal_phi); ); (* }}} *) - (* let loc_toss_rules = *) + (* 8 *) + let goal_rules = + Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule] + | [Var v; gterm], body, neg_body -> + Array.to_list + (Array.map (fun player -> + let sb = [v, player] in + [player; subst sb gterm], + subst_rels sb body, + List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body) + player_terms) + | [Func _; gterm], _, _ -> + (* TODO: easy to fix *) + failwith "GDL.translate_game: bigger player terms not handled yet" + | _ -> assert false) goal_rules in + let goal_brs = + List.map (function + | [player; score], body, neg_body -> + player, (score, ([Const "_IGNORE_RHS_"], body, neg_body)) + | _ -> assert false) goal_rules in + let player_goals = + List.map (fun (player, goal_brs) -> player, Aux.collect goal_brs) + (Aux.collect goal_brs) in + let payoffs = List.map (fun (player, goals) -> + let payoff = List.fold_left (fun sum (score, brs) -> + let score = + match score with + | Const pay -> + (try float_of_string pay with _ -> assert false) + | _ -> assert false in + let goal_uni_vars, goal_4b, brs = + translate_branches struc masks static_rnames dyn_rels brs in + let goal_disjs = List.map (fun ((_,_,_,conjs),_) -> + let disj_vars = FormulaOps.free_vars (Formula.And conjs) in + let disj_4b = + List.filter (fun a -> List.exists (fun v->List.mem v disj_vars) + (FormulaOps.free_vars a)) goal_4b in + lift_universal goal_uni_vars + (disj_4b @ conjs)) brs in + let guard = Formula.Or goal_disjs in + Formula.Plus (sum, Formula.Times ( + Formula.Const score, Formula.Char guard)) + ) (Formula.Const 0.) goals in + player, payoff + ) player_goals in + (* {{{ log entry *) if !debug_level > 1 then ( + Printf.printf "GDL.translate_game: payoffs --\n%!"; + List.iter (fun (player, payoff) -> + Printf.printf "%s: %s\n%!" + (term_str player) (Formula.sprint_real payoff)) + payoffs + ); + (* }}} *) + + (* {{{ log entry *) + if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> Printf.printf "Rule translations for loc %d:\n%!" loc; - List.iter (fun ((lead,_,_), (rhs_pos,rhs_neg,precond)) -> + List.iter (fun (lead, (rhs_pos,rhs_neg,precond)) -> Printf.printf "Rule-translation: player %s move %s precond:\n%s\naction:\nADD %s... DEL %s\n%!" (term_str loc_players.(loc)) (term_str lead) @@ -2516,20 +2577,73 @@ ) loc_toss_rules; ); (* }}} *) - struc + let signature = Structure.rel_signature struc in + let payoffs = Aux.array_from_assoc + (List.map (fun (player, payoff) -> find_player player, payoff) + payoffs) in + let payoffs_pp = + Array.map (fun pay -> Solver.M.register_real_expr pay) payoffs in + let rules_and_locations = + let rnames = ref Aux.Strings.empty in + Array.mapi (fun loc rules_brs -> + let labelled_rules = + List.map (fun (lead, (rhs_pos,rhs_neg,precond)) -> + let precond = + Formula.And [precond; Formula.Not terminal_phi] in + let rname = Aux.not_conflicting_name !rnames + ((term_to_name lead) ^ "_" ^ string_of_int loc) in + rnames := Aux.Strings.add rname !rnames; + let next_loc = (loc + 1) mod loc_n in + let label = { + Arena.rule = rname; + time_in = 0.1, 0.1; parameters_in = [] + }, next_loc in + let discrete = + DiscreteRule.translate_from_precond ~precond + ~add:rhs_pos ~del:rhs_neg in + let rule = + ContinuousRule.make_rule signature [] discrete + [] [] ~pre:discrete.DiscreteRule.pre () in + label, (rname, rule) + ) rules_brs in + let labels, rules = List.split labelled_rules in + let location = { + Arena.id = loc; + player = find_player loc_players.(loc); + payoffs = payoffs; + payoffs_pp = payoffs_pp; + moves = labels} in + rules, location + ) loc_toss_rules in + let rules = Array.map fst rules_and_locations + and locations = Array.map snd rules_and_locations in + let rules = List.concat (Array.to_list rules) in + let player_names = + Array.to_list + (Array.mapi (fun pnum pterm -> term_to_name pterm, pnum) + player_terms) in + let game = { + Arena.rules = rules; + graph = locations; + num_players = players_n; + player_names = player_names; + defined_rels = []} in + let result = { + Arena.game = game; + struc = struc; + time = 0.; + cur_loc = 0; + data = []; + } in + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "\n\nGDL.translate_game:\n%s\n%!" + (Arena.sprint_state result) + ); + (* }}} *) + result -(* - let paths = collect_paths element_terms in - let static_facts = - Array.of_list - (Aux.map_some (function Atomic p -> Some p | _ -> None) game_descr) in - let element_names = List.map term_to_name element_terms in - let struc = List.fold_left (fun acc name -> - fst (Structure.add_new_elem acc ~name ())) - Structure.empty_structure element_names in -*) - let player_name_terms = ref [|Const "uninit"|] Modified: trunk/Toss/GGP/GDL.mli =================================================================== --- trunk/Toss/GGP/GDL.mli 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/GGP/GDL.mli 2011-02-12 17:32:53 UTC (rev 1318) @@ -74,7 +74,7 @@ term list * (term list list list * term list list) (* DEBUG intermediate *) -val translate_game : game_descr_entry list -> Structure.structure +val translate_game : game_descr_entry list -> Arena.game_state val defs_of_rules : gdl_rule list -> exp_def list val expand_def_rules : ?more_defs:exp_def list -> gdl_rule list -> exp_def list Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Play/GameTest.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -20,6 +20,12 @@ let real_expr_of_str s = FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s) +let defstruc_of_str s = + match + ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) + with Arena.StateStruc struc -> struc + | _ -> failwith "defstruc_of_str: not a structure" + let state_of_str s = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string s) @@ -50,8 +56,10 @@ let move_gs_str state move = move_str state.Arena.game.Arena.rules state.Arena.struc move -let update_game (lazy (horizon, adv_ratio, game)) state cur_loc = - let state = struc_of_str state in +let update_game ?(defs=false) + (lazy (horizon, adv_ratio, game)) state cur_loc = + let state = + if defs then defstruc_of_str state else struc_of_str state in horizon, adv_ratio, {game with Arena.struc = state; cur_loc = cur_loc} @@ -821,9 +829,8 @@ "connect4 simple" >:: (fun () -> - let state = update_game connect4_game -"[ | | - ] \" + let state = update_game ~defs:true connect4_game +"MODEL [ | | ] \" . . . . . . . @@ -836,7 +843,8 @@ P . . . . . . P Q Q +Q . . . -\"" 0 in +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in Game.use_monotonic := false; easy_case state 0 "should attack" (fun mov_s -> "Cross{1:a4}" = mov_s); @@ -845,9 +853,8 @@ "connect4 avoid losing" >:: (fun () -> - let state = update_game connect4_game -"[ | | - ] \" + let state = update_game ~defs:true connect4_game +"MODEL [ | | ] \" ... ... ... ... ... ... ... ... ... ... @@ -860,7 +867,8 @@ ... Q..P P.. ... ... ... ... ... Q..P P..P Q.. -\"" 0 in +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in Game.use_monotonic := false; hard_case state 0 "should not attack" (fun mov_s -> "Cross{1:f3}" <> mov_s); @@ -870,9 +878,8 @@ "connect4 endgame" >:: (fun () -> - let state = update_game connect4_game -"[ | | - ] \" + let state = update_game ~defs:true connect4_game +"MODEL [ | | ] \" . . . . . . . @@ -885,7 +892,8 @@ P . +Q Q . . . P P P Q Q . . -\"" 0 in +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in Game.use_monotonic := false; hard_case state 0 "should defend" (fun mov_s -> "Cross{1:e2}" = mov_s); @@ -957,7 +965,7 @@ let a () = match test_filter - ["Game:2:alpha_beta_ord-time 8 16 32:16:connect4 avoid losing"] + ["Game:1:alpha_beta_ord-effort 2 3 4:15:connect4 simple"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) Modified: trunk/Toss/Server/ServerGDLTest.in =================================================================== --- trunk/Toss/Server/ServerGDLTest.in 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Server/ServerGDLTest.in 2011-02-12 17:32:53 UTC (rev 1318) @@ -41,7 +41,7 @@ Content-type: text/acl Content-length: 41 -(PLAY MATCH.3316980891 ((MARK 2 1) NOOP)) +(PLAY MATCH.3316980891 ((MARK 1 1) NOOP)) POST / HTTP/1.0 Accept: text/delim @@ -50,7 +50,7 @@ Content-type: text/acl Content-length: 41 -(PLAY MATCH.3316980891 (NOOP (MARK 2 3))) +(PLAY MATCH.3316980891 (NOOP (MARK 3 2))) POST / HTTP/1.0 Accept: text/delim @@ -59,13 +59,4 @@ Content-type: text/acl Content-length: 41 -(PLAY MATCH.3316980891 ((MARK 3 3) NOOP)) - -POST / HTTP/1.0 -Accept: text/delim -Sender: GAMEMASTER -Receiver: GAMEPLAYER -Content-type: text/acl -Content-length: 41 - -(STOP MATCH.3316980891 (NOOP (MARK 1 1))) +(STOP MATCH.3316980891 ((MARK 3 3) NOOP)) Modified: trunk/Toss/Server/ServerGDLTest.out =================================================================== --- trunk/Toss/Server/ServerGDLTest.out 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Server/ServerGDLTest.out 2011-02-12 17:32:53 UTC (rev 1318) @@ -17,7 +17,7 @@ Content-type: text/acl Content-length: 10 -(MARK 2 1) +(MARK 1 1) HTTP/1.0 200 OK Content-type: text/acl Content-length: 4 @@ -27,15 +27,10 @@ Content-type: text/acl Content-length: 10 -(MARK 1 2) +(MARK 3 3) HTTP/1.0 200 OK Content-type: text/acl Content-length: 4 -NOOP -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 4 - DONE ERR processing completed -- EOF Modified: trunk/Toss/Solver/Structure.ml =================================================================== --- trunk/Toss/Solver/Structure.ml 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Solver/Structure.ml 2011-02-12 17:32:53 UTC (rev 1318) @@ -71,6 +71,10 @@ inv_names = IntMap.empty ; rel_signature = StringMap.empty ; } + +let rel_signature struc = + StringMap.fold (fun r ar si -> (r,ar)::si) + struc.rel_signature [] (* Return the list of relation tuples incident to an element [e] in [struc]. *) @@ -471,9 +475,11 @@ if StringMap.is_empty struc.rel_signature then "" else let s_str rel ar = rel ^ ": " ^ (string_of_int ar) in - (String.concat ", " (StringMap.fold - (fun rel ar acc -> s_str rel ar::acc) - struc.rel_signature [])) + let rel_structure struc = + StringMap.fold + (fun rel ar acc -> s_str rel ar::acc) + struc.rel_signature [] in + String.concat ", " (rel_structure struc) (* Print the structure [struc] as string, in extensive form (not using condensed representations like boards). *) Modified: trunk/Toss/Solver/Structure.mli =================================================================== --- trunk/Toss/Solver/Structure.mli 2011-02-10 17:40:57 UTC (rev 1317) +++ trunk/Toss/Solver/Structure.mli 2011-02-12 17:32:53 UTC (rev 1318) @@ -58,6 +58,7 @@ (** Return the list of functions. *) val f_signature : structure -> string list +val rel_signature : structure -> (string * int) list (** {2 Printing structures} *) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-13 17:46:06
|
Revision: 1319 http://toss.svn.sourceforge.net/toss/?rev=1319&view=rev Author: lukaszkaiser Date: 2011-02-13 17:46:00 +0000 (Sun, 13 Feb 2011) Log Message: ----------- Small change to non-monotonic heuristic to correct Connect4 with Diags in the structure. Modified Paths: -------------- trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Heuristic.ml trunk/Toss/examples/Gomoku.toss Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-12 17:32:53 UTC (rev 1318) +++ trunk/Toss/Play/GameTest.ml 2011-02-13 17:46:00 UTC (rev 1319) @@ -703,8 +703,8 @@ "gomoku8x8 avoid endgame" >:: (fun () -> - let state = update_game gomoku8x8_game -"[ | | ] \" + let state = update_game ~defs:true gomoku8x8_game +"MODEL [ | | ] \" ... ... ... ... ... ... ... ... ... ... ... ... @@ -721,12 +721,13 @@ Q.. ... ... ... ... ... ... ... ... ... ... ... -\"" 0 in +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in easy_big_case state 0 "P should block" (fun mov_s -> "Cross{1:b5}" = mov_s); - let state = update_game gomoku8x8_game -"[ | | ] \" + let state = update_game ~defs:true gomoku8x8_game +"MODEL [ | | ] \" ... ... ... ... ... ... ... ... ... ... ... ... @@ -743,7 +744,8 @@ ... ... ... ... ... ... ... ... ... ... ... ... -\"" 0 in +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in easy_big_case state 0 "P should block with line" (fun mov_s -> "Cross{1:f7}" = mov_s); @@ -752,8 +754,8 @@ "gomoku8x8 block gameover" >:: (fun () -> - let state = update_game gomoku8x8_game -"[ | | ] \" + let state = update_game ~defs:true gomoku8x8_game +"MODEL [ | | ] \" ... ... ... ... ... ... ... ... ... ... ... ... @@ -770,7 +772,8 @@ ... ... ... ... ... ... ... ... ... ... ... ... -\"" 0 in +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in easy_big_case state 0 "P should block" (fun mov_s -> "Cross{1:a3}" = mov_s); @@ -779,8 +782,8 @@ "gomoku8x8 more pieces" >:: (fun () -> - let state = update_game gomoku8x8_game -"[ | | ] \" + let state = update_game ~defs:true gomoku8x8_game +"MODEL [ | | ] \" ... ... ... ... P ... ... ... ... ... ... ... ... @@ -797,15 +800,16 @@ ...P ... P.. ... ... ... ... ... ... ... ...Q ... -\"" 0 in - easy_big_case state 0 "should block the open line" - (fun mov_s -> "Cross{1:e7}" = mov_s); +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in + easy_big_case state 0 "should block the open line" + (fun mov_s -> "Cross{1:e7}" = mov_s); ); "gomoku8x8 attack" >:: (fun () -> - let state = update_game gomoku8x8_game -"[ | | ] \" + let state = update_game ~defs:true gomoku8x8_game +"MODEL [ | | ] \" ... ... ... ... ... ... ... ... ... ... ... ... @@ -822,9 +826,10 @@ ... Q.. P.. ... ... ... ... ... ... ... Q.. ... -\"" 0 in - easy_big_case state 0 "should attack the diagonal" - (fun mov_s -> "Cross{1:d4}" = mov_s); +\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; + DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in + easy_big_case state 0 "should attack the diagonal" + (fun mov_s -> "Cross{1:d4}" = mov_s); ); "connect4 simple" >:: Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2011-02-12 17:32:53 UTC (rev 1318) +++ trunk/Toss/Play/Heuristic.ml 2011-02-13 17:46:00 UTC (rev 1319) @@ -624,8 +624,10 @@ let rels = List.filter (fun (rel,_) -> not (Strings.mem rel frels)) rels in let rec aux all_vars = function + | Rel _ | Eq _ | In _ as phi -> phi + | Not psi -> aux all_vars (FormulaOps.nnf ~neg:true psi) | Or phis -> Or (List.map (aux all_vars) phis) - | And phis as phi when has_rels frels phi -> + | And phis (* as phi when (has_rels frels phi) *) -> And (List.map (aux all_vars) phis) | Ex (vs, phi) when has_rels frels phi -> Ex (vs, aux (add_strings (List.map var_str vs) all_vars) phi) @@ -882,7 +884,8 @@ (* }}} *) let phi'' = if parsimony_level > 0 then phi - else FFTNF.ff_tnf (FFTNF.promote_rels frels) phi in + else phi + (* FFTNF.ff_tnf (FFTNF.promote_rels frels) phi *) in (* {{{ log entry *) if !debug_level > 2 then ( Printf.printf Modified: trunk/Toss/examples/Gomoku.toss =================================================================== --- trunk/Toss/examples/Gomoku.toss 2011-02-12 17:32:53 UTC (rev 1318) +++ trunk/Toss/examples/Gomoku.toss 2011-02-13 17:46:00 UTC (rev 1319) @@ -1,7 +1,5 @@ PLAYERS 1, 2 DATA r1: circle, r2: line, adv_ratio: 4, depth: 2 -REL DiagA (x, y) = ex u (R(x, u) and C(u, y)) -REL DiagB (x, y) = ex u (R(x, u) and C(y, u)) REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w) REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w) REL DiagA5 (x, y, z, v, w) = @@ -58,4 +56,5 @@ ... ... ... ... ... ... ... ... ... ... ... ... -" +" with DiagA (x, y) = ex u (R(x, u) and C(u, y)); + DiagB (x, y) = ex u (R(x, u) and C(y, u)) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-13 23:17:43
|
Revision: 1320 http://toss.svn.sourceforge.net/toss/?rev=1320&view=rev Author: lukaszkaiser Date: 2011-02-13 23:17:36 +0000 (Sun, 13 Feb 2011) Log Message: ----------- Fluents heuristic, ability to run experiments from server. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/Arena.mli trunk/Toss/Arena/DiscreteRule.ml trunk/Toss/Arena/DiscreteRule.mli trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Server/Server.ml Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/Arena.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -69,6 +69,14 @@ (* -------------------- PARSER HELPER ------------------------------ *) +(* Rules with which a player with given number can move. *) +let rules_for_player player_no game = + let rules_of_loc l = + if l.player = player_no then + Some (List.map (fun (lab, _) -> lab.rule) l.moves) + else None in + List.concat (Aux.map_some rules_of_loc (Array.to_list game.graph)) + (* Add a defined relation to a structure. *) let add_def_rel_single struc (r_name, vars, def_phi) = let def_asg = Solver.M.evaluate struc Modified: trunk/Toss/Arena/Arena.mli =================================================================== --- trunk/Toss/Arena/Arena.mli 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/Arena.mli 2011-02-13 23:17:36 UTC (rev 1320) @@ -43,6 +43,9 @@ val empty_state : game_state +(** Rules with which a player with given number can move. *) +val rules_for_player : int -> game -> string list + val add_def_rels : Structure.structure -> (string * string list * Formula.formula) list -> Structure.structure Modified: trunk/Toss/Arena/DiscreteRule.ml =================================================================== --- trunk/Toss/Arena/DiscreteRule.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/DiscreteRule.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -47,7 +47,15 @@ } (* We call fluents the relations that can be modified by a rule. *) -let fluents r = +let fluents_make ?(only_pos=false) f r = + let fl_make (s, tp) = + if tp = [] then None else + Some (f s (Array.length (List.hd tp))) in + if only_pos then + Aux.map_some fl_make r.rhs_pos_tuples + else Aux.map_some fl_make (r.rhs_pos_tuples @ r.rhs_neg_tuples) + +let fluents r = let map_rels = Aux.map_some (fun (rel,tups)->if tups=[] then None else Some rel) in map_rels r.rhs_pos_tuples @ map_rels r.rhs_neg_tuples Modified: trunk/Toss/Arena/DiscreteRule.mli =================================================================== --- trunk/Toss/Arena/DiscreteRule.mli 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/DiscreteRule.mli 2011-02-13 23:17:36 UTC (rev 1320) @@ -44,6 +44,8 @@ (* We call fluents the relations that can be modified by a rule. *) val fluents : rule_obj -> string list +val fluents_make : ?only_pos : bool -> (string -> int -> 'a) -> + rule_obj -> 'a list (* A relation is monotonic if it cannot remove tuples. *) val monotonic : rule_obj -> bool Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Play/Game.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -287,6 +287,28 @@ res) node.Arena.payoffs) graph +let fluents_heuristic game = + let (no_players, rules) = (game.Arena.num_players, game.Arena.rules) in + let pl_rules = Array.mapi + (fun i _ -> Arena.rules_for_player i game) (Array.create no_players 1) in + let pos_fluents_of_rule rname = + let drule = (List.assoc rname rules).ContinuousRule.compiled in + let list_upto_one s i = + let vx = Formula.fo_var_of_string "x" in + if i = 0 then Formula.Const (0.) else if i = 1 then + Formula.Sum ([vx], Formula.Rel (s, [|vx|]), Formula.Const (1.)) + else Formula.Const (0.) in + DiscreteRule.fluents_make ~only_pos:true list_upto_one drule in + let pl_fluents = Array.map (Aux.concat_map pos_fluents_of_rule) pl_rules in + let sums = Array.map (fun fl -> + List.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) + (Aux.unique_sorted fl)) pl_fluents in + let sum_all = + Array.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) sums in + let heurs = Array.map (fun f -> + Formula.Plus (Formula.Times (Formula.Const (2.), f), + Formula.Times (Formula.Const (-1.), sum_all))) sums in + Array.map (fun _ -> heurs) game.Arena.graph (* The UCB1-TUNED estimate, modified to extend to the zero- and one-observation cases. *) @@ -1072,7 +1094,7 @@ match res with | Aux.Left (_,_,_,state) -> (* {{{ log entry *) - if !debug_level > 5 || (!debug_level > 1 && set_timer <> None) then + if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then printf "step-state:\n%s\n%!" (Structure.str state.game_state.struc); (* }}} *) play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Play/Game.mli 2011-02-13 23:17:36 UTC (rev 1320) @@ -213,7 +213,13 @@ val suggest : ?effort:int -> play -> play_state -> (move * play_state) option +(** Various constructed heuristics. *) +val default_heuristic : ?struc:Structure.structure -> float -> + Arena.game -> Formula.real_expr array array +val fluents_heuristic : Arena.game -> Formula.real_expr array array + + (* ------------------------- DEBUGGING ------------------------------------- *) (** Debugging information. At level 0 nothing is printed out. Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Server/Server.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -268,7 +268,7 @@ | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) -> (* GDL will store the player and the game in its state. *) - Random.init 1234; (* for repeatablity *) + Random.self_init (); (* Random.init 1234; for repeatablity *) let effort, horizon, heur_adv_ratio = GDL.initialize_game state player game_descr startcl in (* TODO: handle timer (startclock) in Game.initialize_default*) @@ -490,6 +490,96 @@ output_string out_ch ("ERR internal error -- see server stdout\n") +let set_state_from_file fn = + Printf.printf "Loading file %s...\n%!" fn; + let f = open_in fn in + let s = ArenaParser.parse_game_state Lexer.lex (Lexing.from_channel f) in + Printf.printf "File %s loaded.\n%!" fn; + game_modified := true; + state := s; +;; + +let heur_val_white1 = ref "";; +let heur_val_black1 = ref "";; +let heur_val_white2 = ref "";; +let heur_val_black2 = ref "";; + +let heur_of_vals white_val black_val = + let real_expr_of_str s = + FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s) in + let white_heur = + real_expr_of_str ("("^white_val^") - ("^black_val^")") in + let black_heur = + real_expr_of_str ("("^black_val^") - ("^white_val^")") in + let heuristic = [|white_heur; black_heur|] in + Array.make (Array.length !state.Arena.game.Arena.graph) heuristic +;; + +let print_heur pl heur = + print_endline ("\nAll-Heuristics for player " ^ pl); + let print_heur_arr = Array.iteri (fun i heur -> + print_endline ("\n for player " ^ (string_of_int i)); + print_endline (" " ^ Formula.sprint_real heur);) in + Array.iteri (fun i harr -> + print_endline ("\nHeuristic for location " ^ (string_of_int i)); + print_heur_arr harr;) heur +;; + +let add_heur h1 factor h2 = + Array.mapi (fun i a -> Array.mapi (fun j p -> + Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1 +;; + +let run_test n depth1 depth2 = + let (horizon, heur_adv_ratio) = (Some 400, 2.0) in + let struc = !state.Arena.struc in + let game = !state.Arena.game in + let heur1 = + if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then + let dh = + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + add_heur dh 0.2 (Game.fluents_heuristic game) + else if (!heur_val_white1 = "FLUENT" || !heur_val_black1 = "FLUENT") then + Game.fluents_heuristic game + else if (!heur_val_white1 <> "" && !heur_val_black1 <> "") then + heur_of_vals !heur_val_white1 !heur_val_black1 + else + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + let heur2 = + if (!heur_val_white2 = "MIX" || !heur_val_black2 = "MIX") then + let dh = + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + add_heur dh 0.2 (Game.fluents_heuristic game) + else if (!heur_val_white2 = "FLUENT" || !heur_val_black2 = "FLUENT") then + Game.fluents_heuristic game + else if (!heur_val_white2 <> "" && !heur_val_black2 <> "") then + heur_of_vals !heur_val_white2 !heur_val_black2 + else + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2); + let play = {Game.game = game; agents= + [| Game.default_maximax !state.Arena.struc ~depth:depth1 + ~heuristic:heur1 ~heur_adv_ratio ~pruning:true game; + Game.default_maximax !state.Arena.struc ~depth:depth2 + ~heuristic:heur2 ~heur_adv_ratio ~pruning:true game; + |]; delta = 2.0} in (* FIXME: give/calc delta *) + let init_state = Game.initial_state play struc in + Game.set_debug_level 1; + let (aggr_payoff_w, aggr_payoff_b) = (ref 0., ref 0.) in + Printf.printf "Experiment -- running test!\n"; + for i = 1 to n do ( + Random.self_init (); + Printf.printf "Experiment: Game nr %d of %d\n%!" i n; + let _,payoff = Game.play ~grid_size:Game.cGRID_SIZE ~set_timer:3600 + ?horizon play init_state in + Printf.printf "Game %d payoffs %f, %f\n" i payoff.(0) payoff.(1); + aggr_payoff_w := !aggr_payoff_w +. payoff.(0); + aggr_payoff_b := !aggr_payoff_b +. payoff.(1); + Printf.printf "Aggregate payoffs %f, %f\n" !aggr_payoff_w !aggr_payoff_b; + ) done; +;; + + (* ----------------------- START SERVER WHEN CALLED ------------------------- *) let main () = @@ -498,6 +588,7 @@ Gc.minor_heap_size = 80*1024; (* 2*std, opt ~= L2 cache/proc *) Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) }; let (server, port) = (ref "localhost", ref 8110) in + let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in let opts = [ ("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose"); ("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose"); @@ -506,12 +597,27 @@ ("-gdl", Arg.String (fun s -> GDL.manual_game := s; GDL.manual_translation := true), " GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)"); + ("-f", Arg.String (fun s -> set_state_from_file s), " open file"); ("-nm", Arg.Unit (fun () -> Game.use_monotonic := false), " turn monotonicity off"); ("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)"); ("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)"); + ("-heur-white-1", Arg.String (fun s -> heur_val_white1 := s), + "white (=first) player heuristic for use by the first player in tests"); + ("-heur-black-1", Arg.String (fun s -> heur_val_black1 := s), + "black (=second) player heuristic for use by the first player in tests"); + ("-heur-white-2", Arg.String (fun s -> heur_val_white2 := s), + "white (=first) player heuristic for use by the second player in tests"); + ("-heur-black-2", Arg.String (fun s -> heur_val_black2 := s), + "black (=second) player heuristic for use by the second player in tests"); + ("-experiment", + Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i); + Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)], + "run experiment on the open file [i] times with depth [d1, d2]") ] in Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following."; - try + if !experiment then + run_test !e_len !e_d1 !e_d2 + else try start_server req_handle !port !server with Host_not_found -> print_endline "The host you specified was not found." ;; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-17 21:59:52
|
Revision: 1321 http://toss.svn.sourceforge.net/toss/?rev=1321&view=rev Author: lukaszkaiser Date: 2011-02-17 21:59:46 +0000 (Thu, 17 Feb 2011) Log Message: ----------- Change default heuristic to mix strength and the old default. Modified Paths: -------------- trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Server/Server.ml Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-13 23:17:36 UTC (rev 1320) +++ trunk/Toss/Play/Game.ml 2011-02-17 21:59:46 UTC (rev 1321) @@ -1,3 +1,4 @@ + (* -*- folded-file: t; -*- *) (* Game-related definitions. The UCTS algorithm. *) @@ -242,7 +243,7 @@ let default_adv_ratio = 2.0 -let default_heuristic ?struc advance_ratio +let default_heuristic_old ?struc advance_ratio {Arena.rules=rules; Arena.graph=graph} = (* TODO: cache the default heuristic in game definition or state *) let drules = @@ -310,6 +311,15 @@ Formula.Times (Formula.Const (-1.), sum_all))) sums in Array.map (fun _ -> heurs) game.Arena.graph + +let mix_heur h1 factor h2 = + Array.mapi (fun i a -> Array.mapi (fun j p -> + Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1 + +let default_heuristic ?struc advr g = + mix_heur (default_heuristic_old ?struc advr g) 0.2 (fluents_heuristic g) + + (* The UCB1-TUNED estimate, modified to extend to the zero- and one-observation cases. *) let ucb1_tuned ?(lower_bound=false) Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-13 23:17:36 UTC (rev 1320) +++ trunk/Toss/Play/Game.mli 2011-02-17 21:59:46 UTC (rev 1321) @@ -214,9 +214,15 @@ play -> play_state -> (move * play_state) option (** Various constructed heuristics. *) +val mix_heur : Formula.real_expr array array -> float -> + Formula.real_expr array array -> Formula.real_expr array array + val default_heuristic : ?struc:Structure.structure -> float -> Arena.game -> Formula.real_expr array array +val default_heuristic_old : ?struc:Structure.structure -> float -> + Arena.game -> Formula.real_expr array array + val fluents_heuristic : Arena.game -> Formula.real_expr array array Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-13 23:17:36 UTC (rev 1320) +++ trunk/Toss/Server/Server.ml 2011-02-17 21:59:46 UTC (rev 1321) @@ -525,37 +525,28 @@ print_heur_arr harr;) heur ;; -let add_heur h1 factor h2 = - Array.mapi (fun i a -> Array.mapi (fun j p -> - Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1 -;; - let run_test n depth1 depth2 = let (horizon, heur_adv_ratio) = (Some 400, 2.0) in let struc = !state.Arena.struc in let game = !state.Arena.game in let heur1 = if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then - let dh = - Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in - add_heur dh 0.2 (Game.fluents_heuristic game) + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game else if (!heur_val_white1 = "FLUENT" || !heur_val_black1 = "FLUENT") then Game.fluents_heuristic game else if (!heur_val_white1 <> "" && !heur_val_black1 <> "") then heur_of_vals !heur_val_white1 !heur_val_black1 else - Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + Game.default_heuristic_old ~struc:!state.Arena.struc heur_adv_ratio game in let heur2 = if (!heur_val_white2 = "MIX" || !heur_val_black2 = "MIX") then - let dh = - Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in - add_heur dh 0.2 (Game.fluents_heuristic game) + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game else if (!heur_val_white2 = "FLUENT" || !heur_val_black2 = "FLUENT") then Game.fluents_heuristic game else if (!heur_val_white2 <> "" && !heur_val_black2 <> "") then heur_of_vals !heur_val_white2 !heur_val_black2 else - Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + Game.default_heuristic_old ~struc:!state.Arena.struc heur_adv_ratio game in if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2); let play = {Game.game = game; agents= [| Game.default_maximax !state.Arena.struc ~depth:depth1 This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-19 16:03:38
|
Revision: 1322 http://toss.svn.sourceforge.net/toss/?rev=1322&view=rev Author: lukaszkaiser Date: 2011-02-19 16:03:31 +0000 (Sat, 19 Feb 2011) Log Message: ----------- Moving heuristic generation from Game to Heuristic ml. Modified Paths: -------------- trunk/Toss/GGP/GDL.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Heuristic.ml trunk/Toss/Play/Heuristic.mli trunk/Toss/Server/Server.ml Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/GGP/GDL.ml 2011-02-19 16:03:31 UTC (rev 1322) @@ -2671,7 +2671,7 @@ playing_as := player; game_description := game_descr; player_name_terms := [|Const "X"; Const "O"|]; - Game.use_monotonic := true; + Heuristic.use_monotonic := true; let effort, horizon, heur_adv_ratio = 4, 100, 4.0 in effort, horizon, heur_adv_ratio @@ -2681,7 +2681,7 @@ playing_as := player; game_description := game_descr; player_name_terms := [|Const "WHITE"; Const "RED"|]; - Game.use_monotonic := false; + Heuristic.use_monotonic := false; let effort, horizon, heur_adv_ratio = 10, 100, 4.0 in effort, horizon, heur_adv_ratio Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/Play/Game.ml 2011-02-19 16:03:31 UTC (rev 1322) @@ -1,5 +1,3 @@ - -(* -*- folded-file: t; -*- *) (* Game-related definitions. The UCTS algorithm. *) open Printf @@ -12,7 +10,6 @@ let set_debug_level i = (debug_level := i) let deterministic_suggest = ref false -let use_monotonic = ref true (* A global "hurry up!" switch triggered by the timer alarm. *) let timeout = ref false @@ -242,84 +239,8 @@ let default_adv_ratio = 2.0 +let default_heuristic = Heuristic.default_heuristic -let default_heuristic_old ?struc advance_ratio - {Arena.rules=rules; Arena.graph=graph} = - (* TODO: cache the default heuristic in game definition or state *) - let drules = - List.map (fun r -> (snd r).ContinuousRule.compiled) rules in - let fluents = Aux.concat_map DiscreteRule.fluents drules in - let frels = Aux.strings_of_list fluents in - let monotonic = !use_monotonic && - List.for_all DiscreteRule.monotonic drules in - let signat_struc = - match struc with Some struc -> struc - | None -> - (snd (List.hd - rules)).ContinuousRule.discrete.DiscreteRule.rhs_struc in - let signat rel = - Structure.StringMap.find rel signat_struc.Structure.rel_signature in - let fluent_preconds = - if monotonic then - Some (DiscreteRule.fluent_preconds drules signat fluents) - else None in - Array.mapi (fun i node -> Array.map - (fun payoff -> - (* {{{ log entry *) - if !debug_level > (* 5 *) 1 then ( - Printf.printf - "default_heuristic: Computing for loc %d of payoff %s...\n%!" - i (Formula.sprint_real payoff); - ); - if !debug_level = 5 then ( - Printf.printf - "default_heuristic: Computing for loc %d\n%!" i; - ); - (* }}} *) - let res = - Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio - frels payoff in - (* {{{ log entry *) - if !debug_level > (* 6 *) 1 then ( - Printf.printf "default_heuristic: %s\n%!" - (Formula.sprint_real res) - ); - (* }}} *) - res) - node.Arena.payoffs) graph - -let fluents_heuristic game = - let (no_players, rules) = (game.Arena.num_players, game.Arena.rules) in - let pl_rules = Array.mapi - (fun i _ -> Arena.rules_for_player i game) (Array.create no_players 1) in - let pos_fluents_of_rule rname = - let drule = (List.assoc rname rules).ContinuousRule.compiled in - let list_upto_one s i = - let vx = Formula.fo_var_of_string "x" in - if i = 0 then Formula.Const (0.) else if i = 1 then - Formula.Sum ([vx], Formula.Rel (s, [|vx|]), Formula.Const (1.)) - else Formula.Const (0.) in - DiscreteRule.fluents_make ~only_pos:true list_upto_one drule in - let pl_fluents = Array.map (Aux.concat_map pos_fluents_of_rule) pl_rules in - let sums = Array.map (fun fl -> - List.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) - (Aux.unique_sorted fl)) pl_fluents in - let sum_all = - Array.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) sums in - let heurs = Array.map (fun f -> - Formula.Plus (Formula.Times (Formula.Const (2.), f), - Formula.Times (Formula.Const (-1.), sum_all))) sums in - Array.map (fun _ -> heurs) game.Arena.graph - - -let mix_heur h1 factor h2 = - Array.mapi (fun i a -> Array.mapi (fun j p -> - Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1 - -let default_heuristic ?struc advr g = - mix_heur (default_heuristic_old ?struc advr g) 0.2 (fluents_heuristic g) - - (* The UCB1-TUNED estimate, modified to extend to the zero- and one-observation cases. *) let ucb1_tuned ?(lower_bound=false) Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/Play/Game.mli 2011-02-19 16:03:31 UTC (rev 1322) @@ -4,7 +4,6 @@ (** A global "hurry up!" switch triggered by the timer alarm. *) val get_timeout : unit -> bool val cancel_timeout : unit -> unit -val use_monotonic : bool ref (** History stored for a play, including caching of computations for further use. *) @@ -213,19 +212,7 @@ val suggest : ?effort:int -> play -> play_state -> (move * play_state) option -(** Various constructed heuristics. *) -val mix_heur : Formula.real_expr array array -> float -> - Formula.real_expr array array -> Formula.real_expr array array -val default_heuristic : ?struc:Structure.structure -> float -> - Arena.game -> Formula.real_expr array array - -val default_heuristic_old : ?struc:Structure.structure -> float -> - Arena.game -> Formula.real_expr array array - -val fluents_heuristic : Arena.game -> Formula.real_expr array array - - (* ------------------------- DEBUGGING ------------------------------------- *) (** Debugging information. At level 0 nothing is printed out. Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/Play/GameTest.ml 2011-02-19 16:03:31 UTC (rev 1322) @@ -850,10 +850,10 @@ P Q Q +Q . . . \" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in - Game.use_monotonic := false; + Heuristic.use_monotonic := false; easy_case state 0 "should attack" (fun mov_s -> "Cross{1:a4}" = mov_s); - Game.use_monotonic := true; + Heuristic.use_monotonic := true; ); "connect4 avoid losing" >:: @@ -874,10 +874,10 @@ ... Q..P P..P Q.. \" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in - Game.use_monotonic := false; + Heuristic.use_monotonic := false; hard_case state 0 "should not attack" (fun mov_s -> "Cross{1:f3}" <> mov_s); - Game.use_monotonic := true; + Heuristic.use_monotonic := true; ); @@ -899,10 +899,10 @@ P P P Q Q . . \" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ; DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in - Game.use_monotonic := false; + Heuristic.use_monotonic := false; hard_case state 0 "should defend" (fun mov_s -> "Cross{1:e2}" = mov_s); - Game.use_monotonic := true + Heuristic.use_monotonic := true ); @@ -966,7 +966,7 @@ let a () = Game.set_debug_level 10 -let a () = Game.use_monotonic := false +let a () = Heuristic.use_monotonic := false let a () = match test_filter Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/Play/Heuristic.ml 2011-02-19 16:03:31 UTC (rev 1322) @@ -949,3 +949,83 @@ Printf.printf "Heuristic.of_payoff %s =\n%s\n%!" (real_str expr) (real_str res); res + + +(* ------------ HEURISTICS FINAL GENERATION ------------- *) + +let use_monotonic = ref true + +let default_heuristic_old ?struc advance_ratio + {Arena.rules=rules; Arena.graph=graph} = + (* TODO: cache the default heuristic in game definition or state *) + let drules = + List.map (fun r -> (snd r).ContinuousRule.compiled) rules in + let fluents = Aux.concat_map DiscreteRule.fluents drules in + let frels = Aux.strings_of_list fluents in + let monotonic = !use_monotonic && + List.for_all DiscreteRule.monotonic drules in + let signat_struc = + match struc with Some struc -> struc + | None -> + (snd (List.hd + rules)).ContinuousRule.discrete.DiscreteRule.rhs_struc in + let signat rel = + Structure.StringMap.find rel signat_struc.Structure.rel_signature in + let fluent_preconds = + if monotonic then + Some (DiscreteRule.fluent_preconds drules signat fluents) + else None in + Array.mapi (fun i node -> Array.map + (fun payoff -> + (* {{{ log entry *) + if !debug_level > (* 5 *) 1 then ( + Printf.printf + "default_heuristic: Computing for loc %d of payoff %s...\n%!" + i (Formula.sprint_real payoff); + ); + if !debug_level = 5 then ( + Printf.printf + "default_heuristic: Computing for loc %d\n%!" i; + ); + (* }}} *) + let res = + of_payoff ?struc ?fluent_preconds advance_ratio frels payoff in + (* {{{ log entry *) + if !debug_level > (* 6 *) 1 then ( + Printf.printf "default_heuristic: %s\n%!" + (Formula.sprint_real res) + ); + (* }}} *) + res) + node.Arena.payoffs) graph + +let fluents_heuristic game = + let (no_players, rules) = (game.Arena.num_players, game.Arena.rules) in + let pl_rules = Array.mapi + (fun i _ -> Arena.rules_for_player i game) (Array.create no_players 1) in + let pos_fluents_of_rule rname = + let drule = (List.assoc rname rules).ContinuousRule.compiled in + let list_upto_one s i = + let vx = Formula.fo_var_of_string "x" in + if i = 0 then Formula.Const (0.) else if i = 1 then + Formula.Sum ([vx], Formula.Rel (s, [|vx|]), Formula.Const (1.)) + else Formula.Const (0.) in + DiscreteRule.fluents_make ~only_pos:true list_upto_one drule in + let pl_fluents = Array.map (Aux.concat_map pos_fluents_of_rule) pl_rules in + let sums = Array.map (fun fl -> + List.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) + (Aux.unique_sorted fl)) pl_fluents in + let sum_all = + Array.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) sums in + let heurs = Array.map (fun f -> + Formula.Plus (Formula.Times (Formula.Const (2.), f), + Formula.Times (Formula.Const (-1.), sum_all))) sums in + Array.map (fun _ -> heurs) game.Arena.graph + + +let mix_heur h1 factor h2 = + Array.mapi (fun i a -> Array.mapi (fun j p -> + Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1 + +let default_heuristic ?struc advr g = + mix_heur (default_heuristic_old ?struc advr g) 0.2 (fluents_heuristic g) Modified: trunk/Toss/Play/Heuristic.mli =================================================================== --- trunk/Toss/Play/Heuristic.mli 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/Play/Heuristic.mli 2011-02-19 16:03:31 UTC (rev 1322) @@ -1,3 +1,5 @@ +val use_monotonic : bool ref + (** Generate a heuristic from a payoff. Input: a set of relations F whose instances can be altered duirng a @@ -90,3 +92,16 @@ (** Rewrite numeric constants inside an expression. *) val map_constants : (float -> float) -> Formula.real_expr -> Formula.real_expr + + +(** Various constructed heuristics. *) +val mix_heur : Formula.real_expr array array -> float -> + Formula.real_expr array array -> Formula.real_expr array array + +val default_heuristic : ?struc:Structure.structure -> float -> + Arena.game -> Formula.real_expr array array + +val default_heuristic_old : ?struc:Structure.structure -> float -> + Arena.game -> Formula.real_expr array array + +val fluents_heuristic : Arena.game -> Formula.real_expr array array Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-17 21:59:46 UTC (rev 1321) +++ trunk/Toss/Server/Server.ml 2011-02-19 16:03:31 UTC (rev 1322) @@ -531,22 +531,22 @@ let game = !state.Arena.game in let heur1 = if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then - Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game + Heuristic.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game else if (!heur_val_white1 = "FLUENT" || !heur_val_black1 = "FLUENT") then - Game.fluents_heuristic game + Heuristic.fluents_heuristic game else if (!heur_val_white1 <> "" && !heur_val_black1 <> "") then heur_of_vals !heur_val_white1 !heur_val_black1 else - Game.default_heuristic_old ~struc:!state.Arena.struc heur_adv_ratio game in + Heuristic.default_heuristic_old ~struc:!state.Arena.struc heur_adv_ratio game in let heur2 = if (!heur_val_white2 = "MIX" || !heur_val_black2 = "MIX") then - Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game + Heuristic.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game else if (!heur_val_white2 = "FLUENT" || !heur_val_black2 = "FLUENT") then - Game.fluents_heuristic game + Heuristic.fluents_heuristic game else if (!heur_val_white2 <> "" && !heur_val_black2 <> "") then heur_of_vals !heur_val_white2 !heur_val_black2 else - Game.default_heuristic_old ~struc:!state.Arena.struc heur_adv_ratio game in + Heuristic.default_heuristic_old ~struc:!state.Arena.struc heur_adv_ratio game in if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2); let play = {Game.game = game; agents= [| Game.default_maximax !state.Arena.struc ~depth:depth1 @@ -589,7 +589,7 @@ GDL.manual_game := s; GDL.manual_translation := true), " GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)"); ("-f", Arg.String (fun s -> set_state_from_file s), " open file"); - ("-nm", Arg.Unit (fun () -> Game.use_monotonic := false), " turn monotonicity off"); + ("-nm", Arg.Unit (fun () -> Heuristic.use_monotonic := false), " turn monotonicity off"); ("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)"); ("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)"); ("-heur-white-1", Arg.String (fun s -> heur_val_white1 := s), This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-19 17:22:47
|
Revision: 1323 http://toss.svn.sourceforge.net/toss/?rev=1323&view=rev Author: lukaszkaiser Date: 2011-02-19 17:22:41 +0000 (Sat, 19 Feb 2011) Log Message: ----------- Separate small file for move handling in Play. Modified Paths: -------------- trunk/Toss/Makefile trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Makefile trunk/Toss/Server/Server.ml trunk/Toss/TossTest.ml Added Paths: ----------- trunk/Toss/Play/Move.ml trunk/Toss/Play/Move.mli trunk/Toss/Play/MoveTest.ml Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/Makefile 2011-02-19 17:22:41 UTC (rev 1323) @@ -119,6 +119,7 @@ # Play tests Play_tests: \ Play/HeuristicTest \ + Play/MoveTest \ Play/GameTest # GGP tests Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/Play/Game.ml 2011-02-19 17:22:41 UTC (rev 1323) @@ -2,10 +2,6 @@ open Printf -(* TODO: Sampling grid size fixed until doing more work with - continuous games. *) -let cGRID_SIZE = 5 - let debug_level = ref 0 let set_debug_level i = (debug_level := i) @@ -36,7 +32,6 @@ Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> timeout := true)) - type f_table = float array (* Cumulative score of players for computing value estimate. *) @@ -65,16 +60,6 @@ Array.map (fun payoff -> (0.5 +. 1./.((float_of_int n) +. 2.)) *. payoff) payoffs -(* Data to return a move as a suggestion rather than directly - following it. *) -type move = { - mv_time : float ; - parameters : (string * float) list ; - rule : string ; - next_loc : int ; (* next location in the arena *) - embedding : (int * int) list ; -} - (* Analogous to {!Arena.game_state}, but without the game component. *) type game_state = { struc : Structure.structure ; (* structure state *) @@ -82,6 +67,11 @@ loc : int ; (* positin in the game graph *) } +let gen_models rules models time moves = + let (mv, a) = Move.gen_models rules models time moves in + (mv, Array.map (fun (l, m, t) -> {struc=m; time=t; loc=l}) a) + + type uctree_node = { node_state : game_state ; node_stats : score ; (* playout statistic *) @@ -208,25 +198,7 @@ delta : float ; (* expected width of payoffs *) } -(* 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 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 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 move_gs_str game_state move = - move_str game_state.Arena.game.Arena.rules game_state.Arena.struc move - let default_params = { cUCB = 1.0 ; cLCB = Some 1.0 ; @@ -533,65 +505,6 @@ randbest else bestsc_table, randbest -let gen_moves grid_size rules model loc = - let matchings = - Aux.concat_map - (fun (label,next_loc) -> - let rule = List.assoc label.Arena.rule rules in - List.map (fun emb -> label,next_loc,emb) - (ContinuousRule.matches model rule)) - loc.Arena.moves in - if matchings = [] then [| |] - else ( - (* generating the grid *) - Array.concat - (List.map (fun (label,next_loc,emb) -> - (* not searching through time *) - let t_l, t_r = label.Arena.time_in in - let t = (t_r +. t_l) /. 2. in - if label.Arena.parameters_in = [] then - [| { - mv_time = t; - parameters = []; - rule = label.Arena.rule; - next_loc = next_loc; - embedding = emb - } |] - else - let param_names, params_in = - List.split label.Arena.parameters_in in - let axes = List.map (fun (f_l,f_r) -> - if grid_size < 2 then - [(f_r +. f_l) /. 2.] - else - let df = (f_r -. f_l) /. float_of_int (grid_size - 1) in - Array.to_list - (Array.init grid_size - (fun i -> f_l +. float_of_int i *. df)) - ) params_in in - let grid = Aux.product axes in - Aux.array_map_of_list (fun params -> { - mv_time = t; - parameters = List.combine param_names params; - rule = label.Arena.rule; - next_loc = next_loc; - embedding = emb} - ) grid - ) matchings)) - -let gen_models rules defined_rels model time moves = - let res = - Aux.map_some (fun mv -> - let rule = List.assoc mv.rule rules in - Aux.map_option - (fun (model, time, _) -> - (* ignoring shifts, i.e. animation steps *) - mv, {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) in - let moves, models = List.split res in - Array.of_list moves, Array.of_list models - let debug_count = ref 0 (* Generate evaluation game score (the whole payoff table). *) @@ -615,7 +528,7 @@ and gen_scores grid_size subgames moves models loc = Array.mapi (fun pos mv -> let {struc=model; time=time} = models.(pos) in - play_evgame grid_size model time subgames.(mv.next_loc) + play_evgame grid_size model time subgames.(mv.Move.next_loc) ) moves @@ -635,7 +548,7 @@ let loc = graph.(state.loc) in let moves = if just_payoffs then [| |] - else gen_moves grid_size rules state.struc loc in + else Move.gen_moves grid_size rules state.struc loc in (* Don't forget to check after generating models as well -- postconditions! *) if moves = [| |] then @@ -657,14 +570,14 @@ let nstate = ref None in while !nstate = None && (!pos <> init_pos || !pos < mlen) do let mv = moves.(!pos mod mlen) in - let rule = List.assoc mv.rule rules in + let rule = List.assoc mv.Move.rule rules in nstate := Aux.map_option (fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *) - {loc=mv.next_loc; struc=model; time=time}) + {loc=mv.Move.next_loc; struc=model; time=time}) (ContinuousRule.rewrite_single state.struc state.time - mv.embedding rule mv.mv_time mv.parameters); + mv.Move.embedding rule mv.Move.mv_time mv.Move.parameters); incr pos done; (match !nstate with @@ -731,7 +644,7 @@ ) else let location = graph.(loc) in let moves = - gen_moves grid_size rules model location in + Move.gen_moves grid_size rules model location in if moves = [| |] then (* terminal position *) let res = (* *) @@ -753,8 +666,7 @@ else if !timeout then Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs else - let moves, models = - gen_models rules defined_rels model time moves in + let moves, models = gen_models rules model time moves in let n = Array.length models in if !timeout then Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs @@ -835,8 +747,7 @@ aux alphas 0 in let betas = Array.make num_players infinity in let player = loc.Arena.player in - let moves, models = - gen_models rules defined_rels state.struc state.time moves in + let moves, models = gen_models rules state.struc state.time moves in if models = [| |] then let payoff = Array.map (fun expr -> @@ -982,8 +893,7 @@ (* {{{ log entry *) if !debug_level > 3 then printf "toss: external\n"; (* }}} *) - let moves, models = - gen_models rules defined_rels state.struc state.time moves in + let moves, models = gen_models rules state.struc state.time moves in if models = [| |] then let payoff = Array.map (fun expr -> @@ -1127,7 +1037,7 @@ state ?score subgames evgame_horizon heur_effect heuristic horizon cooperative player = let location = graph.(state.loc) in - let moves = gen_moves grid_size rules state.struc location in + let moves = Move.gen_moves grid_size rules state.struc location in if moves = [| |] then let payoff = Array.map (fun expr -> @@ -1137,8 +1047,7 @@ upscore, Terminal (state, upscore, heuristic, payoff) else - let moves, models = - gen_models rules defined_rels state.struc state.time moves in + let moves, models = gen_models rules state.struc state.time moves in if models = [| |] then let payoff = Array.map (fun expr -> @@ -1336,7 +1245,7 @@ if !debug_level > 2 then printf "\nsuggest:\n%!"; (* }}} *) (match - toss ~grid_size:cGRID_SIZE play play_state + toss ~grid_size:Move.cGRID_SIZE play play_state with | Aux.Left (bpos, moves, memory, _) -> (* [suggest] does not update the state, rule application Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/Play/Game.mli 2011-02-19 17:22:41 UTC (rev 1323) @@ -110,22 +110,6 @@ {!Arena.game}. *) val initial_state : ?loc:int -> play -> Structure.structure -> play_state -(** Data to return a move as a suggestion rather than directly - following it. *) -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_state -> move -> string - val default_params : uct_params (** An UCT-based agent that uses either random playouts (when @@ -147,16 +131,6 @@ Arena.game -> agent -(** Default number of sample points per parameter in tree - search. TODO: fixed for now. *) -val cGRID_SIZE : int - -(** Generate moves available from a state, as an array ordered - deterministically. *) -val gen_moves : - int -> (string * ContinuousRule.rule) list -> - Structure.structure -> Arena.location -> move array - (** Update "memory" assuming that the position given corresponds to a move selected, as generated by {!gen_moves}. With tree search, selects the corresponding subtree of a tree. *) @@ -174,7 +148,7 @@ val toss : grid_size:int -> ?just_payoffs:bool -> play -> play_state -> - (int * move array * memory array * play_state, + (int * Move.move array * memory array * play_state, float array) Aux.choice (** Play a play, by applying {!toss}, till the end. Return the final @@ -210,7 +184,7 @@ state but with accrued computation (i.e. bigger stored search trees). *) val suggest : ?effort:int -> - play -> play_state -> (move * play_state) option + play -> play_state -> (Move.move * play_state) option (* ------------------------- DEBUGGING ------------------------------------- *) Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/Play/GameTest.ml 2011-02-19 17:22:41 UTC (rev 1323) @@ -42,20 +42,9 @@ module StrMap = Structure.StringMap module IntMap = Structure.IntMap -(* Like {!Game.move_str}, but simplified (less data, shorter form). *) -let move_str rules struc move = - (* let r = List.assoc move.Game.rule rules in *) - (* let rhs_struc = r.ContinuousRule.discrete.DiscreteRule.rhs_struc in *) - let p_name (r, e) = - (* Structure.elem_str rhs_struc r *) - string_of_int r ^ ":" ^ Structure.elem_str struc e in - let emb = String.concat ", " - (List.map p_name (List.sort Pervasives.compare move.Game.embedding)) in - move.Game.rule ^ "{" ^ emb ^ "}" +let move_str r s m = Move.move_str_short s m +let move_gs_str = Move.move_gs_str_short -let move_gs_str state move = - move_str state.Arena.game.Arena.rules state.Arena.struc move - let update_game ?(defs=false) (lazy (horizon, adv_ratio, game)) state cur_loc = let state = @@ -311,7 +300,7 @@ delta = 2.0} in (* FIXME: give/calc delta *) let init_state = Game.initial_state play struc in (* let endstate,payoff = *) - ignore (Game.play ~grid_size:Game.cGRID_SIZE + ignore (Game.play ~grid_size:Move.cGRID_SIZE ~set_timer:360 ~horizon:30 play init_state) (* in *) (* nothing to assert -- just check halting without exceptions *) (* @@ -348,7 +337,7 @@ ~loc:0 ~effort:2 ~heuristic:breakthrough_heur ~search_method:"alpha_beta_ord" () in - Game.toss ~grid_size:Game.cGRID_SIZE p ps) in + Game.toss ~grid_size:Move.cGRID_SIZE p ps) in assert_equal ~msg:"black wins: suggest" ~printer:(function | Aux.Left (bpos, moves, _, _) -> "game not over: "^move_gs_str state moves.(bpos) @@ -409,7 +398,7 @@ ~heur_adv_ratio ?horizon ~loc:0 ~effort:1 ~search_method:"alpha_beta_ord" () in - Game.toss ~grid_size:Game.cGRID_SIZE p ps) in + Game.toss ~grid_size:Move.cGRID_SIZE p ps) in assert_equal ~msg:"draw (white no move): suggest" ~printer:(function | Aux.Left (bpos, moves, _, _) -> "game not over: "^move_gs_str state moves.(bpos) @@ -943,7 +932,7 @@ for i = 1 to n do Printf.printf "Experiment: Game nr %d of %d\n%!" i n; let _,payoff = - Game.play ~grid_size:Game.cGRID_SIZE ~set_timer:3600 + Game.play ~grid_size:Move.cGRID_SIZE ~set_timer:3600 ?horizon play init_state in if payoff.(0) > 0.0 then incr winsW; if payoff.(1) > 0.0 then incr winsB; Modified: trunk/Toss/Play/Makefile =================================================================== --- trunk/Toss/Play/Makefile 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/Play/Makefile 2011-02-19 17:22:41 UTC (rev 1323) @@ -10,12 +10,15 @@ make -C .. Play/$@ HeuristicTest: +MoveTest: GameTest: HeuristicTestProfile: +MoveTestProfile: GameTestProfile: HeuristicTestDebug: +MoveTestDebug: GameTestDebug: tests: Added: trunk/Toss/Play/Move.ml =================================================================== --- trunk/Toss/Play/Move.ml (rev 0) +++ trunk/Toss/Play/Move.ml 2011-02-19 17:22:41 UTC (rev 1323) @@ -0,0 +1,108 @@ +(* Move definition, generation and helper functions. *) + + +(* TODO: Sampling grid size fixed until doing more with continuous games. *) +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 ; +} + + +(* 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 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 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 move_gs_str game_state move = + move_str game_state.Arena.game.Arena.rules game_state.Arena.struc move + + +(* Like move_str but simplified (less data, shorter form). *) +let move_str_short struc move = + 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 ^ "}" + +let move_gs_str_short state move = move_str_short state.Arena.struc move + + +(* Generate moves available from a state, as an array, in fixed order. *) +let gen_moves grid_size rules model loc = + let matchings = + Aux.concat_map + (fun (label,next_loc) -> + let rule = List.assoc label.Arena.rule rules in + List.map (fun emb -> label,next_loc,emb) + (ContinuousRule.matches model rule)) + loc.Arena.moves in + if matchings = [] then [| |] + else ( + (* generating the grid *) + Array.concat + (List.map (fun (label,next_loc,emb) -> + (* not searching through time *) + let t_l, t_r = label.Arena.time_in in + let t = (t_r +. t_l) /. 2. in + if label.Arena.parameters_in = [] then + [| { + mv_time = t; + parameters = []; + rule = label.Arena.rule; + next_loc = next_loc; + embedding = emb + } |] + else + let param_names, params_in = + List.split label.Arena.parameters_in in + let axes = List.map (fun (f_l,f_r) -> + if grid_size < 2 then + [(f_r +. f_l) /. 2.] + else + let df = (f_r -. f_l) /. float_of_int (grid_size - 1) in + Array.to_list + (Array.init grid_size + (fun i -> f_l +. float_of_int i *. df)) + ) params_in in + let grid = Aux.product axes in + Aux.array_map_of_list (fun params -> { + mv_time = t; + parameters = List.combine param_names params; + rule = label.Arena.rule; + next_loc = next_loc; + embedding = emb} + ) grid + ) matchings)) + + + +let gen_models rules model time moves = + let res = + Aux.map_some (fun mv -> + let rule = List.assoc mv.rule rules in + Aux.map_option + (fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *) + (mv, (mv.next_loc, model, time))) + (ContinuousRule.rewrite_single model time mv.embedding + rule mv.mv_time mv.parameters)) (Array.to_list moves) in + let moves, models = List.split res in + Array.of_list moves, Array.of_list models + Added: trunk/Toss/Play/Move.mli =================================================================== --- trunk/Toss/Play/Move.mli (rev 0) +++ trunk/Toss/Play/Move.mli 2011-02-19 17:22:41 UTC (rev 1323) @@ -0,0 +1,30 @@ +(** 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_state -> move -> string + +val move_str_short : Structure.structure -> move -> string +val move_gs_str_short : Arena.game_state -> move -> string + + + +(** Default number of sample points per parameter in tree search. + TODO: fixed for now. *) +val cGRID_SIZE : int + +(** Generate moves available from a state, as an array, in fixed order. *) +val gen_moves : int -> (string * ContinuousRule.rule) list -> + Structure.structure -> Arena.location -> move array + +val gen_models : (string * ContinuousRule.rule) list -> Structure.structure -> + float -> move array -> move array * (int * Structure.structure * float) array Added: trunk/Toss/Play/MoveTest.ml =================================================================== --- trunk/Toss/Play/MoveTest.ml (rev 0) +++ trunk/Toss/Play/MoveTest.ml 2011-02-19 17:22:41 UTC (rev 1323) @@ -0,0 +1,21 @@ +open OUnit + +let tests = "Move" >::: [ + "move to string" >:: + (fun () -> + let mv = { + Move.mv_time = 0.; + Move.parameters = []; + Move.rule = "rule"; + Move.next_loc = 1; + Move.embedding = [(1, 1)]; + } in + let s = Structure.empty_structure () in + assert_equal ~printer:(fun x -> x) (Move.move_str_short s mv) + "rule{1:1}" + ); +] ;; + +let a = + Aux.run_test_if_target "MoveTest" tests +;; Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/Server/Server.ml 2011-02-19 17:22:41 UTC (rev 1323) @@ -185,7 +185,7 @@ match res with | Some (move, new_state) -> play_state := Some new_state; - Game.move_gs_str !state move + Move.move_gs_str !state move | None -> "None" ) @@ -205,23 +205,23 @@ let m = List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in let moves = - Game.gen_moves Game.cGRID_SIZE rules + Move.gen_moves Move.cGRID_SIZE rules !state.Arena.struc graph.(!state.Arena.cur_loc) in try for i = 0 to Array.length moves - 1 do (* FIXME: handle time and params! *) let mov = moves.(i) in if - r_name = mov.Game.rule && + r_name = mov.Move.rule && (* t = mov.Game.time && *) (* something wrong with this: List.for_all (fun (pn, pv) -> pv = List.assoc pn mov.Game.parameters) p && *) List.for_all (fun (e, f) -> - f = List.assoc e mov.Game.embedding) m + f = List.assoc e mov.Move.embedding) m (* TODO: handle location matching *) then ( - expected_location := mov.Game.next_loc; + expected_location := mov.Move.next_loc; let _ = if !debug_level > 2 then Printf.printf "expected_location = %d\n%!" !expected_location in @@ -247,10 +247,10 @@ | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) state := - {new_state with Arena.cur_loc = moves.(pos).Game.next_loc}; + {new_state with Arena.cur_loc = moves.(pos).Move.next_loc}; let new_game_state = { Game.struc = new_state.Arena.struc; - loc = moves.(pos).Game.next_loc; + loc = moves.(pos).Move.next_loc; time = new_state.Arena.time; } in play_state := Some { @@ -300,7 +300,7 @@ let m = List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in let moves = - Game.gen_moves Game.cGRID_SIZE rules + Move.gen_moves Move.cGRID_SIZE rules !state.Arena.struc graph.(!state.Arena.cur_loc) in let pos = (try @@ -310,20 +310,20 @@ (* {{{ log entry *) if !debug_level > 3 then ( Printf.printf "GDL: for %s considering move %s\n%!" - r_name (Game.move_gs_str !state mov) + r_name (Move.move_gs_str !state mov) ); (* }}} *) if - r_name = mov.Game.rule && + r_name = mov.Move.rule && (* t = mov.Game.time && *) (* something wrong with this: List.for_all (fun (pn, pv) -> pv = List.assoc pn mov.Game.parameters) p && *) List.for_all (fun (e, f) -> - f = List.assoc e mov.Game.embedding) m + f = List.assoc e mov.Move.embedding) m (* TODO: handle location matching *) then ( - expected_location := mov.Game.next_loc; + expected_location := mov.Move.next_loc; let _ = if !debug_level > 2 then Printf.printf "expected_location = %d\n%!" !expected_location in @@ -348,10 +348,10 @@ | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) state := - {new_state with Arena.cur_loc = moves.(pos).Game.next_loc}; + {new_state with Arena.cur_loc = moves.(pos).Move.next_loc}; let new_game_state = { Game.struc = new_state.Arena.struc; - loc = moves.(pos).Game.next_loc; + loc = moves.(pos).Move.next_loc; time = new_state.Arena.time; } in play_state := Some { @@ -374,7 +374,7 @@ match res with | Some (move, new_state) -> (* Do not change state yet! *) - GDL.translate_move move.Game.rule move.Game.embedding + GDL.translate_move move.Move.rule move.Move.embedding !state | None -> "NOOP" in let msg_len = String.length mov_msg in @@ -401,7 +401,7 @@ let m = List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in let moves = - Game.gen_moves Game.cGRID_SIZE rules + Move.gen_moves Move.cGRID_SIZE rules !state.Arena.struc graph.(!state.Arena.cur_loc) in let pos = (try @@ -411,20 +411,20 @@ (* {{{ log entry *) if !debug_level > 3 then ( Printf.printf "GDL: for %s considering move %s\n%!" - r_name (Game.move_gs_str !state mov) + r_name (Move.move_gs_str !state mov) ); (* }}} *) if - r_name = mov.Game.rule && + r_name = mov.Move.rule && (* t = mov.Game.time && *) (* something wrong with this: List.for_all (fun (pn, pv) -> pv = List.assoc pn mov.Game.parameters) p && *) List.for_all (fun (e, f) -> - f = List.assoc e mov.Game.embedding) m + f = List.assoc e mov.Move.embedding) m (* TODO: handle location matching *) then ( - expected_location := mov.Game.next_loc; + expected_location := mov.Move.next_loc; let _ = if !debug_level > 2 then Printf.printf "expected_location = %d\n%!" !expected_location in @@ -449,10 +449,10 @@ | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) state := - {new_state with Arena.cur_loc = moves.(pos).Game.next_loc}; + {new_state with Arena.cur_loc = moves.(pos).Move.next_loc}; let new_game_state = { Game.struc = new_state.Arena.struc; - loc = moves.(pos).Game.next_loc; + loc = moves.(pos).Move.next_loc; time = new_state.Arena.time; } in play_state := Some { @@ -561,7 +561,7 @@ for i = 1 to n do ( Random.self_init (); Printf.printf "Experiment: Game nr %d of %d\n%!" i n; - let _,payoff = Game.play ~grid_size:Game.cGRID_SIZE ~set_timer:3600 + let _,payoff = Game.play ~grid_size:Move.cGRID_SIZE ~set_timer:3600 ?horizon play init_state in Printf.printf "Game %d payoffs %f, %f\n" i payoff.(0) payoff.(1); aggr_payoff_w := !aggr_payoff_w +. payoff.(0); Modified: trunk/Toss/TossTest.ml =================================================================== --- trunk/Toss/TossTest.ml 2011-02-19 16:03:31 UTC (rev 1322) +++ trunk/Toss/TossTest.ml 2011-02-19 17:22:41 UTC (rev 1323) @@ -22,6 +22,7 @@ let play_tests = "Play" >::: [ HeuristicTest.tests; + MoveTest.tests; GameTest.tests; ] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-22 01:08:55
|
Revision: 1324 http://toss.svn.sourceforge.net/toss/?rev=1324&view=rev Author: lukstafi Date: 2011-02-22 01:08:46 +0000 (Tue, 22 Feb 2011) Log Message: ----------- GDL translation related major commit. Heuristic adv-ratio separate monotonic and non-monotonic defaults, default effort parameter. All-upper/all-lower case insensitive KIF keywords. List-related helper functions. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/Arena.mli trunk/Toss/Arena/DiscreteRule.ml trunk/Toss/Arena/DiscreteRule.mli 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/GDLTest.ml trunk/Toss/GGP/KIFLexer.mll trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Heuristic.ml trunk/Toss/Play/Heuristic.mli trunk/Toss/Server/Server.ml trunk/Toss/Server/ServerTest.ml trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/Solver.mli Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Arena/Arena.ml 2011-02-22 01:08:46 UTC (rev 1324) @@ -473,6 +473,8 @@ | GetRuleMatches of string (* Get matches of a rule *) | ApplyRule of string * (string * string) list * float * (string * float) list (* Apply rule at match for given time and with params *) + | ApplyRuleInt of string * (int * int) list * float * (string * float) list + (* Apply rule at match for given time and with params *) | GetRuleNames (* Get names of all rules *) | SetTime of float * float (* Set time step and time *) | GetTime (* Get time step and time *) @@ -858,6 +860,19 @@ | None -> (state, "ERR applying "^r_name^", postcondition fails") with Not_found -> (state, "ERR applying "^r_name^", rule not found") ) + | ApplyRuleInt (r_name, mtch, t, p) -> + (let try r = List.assoc r_name state.game.rules in + match ContinuousRule.rewrite_single struc state.time mtch r t p with + | Some (new_struc, new_time, shifts) -> + let val_str ((f, e), tl) = + let ts t = string_of_float (Term.term_val t) in + (* we've moved to using element names in Term *) + f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in + let shifts_s = String.concat "; " (List.map val_str shifts) in + ({state with struc = new_struc; time = new_time}, shifts_s) + | None -> (state, "ERR applying "^r_name^", postcondition fails") + with Not_found -> (state, "ERR applying "^r_name^", rule not found") + ) | GetRuleNames -> (state, String.concat "; " (fst (List.split state.game.rules))) | SetTime (tstep, t) -> ContinuousRule.set_time_step tstep; Modified: trunk/Toss/Arena/Arena.mli =================================================================== --- trunk/Toss/Arena/Arena.mli 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Arena/Arena.mli 2011-02-22 01:08:46 UTC (rev 1324) @@ -174,6 +174,7 @@ | GetRuleMatches of string (** Get matches of a rule *) | ApplyRule of string * (string * string) list * float * (string * float) list (** Apply rule at match for given time and with params *) + | ApplyRuleInt of string * (int * int) list * float * (string * float) list | GetRuleNames (** Get names of rules *) | SetTime of float * float (** Set time step and time *) | GetTime (** Get time step and time *) Modified: trunk/Toss/Arena/DiscreteRule.ml =================================================================== --- trunk/Toss/Arena/DiscreteRule.ml 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Arena/DiscreteRule.ml 2011-02-22 01:08:46 UTC (rev 1324) @@ -176,7 +176,7 @@ Solver.M.evaluate model rule_obj.lhs_form_pp (* Convert assignment to an embedding of the LHS structure. *) -let assignment_to_embedding rule_obj assgn = +let assignment_to_embedding rule_obj asgn = List.map (fun (var,e) -> try elem_of_elemvar rule_obj.lhs_elem_names var, e @@ -184,7 +184,7 @@ failwith ( "assignment_to_embedding: inconsistent rule_obj at variable " ^ var)) - assgn + asgn (* Choose an arbitrary embedding of a rule from the matchings returned by {!find_matchings} for the same structure and rewrite rule. Does @@ -192,10 +192,10 @@ let choose_match model rule_obj matches = let elem = Structure.Elems.choose model.Structure.elements in let default = List.map (fun v->v,elem) rule_obj.lhs_elem_vars in - let assgn = AssignmentSet.choose_fo default matches in - assignment_to_embedding rule_obj assgn + let asgn = AssignmentSet.choose_fo default matches in + assignment_to_embedding rule_obj asgn -let rec enumerate_assgns all_elems vars = function +let rec enumerate_asgns all_elems vars = function | AssignmentSet.Any -> (* let all_elems = Structure.Elems.elements all_elems in *) let elems = List.map (fun _ -> all_elems) vars in @@ -207,19 +207,19 @@ let vars = list_remove v vars in concat_map (fun (e,sub)-> List.map (fun tl->(v,e)::tl) - (enumerate_assgns all_elems vars sub)) els + (enumerate_asgns all_elems vars sub)) els | AssignmentSet.MSO (_, els) -> concat_map (fun (e,sub)-> - enumerate_assgns all_elems vars sub) els + enumerate_asgns all_elems vars sub) els | AssignmentSet.Real _ -> failwith "real matches unsupported" (* Enumerate matchings returned by {!find_matchings} for the same structure and rewrite rule. *) let enumerate_matchings model rule matches = let all_elems = Structure.Elems.elements model.Structure.elements in - let assgns = - enumerate_assgns all_elems rule.lhs_elem_vars matches in - List.map (assignment_to_embedding rule) assgns + let asgns = + enumerate_asgns all_elems rule.lhs_elem_vars matches in + List.map (assignment_to_embedding rule) asgns (* Helpers for special relations. *) let orig_rel_of rel = @@ -573,12 +573,12 @@ let arg_tup = Array.of_list args in map_some (fun (brel, ar) -> let selector = Structure.free_for_rel brel ar in - let assgn = + let asgn = Solver.M.evaluate selector rphi in let btup = Array.init ar (fun i->i+1) in (* [selector] has only [btup] with its elements *) let selvars = - enumerate_assgns (Array.to_list btup) args assgn in + enumerate_asgns (Array.to_list btup) args asgn in (* inverse image of [tups] *) let btups = concat_map (fun tup -> @@ -781,17 +781,17 @@ let rhs_opt_rels, rhs_rels, _ = compile_opt_rels rhs_rels in if List.exists (fun (drel, _) -> List.mem_assoc drel rhs_rels) - defined_rels + defined_rels then failwith ("Non-optional defined relation(s) "^ String.concat ", " (Aux.map_some (fun (drel,_) -> if List.mem_assoc drel rhs_rels then Some drel else None) defined_rels) - ^" on RHS."); + ^" on RHS."); (* if the rule is optimized for "nonstructural" rewriting, elements are already renamed; raises Not_found when adding elements *) let mapf_rn = if rlmap = None then fun x->x else - Array.map (fun e-> List.assoc e rule_src.rule_s) in + Array.map (fun e-> List.assoc e rule_src.rule_s) in (* a tuple is positive when it (possibly) has to be added: it does not occur on the LHS *) let rhs_pos_tuples = @@ -799,13 +799,13 @@ rel, List.filter (fun tup -> try not (List.mem (mapf_rn tup) - (try List.assoc rel lhs_pos_expanded with Not_found -> [])) + (try List.assoc rel lhs_pos_expanded with Not_found -> [])) with Not_found -> true (* new element: has to be added *) ) tups) rhs_rels in let rhs_all_tups n = List.map Array.of_list (Aux.product - (Aux.fold_n (fun acc -> rhs_elems::acc) [] n)) in + (Aux.fold_n (fun acc -> rhs_elems::acc) [] n)) in (* a tuple is negative when it has to be removed: it is in $\tau_e$ and in the LHS, but it does not occur on the RHS even optionally *) let rhs_neg_tuples = @@ -813,16 +813,16 @@ rel, List.filter (fun tup -> try (List.mem (mapf_rn tup) - (try List.assoc rel lhs_pos_expanded with Not_found -> []) - || - List.mem (mapf_rn tup) - (try List.assoc rel lhs_opt_rels with Not_found -> [])) + (try List.assoc rel lhs_pos_expanded with Not_found -> []) + || + List.mem (mapf_rn tup) + (try List.assoc rel lhs_opt_rels with Not_found -> [])) && not ( (List.mem tup - (try List.assoc rel rhs_rels with Not_found -> []) - || List.mem tup - (try List.assoc rel rhs_opt_rels with Not_found -> [])) + (try List.assoc rel rhs_rels with Not_found -> []) + || List.mem tup + (try List.assoc rel rhs_opt_rels with Not_found -> [])) ) with Not_found -> false (* adding element: can't be negative *) ) (rhs_all_tups (List.assoc rel signat))) @@ -834,8 +834,19 @@ rel, List.map (fun tup -> Array.map rhs_name_of tup) tups) rhs_neg_tuples in (* Optimizing the embedding formula. *) + (* {{{ log entry *) + if !debug_level > 1 then ( + Printf.printf "compile_rule: embedding formula = %s\n%!" + (Formula.sprint emb) + ); + (* }}} *) let lhs_form_pp = Solver.M.register_formula emb in +(* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "compile_rule: done.\n%!"; + ); + (* }}} *) { lhs_elem_names = lhs_elem_names; lhs_elem_inv_names = lhs_elem_inv_names; @@ -865,13 +876,17 @@ List.map fst rels1 @ List.map fst rels2 @ acc)[] rules -let translate_from_precond ~precond ~add ~del = - let diff a b = List.filter (fun e -> not (List.mem e b)) a in - let del = diff del add in +(* Build a rule by translating the "add" list into the RHS structure + directly, and separating out from a precondition the LHS structure + over the [struc_vars] variables. All relations are + considered embedded. (Obviously, not all rules can be generated in + this way.) *) +let translate_from_precond ~precond ~add ~embed ~struc_elems = let rhs_names = Aux.unique_sorted - (Aux.concat_map (fun (_,arg) -> Array.to_list arg) (add @ del)) in + (Aux.concat_map (fun (_,arg) -> Array.to_list arg) add) in + assert (Aux.list_diff rhs_names struc_elems = []); let rewritable args = - Aux.array_for_all (fun v -> List.mem (Formula.var_str v) rhs_names) + Aux.array_for_all (fun v -> List.mem (Formula.var_str v) struc_elems) args in let conjs = FormulaOps.flatten_ands precond in let literals, conjs = Aux.partition_map (function @@ -881,40 +896,35 @@ Left (Right (rel,args)) | phi -> Right phi) conjs in let posi, nega = Aux.partition_choice literals in + (* FIXME: TODO: check and at least warn when [nega] is smaller than + the complement of [posi] over embedded rels *) let precond = Formula.And conjs in let fvars = FormulaOps.free_vars precond in let local_vars = List.filter (fun v-> - not (List.mem (Formula.var_str v) rhs_names)) fvars in + not (List.mem (Formula.var_str v) struc_elems)) fvars in let precond = if local_vars = [] then precond else Formula.Ex (local_vars, precond) in - let emb_rels = Aux.unique_sorted - (List.map fst (add @ del) @ List.map fst nega) in + let emb_rels = Aux.list_inter embed + (Aux.unique_sorted + (List.map fst add @ List.map fst (posi @ nega))) in let posi_s = List.map (fun (rel, args) -> rel, Array.map Formula.var_str args) posi in - let nega_s = - List.map (fun (rel, args) -> rel, Array.map Formula.var_str args) - nega in - let posi_emb = - List.filter (fun (rel,_) -> List.mem rel emb_rels) posi_s in - let del = List.filter (fun d -> not (List.mem d nega_s)) del in - let rhs_struc, rhs_names = - List.fold_left (fun (rhs_struc, rhs_names) name -> + let rhs_struc, struc_elems = + List.fold_left (fun (rhs_struc, struc_elems) name -> let rhs_struc, elem = Structure.add_new_elem rhs_struc ~name () in - rhs_struc, (name, elem)::rhs_names) - (Structure.empty_structure (), []) rhs_names in + rhs_struc, (name, elem)::struc_elems) + (Structure.empty_structure (), []) struc_elems in let add_rels = List.fold_left (fun struc (rel, args) -> Structure.add_rel struc rel - (Array.map (fun n -> List.assoc n rhs_names) args)) in + (Array.map (fun n -> List.assoc n struc_elems) args)) in let lhs_struc = rhs_struc in - let rhs_struc = add_rels rhs_struc (add @ diff posi_emb del) in + let rhs_struc = add_rels rhs_struc add in let lhs_struc = add_rels lhs_struc posi_s in - let lhs_struc = add_rels lhs_struc - (List.map (fun (rel,args) -> "_opt_"^rel, args) - (diff del (posi_emb @ nega_s))) in + (* no relations are optional, righ? *) { lhs_struc = lhs_struc; rhs_struc = rhs_struc; Modified: trunk/Toss/Arena/DiscreteRule.mli =================================================================== --- trunk/Toss/Arena/DiscreteRule.mli 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Arena/DiscreteRule.mli 2011-02-22 01:08:46 UTC (rev 1324) @@ -41,6 +41,7 @@ rlmap : (string * string) list option; (* rule_s on variables (?) *) } +val elemvar_of_elem : elem_inv_names -> int -> string (* We call fluents the relations that can be modified by a rule. *) val fluents : rule_obj -> string list @@ -116,7 +117,7 @@ val translate_from_precond : precond:Formula.formula -> add:(string * string array) list -> - del:(string * string array) list -> rule + embed:string list -> struc_elems:string list -> rule (** {2 Printing.} *) val matching_str : matching -> string Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Formula/Aux.ml 2011-02-22 01:08:46 UTC (rev 1324) @@ -18,6 +18,24 @@ let ints_of_list nvs = add_ints nvs Ints.empty +module StrMap = Map.Make + (struct type t = string let compare = String.compare end) +let rec strmap_of_assoc = + function + | [] -> StrMap.empty + | (k,v)::tl -> StrMap.add k v (strmap_of_assoc tl) +let strmap_filter p m = + StrMap.fold (fun k v acc -> if p k v then (k,v)::acc else acc) m [] + +module IntMap = Map.Make + (struct type t = int let compare x y = x - y end) +let rec intmap_of_assoc = + function + | [] -> IntMap.empty + | (k,v)::tl -> IntMap.add k v (intmap_of_assoc tl) +let intmap_filter p m = + IntMap.fold (fun k v acc -> if p k v then (k,v)::acc else acc) m [] + let is_digit c = (c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') || (c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9') @@ -71,6 +89,10 @@ let list_remove v l = List.filter (fun w->v<>w) l +let list_diff a b = List.filter (fun e -> not (List.mem e b)) a + +let list_inter a b = List.filter (fun e -> List.mem e b) a + 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 @@ -110,6 +132,16 @@ else aux (pair :: acc) l in aux [] l +let rec update_assoc k v0 f l = + let rec aux acc = function + | [] -> [k, f v0] + | (a, b as pair) :: l -> + if compare a k = 0 then List.rev_append acc ((k, f b)::l) + else aux (pair :: acc) l in + aux [] l + +let cons e l = e::l + let unsome = function | Some v -> v | None -> raise (Invalid_argument "unsome") Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Formula/Aux.mli 2011-02-22 01:08:46 UTC (rev 1324) @@ -11,6 +11,16 @@ val add_ints : int list -> Ints.t -> Ints.t val ints_of_list : int list -> Ints.t +module StrMap : Map.S with type key = string +val strmap_of_assoc : (string * 'a) list -> 'a StrMap.t +val strmap_filter : + (string -> 'a -> bool) -> 'a StrMap.t -> (string * 'a) list + +module IntMap : Map.S with type key = int +val intmap_of_assoc : (int * 'a) list -> 'a IntMap.t +val intmap_filter : + (int -> 'a -> bool) -> 'a IntMap.t -> (int * 'a) list + val is_digit : char -> bool val fst3 : 'a * 'b * 'c -> 'a @@ -44,6 +54,12 @@ inequality. *) val list_remove : 'a -> 'a list -> 'a list +(** Difference: [List.filter (fun e -> not (List.mem e b)) a]. *) +val list_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 + (** Return first key with the given value from the key-value pairs, using structural equality. *) val rev_assoc : ('a * 'b) list -> 'b -> 'a @@ -56,16 +72,24 @@ val assoc_all : 'a -> ('a * 'b) list -> 'b list (** Replace the value of a first occurrence of a key, or place it at - the end of the assoc list. *) + the end of the assoc list. Not tail-recursive. *) val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list (** Find the value associated with the first occurrence of the key and - remove them from the list. Uses structural equality. *) + remove them from the list. Uses structural equality. Tail-recursive. *) val pop_assoc : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list -(** As {!Aux.pop_assoc}, but uses physical equality. *) +(** As {!Aux.pop_assoc}, but uses physical equality. Tail-recursive. *) val pop_assq : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list +(** Update the value associated with the first occurrence of the key, + if no key is present update the given default "zero" + value. Tail-recursive. *) +val update_assoc : 'a -> 'b -> ('b -> 'b) -> ('a * 'b) list -> ('a * 'b) list + +(** [cons e l = e::l]. *) +val cons : 'a -> 'a list -> 'a list + (** unConstructors. *) val unsome : 'a option -> 'a Modified: trunk/Toss/Formula/AuxTest.ml =================================================================== --- trunk/Toss/Formula/AuxTest.ml 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/Formula/AuxTest.ml 2011-02-22 01:08:46 UTC (rev 1324) @@ -77,7 +77,7 @@ ); - "replace_assoc, pop_assoc, pop_assq" >:: + "replace_assoc, pop_assoc, pop_assq, update_assoc" >:: (fun () -> assert_equal ~printer:(print_alist (fun x -> x)) ["B","f";"C","B"; "G","replaced"; "G", "T"] @@ -111,6 +111,10 @@ Not_found (fun () -> Aux.pop_assq g ["B","f";"G", "T0"; "C","B"; "F","Ts"]); + + assert_equal ~msg:"update_assoc: two-level trie" + [(7, [('b', ["ha"])])] + (Aux.update_assoc 7 [] (Aux.update_assoc 'b' [] (Aux.cons "ha")) []) ); "unsome, map_try" >:: Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-19 17:22:41 UTC (rev 1323) +++ trunk/Toss/GGP/GDL.ml 2011-02-22 01:08:46 UTC (rev 1324) @@ -11,7 +11,8 @@ (1) Aggregate playout: generate successive states as if all moves legal in the previous state were performed. Do not check the - termination predicate. + termination predicate. To avoid ungrounded player variables, add + "role" filter to "legal" rules. (1a) Reason for unsoundness: "legal" or "next" preconditions can depend negatively on state, preventing further moves in the @@ -35,6 +36,13 @@ (2) Arena graph: currently, only a simple cycle is allowed. The succession of players is determined from the aggregate playout. + In case of problems, it should be relatively easy to expand the + translation to use a single location per player, and for rules to + determine which player is active after the rule takes effect + (i.e. the target location.) Once Toss has a good system for + simultaneous moves, we can simplify by translating into a single + location game, obsoleting this "chapter". + (2a) We need to recognize which player actually makes a move in a state. For this we need to locate the "noop" arguments to "legal" and "does" relations. A noop action in a location is the only @@ -206,7 +214,7 @@ (7a) We translate each branch of the "legal" relation definition as one or more rewrite rules. Currently, we base availability of rules in a location on the player in the location and noop actions - of other players in it, compared to the the "legal" definition + of other players in it, compared to the "legal" definition branch (currently, we do not allow simultaneous moves). If the branch of "legal" definition has a variable for a player, it is instantiated for each player in the game, and the variable @@ -293,6 +301,13 @@ (7g) Instantiate remaining unfixed variables. Implementation TODO. + (7g1) Duplicate non-frame rules with unfixed variables for each + instantiation of the unfixed variables warranted by the aggregate + playout. (Perhaps can be done "symbolically" to avoid explosion.) + + (7g2) Then, add instantiations of frame rules for each case their + head term unifies with one from all the non-frame rules. + (7h) Introduce a new element variable for each class of "next" and "true" terms equal modulo mask (i.e. there is a mask matching them and they differ only at-or-below metavariables). (Remember the @@ -401,7 +416,9 @@ The rewrite rule is generated by joining the derived conjunctions from "next" atoms as RHS, and from bodies as the precondition. Exactly the RHS variables are listed in the LHS - (other variables are existentially closed in the precondition). + (other variables are existentially closed in the + precondition). All the relations that appear in either LHS or RHS + are considered embedded. (7o) After the rules are translated, perform an aggregated playout of the Toss variant of the game. Remove the rules that were never @@ -420,8 +437,51 @@ branches from the definition). For each goal value we collect bodies to form a disjunction. -() + (9) To translate an incoming action, we: + (9a) find the "lead legal" term to which the "does move" ground + term of the current player matches; + + (9b) earlier, remember which Toss variables of a rule contain which + fixed variables at which positions in their masks; + + (9c) find anchor predicates corresponding to instantiations of the + "lead legal" variables, anchoring positions found by (9b) "fixed + var" - "mask + mask var" correspondence; + + (9d) build a conjunction of anchor predicates over variables that + contain the fixed variable which is "instantiated" by the anchor + of the corresponding position, as established by (9c); + + (9e) conjoin the (9d) with the "matching" formula of a rule, and + evaluate the result for all rules (of the located "lead legal" + class); only a single rule should have a match, and only a single + assignment should be returned; this rule with this assignment is + the translated move. + + (10) To translate an outgoing action, we: + + (10a) associate the rule with its corresponding data: the "lead + legal" term, the fixed variables corresponding to rule elements, + ... + + (10b) earlier, return/store the mapping from an element to the + mask and subsitution that define the element; + + (10c) earlier, for each rule store a mapping from fixed variables + to rule variables and the mask variables that in the rule variable + are instantiated by the fixed variables; + + (10d) to determine how to instantiate the fixed variables in the + "lead legal" term, find the (10b) substitutions of assigned + elements and (10c) mask variables for fixed variables; compose the + maps to get fixed variable to GDL ground term mapping, each + "route" should give the same term. + + Implementation TODO: once the LHS-RHS structures are removed from + the backbone and formula registration is removed, some + simplifications can be done in (9) and (10). + *) let debug_level = ref 0 @@ -467,6 +527,47 @@ | Stop of string * term list (* game ends here: match id, actions on previous step *) +type tossrule_data = { + lead_legal : 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; + (* the LHS match condition (the LHS structure and the precondition) *) + rhs_add : (string * string array) list; + (* the elements of LHS/RHS structures, corresponding to the "next" + terms *) + struc_elems : string list; + fixvar_elemvars : + (string * (term * (string * string list) list) list) list; + (* "state" terms indexed by variables that they contain, together + with the mask-path of the variable *) + elemvars : term Aux.StrMap.t; +(* "state" terms indexed by Toss variable names they generate *) +} + +type gdl_translation = { + anchor_terms : + (term * (string * (term * string) list) list) list; + (* mask path (i.e. mask+var) and a ground term to anchor predicate *) + tossrule_data : tossrule_data Aux.StrMap.t; + (* rule name to rule translation data *) + t_elements : term Aux.IntMap.t; + (* element terms (with metavariables only) *) + playing_as : int; + (* "active" player *) + noop_actions : term option array; + (* NOOP actions of "active" player indexed by locations *) + fluents : string list; +} + +let empty_gdl_translation = + {anchor_terms = []; + tossrule_data = Aux.StrMap.empty; + t_elements = Aux.IntMap.empty; + playing_as = 0; + noop_actions = [||]; + fluents = []} + let rec term_str = function | Const c -> c | Var v -> "?"^v @@ -836,6 +937,7 @@ (* 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 = let instantiate_one tot_base cur_base irules = @@ -927,7 +1029,6 @@ (List.map rules_of_defs (stratify [] (defs_of_rules rules))) -let playing_as = ref (Const "uninitialized") let game_description = ref [] let player_terms = ref [| |] @@ -1115,17 +1216,39 @@ (* Collect the aggregate playout, but also the actions available in the state. *) +exception Playout_over let aggregate_ply players static current rules = let base = Aux.map_prepend static (fun term -> "true", [term]) current in let base = saturate (base @ static) rules in + (* {{{ log entry *) + if !debug_level > 4 then ( + Printf.printf "GDL.aggregate_ply: updated base -- %s\n%!" + (String.concat " " (List.map fact_str base)) + ); + (* }}} *) let does = Aux.map_some (fun (rel, args) -> if rel = "legal" then Some ("does", args) else None) base in if (* no move *) Aux.array_existsi (fun _ player -> - List.for_all (function _, (actor::_) -> player <> actor | _ -> true) + List.for_all (function + |_, (Var _::_) -> false + | _, (actor::_) -> player <> actor | _ -> true) does) players - then raise Not_found + then ( + (* {{{ log entry *) + if !debug_level > 0 then ( + let players_nomove = + Aux.array_find_all (fun player -> + List.for_all (function _, (actor::_) -> player <> actor + | _ -> true) + does) players in + Printf.printf + "GDL.aggregate_ply: playout over due to no move for %s\n%!" + (String.concat ", " (List.map term_str players_nomove)) + ); + (* }}} *) + raise Playout_over) else let step = saturate (does @ base) rules in let step = Aux.map_some (function ("next", [arg]) -> Some arg @@ -1136,7 +1259,13 @@ Aux.array_existsi (fun _ player -> arg=player) players -> true | term -> List.mem term current ) step - then raise Not_found + then ( + (* {{{ log entry *) + if !debug_level > 0 then ( + Printf.printf "GDL.aggregate_ply: playout over due to fixpoint\n%!"; + ); + (* }}} *) + raise Playout_over) else List.map snd does, step @@ -1161,13 +1290,14 @@ (fun ((rel,_),_,_) -> List.mem rel static_rels) rules in let static_base = saturate [] static_rules in let state_rules = - (* 1a *) - if !aggregate_drop_negative then - List.map (function - | ("legal", _ as head), body, _ -> head, body, [] - | ("does", _ as head), body, _ -> head, body, [] - | rule -> rule) dynamic_rules - else dynamic_rules in + (* 1, 1a *) + List.map (function + | ("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, [] *) + | rule -> rule) dynamic_rules in let rec loop actions_accu state_accu step state = (* {{{ log entry *) if !debug_level > 0 then ( @@ -1177,17 +1307,17 @@ (let try actions, next = aggregate_ply players static_base state state_rules in (* {{{ log entry *) - if !debug_level > 0 then ( - Printf.printf "aggregate_playout: state %s\n%!" - (String.concat " " (List.map term_str next)) - ); + if !debug_level > 0 then ( + Printf.printf "aggregate_playout: state %s\n%!" + (String.concat " " (List.map term_str next)) + ); (* }}} *) - 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 Not_found -> + 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 (* FIXME: this is identity, right? remove *) let init_base = saturate static_base state_rules in @@ -1205,6 +1335,12 @@ let find_cycle cands = + (* {{{ log entry *) + if !debug_level > -1 then ( + Printf.printf "GDL.find_cycle: %s\n%!" (String.concat ", " ( + List.map (function Some c -> term_str c | None -> "None") cands)) + ); + (* }}} *) let rec loop cycle trav pref rem path = if cycle = [] then let ini = [List.hd path] in @@ -1270,12 +1406,15 @@ ) masks in let mask, sb, m_sb = match mask_cands with | [mask, (sb, m_sb)] -> mask, sb, m_sb - | _ -> assert false in + | _ -> + Printf.printf "GDL.term_to_blank: bad state term %s\n%!" + (term_str next_arg); + assert false in mask, sb, m_sb, blank_out (next_arg, mask) let toss_var masks term = let mask, _, _, blank = term_to_blank masks term in - mask, Formula.fo_var_of_string (term_to_name blank) + mask, Formula.fo_var_of_string (String.lowercase (term_to_name blank)) let translate_branches struc masks static_rnames dyn_rels (brs : exp_def_branch list) = @@ -1356,7 +1495,8 @@ Aux.concat_map (fun term -> let mask, sb, m_sb, blanked = term_to_blank masks term in Aux.map_some (function - | v, Var t -> Some ((mask, v), (t, term)) + | v, Var t -> + Some ((mask, v), (t, term)) | _ -> None) sb ) state_terms in let path_subterms = Aux.collect path_subterms in @@ -1460,21 +1600,19 @@ (* 7k *) let brs = List.map (fun (static_conjs, (next_arg,body,neg_body)) -> - let rhs_pos_preds, rhs_possneg_preds = - if next_arg = Const "_IGNORE_RHS_" then [], [] + let rhs_pos_preds = + if next_arg = Const "_IGNORE_RHS_" then [] else let mask, sb, m_sb, blanked = term_to_blank masks next_arg in let rhs_elem = - (* Formula.fo_var_of_string *) (term_to_name blanked) in - Aux.partition_map (fun (v,t as v_sb) -> - if t = Const "_BLANK_" then - let neg_rels = List.assoc (mask, v) dyn_rels in - Aux.Right (List.map (fun rel->rel, [|rhs_elem|]) neg_rels) + (* Formula.fo_var_of_string *) + (String.lowercase (term_to_name blanked)) in + Aux.map_some (fun (v,t as v_sb) -> + if t = Const "_BLANK_" then None else let rname = term_to_name (subst_one v_sb mask) in - Aux.Left (rname, [|rhs_elem|]) + Some (rname, [|rhs_elem|]) ) m_sb in - let rhs_possneg_preds = List.flatten rhs_possneg_preds in let dyn_conjs = Aux.concat_map (fun (rel, args) -> if rel = "true" then @@ -1483,22 +1621,13 @@ let mask, sb, m_sb, blanked = term_to_blank masks true_arg in let _, svar = toss_var masks true_arg in - let lhs_pos_preds, lhs_possneg_preds = - Aux.partition_map (fun (v,t as v_sb) -> - if t = Const "_BLANK_" then - (* - let neg_rels = List.assoc (mask, v) dyn_rels in - Aux.Right (List.map (fun rel-> - Formula.Rel (rel, [|svar|])) neg_rels) - *) assert false - else - let rname = term_to_name (subst_one v_sb mask) in - Aux.Left (Formula.Rel (rname, [|svar|])) - ) m_sb in - (* - let lhs_possneg_preds = List.flatten lhs_possneg_preds in - *) - lhs_pos_preds + Aux.map_some (fun (v,t as v_sb) -> + if t = Const "_BLANK_" then + (* None *) assert false + else + let rname = term_to_name (subst_one v_sb mask) in + Some (Formula.Rel (rname, [|svar|])) + ) m_sb else if List.mem rel static_rnames || rel = "_DOES_PLACEHOLDER_" then [] else ( @@ -1548,7 +1677,7 @@ | [disj] -> Some disj | _ -> Some (Formula.Or disjs)) neg_body in let all_conjs = static_conjs @ dyn_conjs @ neg_conjs in - (rhs_pos_preds, rhs_possneg_preds, static_conjs, all_conjs), + (rhs_pos_preds, static_conjs, all_conjs), (next_arg, body, neg_body)) brs in uni_toss_vars, conjs_4b, brs @@ -1585,14 +1714,20 @@ (* }}} *) res -let translate_game game_descr = +let translate_game player_term game_descr = freshen_count := 0; let player_terms = Array.of_list (Aux.map_some (function Role p -> Some p | _ -> None) game_descr) in let players_n = Array.length player_terms in let find_player player = - Aux.array_argfind (fun p->p=player) player_terms in + try + Aux.array_argfind (fun p->p=player) player_terms + with Not_found -> failwith + (Printf.sprintf + "GDL.initialize_game: player %s not found among %s" + (term_str player) (String.concat ", " ( + Array.to_list (Array.map term_str player_terms)))) in let rules = Aux.concat_map rules_of_entry game_descr in let static_rules, dynamic_rules, static_base, init_state, (agg_actions, agg_states) = @@ -1802,15 +1937,15 @@ (mask, if List.mem sb sbs then sbs else sb::sbs)::elements ) [] element_terms in let struc = Structure.empty_structure () in - let struc, elements = - List.fold_left (fun (struc, elements) (mask, sbs) -> + let struc, elements, t_elements = + List.fold_left (fun (struc, elements, t_elements) (mask, sbs) -> (* {{{ log entry *) if !debug_level > 2 then ( Printf.printf "mask-elements:"; ); (* }}} *) - let struc, m_elements = - List.fold_left (fun (struc, m_elements) sb -> + let struc, m_elements, t_elements = + List.fold_left (fun (struc, m_elements, t_elements) sb -> let e_term = subst sb mask in (* {{{ log entry *) if !debug_level > 2 then ( @@ -1819,15 +1954,16 @@ (* }}} *) let struc, elem = Structure.add_new_elem struc ~name:(term_to_name e_term) () in - struc, (sb, elem)::m_elements - ) (struc, []) sbs in + struc, (sb, elem)::m_elements, + Aux.IntMap.add elem e_term t_elements + ) (struc, [], t_elements) sbs in (* {{{ log entry *) if !debug_level > 2 then ( Printf.printf "\n%!"; ); (* }}} *) - struc, (mask, m_elements)::elements - ) (struc, []) elements in + struc, (mask, m_elements)::elements, t_elements + ) (struc, [], Aux.IntMap.empty) elements in (* 4 *) (* currently, position paths are approximated by variables (non-variable positions are ignored) *) @@ -1849,10 +1985,12 @@ List.fold_left (fun struc (brel, arity, path_tups) -> let brel_tups = List.assoc brel static_base in (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "Translating static relation %s with %d tuples:\n%s\n%!" brel (List.length brel_tups) (tuples_str brel_tups); ); + (* }}} *) List.fold_left (fun struc ptup -> let rname = brel ^ "__" ^ String.concat "__" @@ -1910,10 +2048,12 @@ Structure.add_rel_name rname 2 struc in let elems = List.assoc mask elements in (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "Adding static EQ relation %s over %d elements.\n%!" rname (List.length elems); ); + (* }}} *) let elem_tups = List.fold_left (fun tups (sb1, e1) -> @@ -1946,19 +2086,25 @@ Structure.add_rel_name rname 1 struc in let elems = List.assoc mask elements in (* {{{ log entry *) + if !debug_level > 0 then ( Printf.printf "Adding mask anchor predicate %s over %d elements.\n%!" rname (List.length elems); ); + (* }}} *) let elem_tups = List.map (fun (sb, e) -> [|e|]) elems in Structure.unsafe_add_rels struc rname elem_tups ) struc masks in + let anchor_terms = ref [] in let struc = List.fold_left (fun struc (mask, elems) -> List.fold_left (fun struc (sb, elem) -> List.fold_left (fun struc (v,t as v_sb) -> let rname = term_to_name (subst_one v_sb mask) in + anchor_terms := Aux.update_assoc mask [] + (Aux.update_assoc v [] (Aux.update_assoc t "" (fun _ ->rname))) + !anchor_terms; Structure.add_rel struc rname [|elem|]) struc sb) struc elems ) struc elements in @@ -2304,6 +2450,7 @@ rules_brs ) joint_legal_branches ) loc_joint_legal in + (* 7g: (7g1) and (7g2) TODO *) (* {{{ log entry *) if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> @@ -2340,7 +2487,6 @@ let uni_vars, conjs_4b, brs = translate_branches struc masks static_rnames dyn_rels (brs @ synth_brs) in - (* 7l *) let brs = Array.of_list brs in (* indexing branches *) let full_set = Aux.ints_of_list @@ -2407,6 +2553,7 @@ Aux.array_existsi (fun ply states -> if ply mod loc_n = loc then ( (* {{{ log entry *) + if !debug_level > 4 then ( let posi = Aux.map_some (function @@ -2416,6 +2563,7 @@ "Checking branch at states:\n%s\npositives:\n%s\n" (terms_str states) (terms_str posi) ); + (* }}} *) let res = List.for_all (function @@ -2433,51 +2581,70 @@ let cases = Aux.map_try (fun c_brs -> let c_brs = List.map (Array.get brs) c_brs in List.fold_left (fun - (rhs_pos_acc, rhs_neg_acc, static_conjs_acc, conjs_acc) - ((rhs_pos, rhs_neg, static_conjs, conjs), - (_,body,_)) -> + (var_elems, struc_elems, rhs_pos_acc, + static_conjs_acc, conjs_acc) + ((rhs_pos, static_conjs, conjs), + (next_arg,body,_)) -> if not (check_branch body) then raise Not_found; - rhs_pos @ rhs_pos_acc, rhs_neg @ rhs_neg_acc, - static_conjs @ static_conjs_acc, conjs @ conjs_acc) - ([],[],conjs_4b,conjs_4b) c_brs + let nsvar = + if next_arg = Const "_IGNORE_RHS_" + then [] + else [Formula.var_str (snd (toss_var masks next_arg)), + next_arg] in + let var_elems = + List.fold_left (fun acc -> function + | "true", [true_arg] -> + let _, svar = toss_var masks true_arg in + (Formula.var_str svar, true_arg)::acc + | _ -> acc) + (nsvar @ var_elems) body in + var_elems, List.map fst nsvar @ struc_elems, + rhs_pos @ rhs_pos_acc, + static_conjs @ static_conjs_acc, conjs @ conjs_acc) + ([],[],[],conjs_4b,conjs_4b) c_brs ) cases in (* 7m *) - let cases = Aux.map_some (fun (rhs_pos,rhs_neg,static_phis,phis) -> - if rhs_pos = [] && rhs_neg = [] then None - else Some ( - Aux.unique_sorted rhs_pos, Aux.unique_sorted rhs_neg, - static_phis, phis)) cases in - let cases = Aux.map_some (fun (rhs_pos,rhs_neg,static_phis,phis) -> - let phi = Formula.And static_phis in - let rphi = Solver.M.register_formula phi in - (* {{{ log entry *) - if !debug_level > 4 then ( - (* do not print, because it generates too many - answers -- too little constraints per number of - variables when considering a single branch *) - (* - let assgn = Solver.M.evaluate struc rphi in - let avars = List.map Formula.var_str - (FormulaOps.free_vars phi) in - let atups = - AssignmentSet.tuples struc.Structure.elements - avars assgn in *) - Printf.printf "evaluating: %s\n%!" - (Formula.str phi) - (* (List.length atups) *) - ); - (* }}} *) - let res = Solver.M.check_formula struc rphi in - (* {{{ log entry *) - if !debug_level > 4 && res then ( - Printf.printf "holds\n%!" - ); - (* }}} *) - if res then Some (rhs_pos, rhs_neg, phis) - else None) cases in - List.map (fun (rhs_pos, rhs_neg, conjs) -> - lead, (rhs_pos, rhs_neg, lift_universal uni_vars conjs)) cases + let cases = Aux.map_some ( + fun (var_elems,struc_elems,rhs_pos,static_phis,phis) -> + if rhs_pos = [] then None + else Some ( + Aux.unique_sorted var_elems, + Aux.unique_sorted struc_elems, + Aux.unique_sorted rhs_pos, + static_phis, phis)) cases in + let cases = Aux.map_some ( + fun (var_elems,struc_elems,rhs_pos,static_phis,phis) -> + let phi = Formula.And static_phis in + let rphi = Solver.M.register_formula phi in + (* {{{ log entry *) + if !debug_level > 4 then ( + (* do not print, because it generates too many + answers -- too little constraints per number of + variables when considering a single branch *) + (* + let assgn = Solver.M.evaluate struc rphi in + let avars = List.map Formula.var_str + (FormulaOps.free_vars phi) in + let atups = + AssignmentSet.tuples struc.Structure.elements + avars assgn in *) + Printf.printf "evaluating: %s\n%!" + (Formula.str phi) + (* (List.length atups) *) + ); + (* }}} *) + let res = Solver.M.check_formula struc rphi in + (* {{{ log entry *) + if !debug_level > 4 && res then ( + Printf.printf "holds\n%!" + ); + (* }}} *) + if res then Some (var_elems, struc_elems, rhs_pos, phis) + else None) cases in + List.map (fun (var_elems, struc_elems, rhs_pos, conjs) -> + lead, (var_elems, struc_elems, rhs_pos, + lift_universal uni_vars conjs)) cases ) rules_brs ) loc_next_classes in (* 7n *) @@ -2487,7 +2654,7 @@ | _ -> assert false) terminal_rules in let terminal_uni_vars, terminal_4b, terminal_brs = translate_branches struc masks static_rnames dyn_rels terminal_brs in - let terminal_disjs = List.map (fun ((_,_,_,conjs),_) -> + let terminal_disjs = List.map (fun ((_,_,conjs),_) -> let disj_vars = FormulaOps.free_vars (Formula.And conjs) in let disj_4b = List.filter (fun a -> List.exists (fun v->List.mem v disj_vars) @@ -2497,8 +2664,8 @@ (disj_4b @ conjs))) terminal_brs in let terminal_phi = Formula.Or terminal_disjs in - let fluents = Aux.strings_of_list - (Aux.concat_map (fun (_,drels) -> drels) dyn_rels) in + (* let fluents = Aux.strings_of_list + (Aux.concat_map (fun (_,drels) -> drels) dyn_rels) in *) (* {{{ log entry *) if !debug_level > 1 then ( Printf.printf "GDL.translate_game: terminal condition -- %s\n%!" @@ -2538,13 +2705,14 @@ | _ -> assert false in let goal_uni_vars, goal_4b, brs = translate_branches struc masks static_rnames dyn_rels brs in - let goal_disjs = List.map (fun ((_,_,_,conjs),_) -> + let goal_disjs = List.map (fun ((_,_,conjs),_) -> let disj_vars = FormulaOps.free_vars (Formula.And conjs) in let disj_4b = List.filter (fun a -> List.exists (fun v->List.mem v disj_vars) (FormulaOps.free_vars a)) goal_4b in - lift_universal goal_uni_vars - (disj_4b @ conjs)) brs in + let disj = lift_universal goal_uni_vars (disj_4b @ conjs) in + Formula.Ex (FormulaOps.free_vars disj, disj) + ) brs in let guard = Formula.Or goal_disjs in Formula.Plus (sum, Formula.Times ( Formula.Const score, Formula.Char guard)) @@ -2563,47 +2731,97 @@ (* }}} *) (* {{{ log entry *) + if !debug_level > 1 then ( Array.iteri (fun loc rules_brs -> Printf.printf "Rule translations for loc %d:\n%!" loc; - List.iter (fun (lead, (rhs_pos,rhs_neg,precond)) -> + List.iter (fun (lead, (_,_,rhs_pos,precond)) -> Printf.printf - "Rule-translation: player %s move %s precond:\n%s\naction:\nADD %s... DEL %s\n%!" + "Rule-translation: player %s move %s precond:\n%s\naction:\nADD %s\n%!" (term_str loc_players.(loc)) (term_str lead) (Formula.sprint precond) (String.concat "; " (List.map proto_rel_str rhs_pos)) - (String.concat "; " (List.map proto_rel_str rhs_neg)) ) rules_brs; ) loc_toss_rules; ); + (* }}} *) let signature = Structure.rel_signature struc in let payoffs = Aux.array_from_assoc (List.map (fun (player, payoff) -> find_player player, payoff) payoffs) in let payoffs_pp = - Array.map (fun pay -> Solver.M.register_real_expr pay) payoffs in + Array.map (fun pay -> + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Registering payoff %s...\n%!" (Formula.real_str pay) + ); + (* }}} *) + Solver.M.register_real_expr pay) payoffs in + let tossrule_data = ref Aux.StrMap.empty in + let fluents = Aux.concat_map snd dyn_rels in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "fluents: %s\n%!" (String.concat ", " fluents) + ); + (* }}} *) let rules_and_locations = let rnames = ref Aux.Strings.empty in Array.mapi (fun loc rules_brs -> let labelled_rules = - List.map (fun (lead, (rhs_pos,rhs_neg,precond)) -> + List.map (fun (lead, (var_elems,struc_elems,rhs_pos,precond)) -> let precond = Formula.And [precond; Formula.Not terminal_phi] in let rname = Aux.not_conflicting_name !rnames ((term_to_name lead) ^ "_" ^ string_of_int loc) in rnames := Aux.Strings.add rname !rnames; + let fixvar_elemvars = + List.fold_left (fun acc (evar,elem) -> + let mask, sb, m_sb, blank = term_to_blank masks elem in + List.fold_left (fun acc (path,t) -> + match t with + | Var v -> + Aux.update_assoc v [] + (Aux.update_assoc mask [] + (Aux.update_assoc path [] (Aux.cons evar))) acc + | _ -> acc + ) acc sb + ) [] var_elems in + tossrule_data := + Aux.StrMap.add rname { + lead_legal = lead; precond = precond; + fixvar_elemvars = fixvar_elemvars; + rhs_add = rhs_pos; struc_elems = struc_elems; + elemvars = Aux.strmap_of_assoc var_elems} + !tossrule_data; let next_loc = (loc + 1) mod loc_n in let label = { Arena.rule = rname; time_in = 0.1, 0.1; parameters_in = [] }, next_loc in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Translating rule %s into LHS/RHS structures...\n%!" + rname + ); + (* }}} *) let discrete = DiscreteRule.translate_from_precond ~precond - ~add:rhs_pos ~del:rhs_neg in + ~add:rhs_pos ~embed:fluents ~struc_elems in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Making rule %s of:\n%s\n%!" rname + (DiscreteRule.sprint_rule discrete) + ); + (* }}} *) let rule = ContinuousRule.make_rule signature [] discrete [] [] ~pre:discrete.DiscreteRule.pre () in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf "Rule %s done.\n%!" rname + ); + (* }}} *) label, (rname, rule) ) rules_brs in let labels, rules = List.split labelled_rules in @@ -2635,18 +2853,169 @@ cur_loc = 0; data = []; } in + let playing_as = find_player player_term in + let noop_actions = + Array.mapi (fun loc noops-> + match noops.(playing_as) with + | Some ([lead_term], _, _) -> Some lead_term + | Some ([_; lead_term], _, _) -> Some lead_term + | _ -> None + ) loc_noop_legal in (* {{{ log entry *) if !debug_level > 1 then ( Printf.printf "\n\nGDL.translate_game:\n%s\n%!" (Arena.sprint_state result) ); (* }}} *) - result + {anchor_terms = !anchor_terms; + tossrule_data = !tossrule_data; + t_elements = t_elements; + playing_as = playing_as; + noop_actions = noop_actions; + fluents = fluents; + }, result +(* + (9a) find the "lead legal" term to which the "does move" ground + term of the current player matches; -let player_name_terms = ref [|Const "uninit"|] + (9b) earlier, remember which Toss variables of a rule contain which + fixed variables at which positions in their masks; + (9c) find anchor predicates corresponding to instantiations of the + "lead legal" variables, anchoring positions found by (9b) "fixed + var" - "mask + mask var" correspondence; + (9d) build a conjunction of anchor predicates over variables that + contain the fixed variable which is "instantiated" by the anchor + of the corresponding position, as established by (9c); + + (9e) conjoin the (9d) with the "matching" formula of a rule, and + evaluate the result for all rules (of the located "lead legal" + class); only a single rule should have a match, and only a single + assignment should be returned; this rule with this assignment is + the translated move. + *) +let translate_incoming_move gdl state actions = + let loc = state.Arena.cur_loc in + let actions = Array.of_list actions in + let location = state.Arena.game.Arena.graph.(loc) in + let player_action = actions.(location.Arena.player) in + (* 9a *) + let tossrules = + Aux.strmap_filter (fun _ rdata -> + try ignore (match_meta [] [] [player_action] [rdata.lead_legal]); true + with Not_found -> false + ) gdl.tossrule_data in + let tossrules = Aux.collect + (List.map (fun (rname, rdata) -> + rdata.lead_legal, + (rname, rdata.precond, rdata.rhs_add, rdata.struc_elems, + rdata.fixvar_elemvars)) tossrules) in + let lead, tossrules = + match tossrules with + | [lead, tossrules] -> lead, tossrules + | _ -> assert false in + (* 9c *) + let fixed_inst, _ = + match_meta [] [] [player_action] [lead] in + let candidates = Aux.map_some ( + fun (rname, precond, add, struc_elems, fixvar_elemvars) -> + (* 9d *) + let anchors = Aux.concat_map (fun (v,t) -> + let elemvars = List.assoc v fixvar_elemvars in + Aux.concat_map (fun (mask, pevs) -> + Aux.concat_map (fun (path, evs) -> + let pred = List.assoc t + (List.assoc path (List.assoc mask gdl.anchor_terms)) in + List.map (fun ev-> + Formula.Rel (pred, [|Formula.fo_var_of_string + (String.lowercase ev)|])) evs) + pevs) elemvars + ) fixed_inst in + let precond = Formula.And (anchors @ [precond]) in + let rule = + DiscreteRule.translate_from_precond ~precond ~add + ~embed:gdl.fluents ~struc_elems in + let rule = + DiscreteRule.compile_rule (Structure.rel_signature state.Arena.struc) + [] rule in + let asgns = + DiscreteRule.find_matchings state.Arena.struc rule in + (* faster *) + (* let emb = + DiscreteRule.choose_match state.Arena.struc rule asgns in *) + (* but we should check whether there's no ambiguity... *) + match + DiscreteRule.enumerate_matchings state.Arena.struc rule asgns + with + | [] -> None + | [emb] -> Some (rname, emb) + | _ -> failwith + ("GDL.translate_incoming_move: match ambiguity for rule "^rname) + ) tossrules in + match candidates with + | [rname, emb] -> rname, emb + | _ -> failwith + ("GDL.translate_incoming_move: ambiguity among rules "^ + String.concat ", " (List.map fst candidates)) + + +(* + (10a) associate the rule with its corresponding data: the "lead + legal" term, the fixed variables corresponding to rule elements, + ... + + (10b) earlier, return/store the mapping from an element to the + mask and subsitution that define the element; + + (10c) earlier, for each rule store a mapping from fixed variables + to rule variables and the mask variables that in the rule variable + are instantiated by the fixed variables; + + (10d) to determine how to instantiate the fixed variables in the + "lead legal" term, find the (10b) substitutions of assigned + elements and (10c) mask variables for fixed variables; compose the + maps to get fixed variable to GDL ground term mapping, each + "route" should give the same term. + *) +let translate_outgoing_move gdl state rname emb = + (* let loc = state.Arena.cur_loc in *) + (* let location = state.Arena.game.Arena.graph.(loc) in *) + let tossrule = Aux.StrMap.find rname gdl.tossrule_data in + let rule = List.assoc rname state.Arena.game.Arena.rules in + (* 10d *) + let emb = List.map (fun (v, e) -> + let vterm = + DiscreteRule.elemvar_of_elem + rule.ContinuousRule.compiled.DiscreteRule.lhs_elem_inv_names v in + Aux.StrMap.find vterm tossrule.elemvars, + Aux.IntMap.find e gdl.t_elements) emb in + let sb = + try + List.fold_left (fun sb (v_term, e_term) -> + fst (match_meta sb [] [e_term] [v_term])) [] emb + with Not_found -> failwith + ("GDL.translate_outgoing_move: inconsistent match for rule " + ^rname) in + term_str (subst sb tossrule.lead_legal) + +let our_turn gdl state = + let loc = state.Arena.cur_loc in + gdl.playing_as = state.Arena.game.Arena.graph.(loc).Arena.player + +let noop_move ?(force=false) gdl state = + let loc = state.Arena.cur_loc in + match gdl.noop_actions.(loc) with + | Some t -> term_str t + | None when force -> + term_str (Aux.array_map_some (fun x->x) gdl.noop_actions).(0) + | None -> failwith + ("GDL.noop_move: no NOOP move for active player at location " + ^string_of_int loc) + + + let manual_translation = ref true let manual_game = ref "tictactoe" let top_exec_path = ref "." (* path to top Toss directory *) @@ -2657,54 +3026,59 @@ let pawn_whopping_descr = ref None -let initialize_game_tictactoe state player game_descr startcl = - state := state_of_file (!top_exec_path ^ "/examples/Tic-Tac-Toe.toss"); - playing_as := player; +let initialize_game_tictactoe player game_descr startcl = + let state = + state_of_file (!top_exec_path ^ "/examples/Tic-Tac-Toe.toss") in game_description := game_descr; - player_name_terms := [|Const "XPLAYER"; Const "OPLAYER"|]; - let effort, horizon, heur_adv_ratio = + let pterms = [|Const "XPLAYER"; Const "OPLAYER"|] in + let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in + let (* effort, horizon, heur_adv_ratio *) params = 6, 100, 4.0 in - effort, horizon, heur_adv_ratio + pterms, noops, state, Some params -let initialize_game_gomoku state player game_descr startcl = - state := state_of_file (!top_exec_path ^ "/examples/Gomoku.toss"); - playing_as := player; +let initialize_game_gomoku player game_descr startcl = + let state = + state_of_file (!top_exec_path ^ "/examples/Gomoku.toss") in game_description := game_descr; - player_name_terms := [|Const "X"; Const "O"|]; + let pterms = [|Const "X"; Const "O"|] in + let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in Heuristic.use_monotonic := true; - let effort, horizon, heur_adv_ratio = + let (* effort, horizon, heur_adv_ratio *) params = 4, 100, 4.0 in - effort, horizon, heur_adv_ratio + pterms, noops, state, Some params -let initialize_game_connect4 state player game_descr startcl = - state := state_of_file (!top_exec_path ^ "/examples/Connect4.toss"); - playing_as := player; +let initialize_game_connect4 player game_descr startcl = + let state = + state_of_file (!top_exec_path ^ "/examples/Connect4.toss") in game_description := game_descr; - player_name_terms := [|Const "WHITE"; Const "RED"|]; + let pterms = [|Const "WHITE"; Const "RED"|] in + let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in Heuristic.use_monotonic := false; - let effort, horizon, heur_adv_ratio = + let (* effort, horizon, heur_adv_ratio *) params = 10, 100, 4.0 in - effort, horizon, heur_adv_ratio + pterms, noops, state, Some params -let initialize_game_breakthrough state player game_descr startcl = - state := state_of_file (!top_exec_path ^ "/examples/Breakthrough.toss"); - playing_as := player; +let initialize_game_breakthrough player game_descr startcl = + let state = + state_of_file (!top_exec_path ^ "/examples/Breakthrough.toss") in game_description := game_descr; - player_name_terms := [|Const "WHITE"; Const "BLACK"|]; - let effort, horizon, heur_adv_ratio = + let pterms = [|Const "WHITE"; Const "BLACK"|] in + let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in + let (* effort, horizon, heur_adv_ratio *) params = 6, 100, 4.0 in - effort, horizon, heur_adv_ratio + pterms, noops, state, Some params -let initialize_game_pawn_whopping state player game_d... [truncated message content] |
From: <luk...@us...> - 2011-02-22 03:24:53
|
Revision: 1325 http://toss.svn.sourceforge.net/toss/?rev=1325&view=rev Author: lukaszkaiser Date: 2011-02-22 03:24:44 +0000 (Tue, 22 Feb 2011) Log Message: ----------- Split Arena.game_state to game * game_state, add GameTree file with abstract game tree types and functions. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/Arena.mli trunk/Toss/Arena/ArenaParser.mly trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDL.mli trunk/Toss/Makefile trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Makefile trunk/Toss/Play/Move.ml trunk/Toss/Play/Move.mli trunk/Toss/Server/Server.ml trunk/Toss/TossTest.ml trunk/Toss/WebClient/Handler.py Added Paths: ----------- trunk/Toss/Play/GameTree.ml trunk/Toss/Play/GameTree.mli trunk/Toss/Play/GameTreeTest.ml Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Arena/Arena.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -32,37 +32,34 @@ graph : location array; num_players : int; player_names : (string * int) list ; + data : (string * string) list ; defined_rels : (string * (string list * Formula.formula * Solver.M.registered_formula)) list ; } (* State of the game and additional information. *) type game_state = { - game : game ; struc : Structure.structure ; time : float ; cur_loc : int ; - data : (string * string) list ; } let empty_state = let emp_struc = Structure.empty_structure () in let zero = Formula.Const 0.0 in - { - game = - {rules=[]; - graph=Array.make 1 - { id = 0; player = 0; payoffs = [|zero|]; - payoffs_pp = - [|Solver.M.register_real_expr zero|]; - moves = [] }; - player_names = ["1", 0] ; - defined_rels = [] ; - num_players=1;}; - struc = emp_struc ; - time = 0.0 ; - cur_loc = 0 ; - data = [] ; + {rules=[]; + graph=Array.make 1 + { id = 0; player = 0; payoffs = [|zero|]; + payoffs_pp = + [|Solver.M.register_real_expr zero|]; + moves = [] }; + player_names = ["1", 0] ; + data = [] ; + defined_rels = [] ; + num_players=1;}, + {struc = emp_struc ; + time = 0.0 ; + cur_loc = 0 ; } @@ -168,13 +165,13 @@ | None -> [], [], [], [], Structure.empty_structure (), 0.0, 0, [] | Some state -> - state.game.rules, Array.to_list state.game.graph, + (fst state).rules, Array.to_list (fst state).graph, List.map fst (List.sort (fun (_,x) (_,y) -> x-y) - state.game.player_names), + (fst state).player_names), List.map (fun (rel, (args, body, _)) ->rel, args, body) - state.game.defined_rels, - state.struc, state.time, - state.cur_loc, state.data in + (fst state).defined_rels, + (snd state).struc, (snd state).time, + (snd state).cur_loc, (fst state).data in (* {{{ log entry *) if !debug_level > 2 then ( printf "process_definition: %d old rules, %d old locs\n%!" @@ -293,13 +290,12 @@ graph = graph; num_players = num_players; player_names = player_names; + data = data; defined_rels = defined_rels - } in { - game = game; + } in game, { struc = state; time = time; cur_loc = cur_loc; - data = data; } @@ -342,19 +338,17 @@ let equational_def_style = ref true let fprint_state ppf - { - game = { - rules = rules; - graph = graph; - num_players = num_players; - player_names = player_names; - defined_rels = defined_rels; - } ; - struc = struc; - time = time; - cur_loc = cur_loc; - data = data; - } = + ({rules = rules; + graph = graph; + num_players = num_players; + player_names = player_names; + data = data; + defined_rels = defined_rels; + }, + {struc = struc; + time = time; + cur_loc = cur_loc; + }) = Format.fprintf ppf "@[<v>"; List.iter (fun (drel, (args, body, _)) -> if !equational_def_style then @@ -389,13 +383,13 @@ fprint_state Format.str_formatter r; Format.flush_str_formatter () -let str game = sprint_state {empty_state with game=game} +let str game = sprint_state (game, snd empty_state) let state_str state = sprint_state state (* -------------------- WHOLE ARENA MANIPULATION -------------------- *) -let add_new_player state pname = - let player = state.game.num_players in +let add_new_player (state_game, state) pname = + let player = state_game.num_players in let zero = Formula.Const 0.0 in let pp_zero = Solver.M.register_real_expr zero in let add_payoff loc = @@ -403,12 +397,12 @@ payoffs = Array.append loc.payoffs [|zero|]; payoffs_pp = Array.append loc.payoffs_pp [|pp_zero|]; } in - let game = {state.game with - num_players = state.game.num_players + 1; - graph = Array.map add_payoff state.game.graph; - player_names = (pname, player)::state.game.player_names; + let game = {state_game with + num_players = state_game.num_players + 1; + graph = Array.map add_payoff state_game.graph; + player_names = (pname, player)::state_game.player_names; } in - {state with game = game}, player + (game, state), player (* ------------------ REQUESTS TO THE ARENA USED IN OPERATION --------------- *) @@ -478,7 +472,7 @@ | GetRuleNames (* Get names of all rules *) | SetTime of float * float (* Set time step and time *) | GetTime (* Get time step and time *) - | SetState of game_state (* Set the full state *) + | SetState of game * game_state (* Set the full state *) | GetModel (* Return the current model*) | GetState (* Return the state *) @@ -487,70 +481,75 @@ (* Apply function [f] to named structure at location [loc] in [state]. Include what [f] returns - changed named structure and string - and return.*) -let apply_to_loc f loc state err_msg = +let apply_to_loc f loc (state_game, state) err_msg = match loc with Struct -> let (new_struc, msg) = f state.struc in - ({ state with struc = new_struc }, msg) + ((state_game, { state with struc = new_struc }), msg) | Left rn -> ( try - let r = (List.assoc rn state.game.rules) in + let r = (List.assoc rn state_game.rules) in let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let (new_r, msg) = ContinuousRule.apply_to_side true f signat defs r in - let new_rules = Aux.replace_assoc rn new_r state.game.rules in - ({ state with game = {state.game with rules=new_rules}}, msg) - with Not_found -> - (state, "ERR [Not found] on left location of " ^ rn ^", " ^ err_msg) + let new_rules = Aux.replace_assoc rn new_r state_game.rules in + (({state_game with rules=new_rules}, state), msg) + with Not_found -> + ((state_game, state), + "ERR [Not found] on left location of " ^ rn ^", " ^ err_msg) ) | Right rn -> try - let r = (List.assoc rn state.game.rules) in + let r = (List.assoc rn state_game.rules) in let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let (new_r, msg) = ContinuousRule.apply_to_side false f signat defs r in - let new_rules = Aux.replace_assoc rn new_r state.game.rules in - ({ state with game = {state.game with rules=new_rules}}, msg) + let new_rules = Aux.replace_assoc rn new_r state_game.rules in + (({state_game with rules=new_rules}, state), msg) with Not_found -> - (state, "ERR [Not found] on right location of "^rn^", " ^ err_msg) - + ((state_game, state), + "ERR [Not found] on right location of "^rn^", " ^ err_msg) + (* Retrieve value of [f] from structure at location [loc] in [state]. *) -let get_from_loc f loc state err_msg = +let get_from_loc f loc (state_game, state) err_msg = match loc with Struct -> f state.struc | Left r_name -> ( try - let r = (List.assoc r_name state.game.rules) in + let r = (List.assoc r_name state_game.rules) in f r.ContinuousRule.discrete.DiscreteRule.lhs_struc with Not_found -> - "ERR [Not found] getting from left location of " ^ r_name ^ ", " ^ err_msg + "ERR [Not found] getting from left location of " ^ + r_name ^ ", " ^ err_msg ) | Right r_name -> try - let r = (List.assoc r_name state.game.rules) in + let r = (List.assoc r_name state_game.rules) in f r.ContinuousRule.discrete.DiscreteRule.rhs_struc with Not_found -> - "ERR [Not found] getting from right location of " ^ r_name ^ ", " ^ err_msg + "ERR [Not found] getting from right location of " ^ + r_name ^ ", " ^ err_msg (* Apply function [f] to named rule [r_name] in [state], insert and return. *) -let apply_to_rule f r_name state err_msg = +let apply_to_rule f r_name (state_game, state) err_msg = try - let r = List.assoc r_name state.game.rules in + let r = List.assoc r_name state_game.rules in let (nr, msg) = f r in - let new_rules = Aux.replace_assoc r_name nr state.game.rules in - ({ state with game = {state.game with rules=new_rules} }, msg) + let new_rules = Aux.replace_assoc r_name nr state_game.rules in + (({state_game with rules=new_rules}, state), msg) with Not_found -> - (state, "ERR [Not found] applying to rule " ^ r_name ^ ": " ^ err_msg) + ((state_game, state), + "ERR [Not found] applying to rule " ^ r_name ^ ": " ^ err_msg) (* Retrieve value of [f] from rule [r] in [state]. *) -let get_from_rule f r state err = - try f (List.assoc r state.game.rules) +let get_from_rule f r state_game err = + try f (List.assoc r state_game.rules) with Not_found -> "ERR [Not found] getting from rule " ^ r ^ ": " ^ err @@ -559,14 +558,14 @@ Structure.sig_str state.struc (* Request Handler *) -let handle_request state req = +let handle_request (state_game, state) req = let struc = state.struc in let add_new_elem struc = let struc, e = Structure.add_new_elem struc () in struc, string_of_int e in match req with AddElem loc -> - apply_to_loc add_new_elem loc state "add elem" + apply_to_loc add_new_elem loc (state_game, state) "add elem" | AddRel (loc, rel, tp) -> let add_rel struc = let struc, tp = @@ -575,191 +574,197 @@ struc, e::tp) tp (struc, []) in let tp = Array.of_list tp in Structure.add_rel struc rel tp, "REL ADDED" in - apply_to_loc add_rel loc state "add rel" + apply_to_loc add_rel loc (state_game, state) "add rel" | DelElem (loc, elem_name) -> let del_elem struc = let el = Structure.find_elem struc elem_name in Structure.del_elem struc el, "ELEM DELETED" in - apply_to_loc del_elem loc state "del elem" + apply_to_loc del_elem loc (state_game, state) "del elem" | DelRel (loc, rel, tp) -> let del_rel struc = let tp = List.map (fun n -> Structure.find_elem struc n) tp in Structure.del_rel struc rel (Array.of_list tp), "REL DELETED" in - apply_to_loc del_rel loc state "del rel" + apply_to_loc del_rel loc (state_game, state) "del rel" | GetRelSignature loc -> - (state, get_from_loc Structure.sig_str loc state "get signature") + ((state_game, state), + get_from_loc Structure.sig_str loc (state_game, state) "get signature") | GetFunSignature loc -> let fun_signature struc = let funs = Structure.f_signature struc in String.concat "; " funs in - (state, get_from_loc fun_signature loc state "get signature") + ((state_game,state), + get_from_loc fun_signature loc (state_game, state) "get signature") | GetAllTuples (loc, rel) -> let tuples struc = let tps = Structure.StringMap.find rel struc.Structure.relations in Structure.rel_str struc rel tps in - (state, get_from_loc tuples loc state "get all tuples") + ((state_game, state), + get_from_loc tuples loc (state_game, state) "get all tuples") | GetAllElems loc -> let elems struc = let els = Structure.Elems.elements struc.Structure.elements in let el_name e = Structure.elem_str struc e in String.concat "; " (List.map el_name els) in - (state, get_from_loc elems loc state "get all elements") + ((state_game, state), + get_from_loc elems loc (state_game, state) "get all elements") | SetFun (loc, funct, el_name, v) -> let set_fun struc = let el = Structure.find_elem struc el_name in Structure.add_fun struc funct (el, v), "FUN SET" in - apply_to_loc set_fun loc state "set fun" + apply_to_loc set_fun loc (state_game, state) "set fun" | GetFun (loc, funct, el_name) -> let get_fun struc = let el = Structure.find_elem struc el_name in string_of_float (Structure.fun_val struc funct el) in - (state, get_from_loc get_fun loc state "get fun") + ((state_game, state), + get_from_loc get_fun loc (state_game, state) "get fun") | SetData (key, v) -> - let ndata = Aux.replace_assoc key v state.data in - ({ state with data = ndata }, "SET DATA") + let ndata = Aux.replace_assoc key v state_game.data in + (({state_game with data = ndata }, state), "SET DATA") | GetData (key) -> ( - try (state, List.assoc key state.data) - with Not_found -> (state, "ERR no data") + try ((state_game, state), List.assoc key state_game.data) + with Not_found -> ((state_game, state), "ERR no data") ) | SetArity (rel, ar) -> if (try Structure.StringMap.find rel struc.Structure.rel_signature = ar with Not_found -> false) - then state, "SET ARITY" + then (state_game, state), "SET ARITY" else let s = Structure.force_add_rel_name rel ar struc in - ({ state with struc = s }, "SET ARITY") + ((state_game, { state with struc = s }), "SET ARITY") | GetArity (rel) -> ( - if rel = "" then (state, sig_str state) else - try (state, string_of_int + if rel = "" then ((state_game, state), sig_str state) else + try ((state_game, state), string_of_int (Structure.StringMap.find rel state.struc.Structure.rel_signature)) with Not_found -> - (state, "ERR relation "^rel^" arity not found") + ((state_game, state), "ERR relation "^rel^" arity not found") ) | RenamePlayer (old_name, new_name) -> let player, player_names = - Aux.pop_assoc old_name state.game.player_names in - {state with game = - {state.game with player_names = - (new_name, player)::player_names}}, - "PLAYER renamed" + Aux.pop_assoc old_name state_game.player_names in + ({state_game with player_names = (new_name, player)::player_names}, + state), "PLAYER renamed" | SetLoc (i) -> - let l = Array.length state.game.graph in + let l = Array.length state_game.graph in if i < 0 || i > l then (* make new location and set there *) let a = Array.make 1 { id = l; player=0; payoffs=[| |]; payoffs_pp=[| |]; moves=[] } in - ({state with game = - {state.game with graph=Array.append state.game.graph a}; - cur_loc = l }, + (({state_game with graph=Array.append state_game.graph a}, + {state with cur_loc = l }), "NEW LOC ADDED AND CUR LOC SET TO " ^ (string_of_int l)) else - ({ state with cur_loc = i }, "CUR LOC SET") - | GetLoc -> - (state, (string_of_int state.cur_loc) ^ " / " ^ - (string_of_int (Array.length state.game.graph))) + ((state_game, { state with cur_loc = i }), "CUR LOC SET") + | GetLoc -> + ((state_game, state), (string_of_int state.cur_loc) ^ " / " ^ + (string_of_int (Array.length state_game.graph))) | SetLocPlayer (i, player) -> - let state, player = - try state, List.assoc player state.game.player_names - with Not_found -> add_new_player state player in - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + let (state_game, state), player = + try (state_game, state), List.assoc player state_game.player_names + with Not_found -> add_new_player (state_game, state) player in + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( - state.game.graph.(i) <- - { state.game.graph.(i) with player = player }; - (state, "LOC PLAYER SET") + state_game.graph.(i) <- + { state_game.graph.(i) with player = player }; + ((state_game, state), "LOC PLAYER SET") ) | GetLocPlayer (i) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") - else (state, Aux.rev_assoc state.game.player_names - state.game.graph.(i).player) + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") + else ((state_game, state), Aux.rev_assoc state_game.player_names + state_game.graph.(i).player) | SetLocPayoff (i, player, payoff) -> - let state, player = - try state, List.assoc player state.game.player_names - with Not_found -> add_new_player state player in - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + let (state_game, state), player = + try (state_game, state), List.assoc player state_game.player_names + with Not_found -> add_new_player (state_game, state) player in + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( let simp_payoff = FormulaOps.tnf_re payoff in - state.game.graph.(i).payoffs.(player) <- simp_payoff; - (state, "LOC PAYOFF SET") + state_game.graph.(i).payoffs.(player) <- simp_payoff; + ((state_game, state), "LOC PAYOFF SET") ) | GetLocPayoff (i, player) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( try - (state, Formula.real_str - state.game.graph.(i).payoffs.(List.assoc player - state.game.player_names)) - with Not_found -> (state, "0.0") + ((state_game, state), Formula.real_str + state_game.graph.(i).payoffs.(List.assoc player + state_game.player_names)) + with Not_found -> ((state_game, state), "0.0") ) | GetCurPayoffs -> let payoffs = Array.to_list (Array.mapi (fun i v->string_of_int i,v) - state.game.graph.(state.cur_loc).payoffs_pp) in + state_game.graph.(state.cur_loc).payoffs_pp) in let ev (p,e) = p^": "^(string_of_float (Solver.M.get_real_val e struc)) in - (state, String.concat ", " (List.sort compare (List.map ev payoffs))) + ((state_game, state), + String.concat ", " (List.sort compare (List.map ev payoffs))) | SetLocMoves (i, moves) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( - state.game.graph.(i) <- { state.game.graph.(i) with moves = moves }; - (state, "LOC MOVES SET") + state_game.graph.(i) <- { state_game.graph.(i) with moves = moves }; + ((state_game, state), "LOC MOVES SET") ) | GetLocMoves (i) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") - else (state, (String.concat "; " - (List.map move_str state.game.graph.(i).moves))) + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") + else ((state_game, state), + (String.concat "; " (List.map move_str state_game.graph.(i).moves))) | SuggestLocMoves _ -> failwith "handle_req: SuggestLocMoves handled in Server" - | EvalFormula (phi) -> (state, "ERR eval not yet implemented") - | EvalRealExpr (rexpr) -> (state, "ERR eval real not yet implemented") + | EvalFormula (phi) -> ((state_game, state), "ERR eval not yet implemented") + | EvalRealExpr (rexpr) -> + ((state_game, state), "ERR eval real not yet implemented") | SetRule (r_name, r) -> ( try let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let new_rules = Aux.replace_assoc r_name (r signat defs r_name) - state.game.rules in - ({ state with game = {state.game with rules=new_rules} }, "SET RULE") + state_game.rules in + (({state_game with rules=new_rules}, state), "SET RULE") with - Not_found -> - (state, "ERR [Not found] setting rule "^r_name^" failed") + Not_found -> ((state_game, state), + "ERR [Not found] setting rule "^r_name^" failed") ) | GetRule (r_name) -> - let msg = get_from_rule ContinuousRule.str r_name state "get rule" in - (state, msg) + let msg = get_from_rule ContinuousRule.str r_name state_game "get rule" in + ((state_game, state), msg) | SetRuleUpd (r_name, f, elem_name, term) -> let set_upd r = let new_upd = Aux.replace_assoc (f,elem_name) term r.ContinuousRule.update in { r with ContinuousRule.update = new_upd }, "UPDATE SET" in - apply_to_rule set_upd r_name state "set rule upd" + apply_to_rule set_upd r_name (state_game, state) "set rule upd" | GetRuleUpd (r_name, f, elem_name) -> let get_upd r = try let upd = List.assoc (f,elem_name) r.ContinuousRule.update in Term.str upd with Not_found -> "0.0" in - (state, get_from_rule get_upd r_name state "get rule upd") + ((state_game, state), + get_from_rule get_upd r_name state_game "get rule upd") | SetRuleDyn (r_name, f, elem_name, term) -> let set_dyn r = let new_dyn = Aux.replace_assoc (f,elem_name) term r.ContinuousRule.dynamics in { r with ContinuousRule.dynamics = new_dyn },"DYNAMICS SET" in - apply_to_rule set_dyn r_name state "set rule dyn" + apply_to_rule set_dyn r_name (state_game, state) "set rule dyn" | GetRuleDyn (r_name, f, elem_name) -> let get_dyn r = try let dyn = List.assoc (f,elem_name) r.ContinuousRule.dynamics in Term.str dyn with Not_found -> "0.0" in - (state, get_from_rule get_dyn r_name state "get rule dyn") + ((state_game, state), + get_from_rule get_dyn r_name state_game "get rule dyn") | SetRuleCond (r_name, pre, inv, post) -> let set_cond r = let d = r.ContinuousRule.discrete in @@ -767,17 +772,18 @@ let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let nr = (* TODO: rename lhs_* relations to be consistent with ln *) ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in (nr, "RULE COND SET") in - apply_to_rule set_cond r_name state "set rule cond" + apply_to_rule set_cond r_name (state_game, state) "set rule cond" | GetRuleCond (r_name) -> let get_cond r = let pre = r.ContinuousRule.discrete.DiscreteRule.pre in let (inv, post)=(r.ContinuousRule.inv, r.ContinuousRule.post) in (Formula.str pre)^"; "^ (Formula.str inv) ^"; "^ (Formula.str post) in - (state, get_from_rule get_cond r_name state "get rule cond") + ((state_game, state), + get_from_rule get_cond r_name state_game "get rule cond") | SetRuleEmb (r_name, emb) -> let set_emb r = @@ -790,15 +796,16 @@ let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let nr = ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in (nr, "RULE EMB SET") in - apply_to_rule set_emb r_name state "set rule emb" + apply_to_rule set_emb r_name (state_game, state) "set rule emb" | GetRuleEmb (r_name) -> let get_emb r = String.concat ", " r.ContinuousRule.discrete.DiscreteRule.emb_rels in - (state, get_from_rule get_emb r_name state "get rule emb") + ((state_game, state), + get_from_rule get_emb r_name state_game "get rule emb") | SetRuleAssoc (r_name, r_elem_name, rassoc) -> let set_assoc r = let lname l = Structure.find_elem (ContinuousRule.lhs r) l in @@ -816,11 +823,11 @@ let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let nr = ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in (nr, "RULE ASSOC SET") in - apply_to_rule set_assoc r_name state "set rule assoc" + apply_to_rule set_assoc r_name (state_game, state) "set rule assoc" | GetRuleAssoc (r_name, r_elem_name) -> let get_assoc r = let assoc = r.ContinuousRule.discrete.DiscreteRule.rule_s in @@ -829,22 +836,23 @@ let rassoc = List.filter (fun (r, l) -> r = relem) assoc in let l e = Structure.elem_str (ContinuousRule.lhs r) e in String.concat ", " (List.map (fun (_, le) -> l le) rassoc) in - (state, get_from_rule get_assoc r_name state "get rule assoc") + ((state_game, state), + get_from_rule get_assoc r_name state_game "get rule assoc") | GetRuleMatches (r_name) -> ( try - let r = List.assoc r_name state.game.rules in + let r = List.assoc r_name state_game.rules in let matches = ContinuousRule.matches_post struc r state.time in (* matches are from LHS to model *) let name (lhs,rhs) = Structure.elem_str (ContinuousRule.lhs r) lhs ^ " -> " ^ Structure.elem_str struc rhs in let mname m = String.concat ", " (List.map name m) in - (state, String.concat "; " (List.map mname matches)) + ((state_game, state), String.concat "; " (List.map mname matches)) with Not_found -> - (state, "ERR getting "^r_name^" matches, rule not found") + ((state_game, state), "ERR getting "^r_name^" matches, rule not found") ) | ApplyRule (r_name, mtch, t, p) -> - (let try r = List.assoc r_name state.game.rules in + (let try r = List.assoc r_name state_game.rules in let lhs_struc = ContinuousRule.lhs r in let m = List.map (fun (l, s) -> Structure.find_elem lhs_struc l, @@ -856,31 +864,38 @@ (* we've moved to using element names in Term *) f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in let shifts_s = String.concat "; " (List.map val_str shifts) in - ({state with struc = new_struc; time = new_time}, shifts_s) - | None -> (state, "ERR applying "^r_name^", postcondition fails") - with Not_found -> (state, "ERR applying "^r_name^", rule not found") + ((state_game, {state with struc = new_struc; time = new_time}), + shifts_s) + | None -> ((state_game, state), + "ERR applying "^r_name^", postcondition fails") + with Not_found -> + ((state_game, state), "ERR applying "^r_name^", rule not found") ) | ApplyRuleInt (r_name, mtch, t, p) -> - (let try r = List.assoc r_name state.game.rules in + (let try r = List.assoc r_name state_game.rules in match ContinuousRule.rewrite_single struc state.time mtch r t p with | Some (new_struc, new_time, shifts) -> - let val_str ((f, e), tl) = - let ts t = string_of_float (Term.term_val t) in - (* we've moved to using element names in Term *) - f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in + let val_str ((f, e), tl) = + let ts t = string_of_float (Term.term_val t) in + (* we've moved to using element names in Term *) + f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in let shifts_s = String.concat "; " (List.map val_str shifts) in - ({state with struc = new_struc; time = new_time}, shifts_s) - | None -> (state, "ERR applying "^r_name^", postcondition fails") - with Not_found -> (state, "ERR applying "^r_name^", rule not found") + ((state_game, {state with struc = new_struc; time = new_time}), + shifts_s) + | None -> ((state_game, state), + "ERR applying " ^ r_name ^ ", postcondition fails") + with Not_found -> + ((state_game, state), "ERR applying " ^ r_name ^ ", rule not found") ) - | GetRuleNames -> (state, String.concat "; " (fst (List.split state.game.rules))) + | GetRuleNames -> ((state_game, state), + String.concat "; " (fst (List.split state_game.rules))) | SetTime (tstep, t) -> ContinuousRule.set_time_step tstep; - ({ state with time = t }, "TIME SET") + ((state_game, { state with time = t }), "TIME SET") | GetTime -> let (ts, t) = (ContinuousRule.get_time_step (), state.time) in - (state, string_of_float (ts) ^ " / " ^ string_of_float (t)) - | SetState s -> - (s, "STATE SET") - | GetModel -> (state, Structure.sprint state.struc) - | GetState -> (state, state_str state) + ((state_game, state), string_of_float (ts) ^ " / " ^ string_of_float (t)) + | SetState (g, s) -> + ((g, s), "STATE SET") + | GetModel -> ((state_game, state), Structure.sprint state.struc) + | GetState -> ((state_game, state), state_str (state_game, state)) Modified: trunk/Toss/Arena/Arena.mli =================================================================== --- trunk/Toss/Arena/Arena.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Arena/Arena.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -28,20 +28,19 @@ graph : location array; num_players : int; player_names : (string * int) list ; + data : (string * string) list ; defined_rels : (string * (string list * Formula.formula * Solver.M.registered_formula)) list ; } (** State of the game. *) type game_state = { - game : game ; struc : Structure.structure ; time : float ; cur_loc : int ; - data : (string * string) list ; } -val empty_state : game_state +val empty_state : game * game_state (** Rules with which a player with given number can move. *) val rules_for_player : int -> game -> string list @@ -57,15 +56,15 @@ val str : game -> string (** Print the whole state: the game, structure, time and aux data. *) -val state_str : game_state -> string +val state_str : game * game_state -> string (** Whether to print relation definitions as equations, or using the C syntax. Defaults to [true]. *) val equational_def_style : bool ref -val fprint_state : Format.formatter -> game_state -> unit -val print_state : game_state -> unit -val sprint_state : game_state -> string +val fprint_state : Format.formatter -> game * game_state -> unit +val print_state : game * game_state -> unit +val sprint_state : game * game_state -> string (** The order of following entries matters: [DefPlayers] adds more players, with consecutive numbers starting from first available; @@ -109,7 +108,7 @@ (** Create a game state, possibly by extending an old state, from a list of definitions (usually corresponding to a ".toss" file.) *) val process_definition : - ?extend_state:game_state -> definition list -> game_state + ?extend_state:game * game_state -> definition list -> game * game_state (** ------------------ REQUESTS TO THE ARENA USED IN OPERATION --------------- *) @@ -178,8 +177,9 @@ | GetRuleNames (** Get names of rules *) | SetTime of float * float (** Set time step and time *) | GetTime (** Get time step and time *) - | SetState of game_state (** Set the full state *) + | SetState of game * game_state (** Set the full state *) | GetModel (** Return the model *) | GetState (** Return the state *) -val handle_request : game_state -> request -> game_state * string +val handle_request : + game * game_state -> request -> (game * game_state) * string Modified: trunk/Toss/Arena/ArenaParser.mly =================================================================== --- trunk/Toss/Arena/ArenaParser.mly 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Arena/ArenaParser.mly 2011-02-22 03:24:44 UTC (rev 1325) @@ -14,8 +14,8 @@ %type <Arena.struct_loc> struct_location %type <(string * int) list -> Arena.location> location %type <Arena.definition> parse_game_defs -%type <Arena.game_state> parse_game_state game_state -%type <Arena.game_state -> Arena.game_state> extend_game_state +%type <Arena.game * Arena.game_state> parse_game_state game_state +%type <Arena.game * Arena.game_state -> Arena.game * Arena.game_state> extend_game_state %% @@ -134,7 +134,7 @@ | SET_CMD SIG_MOD id_int INT { SetArity ($3, $4) } | GET_CMD SIG_MOD { GetArity ("") } | GET_CMD SIG_MOD id_int { GetArity ($3) } - | SET_CMD STATE_SPEC gs=game_state { SetState gs } + | SET_CMD STATE_SPEC gs=game_state { let (g, s) = gs in SetState (g, s) } | GET_CMD STATE_SPEC { GetState } | GET_CMD MODEL_SPEC { GetModel } | ADD_CMD ELEM_MOD struct_location Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Formula/Aux.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -46,6 +46,9 @@ (* {2 Helper functions on lists and other functions lacking from the standard library.} *) + +let random_elem l = List.nth l (Random.int (List.length l)) + let concat_map f l = let rec cmap_f accu = function | [] -> accu Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Formula/Aux.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -30,6 +30,9 @@ (** {2 Helper functions on lists and other functions lacking from the standard library.} *) +(** Random element of a list. *) +val random_elem : 'a list -> 'a + (** Concatenate results of a function. *) val concat_map : ('a -> 'b list) -> 'a list -> 'b list Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/GGP/GDL.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -2845,13 +2845,12 @@ graph = locations; num_players = players_n; player_names = player_names; + data = []; defined_rels = []} in - let result = { - Arena.game = game; - struc = struc; + let result = game, { + Arena.struc = struc; time = 0.; cur_loc = 0; - data = []; } in let playing_as = find_player player_term in let noop_actions = @@ -2897,9 +2896,9 @@ the translated move. *) let translate_incoming_move gdl state actions = - let loc = state.Arena.cur_loc in + let loc = (snd state).Arena.cur_loc in let actions = Array.of_list actions in - let location = state.Arena.game.Arena.graph.(loc) in + let location = (fst state).Arena.graph.(loc) in let player_action = actions.(location.Arena.player) in (* 9a *) let tossrules = @@ -2937,17 +2936,16 @@ let rule = DiscreteRule.translate_from_precond ~precond ~add ~embed:gdl.fluents ~struc_elems in - let rule = - DiscreteRule.compile_rule (Structure.rel_signature state.Arena.struc) - [] rule in + let rule = DiscreteRule.compile_rule + (Structure.rel_signature (snd state).Arena.struc) [] rule in let asgns = - DiscreteRule.find_matchings state.Arena.struc rule in + DiscreteRule.find_matchings (snd state).Arena.struc rule in (* faster *) (* let emb = - DiscreteRule.choose_match state.Arena.struc rule asgns in *) + DiscreteRule.choose_match (snd state).Arena.struc rule asgns in *) (* but we should check whether there's no ambiguity... *) match - DiscreteRule.enumerate_matchings state.Arena.struc rule asgns + DiscreteRule.enumerate_matchings (snd state).Arena.struc rule asgns with | [] -> None | [emb] -> Some (rname, emb) @@ -2980,10 +2978,10 @@ "route" should give the same term. *) let translate_outgoing_move gdl state rname emb = - (* let loc = state.Arena.cur_loc in *) - (* let location = state.Arena.game.Arena.graph.(loc) in *) + (* let loc = (snd state).Arena.cur_loc in *) + (* let location = (fst state).Arena.graph.(loc) in *) let tossrule = Aux.StrMap.find rname gdl.tossrule_data in - let rule = List.assoc rname state.Arena.game.Arena.rules in + let rule = List.assoc rname (fst state).Arena.rules in (* 10d *) let emb = List.map (fun (v, e) -> let vterm = @@ -3001,8 +2999,8 @@ term_str (subst sb tossrule.lead_legal) let our_turn gdl state = - let loc = state.Arena.cur_loc in - gdl.playing_as = state.Arena.game.Arena.graph.(loc).Arena.player + let loc = (snd state).Arena.cur_loc in + gdl.playing_as = (fst state).Arena.graph.(loc).Arena.player let noop_move ?(force=false) gdl state = let loc = state.Arena.cur_loc in @@ -3235,15 +3233,15 @@ | "connect5" -> translate_last_action_gomoku actions | "connect4" -> - translate_last_action_connect4 state.Arena.struc actions + translate_last_action_connect4 (snd state).Arena.struc actions | "breakthrough" -> translate_last_action_breakthrough actions | "pawn_whopping" -> translate_last_action_pawn_whopping actions | game -> failwith ("GDL: manual translation of unknown game "^game) in - let {Arena.rules=rules; graph=graph} = state.Arena.game in - let struc = state.Arena.struc in + let {Arena.rules=rules; graph=graph} = fst state in + let struc = (snd state).Arena.struc in let fn s n = try Structure.find_elem s n with Not_found -> failwith @@ -3262,14 +3260,14 @@ else translate_incoming_move gdl_translation state actions let translate_move_tictactoe rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in let elem = snd (List.hd emb) in let c, r = Structure.board_elem_coords (Structure.elem_str struc elem) in Printf.sprintf "(MARK %d %d)" c r let translate_move_gomoku rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in let elem = snd (List.hd emb) in let c, r = Structure.board_elem_coords (Structure.elem_str struc elem) in @@ -3277,14 +3275,14 @@ Printf.sprintf "(MARK %c %c)" cs rs let translate_move_connect4 rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in let elem = snd (List.hd emb) in let c, _ = Structure.board_elem_coords (Structure.elem_str struc elem) in Printf.sprintf "(DROP %d)" c let translate_move_breakthrough rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in match emb with | [(_,a); (_,b)] -> let a, b = if rule = "BlackStraight" then a, b else b, a in @@ -3296,7 +3294,7 @@ | _ -> assert false let translate_move_pawn_whopping rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in match emb with | [(_,a); (_,b)] -> let a, b = Modified: trunk/Toss/GGP/GDL.mli =================================================================== --- trunk/Toss/GGP/GDL.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/GGP/GDL.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -81,7 +81,8 @@ term list * (term list list list * term list list) val translate_game : - term -> game_descr_entry list -> gdl_translation * Arena.game_state + term -> game_descr_entry list -> + gdl_translation * (Arena.game * Arena.game_state) (* DEBUG intermediate *) val defs_of_rules : gdl_rule list -> exp_def list @@ -90,19 +91,18 @@ val initialize_game : term -> game_descr_entry list -> int -> - Arena.game_state * (int * int * float) option * gdl_translation + (Arena.game * Arena.game_state) * (int * int * float) option * gdl_translation val translate_last_action : - gdl_translation -> Arena.game_state -> term list -> + gdl_translation -> Arena.game * Arena.game_state -> term list -> string * DiscreteRule.matching (** Rule name, embedding, game state. *) -val translate_move : - gdl_translation -> Arena.game_state -> string -> (int * int) list -> - string +val translate_move : gdl_translation -> Arena.game * Arena.game_state -> + string -> (int * int) list -> string val our_turn : - gdl_translation -> Arena.game_state -> bool + gdl_translation -> Arena.game * Arena.game_state -> bool val noop_move : ?force:bool -> gdl_translation -> Arena.game_state -> string Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Makefile 2011-02-22 03:24:44 UTC (rev 1325) @@ -120,6 +120,7 @@ Play_tests: \ Play/HeuristicTest \ Play/MoveTest \ + Play/GameTreeTest \ Play/GameTest # GGP tests Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Play/Game.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -72,7 +72,8 @@ let gen_models rules models time moves = let (mv, a) = Move.gen_models rules models time moves in - (mv, Array.map (fun (l, m, t) -> {struc=m; time=t; loc=l}) a) + (mv, Array.map (fun s -> {struc=s.Arena.struc; + time=s.Arena.time; loc=s.Arena.cur_loc}) a) type uctree_node = { @@ -1112,6 +1113,7 @@ {Arena.rules = []; player_names = game.Arena.player_names; defined_rels = game.Arena.defined_rels; + data = game.Arena.data; graph = [| {Arena.id=0; player=gloc.Arena.player; payoffs=heuristics.(gloc.Arena.id); @@ -1165,36 +1167,35 @@ let initialize_default state ?loc ?(effort=default_effort) ~search_method ?horizon ?advr ?(payoffs_already_tnf=false) ?heuristic () = - let {Arena.rules=rules; graph=graph; num_players=num_players} = - state.Arena.game in - let struc = state.Arena.struc in + let {Arena.rules=rules; graph=graph; num_players=num_players} = fst state in + let struc = (snd state).Arena.struc in (* {{{ log entry *) if !debug_level > 0 then printf "\ninitializing game and play\n%!"; (* }}} *) (* TODO: default_heuristic redoes payoff normalization. *) - let game = state.Arena.game in + let game = fst state in let agent = match search_method with | "maximax" -> - default_maximax state.Arena.struc ~depth:effort ?heuristic + default_maximax struc ~depth:effort ?heuristic ?advr ~pruning:false game | "alpha_beta_ord" -> - default_maximax state.Arena.struc ~depth:effort ?heuristic + default_maximax struc ~depth:effort ?heuristic ?advr ~pruning:true game | "uct_random_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~random_playout:true game | "uct_greedy_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~random_playout:false game | "uct_maximax_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~random_playout:false ~playout_mm_depth:1 game | "uct_no_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~heur_effect:Heuristic_only game | s -> failwith ("Game.initialize: unknown search method "^s) Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Play/Game.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -174,7 +174,7 @@ Construct a default UCT tree search or plain maximax agent for use with the general {!toss} function. *) val initialize_default : - Arena.game_state -> ?loc:int -> ?effort:int -> + Arena.game * Arena.game_state -> ?loc:int -> ?effort:int -> search_method:string -> ?horizon:int -> ?advr:float -> ?payoffs_already_tnf:bool -> ?heuristic:Formula.real_expr array array -> Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Play/GameTest.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -46,10 +46,11 @@ let move_gs_str = Move.move_gs_str_short let update_game ?(defs=false) - (lazy (horizon, adv_ratio, game)) state cur_loc = - let state = - if defs then defstruc_of_str state else struc_of_str state in - horizon, adv_ratio, {game with Arena.struc = state; cur_loc = cur_loc} + (lazy (horizon, adv_ratio, (state_game, state))) new_struc_s new_loc = + let new_struc = + if defs then defstruc_of_str new_struc_s else struc_of_str new_struc_s in + horizon, adv_ratio, + (state_game, {state with Arena.struc = new_struc; cur_loc = new_loc}) let rec binary_to_assoc = function @@ -189,7 +190,7 @@ String.concat ", " (List.map (fun (p,v)->p^": "^string_of_float v) pay) -let try_n_times n state compute_move pred comment = +let try_n_times n (state_game, state) compute_move pred comment = let hist = ref 0 in let failed = ref [] in for i = 1 to n do @@ -218,7 +219,7 @@ try_n_times 5 state compute_move pred msg else let move, _ = compute_move () in - let move_str = move_gs_str state move in + let move_str = move_gs_str (snd state) move in assert_bool (Printf.sprintf "%s: Failed move: %s." msg move_str) (pred move_str) @@ -292,8 +293,7 @@ skip_if true "loading takes long, worked last time"; let _, advr, state = Lazy.force chess_game in - let struc = state.Arena.struc in - let game = state.Arena.game in + let (game, struc) = (fst state, (snd state).Arena.struc) in let play = {Game.game = game; agents= [|Game.Random_move; Game.Random_move|]; @@ -340,17 +340,17 @@ Game.toss ~grid_size:Move.cGRID_SIZE p ps) in assert_equal ~msg:"black wins: suggest" ~printer:(function | Aux.Left (bpos, moves, _, _) -> - "game not over: "^move_gs_str state moves.(bpos) + "game not over: "^move_gs_str (snd state) moves.(bpos) | Aux.Right poffs -> Printf.sprintf "{W: %F; B: %F}" poffs.(0) poffs.(1)) (Aux.Right [| -1.0; 1.0 |]) move_opt; let payoffs = Array.to_list (Array.mapi (fun i v->string_of_int i,v) - state.Arena.game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs_pp) - in + (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs_pp) + in let ev (p,e) = p^": "^(string_of_float - (Solver.M.get_real_val e state.Arena.struc)) in + (Solver.M.get_real_val e (snd state).Arena.struc)) in let answ = String.concat ", " (List.sort compare (List.map ev payoffs)) in assert_equal ~msg:"black wins: direct" ~printer:(fun x->x) @@ -384,11 +384,11 @@ let payoffs = Array.to_list (Array.mapi (fun i v->string_of_int i,v) - state.Arena.game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs_pp) + (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs_pp) in let ev (p,e) = p^": "^(string_of_float - (Solver.M.get_real_val e state.Arena.struc)) in + (Solver.M.get_real_val e (snd state).Arena.struc)) in let answ = String.concat ", " (List.sort compare (List.map ev payoffs)) in assert_equal ~msg:"draw (white no move): direct" ~printer:(fun x->x) @@ -401,7 +401,7 @@ Game.toss ~grid_size:Move.cGRID_SIZE p ps) in assert_equal ~msg:"draw (white no move): suggest" ~printer:(function | Aux.Left (bpos, moves, _, _) -> - "game not over: "^move_gs_str state moves.(bpos) + "game not over: "^ move_gs_str (snd state) moves.(bpos) | Aux.Right poffs -> Printf.sprintf "{W: %F; B: %F}" poffs.(0) poffs.(1)) (Aux.Right [| 0.0; 0.0 |]) move_opt; @@ -411,8 +411,8 @@ (fun () -> let horizon, advr, state = Lazy.force breakthrough_game in - let r = List.assoc "WhiteDiag" state.Arena.game.Arena.rules in - let matches = ContinuousRule.matches state.Arena.struc r in + let r = List.assoc "WhiteDiag" (fst state).Arena.rules in + let matches = ContinuousRule.matches (snd state).Arena.struc r in assert_bool "Diagonal move should be possible." (matches <> []) ); @@ -436,12 +436,12 @@ state_of_str "#TestGame.ml:play with horizon#RULE 1: [ | | ] -> [ 1 | R:2{} | ] emb R with [] LOC 0 {PLAYER 1 PAYOFF {1: 0.0} MOVES [1, t: 1. -- 1.-> 0]} PLAYERS 1 MODEL [ | R:2 {} | ]" in let play = { - Game.game = state.Arena.game; + Game.game = fst state; agents = [| Game.Random_move |]; delta = 1.0; } in let init = - Game.initial_state play state.Arena.struc in + Game.initial_state play (snd state).Arena.struc in let endmodel, _ = Game.play ~grid_size:1 ~horizon:300 play init in assert_equal ~printer:string_of_int 300 @@ -908,17 +908,17 @@ (fun () -> let (horizon, advr, state) = Lazy.force chess_game in - let struc = state.Arena.struc in - let game = state.Arena.game in + let struc = (snd state).Arena.struc in + let game = fst state in (* TODO: default_heuristic redoes payoff normalization. *) (* default_treesearch uses horizon, but default_maximax doesn't *) let play = {Game.game = game; agents= [| - Game.default_maximax state.Arena.struc ~depth:1 + Game.default_maximax (snd state).Arena.struc ~depth:1 ~heuristic:chess_piece_value_heur ~advr ~pruning:true game; - Game.default_maximax state.Arena.struc ~depth:2 + Game.default_maximax (snd state).Arena.struc ~depth:2 ~heuristic:chess_piece_value_heur ~advr ~pruning:true game; |]; Added: trunk/Toss/Play/GameTree.ml =================================================================== --- trunk/Toss/Play/GameTree.ml (rev 0) +++ trunk/Toss/Play/GameTree.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -0,0 +1,186 @@ +(* Game Tree used for choosing moves. *) + + +(* Abstract game tree, just stores state and move information. *) +type ('a, 'b) abstract_game_tree = + | Terminal of Arena.game_state * int * 'b (* terminal state with player *) + | Leaf of Arena.game_state * int * 'a (* leaf with state, player *) + | Node of Arena.game_state * int * 'a * (* node with state, player, moves *) + (Move.move * ('a, 'b) abstract_game_tree) array + +(* Abstract tree printing function. *) +let rec str_abstract ?(depth=0) str_info str_info_terminal tree = + let s msg state player info_s = + let struc_s = Structure.str state.Arena.struc in + let head_s = Printf.sprintf "Player %d loc %d time %.1f.\n" + player state.Arena.cur_loc state.Arena.time in + let res = "\n" ^ msg ^ head_s ^ struc_s ^ "\n" ^ info_s in + let prefix = if depth=0 then "" else (String.make depth '|') ^ " " in + Str.global_replace (Str.regexp "\n") ("\n" ^ prefix) res in + match tree with + | Terminal (state, player, info) -> + s "Terminal. " state player (str_info_terminal info) + | Leaf (state, player, info) -> s "Leaf. " state player (str_info info) + | Node (state, player, info, children) -> + let next_str (_, t) = + str_abstract ~depth:(depth+1) str_info str_info_terminal t in + let child_s = Array.to_list (Array.map next_str children) in + String.concat "" ((s "Node. " state player (str_info info)) :: child_s) + +(* Number of nodes in the tree. *) +let rec size = function + | Terminal _ | Leaf _ -> 1 + | Node (_, _, _, children) -> + Array.fold_left (fun s (_, c) -> s + (size c)) 1 children + +(* Player in the given node. *) +let player = function + | Terminal (_, player, _) -> player + | Leaf (_, player, _) -> player + | Node (_, player, _, _) -> player + +(* State in the given node. *) +let state = function + | Terminal (state, _, _) -> state + | Leaf (state, _, _) -> state + | Node (state, _, _, _) -> state + + +(* Abstract game tree initialization. *) +let init_abstract game state info_leaf = + let player = game.Arena.graph.(state.Arena.cur_loc).Arena.player in + Leaf (state, player, info_leaf game state player) + + +(* Abstract game tree unfolding function, calls argument functions for work. *) +let rec unfold_abstract ?(depth=0) game + ~info_terminal ~info_leaf ~info_node ~choice = function + | Terminal _ as t -> t + | Leaf (state, player, info) -> + let moves = Move.list_moves game state in + if moves = [||] then + Terminal (state, player, info_terminal depth game state player info) + else + let leaf_of_move leaf_s = + let leaf_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in + Leaf (leaf_s, leaf_pl, info_leaf (depth+1) game leaf_s leaf_pl) in + let children = Array.map (fun (m, s) -> (m, leaf_of_move s)) moves in + Node (state, player,info_node depth game state player children,children) + | Node (state, player, info, children) -> + let n = choice depth game state player info children in + let (move, child) = children.(n) in + let child_unfolded = unfold_abstract ~depth:(depth+1) game + ~info_terminal:info_terminal ~info_leaf:info_leaf ~info_node:info_node + ~choice:choice child in + children.(n) <- (move, child_unfolded); + Node (state, player, info_node depth game state player children, children) + + +(* -------------- TREES WITH PAYOFF AND HEURISTIC DATA --------------- *) + +let cPAYOFF_AS_HEUR = ref 1000. + +(* The general information in a game tree node. *) +type 'a node_info = { + heurs : float array ; (* Heuristic calculated directly or by maximax. *) + info : 'a ; (* Other information. *) +} + +type 'a terminal_info = { + payoffs : float array ; (* Payoffs. *) + heurs_t : float array ; (* Heuristic. *) + info_t : 'a ; (* Other information. *) +} + +type 'a game_tree = ('a node_info, 'a terminal_info) abstract_game_tree + + +(* Game tree printing function. *) +let str f ?(depth=0) tree = + let fas a = String.concat "; " (List.map string_of_float (Array.to_list a)) in + let str_terminal i = "Payoffs: " ^ (fas i.payoffs) ^ + " heurs: " ^ (fas i.heurs_t) ^ " info: " ^ (f i.info_t) in + let str_node i = "Heurs: " ^ (fas i.heurs) ^ " info: " ^ (f i.info) in + str_abstract ~depth:depth str_node str_terminal tree + +(* Get the payoffs / heuristics array of a game tree node. *) +let node_values = function + | Terminal (_, _, i) -> i.payoffs + | Leaf (_, _, i) -> i.heurs + | Node (_, _, i, _) -> i.heurs + +(* Get the stored information of a game tree node. *) +let node_info = function + | Terminal (_, _, i) -> i.info_t + | Leaf (_, _, i) -> i.info + | Node (_, _, i, _) -> i.info + + + +(* Game tree initialization. *) +let info_leaf_f f heurs depth game state player = + let calc re = + Solver.M.get_real_val (Solver.M.register_real_expr re) state.Arena.struc in + { heurs = Array.map calc heurs.(state.Arena.cur_loc); + info = f depth game state } + +let init game state f h = init_abstract game state (info_leaf_f f h 0) + + +(* Game tree unfolding. *) + +let info_terminal_f f depth game state player leaf_info = + let calc re = Solver.M.get_real_val re state.Arena.struc in + let payoffs = + Array.map calc game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs_pp in + { payoffs = payoffs; heurs_t = leaf_info.heurs ; info_t = f depth game state } + +let info_node_f f depth game state player children = + let move_val p mv = (node_values (snd mv)).(p) in + let mval c = move_val player c in + let max_val = ref (mval children.(0)) in + Array.iter (fun c -> max_val := max !max_val (mval c)) children; + let mids = ref [] in (* TODO: use Aux.array_argfind_all_max !!! *) + Array.iteri (fun i c -> if mval c = !max_val then mids := i::!mids) children; + let child = children.(List.hd !mids) in + let pval p = List.fold_left (fun minv i -> + min minv (move_val p children.(i))) (move_val p child) !mids in + let heurs = Array.mapi (fun p _ -> pval p) (node_values (snd child)) in + { heurs = heurs ; info = f depth player heurs children } + +(* Main unfolding function. *) +let unfold game heur ~info_leaf ~info_node ~choice = + unfold_abstract game + ~info_terminal:(info_terminal_f info_leaf) + ~info_leaf:(info_leaf_f info_leaf heur) + ~info_node:(info_node_f info_node) + ~choice:choice + + +(* ------------ MAXIMAX BY DEPTH ------------- *) + +let depth_ready_leaf maxdp dp g s = dp >= maxdp +let depth_ready_node maxdp dp player heurs children = + let mval child = (node_values (snd child)).(player) in + let maxval = heurs.(player) in + Aux.array_existsi (fun _ c -> mval c = maxval && node_info (snd c)) children + +let depth_maximax_choice maxdp dp game state player info children = + let mval child = (node_values (snd child)).(player) in + let (max_val, u... [truncated message content] |
From: <luk...@us...> - 2011-02-23 01:53:50
|
Revision: 1326 http://toss.svn.sourceforge.net/toss/?rev=1326&view=rev Author: lukaszkaiser Date: 2011-02-23 01:53:43 +0000 (Wed, 23 Feb 2011) Log Message: ----------- Remove Game.game_state (= Arena.game_state now), add Move.make_move and haev fun with GameTree. Modified Paths: -------------- trunk/Toss/Formula/Aux.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTree.ml trunk/Toss/Play/GameTree.mli trunk/Toss/Play/GameTreeTest.ml trunk/Toss/Play/Move.ml trunk/Toss/Play/Move.mli trunk/Toss/Server/Server.ml Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Formula/Aux.ml 2011-02-23 01:53:43 UTC (rev 1326) @@ -47,7 +47,8 @@ (* {2 Helper functions on lists and other functions lacking from the standard library.} *) -let random_elem l = List.nth l (Random.int (List.length l)) +let random_elem l = + if l = [] then raise Not_found else List.nth l (Random.int (List.length l)) let concat_map f l = let rec cmap_f accu = function Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/Game.ml 2011-02-23 01:53:43 UTC (rev 1326) @@ -63,21 +63,9 @@ Array.map (fun payoff -> (0.5 +. 1./.((float_of_int n) +. 2.)) *. payoff) payoffs -(* Analogous to {!Arena.game_state}, but without the game component. *) -type game_state = { - struc : Structure.structure ; (* structure state *) - time : float ; (* current time in game *) - loc : int ; (* positin in the game graph *) -} -let gen_models rules models time moves = - let (mv, a) = Move.gen_models rules models time moves in - (mv, Array.map (fun s -> {struc=s.Arena.struc; - time=s.Arena.time; loc=s.Arena.cur_loc}) a) - - type uctree_node = { - node_state : game_state ; + node_state : Arena.game_state ; node_stats : score ; (* playout statistic *) node_heuristic : f_table ; (* heuristic table *) node_bestheur : int ; (* the subtree from which @@ -93,12 +81,12 @@ result in the same array of moves). *) and uctree = | Node of uctree_node - | Leaf of game_state * score * f_table * Structure.structure + | Leaf of Arena.game_state * score * f_table * Structure.structure (* once played leaf: state, time, location, score, heuristic, game-end *) - | Tip of game_state * f_table + | Tip of Arena.game_state * f_table (* unplayed leaf, with heuristic value (evaluation game result) *) - | Terminal of game_state * score * f_table * f_table + | Terminal of Arena.game_state * score * f_table * f_table (* the score, the cache of the actual payoff table and the heuristic *) | TEmpty (* to be expanded in any context *) @@ -190,7 +178,7 @@ (* The evolving state of a play. *) type play_state = { - game_state : game_state ; + game_state : Arena.game_state ; memory : memory array ; (* player-specific history *) } @@ -292,17 +280,17 @@ | TEmpty -> 0 let uctree_location = function - | Node node -> node.node_state.loc - | Leaf (s,_,_,_) -> s.loc - | Tip (s,_) -> s.loc - | Terminal (s,_,_,_) -> s.loc + | Node node -> node.node_state.Arena.cur_loc + | Leaf (s,_,_,_) -> s.Arena.cur_loc + | Tip (s,_) -> s.Arena.cur_loc + | Terminal (s,_,_,_) -> s.Arena.cur_loc | _ -> failwith "uctree_location: empty tree" let uctree_model = function - | Node node -> node.node_state.struc - | Leaf (m,_,_,_) -> m.struc - | Tip (m,_) -> m.struc - | Terminal (m,_,_,_) -> m.struc + | Node node -> node.node_state.Arena.struc + | Leaf (m,_,_,_) -> m.Arena.struc + | Tip (m,_) -> m.Arena.struc + | Terminal (m,_,_,_) -> m.Arena.struc | _ -> failwith "uctree_model: empty tree" let uctree_state = function @@ -333,7 +321,7 @@ | Node node -> node.node_endstate | Leaf (_,_,_,r) -> r | Tip _ -> failwith "uctree_endgame: Tip" - | Terminal (r,_,_,_) -> r.struc + | Terminal (r,_,_,_) -> r.Arena.struc | TEmpty -> failwith "uctree_endgame: TEmpty" @@ -410,14 +398,14 @@ let player_memory = Array.map (function Tree_search _ -> UCTree TEmpty | _ -> No_memory) agents in { - game_state = {loc = loc; time = 0.0; struc = model}; + game_state = {Arena.cur_loc = loc; time = 0.0; struc = model}; memory = player_memory; } (* TODO: [num_players] not used (remove if not needed). *) let update_memory_single num_players state pos = function | No_memory -> No_memory - | State_history history -> State_history (state.struc::history) + | State_history history -> State_history (state.Arena.struc::history) | UCTree (Node node) -> UCTree node.node_subtrees.(pos) | UCTree _ -> UCTree TEmpty @@ -518,7 +506,7 @@ Solver.M.get_real_val expr model) subloc.Arena.payoffs_pp else let state = - {game_state={loc=evgame.ev_location; struc=model; time=time}; + {game_state={Arena.cur_loc=evgame.ev_location; struc=model; time=time}; memory=evgame.ev_memory} in let subplay = {game=evgame.ev_game; agents=evgame.ev_agents; delta=evgame.ev_delta} in @@ -530,7 +518,7 @@ (* Generate evgame scores for possible moves. *) and gen_scores grid_size subgames moves models loc = Array.mapi (fun pos mv -> - let {struc=model; time=time} = models.(pos) in + let {Arena.struc=model; time=time} = models.(pos) in play_evgame grid_size model time subgames.(mv.Move.next_loc) ) moves @@ -548,16 +536,16 @@ defined_rels=defined_rels}; agents=agents; delta=delta} as play_def) {game_state=state; memory=memory} = - let loc = graph.(state.loc) in + let loc = graph.(state.Arena.cur_loc) in let moves = if just_payoffs then [| |] - else Move.gen_moves grid_size rules state.struc loc in + else Move.gen_moves grid_size rules state.Arena.struc loc in (* Don't forget to check after generating models as well -- postconditions! *) if moves = [| |] then let payoff = Array.map (fun expr -> - Solver.M.get_real_val expr state.struc) + Solver.M.get_real_val expr state.Arena.struc) loc.Arena.payoffs_pp in Aux.Right payoff else @@ -578,8 +566,8 @@ Aux.map_option (fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *) - {loc=mv.Move.next_loc; struc=model; time=time}) - (ContinuousRule.rewrite_single state.struc state.time + {Arena.cur_loc=mv.Move.next_loc; struc=model; time=time}) + (ContinuousRule.rewrite_single state.Arena.struc state.Arena.time mv.Move.embedding rule mv.Move.mv_time mv.Move.parameters); incr pos done; @@ -587,7 +575,7 @@ | None -> let payoff = Array.map (fun expr -> - Solver.M.get_real_val expr state.struc) + Solver.M.get_real_val expr state.Arena.struc) loc.Arena.payoffs_pp in Aux.Right payoff | Some state -> @@ -615,7 +603,7 @@ calls, with optional alpha-beta pruning *) (* [betas] are used imperatively *) let rec maximax_tree pre_heur prev_player betas depth - {loc=loc; struc=model; time=time} = + {Arena.cur_loc = loc; struc=model; time=time} = (* {{{ log entry *) incr nodes_count; size_count := !size_count + Array.length moves; @@ -669,7 +657,7 @@ else if !timeout then Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs else - let moves, models = gen_models rules model time moves in + let moves, models = Move.gen_models rules model time moves in let n = Array.length models in if !timeout then Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs @@ -750,11 +738,12 @@ aux alphas 0 in let betas = Array.make num_players infinity in let player = loc.Arena.player in - let moves, models = gen_models rules state.struc state.time moves in + let moves, models = + Move.gen_models rules state.Arena.struc state.Arena.time moves in if models = [| |] then let payoff = Array.map (fun expr -> - Solver.M.get_real_val expr state.struc) + Solver.M.get_real_val expr state.Arena.struc) loc.Arena.payoffs_pp in Aux.Right payoff else @@ -795,7 +784,7 @@ !cur_depth; Array.iteri (fun i score -> Printf.printf "Structure:%s -- score %F\n" - (Structure.str models.(i).struc) score.(player)) scores + (Structure.str models.(i).Arena.struc) score.(player)) scores ); (* }}} *) done; @@ -811,7 +800,7 @@ if !debug_level > 1 && (depth > 1 || !debug_level > 3) then Printf.printf "moving to state\n%s\n%!" - (Structure.str state.struc); + (Structure.str state.Arena.struc); (* }}} *) Aux.Left (best, moves, memory, @@ -879,7 +868,7 @@ (* {{{ log entry *) if !debug_level > 1 then Printf.printf "moving to state\n%s\n%!" - (Structure.str state.struc); + (Structure.str state.Arena.struc); (* }}} *) memory.(loc.Arena.player) <- (UCTree (Node node)); Aux.Left @@ -896,16 +885,17 @@ (* {{{ log entry *) if !debug_level > 3 then printf "toss: external\n"; (* }}} *) - let moves, models = gen_models rules state.struc state.time moves in + let moves, models = + Move.gen_models rules state.Arena.struc state.Arena.time moves in if models = [| |] then let payoff = Array.map (fun expr -> - Solver.M.get_real_val expr state.struc) + Solver.M.get_real_val expr state.Arena.struc) loc.Arena.payoffs_pp in Aux.Right payoff else let descriptions = - Array.map (fun m -> Structure.str m.struc) models in + Array.map (fun m -> Structure.str m.Arena.struc) models in let best = callback descriptions in let state = models.(best) in Aux.Left @@ -939,7 +929,8 @@ | Aux.Left (_,_,_,state) -> (* {{{ log entry *) if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then - printf "step-state:\n%s\n%!" (Structure.str state.game_state.struc); + printf "step-state:\n%s\n%!" + (Structure.str state.game_state.Arena.struc); (* }}} *) play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state | Aux.Right payoff -> @@ -948,7 +939,7 @@ printf "payoff-state:\n%a\n%!" (Aux.array_fprint (fun f pv->fprintf f "%F" pv)) payoff; (* }}} *) - state.game_state.struc, discount plys payoff + state.game_state.Arena.struc, discount plys payoff (* Walk up the tree selecting the optimal estimates route, and update @@ -966,7 +957,7 @@ node_heuristic=heuristic; node_bestheur=old_bestheur; node_endstate=endmodel; node_subtrees=subtrees } -> - let player = graph.(game_state.loc).Arena.player in + let player = graph.(game_state.Arena.cur_loc).Arena.player in (* compute UCBs and update the best subtree *) let ucb_scores = Array.map (fun subtree -> let heuristic = uctree_heuristic subtree in @@ -1006,13 +997,13 @@ } | Leaf (game_state, score, heuristic, endmodel) -> - let player = graph.(game_state.loc).Arena.player in + let player = graph.(game_state.Arena.cur_loc).Arena.player in expand_uctree grid_size play_def game_state ~score subgames evgame_horizon params.heur_effect heuristic params.horizon params.cooperative player | Tip (game_state, heuristic) -> - let player = graph.(game_state.loc).Arena.player in + let player = graph.(game_state.Arena.cur_loc).Arena.player in expand_uctree grid_size play_def game_state subgames evgame_horizon params.heur_effect heuristic params.horizon params.cooperative player @@ -1039,22 +1030,23 @@ delta=delta} as play_def) state ?score subgames evgame_horizon heur_effect heuristic horizon cooperative player = - let location = graph.(state.loc) in - let moves = Move.gen_moves grid_size rules state.struc location in + let location = graph.(state.Arena.cur_loc) in + let moves = Move.gen_moves grid_size rules state.Arena.struc location in if moves = [| |] then let payoff = Array.map (fun expr -> - Solver.M.get_real_val expr state.struc) + Solver.M.get_real_val expr state.Arena.struc) location.Arena.payoffs_pp in let upscore = score_payoff payoff in upscore, Terminal (state, upscore, heuristic, payoff) else - let moves, models = gen_models rules state.struc state.time moves in + let moves, models = + Move.gen_models rules state.Arena.struc state.Arena.time moves in if models = [| |] then let payoff = Array.map (fun expr -> - Solver.M.get_real_val expr state.struc) + Solver.M.get_real_val expr state.Arena.struc) location.Arena.payoffs_pp in let upscore = score_payoff payoff in upscore, Terminal (state, upscore, heuristic, payoff) @@ -1085,11 +1077,11 @@ | None -> upscore | Some score -> add_score score upscore in subtrees.(best) <- - Leaf (next_state, upscore, heuristics.(best), next_state.struc); + Leaf (next_state, upscore, heuristics.(best), next_state.Arena.struc); (upscore, Node { node_state=next_state; node_stats=score; - node_heuristic=heuristic; node_endstate=next_state.struc; + node_heuristic=heuristic; node_endstate=next_state.Arena.struc; node_subtrees=subtrees; node_bestheur=bestheur; }) else Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/Game.mli 2011-02-23 01:53:43 UTC (rev 1326) @@ -85,16 +85,9 @@ structures and return the position of the desired state; for interacting with external players only *) -(** Analogous to {!Arena.game_state}. *) -type game_state = { - struc : Structure.structure ; (** structure state *) - time : float ; (** current time in game *) - loc : int ; (** positin in the game graph *) -} - (** The evolving state of a play. *) type play_state = { - game_state : game_state ; + game_state : Arena.game_state ; memory : memory array ; (** player-specific history *) } @@ -134,7 +127,7 @@ (** Update "memory" assuming that the position given corresponds to a move selected, as generated by {!gen_moves}. With tree search, selects the corresponding subtree of a tree. *) -val update_memory : num_players:int -> game_state -> int -> +val update_memory : num_players:int -> Arena.game_state -> int -> memory array -> memory array (** Make a move in a play, or compute the payoff table when the game Modified: trunk/Toss/Play/GameTree.ml =================================================================== --- trunk/Toss/Play/GameTree.ml 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/GameTree.ml 2011-02-23 01:53:43 UTC (rev 1326) @@ -1,5 +1,6 @@ (* Game Tree used for choosing moves. *) +let debug_level = ref 0 (* Abstract game tree, just stores state and move information. *) type ('a, 'b) abstract_game_tree = @@ -55,7 +56,7 @@ (* Abstract game tree unfolding function, calls argument functions for work. *) let rec unfold_abstract ?(depth=0) game ~info_terminal ~info_leaf ~info_node ~choice = function - | Terminal _ as t -> t + | Terminal _ -> raise Not_found | Leaf (state, player, info) -> let moves = Move.list_moves game state in if moves = [||] then @@ -116,7 +117,6 @@ | Node (_, _, i, _) -> i.info - (* Game tree initialization. *) let info_leaf_f f heurs depth game state player = let calc re = @@ -156,31 +156,44 @@ ~info_node:(info_node_f info_node) ~choice:choice +(* Choose one of the maximizing moves (at random) given a game tree. *) +let choose_move game = function + | Terminal _ -> raise Not_found + | Leaf (state, _, _) -> + fst (Aux.random_elem (Array.to_list (Move.list_moves game state))) + | Node (_, p, info, succ) -> + let mval = info.heurs.(p) in + let max = Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in + let (m, _) = Aux.random_elem max in m + (* ------------ MAXIMAX BY DEPTH ------------- *) -let depth_ready_leaf maxdp dp g s = dp >= maxdp -let depth_ready_node maxdp dp player heurs children = - let mval child = (node_values (snd child)).(player) in - let maxval = heurs.(player) in - Aux.array_existsi (fun _ c -> mval c = maxval && node_info (snd c)) children +let maxdepth_node dp player heurs children = + let depths = Array.map (fun child -> (node_info (snd child))) children in + (Array.fold_left (fun m d -> max m d) 0 depths) + 1 -let depth_maximax_choice maxdp dp game state player info children = - let mval child = (node_values (snd child)).(player) in - let (max_val, unready) = (info.heurs.(player), ref []) in - Array.iteri (fun i c -> if not (node_info (snd c)) then - unready:= i::!unready) children; (* TODO: reordering, alpha-beta *) - if !unready = [] then raise Not_found else List.hd !unready +let maximax_depth_choice dp game cur_state player info children = + let mval child = (node_values (snd child)).(player), node_info (snd child) in + let cmp c1 c2 = + let (v1, d1), (v2, d2) = mval c1, mval c2 in + if d1 > 4*(d2+1) then -1 else if d2 > 4*(d1+1) then 1 else + if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in + let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in + if !debug_level > 0 then + print_endline (Structure.str (state (snd children.(res))).Arena.struc); + res (* Maximax by depth unfolding function. Throws Not_found if ready. *) -let unfold_maximax_depth dp game heur = - unfold game heur ~info_leaf:(depth_ready_leaf dp) - ~info_node:(depth_ready_node dp) ~choice:(depth_maximax_choice dp) +let unfold_maximax game heur = + unfold game heur ~info_leaf:(fun _ _ _ -> 0) + ~info_node:(maxdepth_node) ~choice:(maximax_depth_choice) (* Maximax unfolding upto depth. *) -let rec unfold_maximax_upto dp game heur t = - try - let u = unfold_maximax_depth dp game heur t in - unfold_maximax_upto dp game heur u - with Not_found -> t +let rec unfold_maximax_upto count game heur t = + if count = 0 then t else + try + let u = unfold_maximax game heur t in + unfold_maximax_upto (count-1) game heur u + with Not_found -> t Modified: trunk/Toss/Play/GameTree.mli =================================================================== --- trunk/Toss/Play/GameTree.mli 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/GameTree.mli 2011-02-23 01:53:43 UTC (rev 1326) @@ -68,6 +68,10 @@ val node_info : 'a game_tree -> 'a +(** Choose one of the maximizing moves (at random) given a game tree. *) +val choose_move : Arena.game -> 'a game_tree -> Move.move + + (** Game tree initialization. *) val init : Arena.game -> Arena.game_state -> (int -> Arena.game -> Arena.game_state -> 'a) -> @@ -86,10 +90,10 @@ (** ------------ MAXIMAX BY DEPTH ------------- *) (** Maximax by depth unfolding function. Throws Not_found if ready. *) -val unfold_maximax_depth : int -> Arena.game -> - Formula.real_expr array array -> bool game_tree -> bool game_tree +val unfold_maximax : Arena.game -> + Formula.real_expr array array -> int game_tree -> int game_tree (** Maximax unfolding upto depth. *) val unfold_maximax_upto : int -> Arena.game -> - Formula.real_expr array array -> bool game_tree -> bool game_tree + Formula.real_expr array array -> int game_tree -> int game_tree Modified: trunk/Toss/Play/GameTreeTest.ml =================================================================== --- trunk/Toss/Play/GameTreeTest.ml 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/GameTreeTest.ml 2011-02-23 01:53:43 UTC (rev 1326) @@ -60,21 +60,20 @@ (fun () -> let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in - let t = GameTree.init g s (fun _ _ _ -> false) h in - let u = GameTree.unfold_maximax_depth 1 g h t in - (* print_endline (GameTree.str string_of_bool u); *) - assert_equal ~printer:(fun x -> string_of_bool x) true - (GameTree.node_info u) + let t = GameTree.init g s (fun _ _ _ -> 0) h in + let u = GameTree.unfold_maximax g h t in + (* print_endline (GameTree.str string_of_int u); *) + assert_equal ~printer:(fun x -> string_of_int x) 1 (GameTree.node_info u) ); "maximax unfold upto depth, size" >:: (fun () -> let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in - let t = GameTree.init g s (fun _ _ _ -> false) h in - let u = GameTree.unfold_maximax_upto 2 g h t in - (* print_endline (GameTree.str string_of_bool u); *) - assert_equal ~printer:(fun x -> string_of_int x) 82 (GameTree.size u) + let t = GameTree.init g s (fun _ _ _ -> 0) h in + let u = GameTree.unfold_maximax_upto 50 g h t in + (* print_endline (GameTree.str string_of_int u); *) + assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u) ); ] Modified: trunk/Toss/Play/Move.ml =================================================================== --- trunk/Toss/Play/Move.ml 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/Move.ml 2011-02-23 01:53:43 UTC (rev 1326) @@ -14,7 +14,13 @@ 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 (new_game, new_state), _ = Arena.handle_request (game, state) req in + (new_game, { new_state with Arena.cur_loc = m.next_loc }) + (* Print a move as string. TODO: perhaps find a nicer syntax? See {!TestGame.move_str}. *) let move_str rules struc move = Modified: trunk/Toss/Play/Move.mli =================================================================== --- trunk/Toss/Play/Move.mli 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Play/Move.mli 2011-02-23 01:53:43 UTC (rev 1326) @@ -17,7 +17,11 @@ val move_gs_str_short : Arena.game_state -> move -> string +(** Make a move in a game. *) +val make_move : 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 Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-22 03:24:44 UTC (rev 1325) +++ trunk/Toss/Server/Server.ml 2011-02-23 01:53:43 UTC (rev 1326) @@ -245,17 +245,17 @@ | Some play, Some {Game.memory=memory; game_state=pstate} -> Game.update_memory ~num_players:play.Game.game.Arena.num_players - {Game.struc=old_struc; + {Arena.struc=old_struc; time = (snd !state).Arena.time; - loc = (snd !state).Arena.cur_loc} pos memory + cur_loc = (snd !state).Arena.cur_loc} pos memory | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) let new_loc = moves.(pos).Move.next_loc in state := (fst new_state, {snd new_state with Arena.cur_loc = new_loc}); let new_game_state = { - Game.struc = (snd new_state).Arena.struc; - loc = moves.(pos).Move.next_loc; + Arena.struc = (snd new_state).Arena.struc; + cur_loc = moves.(pos).Move.next_loc; time = (snd new_state).Arena.time; } in play_state := Some { @@ -341,17 +341,17 @@ | Some play, Some {Game.memory=memory; game_state=pstate} -> Game.update_memory ~num_players:play.Game.game.Arena.num_players - {Game.struc=old_struc; + {Arena.struc=old_struc; time = (snd !state).Arena.time; - loc = (snd !state).Arena.cur_loc} pos memory + cur_loc = (snd !state).Arena.cur_loc} pos memory | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) let new_loc = moves.(pos).Move.next_loc in state := (fst new_state, {snd new_state with Arena.cur_loc = new_loc}); let new_game_state = { - Game.struc = (snd new_state).Arena.struc; - loc = moves.(pos).Move.next_loc; + Arena.struc = (snd new_state).Arena.struc; + cur_loc = moves.(pos).Move.next_loc; time = (snd new_state).Arena.time; } in play_state := Some { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2011-02-24 01:48:03
|
Revision: 1327 http://toss.svn.sourceforge.net/toss/?rev=1327&view=rev Author: lukaszkaiser Date: 2011-02-24 01:47:56 +0000 (Thu, 24 Feb 2011) Log Message: ----------- GameTree experiments. Modified Paths: -------------- trunk/Toss/Play/GameTree.ml trunk/Toss/Play/GameTree.mli trunk/Toss/Play/GameTreeTest.ml trunk/Toss/Server/Server.ml trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/Solver.mli Modified: trunk/Toss/Play/GameTree.ml =================================================================== --- trunk/Toss/Play/GameTree.ml 2011-02-23 01:53:43 UTC (rev 1326) +++ trunk/Toss/Play/GameTree.ml 2011-02-24 01:47:56 UTC (rev 1327) @@ -1,13 +1,16 @@ (* Game Tree used for choosing moves. *) let debug_level = ref 0 +let set_debug_level i = debug_level := i (* Abstract game tree, just stores state and move information. *) type ('a, 'b) abstract_game_tree = | Terminal of Arena.game_state * int * 'b (* terminal state with player *) - | Leaf of Arena.game_state * int * 'a (* leaf with state, player *) - | Node of Arena.game_state * int * 'a * (* node with state, player, moves *) + | Leaf of Arena.game_state * int * Solver.cachetbl * 'a + (* leaf with state, player, cache and info *) + | Node of Arena.game_state * int * 'a * (Move.move * ('a, 'b) abstract_game_tree) array + (* node with state, player, moves and info *) (* Abstract tree printing function. *) let rec str_abstract ?(depth=0) str_info str_info_terminal tree = @@ -21,7 +24,7 @@ match tree with | Terminal (state, player, info) -> s "Terminal. " state player (str_info_terminal info) - | Leaf (state, player, info) -> s "Leaf. " state player (str_info info) + | Leaf (state, player, _, info) -> s "Leaf. " state player (str_info info) | Node (state, player, info, children) -> let next_str (_, t) = str_abstract ~depth:(depth+1) str_info str_info_terminal t in @@ -37,34 +40,37 @@ (* Player in the given node. *) let player = function | Terminal (_, player, _) -> player - | Leaf (_, player, _) -> player + | Leaf (_, player, _, _) -> player | Node (_, player, _, _) -> player (* State in the given node. *) let state = function | Terminal (state, _, _) -> state - | Leaf (state, _, _) -> state + | Leaf (state, _, _, _) -> state | Node (state, _, _, _) -> state (* Abstract game tree initialization. *) let init_abstract game state info_leaf = let player = game.Arena.graph.(state.Arena.cur_loc).Arena.player in - Leaf (state, player, info_leaf game state player) + let info, cache = info_leaf game state player in + Leaf (state, player, cache, info) (* Abstract game tree unfolding function, calls argument functions for work. *) let rec unfold_abstract ?(depth=0) game ~info_terminal ~info_leaf ~info_node ~choice = function | Terminal _ -> raise Not_found - | Leaf (state, player, info) -> + | Leaf (state, player, cache, info) -> + Solver.set_cache (state.Arena.struc, cache); let moves = Move.list_moves game state in if moves = [||] then Terminal (state, player, info_terminal depth game state player info) else let leaf_of_move leaf_s = - let leaf_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in - Leaf (leaf_s, leaf_pl, info_leaf (depth+1) game leaf_s leaf_pl) in + let l_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in + let l_info, cache = info_leaf (depth+1) game leaf_s l_pl in + Leaf (leaf_s, l_pl, cache, l_info) in let children = Array.map (fun (m, s) -> (m, leaf_of_move s)) moves in Node (state, player,info_node depth game state player children,children) | Node (state, player, info, children) -> @@ -106,14 +112,14 @@ (* Get the payoffs / heuristics array of a game tree node. *) let node_values = function - | Terminal (_, _, i) -> i.payoffs - | Leaf (_, _, i) -> i.heurs + | Terminal (_, _, i) -> Array.map (fun p -> !cPAYOFF_AS_HEUR *. p) i.payoffs + | Leaf (_, _, _, i) -> i.heurs | Node (_, _, i, _) -> i.heurs (* Get the stored information of a game tree node. *) let node_info = function | Terminal (_, _, i) -> i.info_t - | Leaf (_, _, i) -> i.info + | Leaf (_, _, _, i) -> i.info | Node (_, _, i, _) -> i.info @@ -121,8 +127,10 @@ let info_leaf_f f heurs depth game state player = let calc re = Solver.M.get_real_val (Solver.M.register_real_expr re) state.Arena.struc in - { heurs = Array.map calc heurs.(state.Arena.cur_loc); - info = f depth game state } + let res = + { heurs = Array.map calc heurs.(state.Arena.cur_loc); + info = f depth game state } in + (res, snd (Solver.get_cache ())) let init game state f h = init_abstract game state (info_leaf_f f h 0) @@ -159,12 +167,12 @@ (* Choose one of the maximizing moves (at random) given a game tree. *) let choose_move game = function | Terminal _ -> raise Not_found - | Leaf (state, _, _) -> - fst (Aux.random_elem (Array.to_list (Move.list_moves game state))) + | Leaf (state, _, _, _) -> + Aux.random_elem (Array.to_list (Move.list_moves game state)) | Node (_, p, info, succ) -> let mval = info.heurs.(p) in let max = Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in - let (m, _) = Aux.random_elem max in m + let (m, t) = Aux.random_elem max in (m, state t) (* ------------ MAXIMAX BY DEPTH ------------- *) @@ -177,10 +185,9 @@ let mval child = (node_values (snd child)).(player), node_info (snd child) in let cmp c1 c2 = let (v1, d1), (v2, d2) = mval c1, mval c2 in - if d1 > 4*(d2+1) then -1 else if d2 > 4*(d1+1) then 1 else - if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in + if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in - if !debug_level > 0 then + if !debug_level > 2 then print_endline (Structure.str (state (snd children.(res))).Arena.struc); res @@ -192,8 +199,16 @@ (* Maximax unfolding upto depth. *) let rec unfold_maximax_upto count game heur t = - if count = 0 then t else + if count = 0 || Game.get_timeout () then t else try let u = unfold_maximax game heur t in + if !debug_level > 0 then Printf.printf "%d,%!" (size u); unfold_maximax_upto (count-1) game heur u with Not_found -> t + +(* Maximax unfold upto depth and choose move. *) +let maximax_unfold_choose count game state heur = + let t = init game state (fun _ _ _ -> 0) heur in + let u = unfold_maximax_upto count game heur t in + if !debug_level > 1 then print_endline (str string_of_int u); + choose_move game u Modified: trunk/Toss/Play/GameTree.mli =================================================================== --- trunk/Toss/Play/GameTree.mli 2011-02-23 01:53:43 UTC (rev 1326) +++ trunk/Toss/Play/GameTree.mli 2011-02-24 01:47:56 UTC (rev 1327) @@ -1,9 +1,12 @@ (** Game Tree used for choosing moves. *) +val set_debug_level : int -> unit + (** Abstract game tree, just stores state and move information. *) type ('a, 'b) abstract_game_tree = | Terminal of Arena.game_state * int * 'b (** terminal state with player *) - | Leaf of Arena.game_state * int * 'a (** leaf with state, player *) + | Leaf of Arena.game_state * int * Solver.cachetbl * 'a + (** leaf with state, player, moves and info *) | Node of Arena.game_state * int * 'a * (Move.move * ('a, 'b) abstract_game_tree) array (** node with state, player, moves *) @@ -24,12 +27,14 @@ (** Abstract initialization function. *) val init_abstract : Arena.game -> Arena.game_state -> - (Arena.game -> Arena.game_state -> int -> 'a) -> ('a, 'b) abstract_game_tree + (Arena.game -> Arena.game_state -> int -> 'a * Solver.cachetbl) -> + ('a, 'b) abstract_game_tree (** Abstract game tree unfolding function, calls argument functions for work. *) val unfold_abstract : ?depth:int -> Arena.game -> info_terminal : (int -> Arena.game -> Arena.game_state -> int -> 'a -> 'b) -> - info_leaf : (int -> Arena.game -> Arena.game_state -> int -> 'a) -> + info_leaf : (int -> Arena.game -> Arena.game_state -> int -> + 'a * Solver.cachetbl) -> info_node : (int -> Arena.game -> Arena.game_state -> int -> (Move.move * ('a, 'b) abstract_game_tree) array -> 'a) -> choice : (int -> Arena.game -> Arena.game_state -> int -> 'a -> @@ -69,7 +74,7 @@ (** Choose one of the maximizing moves (at random) given a game tree. *) -val choose_move : Arena.game -> 'a game_tree -> Move.move +val choose_move : Arena.game -> 'a game_tree -> Move.move * Arena.game_state (** Game tree initialization. *) @@ -97,3 +102,7 @@ (** Maximax unfolding upto depth. *) val unfold_maximax_upto : int -> Arena.game -> Formula.real_expr array array -> int game_tree -> int game_tree + +(** Maximax unfold upto depth and choose move. *) +val maximax_unfold_choose : int -> Arena.game -> Arena.game_state -> + Formula.real_expr array array -> Move.move * Arena.game_state Modified: trunk/Toss/Play/GameTreeTest.ml =================================================================== --- trunk/Toss/Play/GameTreeTest.ml 2011-02-23 01:53:43 UTC (rev 1326) +++ trunk/Toss/Play/GameTreeTest.ml 2011-02-24 01:47:56 UTC (rev 1327) @@ -17,13 +17,13 @@ "abstract tree init, to string" >:: (fun () -> let s = {Arena.struc=Structure.empty_structure(); cur_loc=0; time=0.} in - let t = Leaf (s, 1, 5) in + let t = Leaf (s, 1, Hashtbl.create 1, 5) in assert_equal ~printer:(fun x -> x) "\n|| Leaf. Player 1 loc 0 time 0.0.\n|| [ | | ]\n|| 5" (GameTree.str_abstract ~depth:2 string_of_int string_of_int t); let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in - let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in + let t = GameTree.init_abstract g s (fun _ _ _ -> 5, Hashtbl.create 1) in assert_equal ~printer:(fun x -> x) ("\nLeaf. Player 0 loc 0 time 0.0.\n[ | P:1 {}; Q:1 {} | ] \"\n" ^ "\t \n\t. . . \n" ^ @@ -35,8 +35,9 @@ "abstract unfold, size" >:: (fun () -> let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in - let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in - let (i_t, i_l) = (fun _ _ _ _ _ -> 0), (fun _ _ _ _ -> 1) in + let t = GameTree.init_abstract g s (fun _ _ _ -> 5, Hashtbl.create 1) in + let i_t = (fun _ _ _ _ _ -> 0) in + let i_l = (fun _ _ _ _ -> 1, Hashtbl.create 1) in let (i_n, ch) = (fun _ _ _ _ _ -> 2), (fun _ _ _ _ _ _ -> 0) in let u = GameTree.unfold_abstract g i_t i_l i_n ch t in (* print_endline (GameTree.str_abstract string_of_int string_of_int u);*) Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-23 01:53:43 UTC (rev 1326) +++ trunk/Toss/Server/Server.ml 2011-02-24 01:47:56 UTC (rev 1327) @@ -3,6 +3,7 @@ let debug_level = ref 0 let set_debug_level i = debug_level := i; + GameTree.set_debug_level 1; Game.set_debug_level i; Heuristic.debug_level := i - 3 @@ -25,6 +26,10 @@ let dtimeout = ref (-1) let playclock = ref 0 +let g_heur = ref None +let no_gtree = ref true + + (* -------------------- GENERAL SERVER AND REQUEST HANDLER ------------------ *) exception Host_not_found @@ -376,14 +381,27 @@ play, play_state | _ -> assert false in ignore (Unix.alarm (!playclock - time_used - 2)); - let res = Game.suggest p ps in - Game.cancel_timeout (); - match res with - | Some (move, new_state) -> - (* Do not change state yet! *) - GDL.translate_move !gdl_transl !state - move.Move.rule move.Move.embedding - | None -> GDL.noop_move ~force:true !gdl_transl (snd !state) + if !no_gtree then + let res = Game.suggest p ps in + Game.cancel_timeout (); + match res with + | Some (move, _) -> + (* Do not change state yet! *) + GDL.translate_move !gdl_transl !state + move.Move.rule move.Move.embedding + | None -> GDL.noop_move ~force:true !gdl_transl (snd !state) + else + let heur = match !g_heur with + | Some h -> h + | None -> + let h = Heuristic.default_heuristic + ~struc:(snd !state).Arena.struc ~advr:4. (fst !state) in + g_heur := Some h; h in + let (move, _) = GameTree.maximax_unfold_choose 5500 + (fst !state) (snd !state) heur in + Game.cancel_timeout (); + GDL.translate_move !gdl_transl !state + move.Move.rule move.Move.embedding ) else ( Gc.compact (); GDL.noop_move !gdl_transl (snd !state) @@ -453,9 +471,43 @@ print_heur_arr harr;) heur ;; +let do_play game state depth1 depth2 advr heur1 heur2 = + let play = {Game.game = game; agents= + [| Game.default_maximax state.Arena.struc ~depth:depth1 + ~heuristic:heur1 ~advr ~pruning:true game; + Game.default_maximax state.Arena.struc ~depth:depth2 + ~heuristic:heur2 ~advr ~pruning:true game; + |]; delta = 2.0} in (* FIXME: give/calc delta *) + let init_pl s = Game.initial_state ~loc:s.Arena.cur_loc play s.Arena.struc in + let cur_state = ref state in + while Array.length (Move.list_moves game !cur_state) > 0 do + let pl =game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.player in + let depth = if pl = 0 then depth1 else if pl = 1 then depth2 else + failwith "only 2-player games supported in experiments for now" in + if depth < 12 then ( + match Game.suggest ~effort:depth play (init_pl !cur_state) with + | None -> Game.set_debug_level 0; failwith "no suggestion" + | Some (mv, _) -> + Game.set_debug_level 0; + let (_, new_state) = Move.make_move mv (game, !cur_state) in + cur_state := new_state; + ) else ( + let heur = if pl = 0 then heur1 else heur2 in + GameTree.set_debug_level 1; + let (_, s) = GameTree.maximax_unfold_choose depth game !cur_state heur in + GameTree.set_debug_level 0; + cur_state := s + ); + print_endline ("State: " ^ (Structure.str !cur_state.Arena.struc)); + print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter)); + Solver.eval_counter := 0; + done; + let payoffs = game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.payoffs_pp in + Array.map (fun p -> Solver.M.get_real_val p (!cur_state).Arena.struc) payoffs +;; + let run_test n depth1 depth2 = - let (horizon, advr) = (Some 400, 2.0) in - let struc = (snd !state).Arena.struc in + let advr = 2.0 in let game = fst !state in let heur1 = if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then @@ -480,21 +532,12 @@ Heuristic.default_heuristic_old ~struc:(snd !state).Arena.struc ~advr:advr game in if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2); - let play = {Game.game = game; agents= - [| Game.default_maximax (snd !state).Arena.struc ~depth:depth1 - ~heuristic:heur1 ~advr ~pruning:true game; - Game.default_maximax (snd !state).Arena.struc ~depth:depth2 - ~heuristic:heur2 ~advr ~pruning:true game; - |]; delta = 2.0} in (* FIXME: give/calc delta *) - let init_state = Game.initial_state play struc in - Game.set_debug_level 1; let (aggr_payoff_w, aggr_payoff_b) = (ref 0., ref 0.) in Printf.printf "Experiment -- running test!\n"; for i = 1 to n do ( Random.self_init (); Printf.printf "Experiment: Game nr %d of %d\n%!" i n; - let _,payoff = Game.play ~grid_size:Move.cGRID_SIZE ~set_timer:3600 - ?horizon play init_state in + let payoff = do_play game (snd !state) depth1 depth2 advr heur1 heur2 in Printf.printf "Game %d payoffs %f, %f\n" i payoff.(0) payoff.(1); aggr_payoff_w := !aggr_payoff_w +. payoff.(0); aggr_payoff_b := !aggr_payoff_b +. payoff.(1); @@ -533,6 +576,7 @@ "white (=first) player heuristic for use by the second player in tests"); ("-heur-black-2", Arg.String (fun s -> heur_val_black2 := s), "black (=second) player heuristic for use by the second player in tests"); + ("-gtree", Arg.Unit (fun () -> no_gtree := false), "use GameTree module"); ("-experiment", Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i); Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)], Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2011-02-23 01:53:43 UTC (rev 1326) +++ trunk/Toss/Solver/Solver.ml 2011-02-24 01:47:56 UTC (rev 1327) @@ -10,9 +10,15 @@ (* CACHE *) +type cachetbl = (Formula.formula, Assignments.assignment_set) Hashtbl.t + let cache_struc = ref (empty_structure ()) -let cache_results = Hashtbl.create 15; +let cache_results = ref (Hashtbl.create 15) +let get_cache () = (!cache_struc, Hashtbl.copy !cache_results) +let set_cache (struc, res) = cache_struc := struc; cache_results := res + + (* ----------------------- BASIC TYPE DEFINITION -------------------------- *) @@ -224,19 +230,22 @@ let (b, nl) = assoc_del x l in (b, pair :: nl) +let eval_counter = ref 0 + (* Eval with very basic caching. *) let eval_m struc phi = if phi = And [] then Any else if !cache_struc != struc then ( let els = Set (Elems.cardinal struc.elements, struc.elements) in let asg = eval struc (ref els) Any phi in + incr eval_counter; cache_struc := struc; - Hashtbl.clear cache_results; - Hashtbl.add cache_results phi asg; + Hashtbl.clear !cache_results; + Hashtbl.add !cache_results phi asg; asg ) else try - let res = Hashtbl.find cache_results phi in + let res = Hashtbl.find !cache_results phi in if !debug_level > 1 then ( print_endline ("found in cache: " ^ (Formula.str phi)); ); @@ -245,7 +254,8 @@ if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi)); let els = Set (Elems.cardinal struc.elements, struc.elements) in let asg = eval struc (ref els) Any phi in - Hashtbl.add cache_results phi asg; + incr eval_counter; + Hashtbl.add !cache_results phi asg; asg (* Helper function, assignment of tuple. *) @@ -367,6 +377,7 @@ let elems = ref (Set (Elems.cardinal struc.elements, struc.elements)) in let phi = Hashtbl.find solver.formulas_eval formula in + incr eval_counter; eval struc elems fo_aset phi (* Interface to {!SolverIntf}. *) @@ -385,6 +396,7 @@ let elems = ref (Set (Elems.cardinal struc.elements, struc.elements)) in let phi = Hashtbl.find solver.formulas_eval formula in + incr eval_counter; eval struc elems fo_aset phi let check_formula struc formula = Modified: trunk/Toss/Solver/Solver.mli =================================================================== --- trunk/Toss/Solver/Solver.mli 2011-02-23 01:53:43 UTC (rev 1326) +++ trunk/Toss/Solver/Solver.mli 2011-02-24 01:47:56 UTC (rev 1327) @@ -6,10 +6,15 @@ val register_formula : solver -> Formula.formula -> int val get_formula : solver -> int -> Formula.formula - (** {2 Evaluation} *) +type cachetbl = (Formula.formula, Assignments.assignment_set) Hashtbl.t +val eval_counter : int ref +val get_cache : unit -> Structure.structure * cachetbl +val set_cache : Structure.structure * cachetbl -> unit + + (** Evaluate i-th formula on j-th structure. *) val evaluate : solver -> formula:int -> Structure.structure -> Assignments.assignment_set This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |