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

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

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.