[Toss-devel-svn] SF.net SVN: toss:[1225] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1225] trunk/Toss
|
From: <luk...@us...> - 2010-12-05 21:51:56
|
Revision: 1225
http://toss.svn.sourceforge.net/toss/?rev=1225&view=rev
Author: lukstafi
Date: 2010-12-05 21:51:48 +0000 (Sun, 05 Dec 2010)
Log Message:
-----------
Better rule parsing error messages. More diagnostic logging. Small board handling fix (one pending). Endline comments syntax C++ style. Signature-related fixes in DiscreteRule.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRuleParser.mly
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Formula/FFTNF.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Play/Game.ml
trunk/Toss/Play/GameTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/examples/Chess.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/Arena.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -1,5 +1,7 @@
(* Represent the game arena and operate on it. *)
+let debug_level = ref 0
+
(* The label's time interval defaults to this point. *)
let cDEFAULT_TIMESTEP = 0.1
@@ -88,8 +90,10 @@
default location is 0, default time is 0.0, default data is
empty. *)
type definition =
- | DefRule of string * ((string * int) list ->
- (string * (string list * Formula.formula)) list -> ContinuousRule.rule)
+ | DefRule of string * (
+ (string * int) list ->
+ (string * (string list * Formula.formula)) list -> string ->
+ ContinuousRule.rule)
(* add a rule *)
| DefLoc of ((string * int) list -> location)
(* add location to graph *)
@@ -145,6 +149,8 @@
payoffs = payoffs; payoffs_pp = payoffs_pp;
moves = moves }
+open Printf
+
(* Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
let process_definition ?extend_state defs =
@@ -161,37 +167,50 @@
state.game.defined_rels,
state.struc, state.time,
state.cur_loc, state.data in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ printf "process_definition: %d old rules, %d old locs\n%!"
+ (List.length old_rules) (List.length old_locs);
+ );
+ (* }}} *)
let rules, locations, players, defined_rels,
state, time, cur_loc, data =
- List.fold_left (fun (rules, locations, players, defined_rels,
- state, time, cur_loc, data) -> function
- | DefRule (rname, r) ->
- ((rname, r)::rules, locations, players, defined_rels,
- state, time, cur_loc, data)
- | DefLoc loc ->
- (rules, loc::locations, players, defined_rels,
- state, time, cur_loc, data)
- | DefPlayers more_players ->
- (rules, locations, players @ more_players, defined_rels,
- state, time, cur_loc, data)
- | DefRel (rel, args, body) ->
- (rules, locations, players,
- (rel, args, body)::defined_rels,
- state, time, cur_loc, data)
- | StateStruc struc ->
- (rules, locations, players, defined_rels,
- struc, time, cur_loc, data)
- | StateTime ntime ->
- (rules, locations, players, defined_rels,
- state, ntime, cur_loc, data)
- | StateLoc ncur_loc ->
- (rules, locations, players, defined_rels,
- state, time, ncur_loc, data)
- | StateData more_data ->
- (rules, locations, players, defined_rels,
- state, time, cur_loc, data @ more_data)
- ) ([], [], players, defined_rels,
- state, time, cur_loc, data) defs in
+ List.fold_right (fun def (rules, locations, players, defined_rels,
+ state, time, cur_loc, data) ->
+ match def with
+ | DefRule (rname, r) ->
+ ((rname, r)::rules, locations, players, defined_rels,
+ state, time, cur_loc, data)
+ | DefLoc loc ->
+ (rules, loc::locations, players, defined_rels,
+ state, time, cur_loc, data)
+ | DefPlayers more_players ->
+ (rules, locations, players @ more_players, defined_rels,
+ state, time, cur_loc, data)
+ | DefRel (rel, args, body) ->
+ (rules, locations, players,
+ (rel, args, body)::defined_rels,
+ state, time, cur_loc, data)
+ | StateStruc struc ->
+ (rules, locations, players, defined_rels,
+ struc, time, cur_loc, data)
+ | StateTime ntime ->
+ (rules, locations, players, defined_rels,
+ state, ntime, cur_loc, data)
+ | StateLoc ncur_loc ->
+ (rules, locations, players, defined_rels,
+ state, time, ncur_loc, data)
+ | StateData more_data ->
+ (rules, locations, players, defined_rels,
+ state, time, cur_loc, data @ more_data)
+ ) defs ([], [], players, defined_rels,
+ state, time, cur_loc, data) in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ printf "process_definition: %d new rules, %d defined rels\n%!"
+ (List.length rules) (List.length defined_rels);
+ );
+ (* }}} *)
let def_rels_pure =
List.map (fun (rel, args, body) -> (rel, (args, body))) defined_rels in
let defined_rels =
@@ -204,9 +223,19 @@
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
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ printf "process_definition: parsing new rules...%!";
+ );
+ (* }}} *)
let rules =
old_rules @ List.map (fun (name, r) ->
- name, r signature def_rels_pure) rules in
+ name, r signature def_rels_pure name) rules in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ printf " parsed\n%!";
+ );
+ (* }}} *)
let rules =
List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
let updated_locs =
@@ -228,8 +257,18 @@
let reg_ps =
Array.map SolverIntf.M.register_real_expr ps in
{ loc with payoffs = ps; payoffs_pp = reg_ps } in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ printf "process_definition: parsing locations (registering payoffs)...%!";
+ );
+ (* }}} *)
let locations = updated_locs @
List.map (fun loc -> add_def_rel (loc player_names)) locations in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ printf " parsed\n%!";
+ );
+ (* }}} *)
let graph =
try
Aux.array_from_assoc
@@ -313,11 +352,11 @@
if !equational_def_style then
Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ =@ @[<1>%a@]"
drel (Aux.fprint_sep_list "," Format.pp_print_string) args
- (Formula.fprint(* _nobra 0 *)) body
+ Formula.fprint body
else
Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ {@,@[<1>%a@,@]}"
drel (Aux.fprint_sep_list "," Format.pp_print_string) args
- (Formula.fprint(* _nobra 0 *)) body;
+ Formula.fprint body;
Format.fprintf ppf "@]@ ";
) defined_rels;
Format.fprintf ppf "@[<1>PLAYERS@ %a@]@ "
@@ -408,7 +447,8 @@
| EvalRealExpr of Formula.real_expr (* Evaluate real expr *)
| SetRule of string *
((string * int) list ->
- (string * (string list * Formula.formula)) list -> ContinuousRule.rule)
+ (string * (string list * Formula.formula)) list -> string ->
+ ContinuousRule.rule)
(* Set a rule as given *)
| GetRule of string (* Get a rule as string *)
| SetRuleUpd of string*string *string *Term.term (* Set a rule update eq *)
@@ -681,7 +721,7 @@
(fun (drel, (args, body, _)) -> drel,(args,body))
state.game.defined_rels in
let new_rules =
- Aux.replace_assoc r_name (r signat defs)
+ 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")
with
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/Arena.mli 2010-12-05 21:51:48 UTC (rev 1225)
@@ -1,5 +1,7 @@
(* Represent the game arena and operate on it. *)
+val debug_level : int ref
+
(* ------------------------ BASIC TYPE DEFINITIONS -------------------------- *)
(* A single move consists of applying a rewrite rule for a time from the
@@ -76,8 +78,10 @@
default location is 0, default time is 0.0, default data is
empty. *)
type definition =
- | DefRule of string * ((string * int) list ->
- (string * (string list * Formula.formula)) list -> ContinuousRule.rule)
+ | DefRule of string * (
+ (string * int) list ->
+ (string * (string list * Formula.formula)) list -> string ->
+ ContinuousRule.rule)
(* add a rule *)
| DefLoc of ((string * int) list -> location)
(* add location to graph *)
@@ -155,7 +159,8 @@
| EvalRealExpr of Formula.real_expr (* Evaluate real expr *)
| SetRule of string *
((string * int) list ->
- (string * (string list * Formula.formula)) list -> ContinuousRule.rule)
+ (string * (string list * Formula.formula)) list -> string ->
+ ContinuousRule.rule)
(* Set a rule as given *)
| GetRule of string (* Get a rule as string *)
| SetRuleUpd of string*string *string *Term.term (* Set a rule update eq *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/ArenaParser.mly 2010-12-05 21:51:48 UTC (rev 1225)
@@ -94,7 +94,7 @@
| REL_MOD rel = ID
arg = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
EQ
- body = formula_expr %prec COND
+ body = formula_expr
{ DefRel (rel, arg, body) }
| MODEL_SPEC model = struct_expr
{ StateStruc model }
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/ContinuousRule.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -32,7 +32,7 @@
let discrete = { discr with DiscreteRule.pre = cpre } in
let defrels = List.map (fun (rel,(args,body)) ->
rel, (args, body, SolverIntf.M.register_formula body)) defs in
- let obj = DiscreteRule.compile_rule signat defrels discrete in
+ let obj = DiscreteRule.compile_rule signat defrels discr in
{ discrete = discrete;
compiled = obj ;
dynamics = dynamics ;
Modified: trunk/Toss/Arena/ContinuousRuleParser.mly
===================================================================
--- trunk/Toss/Arena/ContinuousRuleParser.mly 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/ContinuousRuleParser.mly 2010-12-05 21:51:48 UTC (rev 1225)
@@ -8,7 +8,7 @@
%start parse_rule
%type < (string * int) list ->
- (string * (string list * Formula.formula)) list ->
+ (string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule> parse_rule rule_expr
@@ -22,10 +22,15 @@
pre = option (preceded (PRE, formula_expr))
inv = option (preceded (INV, formula_expr))
post = option (preceded (POST, formula_expr))
- { fun signat defs ->
+ { fun signat defs rname ->
(* no need to bother passing [pre] to [discr] *)
- ContinuousRule.make_rule signat defs (discr signat (And []))
- dyn upd ?pre ?inv ?post () }
+ try
+ ContinuousRule.make_rule signat defs (discr signat (And []))
+ dyn upd ?pre ?inv ?post ()
+ with Failure s ->
+ report_parsing_error $startpos $endpos
+ ("Error in rule "^rname^": "^s)
+ }
parse_rule:
rule_expr EOF { $1 };
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/DiscreteRule.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -1,5 +1,7 @@
(* Discrete structure rewriting. *)
+let debug_level = ref 0
+
type matching = (int * int) list
type matchings = Assignments.assignment_set
@@ -123,8 +125,7 @@
r, negative_trace rel r.lhs_form, args_l) rel_prods) in
let precond =
match disjs with
- | [] -> raise (Invalid_argument
- ("fluent_preconds: not a fluent: "^rel))
+ | [] -> failwith ("fluent_preconds: not a fluent: "^rel)
| [phi] -> phi
| _ -> Formula.Or disjs in
rel, (nu_args, precond) in
@@ -553,6 +554,12 @@
embedding condition).
*)
let compile_rule signat defined_rels rule_src =
+ (* TODO: but these shouldn't get into the signature in the first
+ place... See also [rhs_rels] -- empty defined relations appear in
+ RHS structure. *)
+ let signat = List.filter (fun (rel,_) ->
+ special_rel_of rel = None &&
+ not (List.mem_assoc rel defined_rels)) signat in
let expand_def_rels rel =
if List.mem_assoc rel defined_rels then
let args, _, rphi = List.assoc rel defined_rels in
@@ -594,7 +601,13 @@
(* expand defined rels in embedding list *)
let base_emb_rels =
unique (=) (concat_map expand_def_rels rule_src.emb_rels) in
-
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "compile_rule: emb=%s -- base_emb_rels=%s\n%!"
+ (String.concat ", " rule_src.emb_rels)
+ (String.concat ", " base_emb_rels);
+ );
+ (* }}} *)
let tups_union ts1 ts2 = Aux.unique (=) (ts1 @ ts2)
and tups_empty = []
and tups_diff ts1 ts2 =
@@ -763,13 +776,19 @@
(* RHS *)
let rhs_rels =
SSMap.fold (fun rel tups rels ->
- (rel, STups.elements tups) :: rels)
+ if STups.is_empty tups then rels
+ else (rel, STups.elements tups) :: rels)
rule_src.rhs_struc.Structure.relations [] in
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
- then failwith "Non-optional defined relation on RHS.";
+ 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.");
(* 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
@@ -934,20 +953,21 @@
let build_rule_s ?rule_s lhs rhs =
let l_elem le =
try Structure.find_elem lhs le
- with Not_found -> raise (Invalid_argument (
- "\"with\" clause element "^le^" not found in LHS.")) in
+ with Not_found -> failwith
+ ("\"with\" clause element "^le^" not found in LHS.") in
let r_elem re =
try Structure.find_elem rhs re
- with Not_found -> raise (Invalid_argument (
- "\"with\" clause element "^re^" not found in RHS.")) in
+ with Not_found -> failwith
+ ("\"with\" clause element "^re^" not found in RHS.") in
let r_str re = Structure.elem_str rhs re in
match rule_s with
| None ->
- if Structure.Elems.cardinal lhs.Structure.elements <>
- Structure.Elems.cardinal rhs.Structure.elements
- then raise (Invalid_argument
- ("\"with\" clause not given but LHS and RHS "^
- "structures have different size"))
+ let lnum = Structure.Elems.cardinal lhs.Structure.elements in
+ let rnum = Structure.Elems.cardinal rhs.Structure.elements in
+ if lnum <> rnum
+ then failwith
+ (Printf.sprintf "\"with\" clause not given but LHS and RHS \
+ structures have different sizes %d and %d" lnum rnum)
else
Structure.Elems.fold (fun re acc -> (re, l_elem (r_str re))::acc)
rhs.Structure.elements []
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Arena/DiscreteRule.mli 2010-12-05 21:51:48 UTC (rev 1225)
@@ -1,5 +1,7 @@
(* Discrete Structure Rewriting Rules and Rewriting. *)
+val debug_level : int ref
+
(* Single match of a rule, and a set of matches. *)
type matching = (int * int) list
type matchings = Assignments.assignment_set
Modified: trunk/Toss/Formula/FFTNF.ml
===================================================================
--- trunk/Toss/Formula/FFTNF.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Formula/FFTNF.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -441,11 +441,11 @@
let location_str loc =
sprintf "%s#[%s]"
- (Formula.str (unpack_flat (
+ (Formula.sprint (unpack_flat (
formula_of_tree
(zip_nonflat {loc with n={
fvs=Vars.empty; t=TProc (-1,Rel("[HOLE]",[||]))}}))))
- (Formula.str (unpack_flat (formula_of_tree loc.n)))
+ (Formula.sprint (unpack_flat (formula_of_tree loc.n)))
(* Flatten and convert to a formula. *)
(* While translating, also simplify constant truth values. *)
@@ -618,7 +618,7 @@
| {t=TNot_subtask subt} ->
Left subt, {loc with n={fvs=Vars.empty; t=TAnd[]}}
| {fvs=lit_vs; t=TLit lit} ->
- let _ = if !debug_level > 3 then
+ let _ = if !debug_level > 4 then
printf "find_unprot: processing literal %s, loc %s\n"
(Formula.str lit) (location_str loc) in
let best_loc = (* store if first *)
@@ -631,7 +631,7 @@
best_loc
| _ ->
let _ = if !debug_level > 3 then begin
- printf "find_unprot: selecting it\n" end in
+ printf "find_unprot: selecting %s\n" (Formula.str lit) end in
Some ((lit,lit_vs), {loc with n={fvs=Vars.empty; t=TAnd[]}}) in
advance best_loc
@@ -661,7 +661,7 @@
(* The rewriting steps. Uses a callback to process subtasks
recursively before putting them in their final locations. *)
let rec pull_out subproc (task_id, task_lit as task) loc =
- let _ = if !debug_level > 2 then
+ let _ = if !debug_level > 4 then
printf "\npull-out_step_location: %s\n" (location_str loc) in
let lit_vs, put_result =
match task_lit with
@@ -878,19 +878,19 @@
let _ = if !debug_level > 2 then begin
printf "\nfound_subtask-literal: %s\n"
(match subt_lit with
- | Left subt -> Formula.str (Not subt)
+ | Left subt -> Formula.sprint (Not subt)
| Right (lit,_) -> Formula.str lit);
printf "location: %s\n" (location_str loc) end in
let phi = pull_out subproc (i, subt_lit) loc in
if !debug_level > 2 then
printf "\npull-out_result: %s\n"
- (Formula.str (formula_of_tree phi));
+ (Formula.sprint (formula_of_tree phi));
loop (i+1) {x=Top; n=phi}
with Lit_not_found ->
let result = zip loc in
let _ = if !debug_level > 2 then begin
printf "\nff_tnf-result: %s\n"
- (Formula.str (formula_of_tree result)) end in
+ (Formula.sprint (formula_of_tree result)) end in
result
and subproc subt =
@@ -903,10 +903,10 @@
let res = loop 0 loc in
if !debug_level > 1 then
- printf "ff_tnf: res=%s\n%!" (Formula.str (formula_of_tree res));
+ printf "ff_tnf: res=%s\n%!" (Formula.sprint (formula_of_tree res));
let flat = flatten_tree_to_formula res in
if !debug_level > 1 then
- printf "ff_tnf: flat=%s\n%!" (Formula.str flat);
+ printf "ff_tnf: flat=%s\n%!" (Formula.sprint flat);
flat
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Formula/Lexer.mll 2010-12-05 21:51:48 UTC (rev 1225)
@@ -95,6 +95,19 @@
pos_bol = pos.Lexing.pos_cnum;
}
+let move_lines_by lexbuf s =
+ let nbrk = ref 0 in
+ for i = 0 to String.length s - 1 do
+ if s.[i] = '\n' then incr nbrk
+ done;
+ if !nbrk > 0 then
+ let pos = lexbuf.Lexing.lex_curr_p in
+ lexbuf.Lexing.lex_curr_p <- { pos with
+ Lexing.pos_lnum = pos.Lexing.pos_lnum + !nbrk;
+ pos_bol = pos.Lexing.pos_cnum;
+ }
+
+
(* Parsing errors are about both syntax and semantics. *)
exception Parsing_error of string
@@ -195,16 +208,17 @@
| "STATE" { STATE_SPEC }
| "LEFT" { LEFT_SPEC }
| "RIGHT" { RIGHT_SPEC }
- | ['0'-'9']+ as n { INT (int_of_string n) }
- | '-' ['0'-'9']+ as n { INT (int_of_string n) }
- | ['0'-'9']* '.' ['0'-'9']+ as x { FLOAT (float_of_string x) }
- | ['0'-'9']+ '.' ['0'-'9']* as x { FLOAT (float_of_string x) }
+ | ['0'-'9']+ as n { INT (int_of_string n) }
+ | '-' ['0'-'9']+ as n { INT (int_of_string n) }
+ | ['0'-'9']* '.' ['0'-'9']+ as x { FLOAT (float_of_string x) }
+ | ['0'-'9']+ '.' ['0'-'9']* as x { FLOAT (float_of_string x) }
| '-' ['0'-'9']* '.' ['0'-'9']+ as x { FLOAT (float_of_string x) }
| '-' ['0'-'9']+ '.' ['0'-'9']* as x { FLOAT (float_of_string x) }
| ['A'-'Z' 'a'-'z' '_']['0'-'9' 'A'-'Z' 'a'-'z' '_']* as s { ID (s) }
| '"'(['0'-'9' 'A'-'Z' 'a'-'z' ' ' '.' '_' '\t' '\n' '*' '+' '-' '?' '#']+
- as s)'"' { BOARD_STRING (s) }
+ as s)'"' { move_lines_by lexbuf s; BOARD_STRING (s) }
| '#' (['0'-'9' 'A'-'Z' 'a'-'z' ' ' '.' ':' '_' '\t' '*' '+' '-' '?'
'/' '\\']+
- as s) '#' { reset_as_file lexbuf s; lex lexbuf }
+ as s) '#' { reset_as_file lexbuf s; lex lexbuf }
+ | "//" [^ '\n']* '\n' { incr_lineno lexbuf; lex lexbuf }
| eof { EOF }
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Play/Game.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -249,10 +249,12 @@
Array.map (fun node -> Array.map
(fun payoff ->
(* {{{ log entry *)
+
if !debug_level > 3 then (
Printf.printf "default_hauristic: Computing of payoff %s...\n%!"
- (Formula.real_str payoff);
+ (Formula.sprint_real payoff);
);
+
(* }}} *)
Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio
(Aux.strings_of_list fluents) payoff)
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Play/GameTest.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -72,7 +72,7 @@
*)
let emb_rels =
Structure.StringMap.fold (fun rel arity acc ->
- if arity = 1 && not (DiscreteRule.special_rel_of rel = Some "opt")
+ if arity = 1 && DiscreteRule.special_rel_of rel = None
then rel::acc else acc)
lhs_struc.Structure.rel_signature [] in
let pre = formula_of_str precond in
@@ -565,11 +565,11 @@
"play: chess suggest first move" >::
(fun () ->
- todo "Payoff too difficult for heuristic generation.";
+ (* todo "Payoff too difficult for heuristic generation."; *)
let state = chess_game in
Game.set_debug_level 7;
Heuristic.debug_level := 7;
- FFTNF.debug_level := 7;
+ FFTNF.debug_level := 4;
let move_opt = (let p,ps = Game.initialize_default (snd state)
~heur_adv_ratio:(fst state)
~loc:0 ~effort:2
@@ -1101,7 +1101,7 @@
(* The same content as in .toss files. *)
let a =
- print_endline ("\n" ^ Arena.sprint_state (snd gomoku19x19_game))
+ print_endline ("\n" ^ Arena.sprint_state (snd chess_game))
let a () =
Game.set_debug_level 7
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Play/Heuristic.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -592,7 +592,7 @@
let substs = trunc_to_vars vars substs in
if !debug_level > 2 then (
printf "expanded_descritpion: phi=%s; aset=%s\nsubsts=%s\n%!"
- (Formula.str phi)
+ (Formula.sprint phi)
(AssignmentSet.str aset)
(String.concat "; "
(List.map (fun sb->String.concat ", "
@@ -628,7 +628,7 @@
if !debug_level > 3 then (
Printf.printf
"Heuristic: computing expanded description for %s...\n%!"
- (Formula.str phi)
+ (Formula.sprint phi)
);
(* }}} *)
let substs =
@@ -818,7 +818,7 @@
if !debug_level > 2 then (
Printf.printf
"Heuristic: for expanding, get ff-tnf of %s...\n%!"
- (Formula.str phi);
+ (Formula.sprint phi);
);
(* }}} *)
let phi'' =
@@ -827,7 +827,7 @@
if !debug_level > 2 then (
Printf.printf
"Heuristic: computing expanded form of %s...\n%!"
- (Formula.str phi'');
+ (Formula.sprint phi'');
);
(* }}} *)
expanded_form max_alt_descr frels struc phi''
@@ -836,7 +836,7 @@
if !debug_level > 2 then (
Printf.printf
"Heuristic: computing for (expanded) formula %s...\n%!"
- (Formula.str phi')
+ (Formula.sprint phi')
);
(* }}} *)
of_formula adv_ratio
@@ -847,7 +847,7 @@
if !debug_level > 2 then (
Printf.printf
"Heuristic: computing monotonic for %s...\n%!"
- (Formula.str phi);
+ (Formula.sprint phi);
);
(* }}} *)
(* FIXME: shouldn't be expanding? *)
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Solver/Structure.ml 2010-12-05 21:51:48 UTC (rev 1225)
@@ -4,6 +4,8 @@
let cBOARD_DX = 15.0
let cBOARD_DY = -15.0
+let debug_level = ref 0
+
(* ------------------------- TYPE DEFINITIONS -------------------------- *)
module IntMap = Map.Make (* Maps from int to 'alpha *)
@@ -141,6 +143,9 @@
if Elems.mem e struc.elements then e
else raise Not_found
+(* Add an element by name, return the updated structure and the
+ element. Search for an element with the given name in the
+ structure, and if not found, add new element with this name. *)
let find_or_new_elem struc name =
if StringMap.mem name struc.names
then struc, StringMap.find name struc.names
@@ -564,52 +569,61 @@
(* Ignore special relations. *)
let find_unique all_preds =
+ (* FIXME: don't force prefix-free *)
let all_preds = List.filter (fun r -> r.[0] <> '_') all_preds in
(* build a fixed depth trie *)
- let trie1 = List.fold_left (fun trie rel ->
- if List.mem_assoc rel.[0] trie then
- let rels, trie = Aux.pop_assoc rel.[0] trie in
- (rel.[0], rel::rels)::trie
- else (rel.[0], [rel])::trie
+ let trie1 = List.fold_left (fun trie pred ->
+ if List.mem_assoc pred.[0] trie then
+ let preds, trie = Aux.pop_assoc pred.[0] trie in
+ (pred.[0], pred::preds)::trie
+ else (pred.[0], [pred])::trie
) [] all_preds in
+ let trie1 = List.map (fun (k,preds) ->
+ let trunc =
+ List.filter (fun r -> String.length r = 1) preds in
+ if trunc = [] then k, preds else k, trunc) trie1 in
let uniq1, trie1 = Aux.partition_map
- (function (k,[rel]) -> Aux.Left (rel, Char.escaped k)
+ (function (k,[pred]) -> Aux.Left (pred, Char.escaped k)
| subt -> Aux.Right subt) trie1 in
let trie1 = List.map
- (fun (k, rels) -> k, List.filter
- (fun rel -> String.length rel > 1) rels) trie1 in
+ (fun (k, preds) -> k, List.filter
+ (fun pred -> String.length pred > 1) preds) trie1 in
let trie2 = Aux.concat_map (fun (key, preds) ->
let trie2 =
- List.fold_left (fun trie rel ->
- if List.mem_assoc rel.[1] trie then
- let rels, trie = Aux.pop_assoc rel.[1] trie in
- (rel.[1], rel::rels)::trie
- else (rel.[1], [rel])::trie
+ List.fold_left (fun trie pred ->
+ if List.mem_assoc pred.[1] trie then
+ let preds, trie = Aux.pop_assoc pred.[1] trie in
+ (pred.[1], pred::preds)::trie
+ else (pred.[1], [pred])::trie
) [] preds in
List.map (fun (key2, preds) ->
Char.escaped key ^ Char.escaped key2, preds) trie2
) trie1 in
+ let trie2 = List.map (fun (k,preds) ->
+ let trunc =
+ List.filter (fun r -> String.length r = 2) preds in
+ if trunc = [] then k, preds else k, trunc) trie2 in
let uniq2, trie2 = Aux.partition_map
- (function (k,[rel]) -> Aux.Left (rel, k)
+ (function (k,[pred]) -> Aux.Left (pred, k)
| subt -> Aux.Right subt) trie2 in
let trie2 = List.map
- (fun (k, rels) -> k, List.filter
- (fun rel -> String.length rel > 2) rels) trie2 in
+ (fun (k, preds) -> k, List.filter
+ (fun pred -> String.length pred > 2) preds) trie2 in
let trie3 = Aux.concat_map (fun (key, preds) ->
let trie3 =
- List.fold_left (fun trie rel ->
- if List.mem_assoc rel.[2] trie then
- let rels, trie = Aux.pop_assoc rel.[2] trie in
- (rel.[2], rel::rels)::trie
- else (rel.[2], [rel])::trie
+ List.fold_left (fun trie pred ->
+ if List.mem_assoc pred.[2] trie then
+ let preds, trie = Aux.pop_assoc pred.[2] trie in
+ (pred.[2], pred::preds)::trie
+ else (pred.[2], [pred])::trie
) [] preds in
List.map (fun (key2, preds) ->
key ^ Char.escaped key2, preds) trie3
) trie2 in
let uniq3 = Aux.map_some
- (function (k,[rel]) -> Some (rel,k) | _ -> None) trie3 in
+ (function (k,[pred]) -> Some (pred,k) | _ -> None) trie3 in
uniq1, uniq2, uniq3
@@ -710,7 +724,16 @@
inferred parameters (row / column relations and position
increments), and the structure with information already extracted
into the string removed. *)
-let board_to_string struc =
+let rec board_to_string struc =
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ let old_level = !debug_level in
+ debug_level := 0;
+ let bstr,_ = board_to_string struc in
+ Printf.printf "board_to_string: printing of %s\n%!" bstr;
+ debug_level := old_level;
+ );
+ (* }}} *)
let col_index =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in
(* find the spanning rectangle *)
@@ -833,10 +856,22 @@
StringMap.fold (fun rel arity predicates ->
if arity = 1 then rel::predicates else predicates)
struc.rel_signature [] in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "board_to_string: all_predicates=%s\n%!"
+ (String.concat ", " all_predicates);
+ );
+ (* }}} *)
let uniq1, uniq2, uniq3 =
find_unique all_predicates in
let uniq_long = uniq1 @ uniq2 @ uniq3 in
let uniq_short = uniq1 @ uniq2 in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "board_to_string: uniq_long=%s\n%!"
+ (String.concat ", " (List.map fst uniq_long));
+ );
+ (* }}} *)
let ret = ref struc in
for c=1 to c_max do
for r=1 to r_max do
@@ -850,7 +885,7 @@
c_max*3*(r_max - r)*2 + c_max*3 + 2*(r_max - r)*2 + (c-1)*3 + 3 in
if elem = -1 then board.[lower_left] <- '*'
else begin
- (* collect the predicates *)
+ (* collect the predicates *)
let tup = [|elem|] in
let predicates = List.filter
(fun pred ->
@@ -858,12 +893,12 @@
try StringMap.find pred !ret.relations
with Not_found -> Tuples.empty in
Tuples.mem tup tmap &&
- let rmap =
- try StringMap.find pred !ret.incidence
- with Not_found -> IntMap.empty in
- not (Tuples.is_empty (
- try IntMap.find elem rmap
- with Not_found -> Tuples.empty)))
+ let rmap =
+ try StringMap.find pred !ret.incidence
+ with Not_found -> IntMap.empty in
+ not (Tuples.is_empty (
+ try IntMap.find elem rmap
+ with Not_found -> Tuples.empty)))
all_predicates in
let up_line = String.make 3 ' '
and lo_line = String.make 3 ' ' in
@@ -902,18 +937,18 @@
init_pos_x +. float_of_int (c - 1) *. pos_dx in
let pos_y =
init_pos_y +. float_of_int (r - 1) *. pos_dy in
- if try fun_val !ret "x" elem = pos_x
- with Not_found -> false then
- ret := del_fun !ret "x" elem;
- if try fun_val !ret "y" elem = pos_y
- with Not_found -> false then
- ret := del_fun !ret "y" elem;
- if try fun_val !ret "vx" elem = 0.0
- with Not_found -> false then
- ret := del_fun !ret "vx" elem;
- if try fun_val !ret "vy" elem = 0.0
- with Not_found -> false then
- ret := del_fun !ret "vy" elem;
+ if (try fun_val !ret "x" elem = pos_x
+ with Not_found -> false)
+ then ret := del_fun !ret "x" elem;
+ if (try fun_val !ret "y" elem = pos_y
+ with Not_found -> false)
+ then ret := del_fun !ret "y" elem;
+ if (try fun_val !ret "vx" elem = 0.0
+ with Not_found -> false)
+ then ret := del_fun !ret "vx" elem;
+ if (try fun_val !ret "vy" elem = 0.0
+ with Not_found -> false)
+ then ret := del_fun !ret "vy" elem;
end
done
done;
@@ -936,8 +971,8 @@
else struc
with Not_found -> struc in
ret := List.fold_left clear_empty !ret ["x"; "y"; "vx"; "vy"];
- (* relations that are in the structure for the sake of
- signature, i.e. they're empty *)
+ (* relations that are in the structure for the sake of
+ signature, i.e. they're empty *)
let signat_rels =
StringMap.fold (fun rel tups acc ->
if Tuples.is_empty tups then rel::acc else acc)
@@ -1100,7 +1135,7 @@
then (
let elname = Char.escaped col_index.[c-1] ^ string_of_int r in
let nstruc, elem =
- add_new_elem !struc ~name:elname () in
+ find_or_new_elem !struc elname in
board_els.(c-1).(r-1) <- elem;
struc := nstruc;
let tup = [|elem|] in
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/Solver/Structure.mli 2010-12-05 21:51:48 UTC (rev 1225)
@@ -1,5 +1,6 @@
(* Representing Structures *)
+val debug_level : int ref
module IntMap : Map.S with type key = int (* Maps from int to 'alpha *)
Modified: trunk/Toss/examples/Chess.toss
===================================================================
--- trunk/Toss/examples/Chess.toss 2010-12-05 20:52:32 UTC (rev 1224)
+++ trunk/Toss/examples/Chess.toss 2010-12-05 21:51:48 UTC (rev 1225)
@@ -327,7 +327,7 @@
[ 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()
-LOC 0 { # both can castle #
+LOC 0 { // both can castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -349,7 +349,7 @@
[WhiteQueen -> 1];
[WhiteKing -> 7]
}
-LOC 1 { # both can castle #
+LOC 1 { // both can castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -371,7 +371,7 @@
[BlackQueen -> 0];
[BlackKing -> 24]
}
-LOC 2 { # w left, b can castle #
+LOC 2 { // w left, b can castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -393,7 +393,7 @@
[WhiteQueen -> 3];
[WhiteKing -> 7]
}
-LOC 3 { # w left, b can castle #
+LOC 3 { // w left, b can castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -415,7 +415,7 @@
[BlackQueen -> 2];
[BlackKing -> 26]
}
-LOC 4 { # w right, b can castle #
+LOC 4 { // w right, b can castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -437,7 +437,7 @@
[WhiteQueen -> 5];
[WhiteKing -> 7]
}
-LOC 5 { # w right, b can castle #
+LOC 5 { // w right, b can castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -459,7 +459,7 @@
[BlackQueen -> 4];
[BlackKing -> 28]
}
-LOC 6 { # w no, b can castle #
+LOC 6 { // w no, b can castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -481,7 +481,7 @@
[WhiteQueen -> 7];
[WhiteKing -> 7]
}
-LOC 7 { # w no, b can castle #
+LOC 7 { // w no, b can castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -503,7 +503,7 @@
[BlackQueen -> 6];
[BlackKing -> 30]
}
-LOC 8 { # w can, b left castle #
+LOC 8 { // w can, b left castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -525,7 +525,7 @@
[WhiteQueen -> 9];
[WhiteKing -> 15]
}
-LOC 9 { # w can, b left castle #
+LOC 9 { // w can, b left castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -547,7 +547,7 @@
[BlackQueen -> 8];
[BlackKing -> 24]
}
-LOC 10 { # w left, b left castle #
+LOC 10 { // w left, b left castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -569,7 +569,7 @@
[WhiteQueen -> 11];
[WhiteKing -> 15]
}
-LOC 11 { # w left, b left castle #
+LOC 11 { // w left, b left castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -591,7 +591,7 @@
[BlackQueen -> 10];
[BlackKing -> 26]
}
-LOC 12 { # w right, b left castle #
+LOC 12 { // w right, b left castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -613,7 +613,7 @@
[WhiteQueen -> 13];
[WhiteKing -> 15]
}
-LOC 13 { # w right, b left castle #
+LOC 13 { // w right, b left castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -635,7 +635,7 @@
[BlackQueen -> 12];
[BlackKing -> 28]
}
-LOC 14 { # w no, b left castle #
+LOC 14 { // w no, b left castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -657,7 +657,7 @@
[WhiteQueen -> 15];
[WhiteKing -> 15]
}
-LOC 15 { # w no, b left castle #
+LOC 15 { // w no, b left castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -679,7 +679,7 @@
[BlackQueen -> 14];
[BlackKing -> 30]
}
-LOC 16 { # w can, b right castle #
+LOC 16 { // w can, b right castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -701,7 +701,7 @@
[WhiteQueen -> 17];
[WhiteKing -> 23]
}
-LOC 17 { # w can, b right castle #
+LOC 17 { // w can, b right castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -723,7 +723,7 @@
[BlackQueen -> 16];
[BlackKing -> 24]
}
-LOC 18 { # w left, b right castle #
+LOC 18 { // w left, b right castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -745,7 +745,7 @@
[WhiteQueen -> 19];
[WhiteKing -> 23]
}
-LOC 19 { # w left, b right castle #
+LOC 19 { // w left, b right castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -767,7 +767,7 @@
[BlackQueen -> 18];
[BlackKing -> 26]
}
-LOC 20 { # w right, b right castle #
+LOC 20 { // w right, b right castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -789,7 +789,7 @@
[WhiteQueen -> 21];
[WhiteKing -> 23]
}
-LOC 21 { # w right, b right castle #
+LOC 21 { // w right, b right castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -811,7 +811,7 @@
[BlackQueen -> 20];
[BlackKing -> 28]
}
-LOC 22 { # w no, b right castle #
+LOC 22 { // w no, b right castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -833,7 +833,7 @@
[WhiteQueen -> 23];
[WhiteKing -> 23]
}
-LOC 23 { # w no, b right castle #
+LOC 23 { // w no, b right castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -855,7 +855,7 @@
[BlackQueen -> 22];
[BlackKing -> 30]
}
- LOC 24 { # w can, b no castle #
+ LOC 24 { // w can, b no castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -877,7 +877,7 @@
[WhiteQueen -> 25];
[WhiteKing -> 31]
}
-LOC 25 { # w can, b no castle #
+LOC 25 { // w can, b no castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -899,7 +899,7 @@
[BlackQueen -> 24];
[BlackKing -> 24]
}
-LOC 26 { # w left, b no castle #
+LOC 26 { // w left, b no castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -921,7 +921,7 @@
[WhiteQueen -> 27];
[WhiteKing -> 31]
}
-LOC 27 { # w left, b no castle #
+LOC 27 { // w left, b no castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -943,7 +943,7 @@
[BlackQueen -> 26];
[BlackKing -> 26]
}
-LOC 28 { # w right, b no castle #
+LOC 28 { // w right, b no castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -965,7 +965,7 @@
[WhiteQueen -> 29];
[WhiteKing -> 31]
}
-LOC 29 { # w right, b no castle #
+LOC 29 { // w right, b no castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -987,7 +987,7 @@
[BlackQueen -> 28];
[BlackKing -> 28]
}
-LOC 30 { # w no, b no castle #
+LOC 30 { // w no, b no castle
PLAYER 1
PAYOFF {
1: :(CheckB()) - :(CheckW());
@@ -1009,7 +1009,7 @@
[WhiteQueen -> 31];
[WhiteKing -> 31]
}
-LOC 31 { # w no, b no castle #
+LOC 31 { // w no, b no castle
PLAYER 2
PAYOFF {
1: :(CheckB()) - :(CheckW());
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
