[Toss-devel-svn] SF.net SVN: toss:[1681] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1681] trunk/Toss
|
From: <luk...@us...> - 2012-02-28 02:36:37
|
Revision: 1681
http://toss.svn.sourceforge.net/toss/?rev=1681&view=rev
Author: lukaszkaiser
Date: 2012-02-28 02:36:29 +0000 (Tue, 28 Feb 2012)
Log Message:
-----------
Make tests work in JS.
Modified Paths:
--------------
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/ClassTest.ml
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Client/clientTest.js 2012-02-28 02:36:29 UTC (rev 1681)
@@ -88,9 +88,9 @@
return (existsId ("pred_b2_P"));
});
doAtTime (page, 4100, function () {
- ASYNCH ("run_tests_small", [""], function () {});
+ ASYNCH ("run_tests_big", [""], function () {});
});
- doAtTime (undefined, 900000, function () {
+ doAtTime (undefined, 30000000, function () {
//console.log ("rendering");
//page.render ("clientTestRender.png");
phantom.exit();
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/Aux.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -311,8 +311,7 @@
List.rev_append (List.map (fun e-> hd, e) tl) (pairs tl)
let rec fold_n f accu n =
- if n <= 0 then accu
- else fold_n f (f accu) (n-1)
+ if n <= 0 then accu else fold_n f (f accu) (n-1)
let all_ntuples ?(timeout = fun () -> false) elems arity =
fold_n (fun tups ->
@@ -741,16 +740,6 @@
Format.fprintf f "%a%a" f_el hd pr_tail tl
-let set_optimized_gc () =
- IFDEF JAVASCRIPT THEN (
- ()
- ) ELSE (
- Gc.set { (Gc.get()) with
- Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
- Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
- }
- ) ENDIF
(* Replacements for basic Str functions. *)
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/Aux.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -359,8 +359,6 @@
?newline : int -> string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a list -> unit
-(** Set more agressive Gc values optimized for heavier computations. *)
-val set_optimized_gc : unit -> unit
(** Replacements for basic Str functions. *)
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -2,6 +2,9 @@
structures and standard library-like definitions. *)
open Aux
+let default_debug_level = ref 0
+
+
let gettimeofday () =
IFDEF JAVASCRIPT THEN (
let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
@@ -10,6 +13,24 @@
Unix.gettimeofday ()
) ENDIF
+let gc_compact () =
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
+ Gc.compact ();
+ ) ENDIF
+
+let set_optimized_gc () =
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
+ }
+ ) ENDIF
+
let backtrace () =
IFDEF JAVASCRIPT THEN ( "" ) ELSE (
(if Printexc.backtrace_status () then
@@ -38,7 +59,8 @@
String.sub fn_in 2 ((String.length fn_in) - 2)
else fn_in in
IFDEF JAVASCRIPT THEN (
- Resources.get_file fn
+ try Resources.get_file fn with Not_found ->
+ failwith ("File " ^ fn ^ " not found")
) ELSE (
try Resources.get_file fn with Not_found -> (
let input_file_desc file =
@@ -50,12 +72,23 @@
let f = open_in fn in
let res = input_file_desc f in
close_in f;
- print_endline ("WARNING: file " ^ fn ^ " not in resources");
+ if !default_debug_level > 0 then
+ print_endline ("WARNING: file " ^ fn ^ " not in resources");
res
)
) ENDIF
+let output_file ~fname str =
+ IFDEF JAVASCRIPT THEN (
+ failwith "File output not implemented in JavaScript"
+ ) ELSE (
+ let file = open_out fname in
+ output_string file str;
+ flush file;
+ close_out file;
+ ) ENDIF
+
let list_dir dirname =
IFDEF JAVASCRIPT THEN (
failwith "JavaScript file manipulation not implemented"
@@ -67,6 +100,9 @@
) ENDIF
let rec input_http_message file =
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript: http not implemented"
+ ) ELSE (
let buf = Buffer.create 256 in
let get_pair s =
let i, l = String.index s '=', String.length s in
@@ -93,6 +129,7 @@
done;
Buffer.add_channel buf file !msg_len;
(String.concat "\n" !head, Buffer.contents buf, !cookies)
+ ) ENDIF
let input_if_http_message line in_ch =
let ht1, ht2 = "GET /", "POST /" in
@@ -120,7 +157,7 @@
let toss_call (client_port, client_addr_s) f_in x =
IFDEF JAVASCRIPT THEN (
- failwith "JavaScript TCP/IP manipulation not implemented yet"
+ failwith "JavaScript TCP/IP manipulation not implemented"
) ELSE (
try
let client_addr = get_inet_addr client_addr_s in
@@ -166,7 +203,7 @@
ENDIF
-let default_debug_level = ref 0
+
let debug_levels = Hashtbl.create 7
let set_debug_level module_name debug_lev =
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -4,7 +4,12 @@
(** Replacement for Unix.gettimeofday. *)
val gettimeofday: unit -> float
+(** Set more agressive Gc values optimized for heavier computations. *)
+val set_optimized_gc : unit -> unit
+(** Gc.compact () or nothing when running in JS. *)
+val gc_compact : unit -> unit
+
(** Run a function if the executable name matches the given prefix. *)
val run_if_target : string -> (unit -> unit) -> unit
@@ -14,6 +19,9 @@
(** Input a file with given filename to a string. *)
val input_file : string -> string
+(** Output a string to a file with given filename [fname]. *)
+val output_file : fname: string -> string -> unit
+
(** List the contents of a directory *)
val list_dir : string -> string list
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -920,14 +920,34 @@
(* Read a qdimacs description of a QBF from [in_ch]. *)
-let read_qdimacs in_ch =
+let read_qdimacs in_str =
+ let in_ch = ref in_str in
+ let sinput_one_line () =
+ try
+ let i, l = String.index !in_ch '\n', String.length !in_ch in
+ if i = l-1 then (
+ let line = !in_ch in
+ in_ch := "";
+ line
+ ) else (
+ let line = String.sub !in_ch 0 i in
+ in_ch := String.sub !in_ch (i+1) (l - i - 1);
+ line
+ )
+ with Not_found ->
+ if !in_ch = "" then raise End_of_file else
+ let line = !in_ch in in_ch := ""; line in
+ let rec sinput_line () =
+ let l = sinput_one_line () in if l = "" then sinput_line () else l in
(* Read the starting 'c' comment lines, and the first 'p' line.
Set the number of variables and the number of clauses. *)
let rec read_header () =
- let line = input_line in_ch in
+ let line = sinput_line () in
if line.[0] = 'c' then read_header () else
- Scanf.sscanf line "p cnf %i %i" (fun x y -> (x, y)) in
-
+ (* Scanf.sscanf line "p cnf %i %i" (fun x y -> y) in *)
+ let i = String.index_from line 6 ' ' in
+ int_of_string (String.sub line (i+1) ((String.length line) - i - 1)) in
+
(* Read one clause from a line. *)
let read_clause line =
let (s, i, clause) = (ref "", ref 0, ref []) in
@@ -950,9 +970,9 @@
(fun s -> int_of_string s) (List.tl split))) in
let read_formula () =
- let (no_var, no_cl) = read_header () in
+ let no_cl = read_header () in
let rec read_phi () =
- let line = input_line in_ch in
+ let line = sinput_line () in
if line.[0] == 'a' then
QAll (list_int line, read_phi ())
else if line.[0] == 'e' then
@@ -960,7 +980,7 @@
else (
let cls = ref [read_clause (line)] in
for i = 1 to (no_cl-1) do
- cls := (read_clause (input_line in_ch)) :: !cls
+ cls := (read_clause (sinput_line ())) :: !cls
done;
QFree (
BAnd (List.map (fun lits -> BOr (List.map lit_of_int lits)) !cls))
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -84,8 +84,8 @@
(** Print a QBF formula. *)
val qbf_str : qbf -> string
-(** Read a qdimacs description of a QBF from [in_ch]. *)
-val read_qdimacs : in_channel -> qbf
+(** Read a qdimacs description of a QBF from a string. *)
+val read_qdimacs : string -> qbf
(** Eliminating quantifiers from QBF formulas. *)
val elim_quant : qbf -> bool_formula
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -396,26 +396,19 @@
-45 85 0
20 27 45 -85 0
-60 -61 -62 -63 -64 -65 -66 -67 -68 -69 -70 -71 -72 -73 -74 -75 -76 -77 -78 -79 -80 -81 -82 -83 -84 -85 0
-" in
-
- let f = open_out "tmp_testfile_28721.bf" in
- output_string f s27_d2_s;
- close_out f;
- let f = open_in "tmp_testfile_28721.bf" in
- let qbf = read_qdimacs f in
- close_in f;
- Sys.remove "tmp_testfile_28721.bf";
+" in
+ let qbf = read_qdimacs s27_d2_s in
test_elim qbf "true";
- );
+ );
]
let exec () = OUnit.run_test_if_target "BoolFormulaTest" tests
-let execbig ()= OUnit.run_test_if_target "BoolFormulaTest" bigtests
+let execbig () = OUnit.run_test_if_target "BoolFormulaTest" bigtests
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (file) = (ref "") in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_elim true), "be verbose");
@@ -424,9 +417,7 @@
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
if !file = "" then ( exec (); execbig (); ) else (
- let f = open_in !file in
- let qbf = read_qdimacs f in
- close_in f;
+ let qbf = read_qdimacs (AuxIO.input_file !file) in
print_endline (BoolFormula.str (elim_quant qbf))
)
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -106,7 +106,7 @@
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (file, print_bool, debug_level) = (ref "", ref false, ref 0) in
let dbg_level i = (debug_level := i; BoolFunction.set_debug_level i) in
let (only_inline, only_fp, nf) = (ref false, ref false, ref 0) in
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GDL.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -16,7 +16,7 @@
let timeout = ref (fun () -> false)
let set_timeout f = timeout := f
let check_timeout ?(print=true) msg =
- if print && !debug_level > 1 then print_endline ("TimeoutCheck: " ^ msg);
+ if print then LOG 2 "TimeoutCheck: %s" msg;
if !timeout () then (timeout := (fun () -> false); raise (Aux.Timeout msg))
type term =
@@ -469,6 +469,11 @@
let rel_atoms_str body = String.concat " " (List.map rel_atom_str body)
+let gdl_rule_str (ra, rs1, rs2) =
+ (rel_atom_str ra) ^ ": " ^ (rel_atoms_str rs1) ^ "; " ^ (rel_atoms_str rs1)
+
+let gdl_rules_str rs = String.concat ";; " (List.map gdl_rule_str rs)
+
let neg_rel_atoms_str neg_body =
String.concat " "
(List.map (fun a -> "(not " ^ rel_atom_str a ^")") neg_body)
@@ -1279,12 +1284,7 @@
let base = Aux.StrMap.add "true" current
(*tuples_of_list (List.map (fun term -> [|term|]) current)*) static in
let base = saturate base rules in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "GDL.ply: updated base -- %s\n%!"
- (rel_atoms_str (graph_to_atoms base))
- );
- (* }}} *)
+ LOG 5 "GDL.ply: updated base -- %s" (rel_atoms_str (graph_to_atoms base));
let does = Tuples.elements (Aux.StrMap.find "legal" base) in
let does =
if aggregate then does
@@ -1381,20 +1381,11 @@
| rule -> rule) dynamic_rules in
let rec loop actions_accu state_accu step state =
check_timeout ("GDL: playout_satur: loop step " ^ (string_of_int step));
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "playout: step %d...\n%!" step
- );
- (* }}} *)
+ LOG 1 "playout: step %d...\n%!" step;
(let try actions, next =
ply_satur ~aggregate players static_base state state_rules in
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "playout: state %s\n%!"
- (String.concat " "
- (List.map term_str (state_of_tups next)))
- );
- (* }}} *)
+ LOG 1 "playout: state %s"
+ (String.concat " " (List.map term_str (state_of_tups next)));
let next =
if aggregate then (Tuples.union state next) else next in
if step < horizon then
@@ -1427,23 +1418,20 @@
(* [~aggregate:true] performs an aggregate ply, [~aggregate:false]
performs a random ply. *)
let ply_prolog ~aggregate players current program =
- let program =
- replace_rel_in_program "true"
- (List.map (fun term -> ("true", [|term|]), []) current) program in
+ let program = replace_rel_in_program "true"
+ (List.map (fun term -> ("true", [|term|]), []) current) program in
let legal_terms = List.map snd
(run_prolog_atom ("legal", [|Var "x"; Var "y"|]) program) in
let program =
- if aggregate then (run_prolog_aggregate := true; program)
- else (
+ if aggregate then (run_prolog_aggregate := true; program) else (
run_prolog_aggregate := false;
let legal_by_player = Aux.collect
- (List.map
- (function [|pl; lterm|] -> pl, lterm | _ -> assert false)
+ (List.map (function [|pl; lterm|] -> pl, lterm | _ -> assert false)
legal_terms) in
let does_cls = List.map
(fun (player, lterms) ->
- ("does", [|player; Aux.random_elem lterms|]), [])
- legal_by_player in
+ ("does", [|player; Aux.random_elem lterms|]), [])
+ legal_by_player in
replace_rel_in_program "does" does_cls program) in
if (* no move *)
Aux.array_existsi (fun _ player ->
@@ -1473,21 +1461,13 @@
Aux.sorted_diff step_state current = [] &&
(aggregate || Aux.sorted_diff current step_state = [])
then (
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "GDL.ply: playout over due to fixpoint\n%!";
- );
- (* }}} *)
+ LOG 2 "GDL.ply: playout over due to fixpoint";
raise Playout_over)
else if not aggregate && (* terminal position reached *)
run_prolog_check_goal
[Pos (Rel ("terminal", [||]))] program
then (
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "GDL.ply: playout over due to terminal position\n%!";
- );
- (* }}} *)
+ LOG 1 "GDL.ply: playout over due to terminal position";
raise Playout_over)
else
legal_terms, step_state
@@ -1520,41 +1500,25 @@
else program in
let rec loop actions_accu state_accu step state =
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "playout_prolog: step %d...\n%!" step
- );
- (* }}} *)
+ LOG 2 "playout_prolog: step %d..." step;
check_timeout ("GDL: playout_prolog: step " ^ (string_of_int step));
- (let try actions, next =
- ply_prolog ~aggregate players state program in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "playout: state %s\n%!"
- (String.concat " " (List.map term_str next))
- );
- (* }}} *)
+ (let try actions, next = ply_prolog ~aggregate players state program in
+ LOG 3 "playout: state %s" (String.concat " " (List.map term_str next));
let next =
if aggregate then Aux.sorted_merge state next else next in
if step < horizon then
loop (actions::actions_accu) (state::state_accu) (step+1) next
else
- List.rev (actions::actions_accu),
- List.rev (state::state_accu), next
+ List.rev (actions::actions_accu), List.rev (state::state_accu), next
with Playout_over ->
List.rev actions_accu, List.rev state_accu, state) in
+
let init_state = List.map (fun (_,args) -> args.(0))
(run_prolog_atom ("init", [|Var "x"|]) program) in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "playout: init %s\n%!"
- (String.concat " " (List.map term_str init_state))
- );
- (* }}} *)
+ LOG 3 "playout: init %s" (String.concat " " (List.map term_str init_state));
loop [] [] 0 init_state
-
let find_cycle cands =
(* {{{ log entry *)
if !debug_level > 0 then (
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GDL.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -181,6 +181,8 @@
val atom_str : atom -> string
val rel_atom_str : rel_atom -> string
val rel_atoms_str : rel_atom list -> string
+val gdl_rule_str : gdl_rule -> string
+val gdl_rules_str : gdl_rule list -> string
val def_str : string * def_branch list -> string
val literal_str : literal -> string
val literals_str : literal list -> string
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GDLTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -11,18 +11,11 @@
let pte = parse_term
-let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- res
-
let load_rules fname =
- let f = open_in fname in
+ let f = AuxIO.input_file fname in
let descr =
GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_channel f) in
+ (Lexing.from_string f) in
descr
let emb_str (game, state) (rname, emb) =
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GameSimplTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -2,10 +2,8 @@
let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
+ let f = AuxIO.input_file s in
+ let res = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string f) in
res
let tests = "GameSimpl" >::: [
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -15,21 +15,7 @@
let pte = parse_term
-let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- res
-let load_rules fname =
- let f = open_in fname in
- let descr =
- GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_channel f) in
- descr
-
-
let tests = "TranslateFormula" >::: [
"separate_disj" >::
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/TranslateGame.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -39,7 +39,7 @@
let timeout = ref (fun () -> false)
let set_timeout f = (timeout := f; GDL.set_timeout f)
let check_timeout ?(print=true) msg =
- if print && !debug_level > 1 then print_endline ("TimeoutCheck: " ^ msg);
+ if print then LOG 2 "TimeoutCheck: %s" msg;
if !timeout () then (timeout := (fun () -> false); raise (Aux.Timeout msg))
@@ -1577,7 +1577,7 @@
| _ -> raise Not_found in
match arg with
| Const c when
- (try ignore (float_of_string c); true
+ (try Pervasives.compare (float_of_string c) nan <> 0
with Failure "float_of_string" -> false) ->
[Pos (True arg)], body
| Var _ as v ->
@@ -2947,26 +2947,14 @@
let generate_playout_states ?(with_terminal=false) program players =
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "translate_game: generating states...\n%!";
- (* GDL.debug_level := 4; *)
- );
- (* }}} *)
+ LOG 2 "translate_game: generating states...";
let states = Aux.fold_n
(fun acc ->
let _, states, terminal_state =
- playout_prolog ~aggregate:false players !playout_horizon
- program in
+ playout_prolog ~aggregate:false players !playout_horizon program in
if with_terminal then terminal_state :: states @ acc
else states @ acc) [] !playouts_for_rule_filtering in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- (* GDL.debug_level := 0; *)
- Printf.printf "translate_game: generated %d states.\n%!"
- (List.length states)
- );
- (* }}} *)
+ LOG 2 "translate_game: generated %d states." (List.length states);
states
let is_counter_cl num_functors counter_cands (arg, body) =
@@ -2982,22 +2970,20 @@
piecewise-linear functions of argument [RVar ":x"], and remaining
(unchanged) clauses. *)
let detect_counters clauses =
+ let is_nan f = (Pervasives.compare f nan = 0) in
let num_functions =
Aux.map_reduce (fun ((rel,args),b) -> rel,(args,b))
(fun acc br ->
match acc, br with
| Some graph, ([|Const x; Const y|], []) ->
- (try Some ((float_of_string x, float_of_string y)::graph)
+ (try let xf, yf = float_of_string x, float_of_string y in
+ if is_nan xf || is_nan yf then None else Some ((xf, yf)::graph)
with Failure "float_of_string" -> None)
| _ -> None)
(Some []) clauses in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: num_functions cands=%s\n%!"
- (String.concat ", "(Aux.map_some (fun (r,g)->
- if g=None then None else Some r) num_functions))
- );
- (* }}} *)
+ LOG 4 "detect_counters: num_functions cands=%s"
+ (String.concat ", "(Aux.map_some (fun (r,g)->
+ if g=None then None else Some r) num_functions));
let num_functions = Aux.map_some
(function
| rel, Some graph ->
@@ -3006,29 +2992,22 @@
| _ -> None)
num_functions in
let num_functors = List.map fst num_functions in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: num_functors=%s\n%!"
- (String.concat ", " num_functors)
- );
- (* }}} *)
+ LOG 4 "detect_counters: num_functors=%s"
+ (String.concat ", " num_functors);
(* Build initial counter candidates based on their "init" clauses. *)
let counter_inits = Aux.map_some
(function
| ("init", [|Func (cand, [|Const y|])|]), [] ->
- (try Some (cand, float_of_string y)
+ (try let yf = float_of_string y in
+ if is_nan yf then None else Some (cand, yf)
with Failure "float_of_string" -> None)
| _ -> None)
clauses in
let counter_inits = Aux.map_some
(function f, [init_v] -> Some (f, init_v) | _ -> None)
(Aux.collect counter_inits) in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: counter_inits cands=%s\n%!"
- (String.concat ", "(List.map fst counter_inits))
- );
- (* }}} *)
+ LOG 4 "detect_counters: counter_inits cands=%s"
+ (String.concat ", "(List.map fst counter_inits));
let counter_cl_cands = Aux.collect
(Aux.map_some
(function ("next",[|Func (f, [|arg|])|]),body
@@ -3050,12 +3029,8 @@
let counters = List.map fst counter_cls in
let counter_inits = Aux.map_try
(fun c -> c, List.assoc c counter_inits) counters in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: resulting counters=%s\n%!"
- (String.concat ", " counters)
- );
- (* }}} *)
+ LOG 4 "detect_counters: resulting counters=%s"
+ (String.concat ", " counters);
let counter_cls, clauses = List.partition
(function
| ("next",[|Func (f,_)|]),_ -> List.mem f counters
@@ -3114,18 +3089,14 @@
determine values, not to expand their goal value variables later. *)
let counter_inits, counter_cls, goal_cls_w_counters,
num_functions, clauses = detect_counters clauses in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "translate_game: detected counters = %s\n%!"
- (String.concat "; "
- (List.map (fun (c,v) -> c^"="^string_of_float v) counter_inits))
- );
- (* }}} *)
+ LOG 2 "translate_game: detected counters = %s" (String.concat "; " (
+ List.map (fun (c,v) -> c^"="^string_of_float v) counter_inits));
let static_base, init_state, c_paths, f_paths, element_reps, root_reps,
ground_state_terms, arities, term_arities, static_rels, nonstatic_rels,
frame_clauses, move_clauses, clauses, program, playout_states =
prepare_paths_and_elems players_wo_env ~playout_states clauses in
(* recompile the program *)
+ check_timeout "TranslateGame: before testground";
let testground =
replace_rel_in_program "true" (state_cls init_state) program in
let program = optimize_program ~testground program in
@@ -3358,10 +3329,9 @@
with Not_found -> 0 in
(match !generate_test_case with
| None -> ()
- | Some game_name ->
- let file = open_out ("./GGP/tests/"^game_name^"-raw.toss") in
- output_string file (Arena.state_str result);
- flush file; close_out file);
+ | Some game_name ->
+ AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-raw.toss")
+ (Arena.state_str result));
let result = GameSimpl.simplify result in
let gdl_translation = {
(* map between structure elements and their term representations;
@@ -3380,9 +3350,8 @@
(match !generate_test_case with
| None -> ()
| Some game_name ->
- let file = open_out ("./GGP/tests/"^game_name^"-simpl.toss") in
- output_string file (Arena.state_str result);
- flush file; close_out file);
+ AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-simpl.toss")
+ (Arena.state_str result));
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "\n\ntranslate_game: simplified rel sizes --\n%s\n%!"
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -2,27 +2,24 @@
open GDL
let parse_game_descr s =
- GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_string s)
+ GDLParser.parse_game_description KIFLexer.lex (Lexing.from_string s)
let parse_term s =
- GDLParser.parse_term KIFLexer.lex
- (Lexing.from_string s)
+ GDLParser.parse_term KIFLexer.lex (Lexing.from_string s)
let pte = parse_term
let state_of_file s =
- let f = open_in s in
+ let f = AuxIO.input_file s in
let res =
ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
+ (Lexing.from_string f) in
res
let load_rules fname =
- let f = open_in fname in
+ let f = AuxIO.input_file fname in
let descr =
- GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_channel f) in
+ GDLParser.parse_game_description KIFLexer.lex (Lexing.from_string f) in
descr
let emb_str (game, state) (rname, emb) =
@@ -52,17 +49,17 @@
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
let goal_str = AuxIO.input_file ("./GGP/tests/" ^ goal_name) in
- let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in
+ (* let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in *)
let res_str = Arena.state_str (r_game, r_struc) in
- output_string resf res_str;
- close_out resf;
+ (* output_string resf res_str;
+ close_out resf; *)
(* let eq, msg = Arena.compare_diff goal res in *)
let eq, msg = goal_str = res_str, "sorry, just comparing as strings" in
- assert_bool
- ("GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
- ", see GGP/tests/"^game_name^"-temp.toss: "^msg)
- eq;
- Sys.remove ("./GGP/tests/"^game_name^"-temp.toss");
+ assert_bool ("tests for " ^ game_name ^ " failed (" ^ goal_name ^ ")")
+ (* "GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
+ ", see GGP/tests/"^game_name^"-temp.toss: "^msg *)
+ eq;
+ (* Sys.remove ("./GGP/tests/"^game_name^"-temp.toss"); *)
let rname = loc0_rule_name in
let emb =
Arena.matching_of_names res rname loc0_emb in
@@ -152,17 +149,17 @@
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
let goal_str = AuxIO.input_file ("./GGP/tests/"^goal_name) in
- let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in
+ (* let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in *)
let res_str = Arena.state_str (r_game, r_struc) in
- output_string resf res_str;
- close_out resf;
+ (* output_string resf res_str;
+ close_out resf; *)
(* let eq, msg = Arena.compare_diff goal res in *)
let eq, msg = goal_str = res_str, "sorry, just comparing as strings" in
- assert_bool
- ("GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
- ", see GGP/tests/"^game_name^"-temp.toss: "^msg)
- eq;
- Sys.remove ("./GGP/tests/"^game_name^"-temp.toss");
+ assert_bool ("tests for " ^ game_name ^ " failed (" ^ goal_name ^ ")")
+ (*"GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
+ ", see GGP/tests/"^game_name^"-temp.toss: "^msg*)
+ eq;
+ (* Sys.remove ("./GGP/tests/"^game_name^"-temp.toss"); *)
let embs = Array.map
(fun (rname, emb) -> Arena.matching_of_names res rname emb)
rules_and_embs in
@@ -249,7 +246,7 @@
"control__BLANK_", "control__BLANK_"]
~loc1_noop:"noop" ~loc1_move:"(mark f g)" ()
);
-
+(*
"breakthrough" >::
(fun () ->
game_test_case ~game_name:"breakthrough" ~player:"white"
@@ -361,7 +358,7 @@
"control__BLANK_", "control__BLANK_"]
~loc1_noop:"noop" ~loc1_move:"(move 7 7 7 6)" ()
);
-
+*)
]
let set_debug_level i =
@@ -476,7 +473,7 @@
(fun () -> AuxIO.gettimeofday() -. start > float (timeout));
let res, msg = translate_file (dirname ^ fname) None in
let t = AuxIO.gettimeofday() -. start in
- Gc.compact ();
+ AuxIO.gc_compact ();
let final = if res then Printf.sprintf "Suceeded (%f sec.)\n%!" t else
Printf.sprintf "%s (%f sec)\n%!" msg t in
assert_bool final res
@@ -489,7 +486,7 @@
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (file, testdir, timeout) = (ref "", ref "", ref 45) in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_level 1), "be verbose");
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -92,7 +92,7 @@
List.map getstruc (List.filter (fun s -> s <> "") (split_list "\n\n" st_s))
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (testname, dir) = (ref "", ref "examples") in
let dbg_level i = (LearnGame.set_debug_level i) in
let opts = [
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Makefile 2012-02-28 02:36:29 UTC (rev 1681)
@@ -69,8 +69,6 @@
TOSSEXFILES = $(shell find examples -name "*.toss")
TOSSEXRESC = $(addsuffix .resource, $(TOSSEXFILES))
-TOSSGGPFILES = $(shell find GGP/tests -name "*.toss")
-TOSSGGPRESC = $(addsuffix .resource, $(TOSSGGPFILES))
new_resource_file:
@echo "(* Automatically Constructed Resources *)" > Formula/Resources.ml
@@ -80,11 +78,16 @@
@echo "let get_file fn = List.assoc fn !files" >> Formula/Resources.ml
@echo "" >> Formula/Resources.ml
-all_resources: $(TOSSEXRESC) $(TOSSGGPRESC) \
- Server/ServerGDLTest.in.resource \
- Server/ServerGDLTest.out.resource \
- Server/ServerGDLTest.in2.resource \
- Server/ServerGDLTest.out2.resource \
+all_resources: $(TOSSEXRESC) \
+ GGP/tests/connect5-simpl.toss.resource \
+ GGP/tests/breakthrough-simpl.toss.resource \
+ GGP/examples/connect5.gdl.resource \
+ GGP/examples/tictactoe.gdl.resource \
+ GGP/tests/tictactoe-simpl.toss.resource \
+ GGP/examples/tictactoe-other.gdl.resource \
+ GGP/tests/tictactoe-other-simpl.toss.resource \
+ GGP/examples/2player_normal_form_joint.gdl.resource \
+ GGP/tests/2player_normal_form_joint-simpl.toss.resource \
Formula/Resources.ml:
@make new_resource_file > /dev/null
@@ -237,6 +240,7 @@
clean:
ocamlbuild -clean
+ rm -f Client/JsHandler.js
rm -f *.cmx *.cmi *.o *.cmo *.a *.cmxa *.cma *.annot *~ TossServer
rm -f Formula/*~ Solver/*~ Arena/*~ Learn/*~ Play/*~ GGP/*~ Server/*~
rm -f caml_extensions/*.cmo caml_extensions/*.cmi Formula/Resources.ml
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Server/ReqHandler.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -159,7 +159,7 @@
TranslateGame.translate_outgoing_move gdl_transl state
move.Arena.rule move.Arena.matching
) else (
- Gc.compact ();
+ AuxIO.gc_compact ();
TranslateGame.noop_move gdl_transl (snd state)
) in
let msg_len = String.length mov_msg in
@@ -229,28 +229,16 @@
match read_in_line in_ch with
| ("", None) -> print_endline "Empty line."; (rstate, true)
| (line, Some (Aux.Right (f, x))) when line = "COMP" ->
- (* stop forking for now
- (match Unix.fork () with
- | 0 (* child *) ->
- (* if Unix.fork() <> 0 then exit 0; double fork trick for zombies *)
- *)
- let res = f x in
- Marshal.to_channel out_ch res [Marshal.Closures];
- flush out_ch;
- (rstate, false)
- (* | _ (* parent *) -> (rstate, true) ) *)
-
+ let res = f x in
+ Marshal.to_channel out_ch res [Marshal.Closures];
+ flush out_ch;
+ (rstate, false)
+
| (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" ->
(match handle_http_msg rstate cmd head msg ck with
| Aux.Left ((state, resp)) -> report (state, resp) true
| Aux.Right (state, future) ->
- (* stop forking for now
- match Unix.fork () with
- | 0 (* child *) ->
- (*if Unix.fork() <> 0 then exit 0; double fork trick, zombies *)
- *)
- report (state, future ()) false
- (* | _ (* parent *) -> state, true *)
+ report (state, future ()) false
)
| (_, Some _) -> failwith "Internal ReqHandler Error (full_req_handle)!"
| (line, None) ->
@@ -275,8 +263,7 @@
| exn ->
Printf.printf "Toss Server: error -- exception %s\n%!"
(Printexc.to_string exn);
- Printf.printf "Exception backtrace: %s\n%!"
- (Printexc.get_backtrace ());
+ Printf.printf "Exception backtrace: %s\n%!" (AuxIO.backtrace ());
output_string out_ch ("ERR internal error -- see server stdout\n");
flush out_ch;
rstate, true
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Server/Server.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -144,7 +144,7 @@
(* ----------------------- START SERVER WHEN CALLED ------------------------- *)
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (server, port) = (ref "localhost", ref 8110) in
let (test_s, test_full) = (ref "# # / $", ref false) in
let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Server/Tests.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -44,10 +44,14 @@
]
let ggp_tests = "GGP", [
- "GameSimplTest", [GameSimplTest.tests];
- "GDLTest", [GDLTest.tests; GDLTest.bigtests];
- "TranslateGameTest", [TranslateGameTest.tests; TranslateGameTest.bigtests];
- "TranslateFormulaTest", [TranslateFormulaTest.tests];
+ "GameSimplTest", [GameSimplTest.tests];
+ "GDLTest", [GDLTest.tests; GDLTest.bigtests];
+ "TranslateGameTest", IFDEF JAVASCRIPT THEN (
+ [TranslateGameTest.tests]
+ ) ELSE (
+ [TranslateGameTest.tests; TranslateGameTest.bigtests]
+ ) ENDIF;
+ "TranslateFormulaTest", [TranslateFormulaTest.tests];
]
let learn_tests = "Learn", [
@@ -55,9 +59,10 @@
"LearnGameTest", [LearnGameTest.tests];
]
-let server_tests = "Server", [
- "ReqHandlerTest", [ReqHandlerTest.tests];
-]
+let server_tests = "Server",
+IFDEF JAVASCRIPT THEN ( [] ) ELSE (
+ [ "ReqHandlerTest", [ReqHandlerTest.tests] ]
+) ENDIF
let tests_l = [
formula_tests;
Modified: trunk/Toss/Solver/ClassTest.ml
===================================================================
--- trunk/Toss/Solver/ClassTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Solver/ClassTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -431,7 +431,7 @@
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (file, example, debug_level) = (ref "", ref false, ref 0) in
let dbg_level i = (Class.set_debug_level i; debug_level := i;) in
let opts = [
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
