toss-devel-svn Mailing List for Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn — Toss development: svn commits
You can subscribe to this list here.
| 2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(25) |
Dec
(62) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2011 |
Jan
(26) |
Feb
(38) |
Mar
(67) |
Apr
(22) |
May
(41) |
Jun
(30) |
Jul
(24) |
Aug
(32) |
Sep
(29) |
Oct
(34) |
Nov
(18) |
Dec
(2) |
| 2012 |
Jan
(19) |
Feb
(25) |
Mar
(16) |
Apr
(2) |
May
(18) |
Jun
(21) |
Jul
(11) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <luk...@us...> - 2012-07-18 15:33:32
|
Revision: 1748
http://toss.svn.sourceforge.net/toss/?rev=1748&view=rev
Author: lukaszkaiser
Date: 2012-07-18 15:33:21 +0000 (Wed, 18 Jul 2012)
Log Message:
-----------
Testing TC - bug found and removed.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-07-18 13:38:17 UTC (rev 1747)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-07-18 15:33:21 UTC (rev 1748)
@@ -40,20 +40,23 @@
let var_str = string_of_int
(** Print a Boolean formula as a string. *)
-let rec str = function
- | BVar v -> var_str v
- | BNot phi -> "(not " ^ (str phi) ^ ")"
- | BAnd [] -> "true"
- | BOr [] -> "false"
- | BAnd (bflist) -> bf_list_str " and " bflist
- | BOr (bflist) -> bf_list_str " or " bflist
+let rec str ?names bf =
+ let name s = match names with None -> var_str s | Some tbl ->
+ try Hashtbl.find tbl s with Not_found -> var_str s in
+ let rec str_rec = function
+ | BVar v -> if v < 0 then "-" ^ (name (-v)) else name v
+ | BNot phi -> "(not " ^ (str_rec phi) ^ ")"
+ | BAnd [] -> "true"
+ | BOr [] -> "false"
+ | BAnd (bflist) -> bf_list_str " and " bflist
+ | BOr (bflist) -> bf_list_str " or " bflist
+ and bf_list_str sep = function
+ | [] -> "[]"
+ | [phi] -> str_rec phi
+ | lst -> "(" ^ (String.concat sep (List.map str_rec lst)) ^ ")" in
+ str_rec bf
-and bf_list_str sep = function
- | [] -> "[]"
- | [phi] -> str phi
- | lst -> "(" ^ (String.concat sep (List.map str lst)) ^ ")"
-
(* ------------------------ ORDER ON FORMULAS ------------------------------- *)
(** Compare two variables. We assume that FO < MSO < Real. *)
@@ -961,7 +964,7 @@
let name s = match names with None -> var_str s | Some tbl ->
try Hashtbl.find tbl s with Not_found -> var_str s in
let rec qbf_str_rec = function
- | QVar v -> name v
+ | QVar v -> if v < 0 then "-" ^ (name (-v)) else name v
| QNot phi -> "(not " ^ (qbf_str_rec phi) ^ ")"
| QAnd [] -> "true"
| QOr [] -> "false"
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-07-18 13:38:17 UTC (rev 1747)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-07-18 15:33:21 UTC (rev 1748)
@@ -17,7 +17,7 @@
val var_str : int -> string
(** Print a formula as a string. *)
-val str : bool_formula -> string
+val str : ?names: (int, string) Hashtbl.t -> bool_formula -> string
(** Helper function to flatten multiple or's and and's. *)
val flatten_sort : bool_formula -> bool_formula
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-07-18 13:38:17 UTC (rev 1747)
+++ trunk/Toss/Solver/Solver.ml 2012-07-18 15:33:21 UTC (rev 1748)
@@ -554,7 +554,7 @@
let qbf, rev_ids = so_to_qbf struc psi in
(match logtime with None -> () | Some t ->
LOG 0 "%sQBF constructed at %.3fs" logprefix (AuxIO.gettimeofday ()-.t));
- let bf = BoolFormula.sat_of_qbf (*elim_quant*) qbf in
+ let bf = BoolFormula.elim_quant qbf in
(match logtime with None -> () | Some t ->
LOG 0 "%sBF constructed at %.3fs" logprefix (AuxIO.gettimeofday () -. t));
match BoolFormula.find_model ?logtime ~logprefix bf with
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-07-18 13:38:17 UTC (rev 1747)
+++ trunk/Toss/Solver/SolverTest.ml 2012-07-18 15:33:21 UTC (rev 1748)
@@ -198,8 +198,11 @@
(String.concat "." (Array.to_list (Array.map string_of_int arr))) in
let names_tbl = Hashtbl.create (Hashtbl.length rev_ids) in
Hashtbl.iter (fun k v -> Hashtbl.add names_tbl k (name v)) rev_ids;
- assert_equal ~printer:(fun x -> x) qbf_s
- (BoolFormula.qbf_str ~names:names_tbl qbf_res) in
+ let qbf_res_s = BoolFormula.qbf_str ~names:names_tbl qbf_res in
+ LOG 1 "QBF %s BF %s" qbf_res_s (
+ let bf = BoolFormula.simplify (BoolFormula.sat_of_qbf qbf_res) in
+ (BoolFormula.str ~names:names_tbl bf) );
+ assert_equal ~printer:(fun x -> x) qbf_s qbf_res_s in
qbf_str_eq "[ a, b | T { a } | ]" "ex |R all x, y (T(x) or |R (x, y))"
"(ex R.2.2, R.2.1, R.1.2, R.1.1 (R.2.1 and R.2.2))";
@@ -229,8 +232,8 @@
"(|A(x) | (|A(y) & E(x,y))) & (|B(x) | (|B(u)&E(x,u))) &" ^
" (|C(x)|(|C(v) & E(x,v))))") in
let yd = "(&x2=&x1+1 | &x2=&x1+2 | &x1=&x2+1 | &x1=&x2+2)" in ();
-(* find_so_test dnp3 ("[ 0 - 4 | | - ] with E(x1, x2) = " ^ yd)
- "|C {e1; e3}; |B {e0; e4}; |A (e2)"; *)
+ find_so_test dnp3 ("[ 0 - 4 | | - ] with E(x1, x2) = " ^ yd)
+ "|C {e1; e3}; |B {e0; e4}; |A (e2)";
let nd = yd ^ "& ((~(&x1=1) & ~(&x2=1)) | (&x1=1 & &x2=3))" in
find_so_test dnp3 ("[ 0 - 4 | | - ] with E(x1, x2) = " ^ nd) "UNSAT";
@@ -246,8 +249,10 @@
"( (|Tc(x, y) ∧ |Tc(y, z)) -> |Tc(x, z) ) ) ) ∧ " ^
"( ∀ |T ( (∀ x,y,z ( ( E(x, y) → |T(x, y) ) ∧ " ^
"( (|T(x, y) ∧ |T(y, z)) -> |T(x, z) ) ) ) → " ^
- "(∀ x, y (|T(x, y) → |Tc(x, y) )) ))" in
- find_so_test tc2phi "[ c | E { (a, b) } | ]" "|Tc?";
+ "(∀ x, y (|Tc(x, y) → |T(x, y) )) ))" in
+ find_so_test tc2phi "[ | E { (a, b); (c, d) } | ]" "|Tc {(a, b); (c, d)}";
+ find_so_test tc2phi "[ | E { (a, b); (b, c) } | ]"
+ "|Tc {(a, b); (a, c); (b, c)}";
);
"eval: second-order" >::
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-18 13:38:26
|
Revision: 1747
http://toss.svn.sourceforge.net/toss/?rev=1747&view=rev
Author: lukaszkaiser
Date: 2012-07-18 13:38:17 +0000 (Wed, 18 Jul 2012)
Log Message:
-----------
Testing TC bug, first step.
Modified Paths:
--------------
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-07-17 11:31:00 UTC (rev 1746)
+++ trunk/Toss/Solver/Solver.ml 2012-07-18 13:38:17 UTC (rev 1747)
@@ -554,7 +554,7 @@
let qbf, rev_ids = so_to_qbf struc psi in
(match logtime with None -> () | Some t ->
LOG 0 "%sQBF constructed at %.3fs" logprefix (AuxIO.gettimeofday ()-.t));
- let bf = BoolFormula.elim_quant qbf in
+ let bf = BoolFormula.sat_of_qbf (*elim_quant*) qbf in
(match logtime with None -> () | Some t ->
LOG 0 "%sBF constructed at %.3fs" logprefix (AuxIO.gettimeofday () -. t));
match BoolFormula.find_model ?logtime ~logprefix bf with
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-07-17 11:31:00 UTC (rev 1746)
+++ trunk/Toss/Solver/SolverTest.ml 2012-07-18 13:38:17 UTC (rev 1747)
@@ -228,9 +228,9 @@
"(|C(x)-> not (|A(x)| |B(x)))) & " ^
"(|A(x) | (|A(y) & E(x,y))) & (|B(x) | (|B(u)&E(x,u))) &" ^
" (|C(x)|(|C(v) & E(x,v))))") in
- let yd = "(&x2=&x1+1 | &x2=&x1+2 | &x1=&x2+1 | &x1=&x2+2)" in
- find_so_test dnp3 ("[ 0 - 4 | | - ] with E(x1, x2) = " ^ yd)
- "|C {e1; e3}; |B {e0; e4}; |A (e2)";
+ let yd = "(&x2=&x1+1 | &x2=&x1+2 | &x1=&x2+1 | &x1=&x2+2)" in ();
+(* find_so_test dnp3 ("[ 0 - 4 | | - ] with E(x1, x2) = " ^ yd)
+ "|C {e1; e3}; |B {e0; e4}; |A (e2)"; *)
let nd = yd ^ "& ((~(&x1=1) & ~(&x2=1)) | (&x1=1 & &x2=3))" in
find_so_test dnp3 ("[ 0 - 4 | | - ] with E(x1, x2) = " ^ nd) "UNSAT";
@@ -240,6 +240,14 @@
find_so_test ~sat_only:true col3
("[ 0 - 9 | | - ] with E(x1, x2) = " ^ tcol) "SAT";
find_so_test col3 ("[ 0 - 9 | | - ] with E(x1, x2) = " ^ ntcol) "UNSAT";
+
+ let tc2phi =
+ "( ∀ x,y,z ( ( E(x, y) → |Tc(x, y) ) ∧" ^
+ "( (|Tc(x, y) ∧ |Tc(y, z)) -> |Tc(x, z) ) ) ) ∧ " ^
+ "( ∀ |T ( (∀ x,y,z ( ( E(x, y) → |T(x, y) ) ∧ " ^
+ "( (|T(x, y) ∧ |T(y, z)) -> |T(x, z) ) ) ) → " ^
+ "(∀ x, y (|T(x, y) → |Tc(x, y) )) ))" in
+ find_so_test tc2phi "[ c | E { (a, b) } | ]" "|Tc?";
);
"eval: second-order" >::
@@ -265,13 +273,6 @@
("ex |R, |G all x, y ( (|R(x) or |G(x)) and ( E(x, y) -> " ^
"not ( (|R(x) and |R(y)) " ^ " or (|G(x) and |G(y)))))") in
eval_eq triangle col2phi "{}";
-
- let tc2_phi =
- "( ∀ x,y,z ( ( E(x, y) → |Tc(x, y) ) ∧" ^
- "( (|Tc(x, y) ∧ |Tc(y, z)) -> |Tc(x, z) ) ) ) ∧ " ^
- "( ∀ |T (∀ x,y,z ( ( E(x, y) → |T(x, y) ) ∧ " ^
- "( (|T(x, y) ∧ |T(y, z)) -> |T(x, z) ) ) → " ^
- "(∀ x, y (|T(x, y) → |Tc(x, y) )) ))" in ();
);
"eval: game heuristic tests" >::
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-17 11:31:12
|
Revision: 1746
http://toss.svn.sourceforge.net/toss/?rev=1746&view=rev
Author: lukstafi
Date: 2012-07-17 11:31:00 +0000 (Tue, 17 Jul 2012)
Log Message:
-----------
Topological sorting. Term parsing moved to iterated substitutions.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Term/Makefile
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArc.mli
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Formula/Aux.ml 2012-07-17 11:31:00 UTC (rev 1746)
@@ -484,20 +484,30 @@
type 'a topol_sort_ops = {
rem_edge : 'a -> 'a -> unit; (* [rem_edge a b] removes a->b. *)
iter_outgoing : ('a -> unit) -> 'a -> unit;
- no_outgoing : 'a -> bool
+ no_incoming : 'a -> bool;
+ node_to_string : 'a -> string;
}
let topol_sort ops l =
- let top = ref (List.filter (fun e -> ops.no_outgoing e) l) in
+ let top = ref (List.filter (fun e -> ops.no_incoming e) l) in
+ (*Printf.printf "topol_sort: top=%s\n%!"
+ (String.concat ", " (List.map (fun n -> ops.node_to_string n) !top));*)
let res = ref [] in
while !top <> [] do
let n = List.hd !top in
top := List.tl !top; res := n:: !res;
ops.iter_outgoing (fun m ->
- ops.rem_edge n m; if ops.no_outgoing m then res := m:: !res) n;
+ ops.rem_edge n m; if ops.no_incoming m then top := m:: !top) n;
done;
- if List.for_all ops.no_outgoing l then List.rev !res
- else raise Not_found
+ (* FIXME *)
+ if List.for_all ops.no_incoming l then List.rev !res
+ else (*
+ Printf.printf "topol_sort: cycle\n%!";
+ List.iter (fun n -> ops.iter_outgoing (fun m ->
+ Printf.printf "%s->%s; " (ops.node_to_string n) (ops.node_to_string m)
+ ) n) l;
+ Printf.printf "\n%!";*)
+ raise Not_found
let all_subsets ?max_size set =
let size = match max_size with Some i -> i | None -> List.length set in
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Formula/Aux.mli 2012-07-17 11:31:00 UTC (rev 1746)
@@ -219,7 +219,8 @@
type 'a topol_sort_ops = {
rem_edge : 'a -> 'a -> unit; (** [rem_edge a b] removes [a->b]. *)
iter_outgoing : ('a -> unit) -> 'a -> unit;
- no_outgoing : 'a -> bool
+ no_incoming : 'a -> bool;
+ node_to_string : 'a -> string;
}
(** Topogical sort of [l] where [cmp a b = true] means that there is
Modified: trunk/Toss/Term/Makefile
===================================================================
--- trunk/Toss/Term/Makefile 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Term/Makefile 2012-07-17 11:31:00 UTC (rev 1746)
@@ -1,6 +1,6 @@
all: allparsed
-MKPARSED = ../TRSTest.native -v -l "../Term/lib"
+MKPARSED = OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TRSTest.native -v -l "../Term/lib"
coreparsed:
make -C .. ./Term/TRSTest.native
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Term/ParseArc.ml 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Term/ParseArc.ml 2012-07-17 11:31:00 UTC (rev 1746)
@@ -11,8 +11,8 @@
[term] does not have [substitution] applied. *)
type parser_elem =
| Token of string
- | PTerm of term * substs * int (* From [parsed_elems], [cstrn]
- and [endpos] of {!parser_arc}. *)
+ | PTerm of term * isubsts * int (* From [parsed_elems], [cstrn]
+ and [endpos] of {!parser_arc}. *)
(* Print a parser elem. *)
let elem_str = function
@@ -33,7 +33,7 @@
spos : int; (* Start position of the arc. *)
endpos : int; (* The current end position of the
arc. FIXME: unnecessary? *)
- cstrn : substs; (* Constraint for the arc. *)
+ cstrn : isubsts; (* Constraint for the arc. *)
}
(* --- Extending and closing arcs --- *)
@@ -71,35 +71,27 @@
(* For now (first-order mgu) we assume single type. *)
let pty = type_of t in
try
- (* Purely an optimization step. *)
- precheck_eq ty pty;
- (*let ty = Term.apply_sb arc.cstrn ty in
- let pty = Term.apply_sb t_cstrn pty in
- precheck_eq ty pty;*)
(* Combine the constraints so far, and extend them to cover
the new parsed element. *)
- (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ (*if !debug then Printf.printf
"extend_arc: sd_n=%s; #parsed=%d\nty=%s; pty=%s\nt=%s\nt_cstrn=%s\narc.cstrn=%s\n%!"
arc.sd_n (List.length arc.parsed_elems)
- (type_to_string ty) (type_to_string pty)
- (Coding.term_to_string t) (substs_str t_cstrn) (substs_str arc.cstrn)
- ;*)
- let cstrn' = combine_mgu_sbs t_cstrn arc.cstrn in
- (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
- "S(ty)=%s; S(pty)=%s\ncstrn'=%s\n%!"
- (type_to_string (apply_sbs cstrn' ty))
- (type_to_string (apply_sbs cstrn' pty))
- (substs_str cstrn');*)
+ (term_str ty) (term_str pty)
+ (term_str t)
+ (isubsts_str t_cstrn) (isubsts_str arc.cstrn);*)
+ let cstrn' = aux_mgu_i_cont global_decls t_cstrn arc.cstrn in
+ (*if !debug then Printf.printf
+ "cstrn'=%s\n%!" (isubsts_str cstrn');*)
let cstrn =
- mgu cstrn' [apply_sbs cstrn' pty, apply_sbs cstrn' ty] in
- (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ aux_mgu_i global_decls cstrn' pty ty in
+ (*if !debug then Printf.printf
"cstrn=%s\n%!"
- (substs_str cstrn);*)
+ (isubsts_str cstrn);*)
Some
{arc with rem_elems; parsed_elems = elem::arc.parsed_elems;
endpos = t_endpos; cstrn}
with UNIFY ->
- (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ (*if !debug then Printf.printf
"NO UNIFY\n%!";*)
None
@@ -158,7 +150,7 @@
rem_elems = elems;
parsed_elems = [];
endpos = spos;
- cstrn = empty_sbs;
+ cstrn = empty_isbs;
}
(* TODO: clean-up the description.
@@ -284,11 +276,12 @@
(* --- Final parsing --- *)
let parse_with_sdefs sdefs str =
(*Printf.printf "\nparse_with_sdefs: str=%s\n%!" str;
- if str = "if is digit string from c_a :: [] then added ending cl_a else false"
- then debug := true;*)
+ if str = "Let map f_1 {} | {} to x :: xs with first argument v_a be
+ (f_1 v_a | x) :: map f_1 {} | {} to xs with first argument v_a"
+ then (debug := true; Term.debug := true);*)
let type_of_pe = function Token _ -> None
| PTerm (te, cstrn, _) ->
- let result = apply_sbs cstrn te in
- Some result in
+ try Some (apply_isbs cstrn te)
+ with UNIFY -> None in
let elems = parse sdefs (split_input_string str) in
Aux.map_some type_of_pe elems
Modified: trunk/Toss/Term/ParseArc.mli
===================================================================
--- trunk/Toss/Term/ParseArc.mli 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Term/ParseArc.mli 2012-07-17 11:31:00 UTC (rev 1746)
@@ -9,8 +9,8 @@
have [substitution] applied. *)
type parser_elem =
| Token of string
- | PTerm of term * substs * int (** From [parsed_elems], [cstrn]
- and [endpos] of {!parser_arc}. *)
+ | PTerm of term * isubsts * int (** From [parsed_elems], [cstrn]
+ and [endpos] of {!parser_arc}. *)
(** Print a parser elem. *)
val elem_str : parser_elem -> string
@@ -29,7 +29,7 @@
rev. order (all will be arguments). *)
spos : int; (** Start position of the arc. *)
endpos : int; (** The current end position of the arc. *)
- cstrn : substs; (** Constraint for the arc. *)
+ cstrn : isubsts; (** Constraint for the arc. *)
}
Modified: trunk/Toss/Term/ParseArcTest.ml
===================================================================
--- trunk/Toss/Term/ParseArcTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Term/ParseArcTest.ml 2012-07-17 11:31:00 UTC (rev 1746)
@@ -37,12 +37,30 @@
let cons_closed = fst (Aux.find_some close_arc cons_arc) in
elem_eq "Te @L[@V [Vx @: @? a @: 0 ]]" cons_closed;
+ (* With iterated substitutions, occurs/cyclicity check is only performed
+ when the substitution is applied, which only happens when
+ parser element is converted to standard term in [parse_with_sdefs].
+
let cons_bad_arc = extend_arc_list var_closed cons_part2_arc in
let cons_bad_closed = Aux.map_some close_arc cons_bad_arc in
- assert_equal ~printer:(fun x -> "empty list test") [] cons_bad_closed;
+ assert_equal ~printer:(fun l ->
+ "["^String.concat"; "(List.map (fun (e,_)->elem_str e) l)^"]")
+ [not empty] cons_bad_closed;
+
+ Instead, we check non-polymorphic case: *)
+
+ let cst_arc = extend_arc_list (Token "true") arcs in
+ let cst_closed = fst (Aux.find_some close_arc cst_arc) in
+ let cons_part1_arc = extend_arc_list cst_closed arcs in
+ let cons_part2_arc = extend_arc_list (Token ",") cons_part1_arc in
+ let cons_bad_arc = extend_arc_list cst_closed cons_part2_arc in
+ let cons_bad_closed = Aux.map_some close_arc cons_bad_arc in
+ assert_equal ~printer:(fun l ->
+ "["^String.concat"; "(List.map (fun (e,_)->elem_str e) l)^"]")
+ [] cons_bad_closed;
);
- "parse" >::
+ "parse_with_sdefs" >::
(fun () ->
let type_decls_list = [
(list_cons_name, Term (Term.fun_type_name, [||],
@@ -57,16 +75,16 @@
let sdefs_basic = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let sdefs = List.map (fun sd -> (name_of_sd sd, sd)) sdefs_basic in
- let parse_test res l =
- let ls = String.concat ", " (List.map elem_str (parse sdefs l)) in
+ let parse_test res s =
+ let ls = String.concat ", "
+ (List.map term_str (parse_with_sdefs sdefs s)) in
assert_equal ~printer:(fun x -> x) res ls in
- parse_test "Te @V [Vx @: @? a @: 0 ]" ["x"];
- parse_test "Te @L[@V [Vx @: @? a @: 0 ]]"
- ["x"; ","; "["; "]"];
- parse_test "" ["x"; ","; "x"];
+ parse_test "Vx[0:?a]" "x";
+ parse_test "F\\?_\\cm_\\?[:T\\?_list(?a._.7)](Vx[0:?a._.7], F\\ls_\\rs[:T\\?_list(?a._.7)])" "x , [ ]";
+ parse_test "" "x , x";
parse_test
- ("Te @L[@V [Vx @: @? a @: 0 ], @V [Vx @: @? a @: 0 ]]")
- ["x"; ","; "x"; ","; "["; "]"];
+ "F\\?_\\cm_\\?[:T\\?_list(?a._.40)](Vx[0:?a._.40], F\\?_\\cm_\\?[:T\\?_list(?a._.40)](Vx[0:?a._.40], F\\ls_\\rs[:T\\?_list(?a._.40)]))"
+ "x , x , [ ]";
);
Modified: trunk/Toss/Term/Term.ml
===================================================================
--- trunk/Toss/Term/Term.ml 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Term/Term.ml 2012-07-17 11:31:00 UTC (rev 1746)
@@ -243,6 +243,25 @@
which is a distinctive kind of toplevel types. *)
let fun_type_name = "fffuuunnntyppe"
+(* Concise readable form. *)
+let rec term_str term =
+ let term_array_str ta =
+ String.concat ", " (to_list (map term_str ta)) in
+ match term with
+ | TVar n -> "?"^n
+ | SVar (v, d, t, [||]) ->
+ v ^ "[" ^ string_of_int d ^ ":" ^ term_str t ^ "]"
+ | SVar (v, d, t, a) ->
+ v ^ "[" ^ string_of_int d ^ ":" ^ term_str t ^ "](" ^
+ term_array_str a ^ ")"
+ | Term (n, [||], [||]) -> n
+ | Term (n, [||], a) ->
+ n ^ "(" ^ term_array_str a ^ ")"
+ | Term (n, t, [||]) ->
+ n ^ "[:" ^ term_array_str t ^ "]"
+ | Term (n, t, a) ->
+ n ^ "[:" ^ term_array_str t ^ "](" ^ term_array_str a ^ ")"
+
(* Suffix variables to rename them. *)
let rec suffix i = function
| Term (n, t, a) -> Term (n, map (fun t -> suffix i t) t,
@@ -307,10 +326,12 @@
type optimize = {
mutable no_glb_type_of_var : bool;
mutable no_isa_match_type_of_var : bool;
+ mutable no_mgu_type_of_var : bool;
}
let optimize = {
no_glb_type_of_var = false;
no_isa_match_type_of_var = false;
+ no_mgu_type_of_var = false;
}
@@ -780,7 +801,26 @@
type iterated_subst = (string * term) list
type iter_s_subst = iterated_subst
type iter_t_subst = iterated_subst
+type isubsts = iter_s_subst * iter_t_subst
+let empty_t_isb = empty_sb
+let empty_s_isb = empty_sb
+let empty_isbs = empty_s_isb, empty_t_isb
+
+let subst_str subst = String.concat ", "
+ (List.map (fun (s, t) -> s ^ " <- " ^ (term_str t)) subst)
+
+let s_subst_str = subst_str
+let t_subst_str = subst_str
+
+let substs_str (s_sb, t_sb) =
+ (* "S:"^ *)s_subst_str s_sb ^ (if s_sb <> [] && t_sb <> [] then "; " else "")
+ ^ (* "T:"^ *)t_subst_str t_sb
+
+let isubsts_str = substs_str
+
+let debug = ref false
+
let rec merge_isbs op acc = function
| [], isb | isb, [] -> (* with optimization *)
(match acc with
@@ -790,8 +830,11 @@
| [p3; p2; p1] -> p1::p2::p3::isb
| _ -> List.rev (List.rev_append isb acc))
| ((v1, t1 as p1)::isb1' as isb1), ((v2, t2 as p2)::isb2' as isb2) ->
- if v1 < v2 then merge_isbs op (p1::acc) (isb1', isb2)
- else if v1 = v2 then merge_isbs op ((v1, op t1 t2)::acc) (isb1', isb2')
+ let vcmp = String.compare v1 v2 in
+ if vcmp < 0 (* v1 < v2 *)
+ then merge_isbs op (p1::acc) (isb1', isb2)
+ else if vcmp = 0 (* v1 = v2 *)
+ then merge_isbs op ((v1, op t1 t2)::acc) (isb1', isb2')
else merge_isbs op (p2::acc) (isb1, isb2')
(** [subst_t_pos p subt t] places [subt] at supertype position [p] in [t]. *)
@@ -839,23 +882,47 @@
let rec glb decls t1 t2 =
match t1, t2 with
| _ when t1 == t2 -> ([], []), t1
+ | SVar (v1, _, ty1, [||]), SVar (v2, _, ty2, [||]) ->
+ let vcmp = String.compare v1 v2 in
+ if vcmp = 0 then ([], []), t1
+ else
+ let v, var, ty, te =
+ if vcmp < 0 then v1, t1, ty1, t2 else v2, t2, ty2, t1 in
+ if optimize.no_glb_type_of_var
+ then ([v, te], []), var
+ else aux_glb decls ([v, te], []) ty te
+
+ | TVar v1, TVar v2 ->
+ let vcmp = String.compare v1 v2 in
+ if vcmp = 0 then ([], []), t1
+ else
+ let v, var, te = if vcmp < 0 then v1, t1, t2 else v2, t2, t1 in
+ ([], [v, te]), var
+
| (SVar (v, _, ty, [||]) as var, te | te, (SVar (v, _, ty, [||]) as var)) ->
if optimize.no_glb_type_of_var
then ([v, te], []), var
else aux_glb decls ([v, te], []) ty te
| (SVar (v, d, ty, ste1), (Term (c, sty, ste2) as te)
- | (Term (c, sty, ste2) as te), SVar (v, d, ty, ste1)) ->
+ | (Term (c, sty, ste2) as te), SVar (v, d, ty, ste1))
+ when Array.length ste1 = Array.length ste2 ->
let isbs, glste =
Aux.array_fold_map2 (aux_glb decls) ([v,te],[]) ste1 ste2 in
(* TODO: ignoring the var type *)
isbs, SVar (v, d, ty, glste)
+ | (SVar _, Term _ | Term _, SVar _) (* when arity mismatch *) ->
+ raise UNIFY
- | (SVar (v, d, ty, ste1), (SVar (_, _, ty2, ste2) as te)) ->
+ | (SVar (v, d, ty, ste1), (SVar (_, _, ty2, ste2) as te))
+ when Array.length ste1 = Array.length ste2 ->
+ (* TODO: ignoring v1 = v2, v1 > v2 *)
let isbs, glste =
Aux.array_fold_map2 (aux_glb decls) ([v,te],[]) ste1 ste2 in
(* TODO: ignoring the var type *)
isbs, SVar (v, d, ty, glste)
+ | SVar _, SVar _ (* when arity mismatch *) ->
+ raise UNIFY
| (TVar v as var, te | te, (TVar v as var)) ->
([], [v, te]), var
@@ -876,11 +943,15 @@
let isbs, glte = glb decls t1 (get_t_pos p t2) in
isbs, subst_t_pos p glte t2
| GLB_equal ->
- let isbs, glsty =
- Aux.array_fold_map2 (aux_glb decls) ([], []) sty1 sty2 in
- let isbs, glste =
- Aux.array_fold_map2 (aux_glb decls) isbs ste1 ste2 in
- isbs, Term (c1, glsty, glste)
+ if Array.length sty1 = Array.length sty2 &&
+ Array.length ste1 = Array.length ste2
+ then
+ let isbs, glsty =
+ Aux.array_fold_map2 (aux_glb decls) ([], []) sty1 sty2 in
+ let isbs, glste =
+ Aux.array_fold_map2 (aux_glb decls) isbs ste1 ste2 in
+ isbs, Term (c1, glsty, glste)
+ else raise UNIFY (* arity mismatch *)
| GLB_disjoint -> raise UNIFY
(** Least Upper Bound Unification w.r.t. the ISA relation. Returns
@@ -891,6 +962,23 @@
and lub decls t1 t2 =
match t1, t2 with
| _ when t1 == t2 -> ([], []), t1
+ | SVar (v1, _, ty1, [||]), SVar (v2, _, ty2, [||]) ->
+ let vcmp = String.compare v1 v2 in
+ if vcmp = 0 then ([], []), t1
+ else
+ let v, var, ty, te =
+ if vcmp < 0 then v1, t1, ty1, t2 else v2, t2, ty2, t1 in
+ if optimize.no_glb_type_of_var
+ then ([v, te], []), var
+ else aux_glb decls ([v, te], []) ty te
+
+ | TVar v1, TVar v2 ->
+ let vcmp = String.compare v1 v2 in
+ if vcmp = 0 then ([], []), t1
+ else
+ let v, var, te = if vcmp < 0 then v1, t1, t2 else v2, t2, t1 in
+ ([], [v, te]), var
+
| (SVar (v, _, ty, [||]) as var, te | te, (SVar (v, _, ty, [||]) as var)) ->
if optimize.no_glb_type_of_var
then ([v, te], []), var
@@ -898,19 +986,25 @@
else aux_glb decls ([v, te], []) ty te
| (SVar (v, d, ty, ste1), (Term (c, sty, ste2) as te)
- | (Term (c, sty, ste2) as te), SVar (v, d, ty, ste1)) ->
+ | (Term (c, sty, ste2) as te), SVar (v, d, ty, ste1))
+ when Array.length ste1 = Array.length ste2 ->
(* TODO: not sure whether GLB or LUB *)
let isbs, glste =
Aux.array_fold_map2 (aux_glb decls) ([v,te],[]) ste1 ste2 in
(* TODO: ignoring the var type *)
isbs, SVar (v, d, ty, glste)
+ | (SVar _, Term _ | Term _, SVar _) (* when arity mismatch *) ->
+ raise UNIFY
- | (SVar (v, d, ty, ste1), (SVar (_, _, ty2, ste2) as te)) ->
+ | (SVar (v, d, ty, ste1), (SVar (_, _, ty2, ste2) as te))
+ when Array.length ste1 = Array.length ste2 ->
(* TODO: not sure whether GLB or LUB *)
let isbs, glste =
Aux.array_fold_map2 (aux_glb decls) ([v,te],[]) ste1 ste2 in
(* TODO: ignoring the var type *)
isbs, SVar (v, d, ty, glste)
+ | SVar _, SVar _ (* when arity mismatch *) ->
+ raise UNIFY
| (TVar v as var, te | te, (TVar v as var)) ->
([], [v, te]), var
@@ -927,11 +1021,15 @@
| LUB_greater p ->
lub decls t1 (get_t_pos p t2)
| LUB_equal ->
- let isbs, lusty =
- Aux.array_fold_map2 (aux_lub decls) ([], []) sty1 sty2 in
- let isbs, luste =
- Aux.array_fold_map2 (aux_lub decls) isbs ste1 ste2 in
- isbs, Term (c1, lusty, luste)
+ if Array.length sty1 = Array.length sty2 &&
+ Array.length ste1 = Array.length ste2
+ then
+ let isbs, lusty =
+ Aux.array_fold_map2 (aux_lub decls) ([], []) sty1 sty2 in
+ let isbs, luste =
+ Aux.array_fold_map2 (aux_lub decls) isbs ste1 ste2 in
+ isbs, Term (c1, lusty, luste)
+ else raise UNIFY (* arity mismatch *)
| LUB_unconnected -> raise UNIFY
and aux_glb decls isbs t1 t2 =
@@ -980,19 +1078,28 @@
and isa_match decls pa te =
match pa, te with
| _ when pa == te -> [], []
+ | SVar (v1, _, _, _), SVar (v2, _, _, _) when v1 = v2 ->
+ ([], [])
+ | TVar v1, TVar v2 when v1 = v2 ->
+ ([], [])
+
| SVar (v, _, ty, [||]), te ->
if optimize.no_isa_match_type_of_var
then [v, te], []
else aux_match decls ([v, te], []) ty te
- | SVar (v, _, ty, ste1), (Term (c, sty, ste2) as te) ->
- (* TODO: ignoring variable type *)
- (* TODO: ignoring arity mismatch *)
+ | SVar (v, _, ty, ste1), (Term (c, sty, ste2) as te)
+ when Array.length ste1 = Array.length ste2 ->
+ (* TODO: ignoring variable type -- should first try to match
+ the proper level in the other term *)
Aux.array_fold_left2 (aux_match decls) ([v,te],[]) ste1 ste2
+ | SVar _, Term _ (* when arity mismatch *) -> raise UNIFY
- | SVar (v, _, ty, ste1), (SVar (_, _, ty2, ste2) as te) ->
+ | SVar (v, _, ty, ste1), (SVar (_, _, ty2, ste2) as te)
+ when Array.length ste1 = Array.length ste2 ->
(* TODO: ignoring variable type *)
Aux.array_fold_left2 (aux_match decls) ([v,te],[]) ste1 ste2
+ | SVar _, SVar _ (* when arity mismatch *) -> raise UNIFY
| SVar _, TVar _ -> raise UNIFY
@@ -1009,10 +1116,13 @@
| GLB_greater p ->
isa_match decls pa (get_t_pos p te)
| GLB_equal ->
- let isbs =
- Aux.array_fold_left2 (aux_match decls) ([], []) sty1 sty2 in
- Aux.array_fold_left2 (aux_match decls) isbs ste1 ste2
-
+ if Array.length sty1 = Array.length sty2 &&
+ Array.length ste1 = Array.length ste2
+ then
+ let isbs =
+ Aux.array_fold_left2 (aux_match decls) ([], []) sty1 sty2 in
+ Aux.array_fold_left2 (aux_match decls) isbs ste1 ste2
+ else raise UNIFY
| GLB_glb _ | GLB_smaller _ | GLB_disjoint -> raise UNIFY
and aux_match decls isbs pa te =
@@ -1035,41 +1145,73 @@
and mgu_iter decls t1 t2 =
match t1, t2 with
| _ when t1 == t2 -> [], []
+ | SVar (v1, _, ty1, [||]), SVar (v2, _, ty2, [||]) ->
+ let vcmp = String.compare v1 v2 in
+ if vcmp = 0 then ([], [])
+ else
+ let v, var, ty, te =
+ if vcmp < 0 then v1, t1, ty1, t2 else v2, t2, ty2, t1 in
+ if optimize.no_glb_type_of_var
+ then ([v, te], [])
+ else aux_match decls ([v, te], []) ty te
+
+ | TVar v1, TVar v2 ->
+ let vcmp = String.compare v1 v2 in
+ if vcmp = 0 then ([], [])
+ else
+ let v, var, te = if vcmp < 0 then v1, t1, t2 else v2, t2, t1 in
+ ([], [v, te])
+
| (SVar (v, _, ty, [||]), te | te, SVar (v, _, ty, [||])) ->
- aux_match decls ([v, te], []) ty te
+ if optimize.no_mgu_type_of_var
+ then [v, te], []
+ else aux_match decls ([v, te], []) ty te
| (SVar (v, _, ty, ste1), (Term (c, _, ste2) as te)
- | (Term (c, _, ste2) as te), SVar (v, _, ty, ste1)) ->
- Aux.array_fold_left2 (aux_mgu decls)
+ | (Term (c, _, ste2) as te), SVar (v, _, ty, ste1))
+ when Array.length ste1 = Array.length ste2 ->
+ Aux.array_fold_left2 (aux_mgu_i decls)
(aux_match decls ([v, te], []) ty te)
ste1 ste2
+ | (SVar _, Term _ | Term _, SVar _) -> raise UNIFY
- | (SVar (v, _, ty, ste1), (SVar (_, _, ty2, ste2) as te)) ->
- (* TODO: ignoring variable types *)
- Aux.array_fold_left2 (aux_mgu decls)
+ | (SVar (v, _, ty, ste1), (SVar (_, _, ty2, ste2) as te))
+ when Array.length ste1 = Array.length ste2 ->
+ (* TODO: ignoring variable types, and v1=v2, v1>v2 *)
+ Aux.array_fold_left2 (aux_mgu_i decls)
([v, te], []) ste1 ste2
+ | SVar _, SVar _ -> raise UNIFY
| (TVar v, te | te, TVar v) -> [], [v, te]
- | Term (c1, sty1, ste1), Term (c2, sty2, ste2) when c1 = c2 ->
+ | Term (c1, sty1, ste1), Term (c2, sty2, ste2)
+ when c1 = c2 && Array.length sty1 = Array.length sty2
+ && Array.length ste1 = Array.length ste2 ->
let isbs =
- Aux.array_fold_left2 (aux_mgu decls) ([], []) sty1 sty2 in
- Aux.array_fold_left2 (aux_mgu decls) isbs ste1 ste2
+ Aux.array_fold_left2 (aux_mgu_i decls) ([], []) sty1 sty2 in
+ Aux.array_fold_left2 (aux_mgu_i decls) isbs ste1 ste2
- | Term (c1, _, _), Term (c2, _, _) (* when c1 <> c2 *) ->
+ | Term (c1, _, _), Term (c2, _, _)(* when c1 <> c2 or arity mismatch *) ->
raise UNIFY
-and aux_mgu decls isbs t1 t2 =
+and aux_mgu_i decls isbs t1 t2 =
let isbs' = mgu_iter decls t1 t2 in
- aux_mgu_cont decls isbs isbs'
+ aux_mgu_i_cont decls isbs isbs'
-and aux_mgu_cont decls (s_isb, t_isb) (s_isb', t_isb') =
+and aux_mgu_i_cont decls (s_isb, t_isb) (s_isb', t_isb') =
+ (*if !debug then Printf.printf "aux_mgu_i_cont: isbs=%s\nisbs'=%s\n%!"
+ (isubsts_str (s_isb, t_isb))
+ (isubsts_str (s_isb', t_isb'));*)
let s_isb, more_isbs1 =
mgu_combine_isbs decls s_isb s_isb' in
let t_isb, more_isbs2 =
mgu_combine_isbs decls t_isb t_isb' in
- List.fold_left (aux_mgu_cont decls)
- (List.fold_left (aux_mgu_cont decls) (s_isb, t_isb) more_isbs1)
+ (*if !debug then Printf.printf "aux_mgu_i_cont: combined=%s\nmore_isbs=%s\n%!"
+ (isubsts_str (s_isb, t_isb))
+ (String.concat " / "
+ (List.map isubsts_str (more_isbs1 @ more_isbs2)));*)
+ List.fold_left (aux_mgu_i_cont decls)
+ (List.fold_left (aux_mgu_i_cont decls) (s_isb, t_isb) more_isbs1)
more_isbs2
@@ -1078,8 +1220,10 @@
let result = merge_isbs
(fun t1 t2 -> let isb = mgu_iter decls t1 t2 in
if isb <> ([],[]) then more_isbs := isb:: !more_isbs;
- (* no change since it's an iterated substitution *)
- t1)
+ (* no change since it's an iterated substitution
+ t2 not to fall into a loop with cyclic substs --
+ because isb2 comes from mgu_iter so it's smaller *)
+ t2)
[] (isb1, isb2) in
result, !more_isbs
@@ -1125,12 +1269,10 @@
(* TODO: come up with better function names... *)
let appl_s_sb sb t = (* None = no change *)
match app_s_sb sb t with None -> t | Some t -> t
-let appl_t_sb sb t =
- match app_s_sb sb t with None -> t | Some t -> t
let rec app_t_sb sb t =
let app_tuple a =
- let a' = Array.map (app_s_sb sb) a in
+ let a' = Array.map (app_t_sb sb) a in
if Aux.array_for_all (function None -> true | Some _ -> false) a'
then None
else
@@ -1139,11 +1281,18 @@
match t with
| TVar n ->
(try Some (List.assoc n sb) with Not_found -> None)
- | SVar _ -> None
+ | SVar (_,_,(Term (_, [||], [||]) (* TODO: optimization, test *)
+ | Term (_, [|Term (_, [||], [||])|], [||])),[||]) -> None
| (Term (_, [||], [||]) (* TODO: optimization, test *)
| Term (_, [|Term (_, [||], [||])|], [||])
| Term (_, [|Term (_, [||], [||])|],
[|Term (_, [||], [||])|])) -> None
+ | SVar (n, d, t, a) ->
+ (match app_t_sb sb t, app_tuple a with
+ | None, None -> None
+ | None, Some a -> Some (SVar (n, d, t, a))
+ | Some t, None -> Some (SVar (n, d, t, a))
+ | Some t, Some a -> Some (SVar (n, d, t, a)))
| Term (n, t, a) ->
(match app_tuple t, app_tuple a with
| None, None -> None
@@ -1151,17 +1300,23 @@
| Some t, None -> Some (Term (n, t, a))
| Some t, Some a -> Some (Term (n, t, a)))
-type topsort_elem = {
- e_assoc : string * term;
- e_outgoing : (string, topsort_elem) Hashtbl.t;
+let appl_t_sb sb t =
+ match app_t_sb sb t with None -> t | Some t -> t
+
+type topsort_node = {
+ n_assoc : string * term;
+ n_outgoing : (string, topsort_node) Hashtbl.t;
+ n_incoming : (string, topsort_node) Hashtbl.t;
}
let topsort_ops = {
Aux.rem_edge = (fun n m ->
- Hashtbl.remove n.e_outgoing (fst m.e_assoc));
+ Hashtbl.remove m.n_incoming (fst n.n_assoc);
+ Hashtbl.remove n.n_outgoing (fst m.n_assoc));
iter_outgoing = (fun f n ->
- Hashtbl.iter (fun _ -> f) n.e_outgoing);
- no_outgoing = (fun n -> Hashtbl.length n.e_outgoing = 0)
+ Hashtbl.iter (fun _ -> f) n.n_outgoing);
+ no_incoming = (fun n -> Hashtbl.length n.n_incoming = 0);
+ node_to_string = (fun n -> fst n.n_assoc);
}
(** Apply an iterated substitution -- "unpack" all the variables. We
@@ -1174,34 +1329,54 @@
to be fixed once explicit sharing gets introduced -- although
then the need for [apply_isbs] will be smaller. *)
let apply_isbs (s_isb, t_isb) t =
+ (*if !debug then Printf.printf "apply_isbs: initial isbs = %s\n%!"
+ (isubsts_str (s_isb,t_isb));*)
let s_nodes = List.map
(fun (v,_ as p) ->
- v, {e_assoc = p; e_outgoing = Hashtbl.create 2}) s_isb in
+ v, {n_assoc = p; n_outgoing = Hashtbl.create 2;
+ n_incoming = Hashtbl.create 2}) s_isb in
let t_nodes = List.map
(fun (v,_ as p) ->
- v, {e_assoc = p; e_outgoing = Hashtbl.create 2}) t_isb in
- let s_outgoing (_,{e_assoc=v,t; e_outgoing=vs}) =
+ v, {n_assoc = p; n_outgoing = Hashtbl.create 2;
+ n_incoming = Hashtbl.create 2}) t_isb in
+ (* The incoming edges are the variables in the substituted term. *)
+ let add_edges nodes get_in (_,({n_assoc=v1,t; n_incoming=in_vs} as n1)) =
List.iter
- (fun v -> Hashtbl.add vs v (List.assoc v s_nodes))
- (s_vars_in_term [] t) in
- let t_outgoing (_,{e_assoc=v,t; e_outgoing=vs}) =
- List.iter
- (fun v -> Hashtbl.add vs v (List.assoc v t_nodes))
- (t_vars_in_term [] t) in
- List.iter s_outgoing s_nodes;
- List.iter t_outgoing t_nodes;
- let s_isb = List.map (fun n->n.e_assoc)
- (Aux.topol_sort topsort_ops (List.map snd s_nodes)) in
- let t_isb = List.map (fun n->n.e_assoc)
- (Aux.topol_sort topsort_ops (List.map snd t_nodes)) in
+ (fun v2 ->
+ try
+ let n2 = List.assoc v2 nodes in
+ Hashtbl.add n2.n_outgoing v1 n1;
+ Hashtbl.add in_vs v2 n2
+ with Not_found -> ())
+ (get_in t) in
+ List.iter (add_edges s_nodes (s_vars_in_term [])) s_nodes;
+ List.iter (add_edges t_nodes (t_vars_in_term [])) t_nodes;
+ let s_isb =
+ try
+ List.map (fun n->n.n_assoc)
+ (Aux.topol_sort topsort_ops (List.map snd s_nodes))
+ with Not_found ->
+ failwith "apply_isbs: cyclic terms require explicit sharing" in
+ let t_isb =
+ try
+ List.map (fun n->n.n_assoc)
+ (Aux.topol_sort topsort_ops (List.map snd t_nodes))
+ with Not_found -> raise UNIFY in
+ (*if !debug then Printf.printf "apply_isbs: sorted isbs = %s\n%!"
+ (isubsts_str (s_isb,t_isb));*)
let s_sb = List.fold_left
(fun sb (v,t) -> (v, appl_s_sb sb t)::sb) [] s_isb in
let t_sb = List.fold_left
(fun sb (v,t) -> (v, appl_t_sb sb t)::sb) [] t_isb in
let s_sb = List.map (fun (v,t) -> v, appl_t_sb t_sb t) s_sb in
let t_sb = List.map (fun (v,t) -> v, appl_s_sb s_sb t) t_sb in
+ (*if !debug then Printf.printf "apply_isbs: applied sbs = %s\n%!"
+ (substs_str (s_sb,t_sb));*)
(* TODO: perhaps someone needs te substitutions *)
- appl_s_sb s_sb (appl_t_sb t_sb t)
+ let res = appl_s_sb s_sb (appl_t_sb t_sb t) in
+ (*if !debug then Printf.printf "apply_isbs:\nt=%s;\nS(t)=%s\n%!"
+ (term_str t) (term_str res);*)
+ res
(* --- Type printing and parsing --- *)
@@ -1288,18 +1463,6 @@
let (ty, cont) = parse_type (split_to_list s) in
if cont = [] then ty else failwith "type_of_string: incomplete parse"
-let subst_str subst = String.concat ", "
- (List.map (fun (s, tp) ->
- s ^ " <- " ^ (type_to_string tp)) subst)
-
-let s_subst_str = subst_str
-let t_subst_str = subst_str
-
-let substs_str (s_sb, t_sb) =
- (* "S:"^ *)s_subst_str s_sb ^ (if s_sb <> [] && t_sb <> [] then "; " else "")
- ^ (* "T:"^ *)t_subst_str t_sb
-
-
(* --- Hashtables for Terms --- *)
module HashableTerm =
Modified: trunk/Toss/Term/Term.mli
===================================================================
--- trunk/Toss/Term/Term.mli 2012-07-15 20:43:16 UTC (rev 1745)
+++ trunk/Toss/Term/Term.mli 2012-07-17 11:31:00 UTC (rev 1746)
@@ -12,6 +12,9 @@
(** The name for function type (type of un-applied function term). *)
val fun_type_name : string
+(** Concise readable form. *)
+val term_str : term -> string
+
(** Suffix all type variables, useful for renaming. *)
val suffix : int -> term -> term
@@ -76,6 +79,99 @@
(** Return the supertypes of a term or type of a variable. *)
val types_of : term -> term array
+
+(** {2 ISA relation and iterated substitution based operations.} *)
+
+(** Global optimization settings. *)
+type optimize = {
+ mutable no_glb_type_of_var : bool;
+ mutable no_isa_match_type_of_var : bool;
+ mutable no_mgu_type_of_var : bool;
+}
+val optimize : optimize
+
+(** {i Iterated substitutions} are sets of term equations in solved
+ form, but without disjointness between the domain and variables
+ in the image of substitution. See "Term Rewriting and All That"
+ p. 82. Currently implemented as sorted association lists. *)
+type iter_s_subst
+type iter_t_subst
+type isubsts = iter_s_subst * iter_t_subst
+
+val empty_t_isb : iter_t_subst
+val empty_s_isb : iter_s_subst
+val empty_isbs : isubsts
+
+(** Adding a declaration to a well-formed set of declarations. *)
+type add_to_decls =
+ | Decls_OK (** Declaration added. *)
+ | Decls_multi_glb of string * string * string
+ (** The first two symbols already have the third symbol as a greatest
+ lower bound, the proposed declaration would introduce alternative
+ GLB for them. *)
+ | Decls_multi_lub of string * string * string
+ (** The proposed declaration together with the third symbol would
+ have the first two symbols both as least upper bounds. *)
+ | Decls_redundant_s of string * string
+ (** Of proposed direct superclasses one ISA the second one. *)
+ | Decls_var | Decls_repeating
+
+(** Data associated with a well-formed set of declarations; expected
+ to grow monotonically by adding new declarations. *)
+type decls_set
+
+val global_decls : decls_set
+val copy_global_decls : unit -> decls_set
+
+exception EXC_Decls_multi_lub of string * string * string
+
+(** Assuming that the given set of declarations is well-formed, check
+ if it will remain well-formed after adding the given declaration.
+ If so, add it and update the [ISA] order relation. Return whether
+ the declaration was added or the reason it was not added. *)
+val add_to_decls : decls_set -> term -> add_to_decls
+
+(** Greatest Lower Bound Unification w.r.t. the ISA relation. Returns
+ the unsubstituted GLB term and iterated substitutions, or raises
+ [UNIFY]. Shared variables are merged using GLB-unification and
+ type variables are merged using LUB-unification. The returned term
+ contains variables from the substitution.
+
+ Substitutions are never applied during glb-unification. It
+ is important to return this intermediate representation, because
+ parsing is a "distributed glb-unification" as it produces a
+ single term that ISA a declaration. *)
+val glb : decls_set -> term -> term -> isubsts * term
+val aux_glb : decls_set -> isubsts -> term -> term -> isubsts * term
+
+(** Least Upper Bound Unification w.r.t. the ISA relation. Returns
+ the unsubstituted LUB term and iterated substitutions, or raises
+ [UNIFY]. Shared variables are merged using GLB-unification and
+ type variables are merged using LUB-unification. See also {!glb}. *)
+val lub : decls_set -> term -> term -> isubsts * term
+val aux_lub : decls_set -> isubsts -> term -> term -> isubsts * term
+
+val aux_glb_lub_cont : decls_set -> isubsts -> isubsts -> isubsts
+
+(** Returns the ISA-matching or raises [UNIFY]. First term is the
+ pattern. Shared variables are merged using MGU (eq-unification)
+ and type variables are merged using LUB-unification. See also
+ {!glb}. *)
+val isa_match : decls_set -> term -> term -> isubsts
+val aux_match : decls_set -> isubsts -> term -> term -> isubsts
+val aux_match_cont : decls_set -> isubsts -> isubsts -> isubsts
+
+(** Iterated Substitution based variant of the Most General Unifier
+ substitution, throws [UNIFY] if not unifiable. Both shared
+ variables and type variables are merged using MGU
+ (eq-unification). *)
+val mgu_iter : decls_set -> term -> term -> isubsts
+val aux_mgu_i : decls_set -> isubsts -> term -> term -> isubsts
+val aux_mgu_i_cont : decls_set -> isubsts -> isubsts -> isubsts
+
+val debug : bool ref
+val apply_isbs : isubsts -> term -> term
+
(** {2 Parsing and Printing Types} *)
(** Printing types in the internal format. *)
@@ -93,6 +189,7 @@
val s_subst_str : s_subst -> string
val t_subst_str : t_subst -> string
val substs_str : substs -> string
+val isubsts_str : isubsts -> string
(** {2 Hashtable for Terms} *)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-15 20:43:25
|
Revision: 1745
http://toss.svn.sourceforge.net/toss/?rev=1745&view=rev
Author: lukstafi
Date: 2012-07-15 20:43:16 +0000 (Sun, 15 Jul 2012)
Log Message:
-----------
Hierarchical terms: modified specification. Changed representation of terms. New Speagram step 3: iterated substitution based algorithms: MGU, ISA-matching, greatest lower bound and lowest upper bound unification; untested.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/Coding.ml
trunk/Toss/Term/CodingTest.ml
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArc.mli
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/RewritingTest.ml
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDefTest.ml
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRSTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Formula/Aux.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -368,6 +368,13 @@
let new_accu = try f accu a with Not_found -> accu in
fold_left_try f new_accu l
+let array_foldi_left f x a =
+ let r = ref x in
+ for i = 0 to Array.length a - 1 do
+ r := f i !r (Array.unsafe_get a i)
+ done;
+ !r
+
let rec power ?(timeout = fun () -> false) dom img =
List.fold_left (fun sbs v ->
concat_map (fun e -> List.rev (List.rev_map (fun sb ->
@@ -473,6 +480,25 @@
| [] -> acc in
idemp [] (List.sort (fun x y -> - (cmp x y)) l)
+(* Operations for imperatively manipulating the graph for {!topol_sort}. *)
+type 'a topol_sort_ops = {
+ rem_edge : 'a -> 'a -> unit; (* [rem_edge a b] removes a->b. *)
+ iter_outgoing : ('a -> unit) -> 'a -> unit;
+ no_outgoing : 'a -> bool
+}
+
+let topol_sort ops l =
+ let top = ref (List.filter (fun e -> ops.no_outgoing e) l) in
+ let res = ref [] in
+ while !top <> [] do
+ let n = List.hd !top in
+ top := List.tl !top; res := n:: !res;
+ ops.iter_outgoing (fun m ->
+ ops.rem_edge n m; if ops.no_outgoing m then res := m:: !res) n;
+ done;
+ if List.for_all ops.no_outgoing l then List.rev !res
+ else raise Not_found
+
let all_subsets ?max_size set =
let size = match max_size with Some i -> i | None -> List.length set in
[] :: (unique_sorted (List.map unique_sorted (all_ntuples set size)))
@@ -573,11 +599,33 @@
if i = len1 then acc else
fl2_rec (f acc a1.(i) a2.(i)) (i+1) in
fl2_rec start 0
-
+let array_fold_map2 f x a1 a2 =
+ let l1 = Array.length a1 and l2 = Array.length a2 in
+ if l1 <> l2 then raise (Invalid_argument "Aux.array_fold_map2");
+ if l1 = 0 then x, [||] else begin
+ let x0, v0 = f x (Array.unsafe_get a1 0) (Array.unsafe_get a2 0) in
+ let rx = ref x0 in
+ let ra = Array.create l1 v0 in
+ for i = 1 to Array.length ra - 1 do
+ let xi, vi = f !rx (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) in
+ rx := xi; Array.unsafe_set ra i vi
+ done;
+ !rx, ra
+ end
+
+
let array_combine a b =
array_map2 (fun x y->x,y) a b
+let array_exists p a =
+ let res = ref false in
+ let i = ref 0 in
+ while !i < Array.length a && not !res do
+ res := p (Array.unsafe_get a !i);
+ incr i
+ done; !res
+
let array_existsi p a =
let res = ref false in
let i = ref 0 in
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Formula/Aux.mli 2012-07-15 20:43:16 UTC (rev 1745)
@@ -161,6 +161,9 @@
[Not_found]. *)
val fold_left_try : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+(** As {!Array.fold_left}, but with the element position passed. *)
+val array_foldi_left : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+
(** [power dom img] generates all functions with domain [dom] and
image [img], as graphs. Tail recursive. *)
val power : ?timeout:(unit -> bool) -> 'a list -> 'b list -> ('a * 'b) list list
@@ -212,6 +215,22 @@
[add_to_maximal cmp l1 l2] computes [maximal cmp (l1 @ l2)]. *)
val add_to_maximal : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
+(** Operations for imperatively manipulating the graph for {!topol_sort}. *)
+type 'a topol_sort_ops = {
+ rem_edge : 'a -> 'a -> unit; (** [rem_edge a b] removes [a->b]. *)
+ iter_outgoing : ('a -> unit) -> 'a -> unit;
+ no_outgoing : 'a -> bool
+}
+
+(** Topogical sort of [l] where [cmp a b = true] means that there is
+ an arrow from [a] to [b]. Elements without incoming edges are first
+ and elements without outgoing edges are last. Returns [None] /
+ raises [Not_found] if a cycle is detected.
+
+ Implementation:
+ http://en.wikipedia.org/wiki/Topological_sort#Algorithms *)
+val topol_sort : 'a topol_sort_ops -> 'a list -> 'a list
+
(** Return the list of structurally unique elements, in order sorted
by {!Pervasives.compare}. Not tail-recursive. *)
val unique_sorted : ?cmp: ('a -> 'a -> int) -> 'a list -> 'a list
@@ -259,10 +278,15 @@
val array_fold_left2 :
('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+(** Fold-left and map on two arrays. *)
+val array_fold_map2 :
+ ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array
+
(** Zip two arrays into an array of pairs. Raises [Invalid_argument
"Aux.array_map2"] if the arrays are of different lengths. *)
val array_combine : 'a array -> 'b array -> ('a * 'b) array
+val array_exists : ('a -> bool) -> 'a array -> bool
val array_existsi : (int -> 'a -> bool) -> 'a array -> bool
val array_mem : 'a -> 'a array -> bool
@@ -330,7 +354,7 @@
(** Iterate a function [n] times: [f^n(x)]. *)
val fold_n : ('a -> 'a) -> 'a -> int -> 'a
-(** Returns a string proloning [s] and not appearing in [names]. If
+(** Returns a string prolonging [s] and not appearing in [names]. If
[truncate] is true, remove numbers from the end of [s]. *)
val not_conflicting_name : ?truncate:bool -> Strings.t -> string -> string
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Formula/AuxTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -231,6 +231,10 @@
["a1";"c2"; "b1"; "a3"; "c7"]);
);
+ "topol_sort" >::
+ (fun () -> ()
+ );
+
"unique, unique_soted, not_unique, take_n" >::
(fun () ->
assert_equal ~printer:(String.concat "; ")
@@ -405,6 +409,17 @@
[|"a";"c";"b"|] [|"e"; "d"|]);
);
+ "array_fold_map2" >::
+ (fun () ->
+ let printer (v,a) =
+ string_of_int v^", [|"^String.concat "; " (Array.to_list a)^"|]" in
+ let sum acc i j = acc+i*j, string_of_int i^string_of_int j in
+ assert_equal ~printer (5, [|"11";"22";"30"|])
+ (Aux.array_fold_map2 sum 0 [|1;2;3|] [|1;2;0|]);
+ assert_equal ~printer (0, [||])
+ (Aux.array_fold_map2 sum 0 [||] [||]);
+ );
+
"partition_choice, partition_map" >::
(fun () ->
assert_equal ~printer:(fun (x,y)->
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -29,12 +29,12 @@
let list_sd = SDtype [Tp term_type_tp; Str "list"]
let list_name = name_of_sd list_sd
-let list_tp t = Term (list_name, toplevel_type, [|t|])
-let list_tp_a = list_tp (Var ("a", 0, top_type_term, [||]))
+let list_tp t = Term (list_name, [||], [|t|])
+let list_tp_a = list_tp (TVar "a")
let list_nil_sd = SDfun ([Str "["; Str "]"], list_tp_a)
let list_nil_name = name_of_sd list_nil_sd
-let list_cons_sd = SDfun ([Tp (Var ("a",0,top_type_term,[||]));
+let list_cons_sd = SDfun ([Tp (TVar "a");
Str ","; Tp list_tp_a],
list_tp_a)
let list_cons_name = name_of_sd list_cons_sd
@@ -150,8 +150,8 @@
let input_rewrite_rule_name = name_of_sd input_rewrite_rule_sd
let input_rewrite_rule_tp = type_of_sd input_rewrite_rule_sd
-let let_be_sd = SDfun ([Str "let"; Tp (Var ("a_1",0,top_type_term,[||]));
- Str "be"; Tp (Var ("a_1",0,top_type_term,[||]))],
+let let_be_sd = SDfun ([Str "let"; Tp (TVar "a_1");
+ Str "be"; Tp (TVar "a_1")],
input_rewrite_rule_tp)
let let_be_name = name_of_sd let_be_sd
@@ -164,8 +164,8 @@
let let_major_be_sd =
SDfun ([Str "let"; Str "major";
- Tp (Var ("a_1",0,top_type_term,[||])); Str "be";
- Tp (Var ("a_1",0,top_type_term,[||]))],
+ Tp (TVar "a_1"); Str "be";
+ Tp (TVar "a_1")],
priority_input_rewrite_rule_tp)
let let_major_be_name = name_of_sd let_major_be_sd
@@ -191,47 +191,47 @@
let exception_cl_sd = SDtype [Tp term_type_tp; Str "exception"]
let exception_cl_name = name_of_sd exception_cl_sd
-let exception_cl_tp t = Term (exception_cl_name, toplevel_type, [|t|])
+let exception_cl_tp t = Term (exception_cl_name, [||], [|t|])
let exception_sd =
- SDfun ([Str "!"; Str "!"; Tp (Var ("a",0,top_type_term,[||]));
+ SDfun ([Str "!"; Str "!"; Tp (TVar "a");
Str "!";Str "!";],
- exception_cl_tp (Var ("other_than_a!",0,top_type_term,[||])))
+ exception_cl_tp (TVar "other_than_a!"))
let exception_name = name_of_sd exception_sd
let exn_ok_sd =
- SDfun ([Str "+"; Str "+"; Tp (Var ("a",0,top_type_term,[||]));
+ SDfun ([Str "+"; Str "+"; Tp (TVar "a");
Str "+";Str "+";],
- exception_cl_tp (Var ("a",0,top_type_term,[||]))) (* Here it should be a! *)
+ exception_cl_tp (TVar "a")) (* Here it should be a! *)
let exn_ok_name = name_of_sd exception_sd
(* --- Special functions recognized during Normalisation --- *)
let brackets_sd = SDfun ([Str "(";
- Tp (Var ("b",0,top_type_term,[||])); Str ")"],
- Var ("b",0,top_type_term,[||]))
+ Tp (TVar "b"); Str ")"],
+ TVar "b")
let brackets_name = name_of_sd brackets_sd
-let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (Var ("b",0,top_type_term,[||]));
- Str "|"; Str ">"], Var ("b",0,top_type_term,[||]))
+let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (TVar "b");
+ Str "|"; Str ">"], TVar "b")
let verbatim_name = name_of_sd verbatim_sd
let if_then_else_sd = SDfun ([Str "if"; Tp boolean_tp; Str "then";
- Tp (Var ("a",0,top_type_term,[||])); Str "else";
- Tp (Var ("a",0,top_type_term,[||]))], Var ("a",0,top_type_term,[||]))
+ Tp (TVar "a"); Str "else";
+ Tp (TVar "a")], TVar "a")
let if_then_else_name = name_of_sd if_then_else_sd
-let eq_bool_sd = SDfun ([Tp (Var ("a",0,top_type_term,[||])); Str "=";
- Tp (Var ("a",0,top_type_term,[||]))], boolean_tp)
+let eq_bool_sd = SDfun ([Tp (TVar "a"); Str "=";
+ Tp (TVar "a")], boolean_tp)
let eq_bool_name = name_of_sd eq_bool_sd
(* --- Syntax Definitions for special meta-functions --- *)
-let code_as_term_sd = SDfun ([Str "code"; Tp (Var ("a",0,top_type_term,[||]));
+let code_as_term_sd = SDfun ([Str "code"; Tp (TVar "a");
Str "as"; Str "term"], term_tp)
let code_as_term_name = name_of_sd code_as_term_sd
@@ -287,13 +287,13 @@
let set_command_tp = type_of_sd set_command_sd
let set_prop_sd = SDfun ([Str "set"; Tp (string_tp); Str "of";
- Tp (Var ("a",0,top_type_term,[||])); Str "to";
- Tp (Var ("b",0,top_type_term,[||]))], set_command_tp)
+ Tp (TVar "a"); Str "to";
+ Tp (TVar "b")], set_command_tp)
let set_prop_name = name_of_sd set_prop_sd
let preprocess_sd = SDfun ([Str "#"; Str "#"; Str "#";
- Tp (Var ("p",0,top_type_term,[||]))], Var ("p",0,top_type_term,[||]))
+ Tp (TVar "p")], TVar "p")
let preprocess_name = name_of_sd preprocess_sd
Modified: trunk/Toss/Term/Coding.ml
===================================================================
--- trunk/Toss/Term/Coding.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/Coding.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -95,34 +95,32 @@
| Term (n, _, [||]) when n = boolean_false_name -> false
| _ -> raise (DECODE "bool")
-
+(* FIXME: remainder of the old Speagram distinction between types and terms *)
let rec code_term_type = function
- | Var (name, 0, tp, [||]) when tp = top_type_term ->
+ | TVar name ->
Term (term_type_var_name, [|term_type_tp|], [|code_string name|])
- | Var _ -> failwith "code_term_type: non-type variable"
- | Term (name, tp, arr) when name = Term.fun_type_name && tp = toplevel_type->
+ | SVar _ -> failwith "code_term_type: sharing variable"
+ | Term (name, [||], arr) when name = Term.fun_type_name ->
let l = Array.length arr in
let (args_types, return_type) = (Array.sub arr 0 (l-1), arr.(l-1)) in
Term (term_type_fun_name, [|term_type_tp|], [|
code_list [|list_tp term_type_tp|] code_term_type (to_list args_types);
code_term_type return_type|])
- | Term (name, tp, args) when tp = toplevel_type ->
+ | Term (name, [||], args) ->
Term (term_type_cons_name, [|term_type_tp|], [|
code_string name;
code_list [|list_tp term_type_tp|] code_term_type (to_list args)|])
- | Term (name, _, _) when name = top_type_name -> failwith
- "code_term_type: coding top term (the type of a type) not supported"
| Term (name, _, _) -> failwith
- ("code_term_type: non-type term at symbol " ^ name)
+ ("code_term_type: non-toplevel-type term at symbol " ^ name)
let rec decode_term_type = function
| Term (s, _, [|coded_name|]) when s = term_type_var_name ->
- Var (decode_string coded_name, 0, top_type_term, [||])
+ TVar (decode_string coded_name)
| Term (s, _, [|coded_1; coded_2|]) when s = term_type_fun_name ->
- Term (Term.fun_type_name, toplevel_type, of_list (
+ Term (Term.fun_type_name, [||], of_list (
(decode_list decode_term_type coded_1) @ [decode_term_type coded_2]))
| Term (s, _, [|coded_1; coded_2|]) when s = term_type_cons_name ->
- Term (decode_string coded_1, toplevel_type,
+ Term (decode_string coded_1, [||],
of_list (decode_list decode_term_type coded_2))
| _ -> raise (DECODE "term_type")
@@ -132,7 +130,9 @@
let rec code_term = function
- | Var (name, deg, var_type, args) ->
+ | TVar name ->
+ Term (term_type_var_name, [|term_tp|], [|code_string name|])
+ | SVar (name, deg, var_type, args) ->
Term (term_var_cons_name, [|term_tp|],
[|code_string name;
code_term_type var_type;
@@ -146,8 +146,10 @@
let rec code_term_incr_vars = function
- | Var (name, deg, var_type, args) ->
- Var (name, deg+1, var_type, map code_term_incr_vars args)
+ | TVar name ->
+ Term (term_type_var_name, [|term_tp|], [|code_string name|])
+ | SVar (name, deg, var_type, args) ->
+ SVar (name, deg+1, var_type, map code_term_incr_vars args)
| Term (name, types, args) ->
Term (term_term_cons_name, [|term_tp|],
[|code_string name;
@@ -156,9 +158,12 @@
let rec decode_term = function
+ | Term (s, _, [|coded_name|])
+ when s = term_type_var_name ->
+ TVar (decode_string coded_name)
| Term (s, _, [|coded_name; coded_type; coded_deg; coded_args|])
when s = term_var_cons_name ->
- Var (decode_string coded_name,
+ SVar (decode_string coded_name,
bits_to_int (decode_list decode_bit coded_deg),
decode_term_type coded_type,
of_list (decode_list decode_term coded_args))
@@ -226,9 +231,9 @@
let code_type_definition (name, arity) =
let rec var = function
| 0 -> []
- | i -> Var ("a_" ^ (string_of_int i), 0, top_type_term, [||]) :: (var (i-1)) in
+ | i -> TVar ("a_" ^ string_of_int i) :: (var (i-1)) in
Term (type_of_name, [|type_definition_tp|],
- [|code_term_type (Term (name, toplevel_type, of_list (var arity)))|])
+ [|code_term_type (Term (name, [||], of_list (var arity)))|])
let decode_type_definition = function
@@ -296,36 +301,17 @@
(* --- Term matching and substitutions --- *)
-(* Including supertypes.
-let rec matches dict = function
- | (Term (n1, t1, a1), Term (n2, t2, a2))
- when n1=n2 && (length t1 = length t2) && (length a1 = length a2)->
- Aux.array_for_all2 (fun u v -> matches dict (u, v)) t1 t2 &&
- Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, d1, t1, a1), Var (n2, d2, t2, a2))
- when n1 = n2 && d1 = d2 && length a1 = length a2 ->
- matches dict (t1, t2) &&
- Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, d1, t1, [||]), te) ->
- (try
- let arg = List.assoc n1 (!dict) in
- let coded_arg = fn_apply d1 code_term arg in
- te = coded_arg
- with Not_found ->
- let decoded_te = fn_apply d1 decode_term te in
- (dict := (n1, decoded_te) :: (!dict); true)
- )
- | _ -> false
-*)
+(* FIXME: these functions should are obsoleted by the Term module. *)
+
(* Ignoring supertypes. *)
let rec matches dict = function
| (Term (n1, _, a1), Term (n2, _, a2))
when n1=n2 && (length a1 = length a2)->
Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, d1, _, a1), Var (n2, d2, _, a2))
+ | (SVar (n1, d1, _, a1), SVar (n2, d2, _, a2))
when n1 = n2 && d1 = d2 && length a1 = length a2 ->
Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, d1, t1, [||]), te) ->
+ | (SVar (n1, d1, t1, [||]), te) ->
(try
let arg = List.assoc n1 (!dict) in
let coded_arg = fn_apply d1 code_term arg in
@@ -339,45 +325,47 @@
(* Application of term substitutions (only flat functional
substitutes). Ignoring supertypes. *)
let rec apply_s substs = function
- | Var (n, d, _, [||]) as t ->
+ | SVar (n, d, _, [||]) as t ->
(* FIXME: why we don't apply substitutions recursively, as below? *)
(try (fn_apply d code_term (List.assoc n substs)) with Not_found -> t)
| Term (n, tp, a) -> Term (n, tp, map (apply_s substs) a)
- | Var (n, deg, t, a) ->
+ | TVar _ as ty -> ty
+ | SVar (n, deg, t, a) ->
try (
let raw_result =
match (List.assoc n substs) with
| Term (name, tps, [||]) ->
Term (name, tps, map (apply_s substs) a)
- | Var (name, d, ty, [||]) ->
- Var (name, d, ty, map (apply_s substs) a)
+ | SVar (name, d, ty, [||]) ->
+ SVar (name, d, ty, map (apply_s substs) a)
| _ -> failwith "functional substitution of non-flat term" in
fn_apply deg code_term raw_result
)
- with Not_found -> Var (n, deg, t, map (apply_s substs) a)
+ with Not_found -> SVar (n, deg, t, map (apply_s substs) a)
(* Application of term substitutions (only flat functional
substitutes). Including supertypes. *)
let rec apply_st substs = function
- | Var (n, d, t, [||]) ->
+ | SVar (n, d, t, [||]) ->
(* FIXME: why we don't apply substitutions recursively, as below? *)
(try (fn_apply d code_term (List.assoc n substs))
- with Not_found -> Var (n, d, apply_st substs t, [||]))
+ with Not_found -> SVar (n, d, apply_st substs t, [||]))
| Term (n, tp, a) ->
Term (n, map (apply_st substs) tp, map (apply_st substs) a)
- | Var (n, deg, t, a) ->
+ | TVar _ as ty -> ty
+ | SVar (n, deg, t, a) ->
try (
let raw_result =
match (List.assoc n substs) with
| Term (name, tps, [||]) ->
Term (name, map (apply_st substs) tps, map (apply_st substs) a)
- | Var (name, d, ty, [||]) ->
- Var (name, d, apply_st substs ty, map (apply_st substs) a)
+ | SVar (name, d, ty, [||]) ->
+ SVar (name, d, apply_st substs ty, map (apply_st substs) a)
| _ -> failwith "functional substitution of non-flat term" in
fn_apply deg code_term raw_result
)
with Not_found ->
- Var (n, deg, apply_st substs t, map (apply_st substs) a)
+ SVar (n, deg, apply_st substs t, map (apply_st substs) a)
(* --- Nice Term display based on Syntax Definitions --- *)
@@ -393,7 +381,8 @@
| Term (n, _, a) ->
let args = List.map display_term (Array.to_list a) in
display_sd (split_sdef_name n) args
- | Var (n, _, _, a) ->
+ | TVar _ -> failwith "display_term: type variable"
+ | SVar (n, _, _, a) ->
let args = List.map display_term (Array.to_list a) in
display_sd (split_sdef_name n) args
@@ -407,7 +396,8 @@
| Term (n, _, a) ->
let args = List.map display_term_bracketed (Array.to_list a) in
display_sd_bracketed (split_sdef_name n) args
- | Var (n, _, _, a) ->
+ | TVar _ -> failwith "display_term: type variable"
+ | SVar (n, _, _, a) ->
let args = List.map display_term_bracketed (Array.to_list a) in
display_sd_bracketed (split_sdef_name n) args
@@ -415,9 +405,9 @@
(* --- Display terms and types as XML --- *)
let rec display_type_xml = function
- | Var (n, 0, top_type_term, [||]) ->
+ | TVar n ->
"<type_var>" ^ (make_xml_compatible n) ^ "</type_var>"
- | Var _ -> failwith "display_type_xml: non-type variable"
+ | SVar _ -> failwith "display_type_xml: sharing variable"
| Term (n, _, a) ->
"<type class=\"" ^ (make_xml_compatible n) ^ "\">\n" ^
(String.concat "\n" (List.map display_type_xml (to_list a))) ^
@@ -434,7 +424,8 @@
"<term class=\"" ^ (make_xml_compatible n) ^ "\">\n" ^
(String.concat "\n" (List.map display_term_xml (to_list a))) ^
"\n</term>"
- | Var (n, deg, ty, a) ->
+ | TVar _ -> failwith "display_term_xml: type variable"
+ | SVar (n, deg, ty, a) ->
"<term-variable class=\"" ^ (make_xml_compatible n) ^
"\" deg=\"" ^ (string_of_int deg) ^ "\">" ^
(String.concat "" (List.map display_term_xml (to_list a))) ^
@@ -464,13 +455,14 @@
| _ when is_some (decode_term_opt term) ->
(match (decode_term_opt term) with None -> ""
| Some te -> "@T " ^ (term_to_string te))
- | Var (v, d, t, [||]) ->
+ | TVar _ as ty -> type_to_string ty
+ | SVar (v, d, t, [||]) ->
(try
"@V [" ^ v ^ " @: " ^ (type_to_string t) ^
" @: "^ string_of_int (d) ^ " ]"
with exn -> Printf.printf "Nontype: %s\n%!"(term_to_string t);
raise exn)
- | Var (v, d, t, a) ->
+ | SVar (v, d, t, a) ->
(try
"@V [" ^ v ^ " @: " ^ (type_to_string t) ^
" @: "^ string_of_int (d) ^ " ] (" ^
@@ -502,9 +494,10 @@
(match parse_term_list rest with
| (l, (Delim "]") :: cont) ->
let tp = match l with
- | [] -> top_type_term
- | Var (_, _, tp, _)::_ -> tp
- | Term (_, tps, _)::_ -> tps.(0) in
+ | [] -> TVar "a"
+ | SVar (_, _, ty, _)::_ -> ty
+ | TVar _ as ty::_ -> ty
+ | Term (_, tys, _)::_ -> tys.(0) in
code_list [|list_tp tp|] (fun x -> x) l, cont
| _ -> failwith "parse_term: list not closed"
)
@@ -518,7 +511,7 @@
(match parse_type rest with
| (ty, (Delim "@:") :: (Text deg) :: (Delim "]") :: cont) ->
let (l, c) = parse_bracketed_list cont in
- (Var (v, int_of_string (deg), ty, of_list l), c)
+ (SVar (v, int_of_string deg, ty, of_list l), c)
| _ -> failwith "parse_term: var not closed"
)
| (Text n) :: Delim "[" :: Delim "@:" :: rest ->
@@ -575,29 +568,29 @@
(* --- Rules for special built-in functions --- *)
let brackets_rules =
- [(Term (brackets_name, [|Var ("b",0,top_type_term,[||])|], [|Var ("x", 0, Var("a",0,top_type_term,[||]),[||])|]),
- Var ("x", 0, Var ("a",0,top_type_term,[||]), [||]))]
+ [(Term (brackets_name, [|TVar "b"|], [|SVar ("x", 0, TVar "a",[||])|]),
+ SVar ("x", 0, TVar "a", [||]))]
let verbatim_rules =
- [(Term (verbatim_name, [|Var ("b",0,top_type_term,[||])|], [|Var ("x",0,Var ("a",0,top_type_term,[||]),[||])|]),
- Var ("x", 0, Var ("a",0,top_type_term,[||]), [||]))]
+ [(Term (verbatim_name, [|TVar "b"|], [|SVar ("x",0,TVar "a",[||])|]),
+ SVar ("x", 0, TVar "a", [||]))]
let if_then_else_rules = [
- (Term (if_then_else_name, [|Var ("a",0,top_type_term,[||])|],
+ (Term (if_then_else_name, [|TVar "a"|],
[|code_bool true;
- Var ("x",0,Var ("a",0,top_type_term,[||]),[||]);
- Var ("y",0,Var ("a",0,top_type_term,[||]),[||])|]),
- Var ("x",0,Var ("a",0,top_type_term,[||]),[||]));
- (Term (if_then_else_name, [|Var ("a",0,top_type_term,[||])|],
+ SVar ("x",0,TVar "a",[||]);
+ SVar ("y",0,TVar "a",[||])|]),
+ SVar ("x",0,TVar "a",[||]));
+ (Term (if_then_else_name, [|TVar "a"|],
[|code_bool false;
- Var ("x",0,Var ("a",0,top_type_term,[||]),[||]);
- Var ("y",0,Var ("a",0,top_type_term,[||]),[||])|]),
- Var ("y",0,Var ("a",0,top_type_term,[||]),[||]))]
+ SVar ("x",0,TVar "a",[||]);
+ SVar ("y",0,TVar "a",[||])|]),
+ SVar ("y",0,TVar "a",[||]))]
-let varx_te = Var ("x", 0, Var ("p",0,top_type_term,[||]), [||])
-let preprocess_rules = [(Term (preprocess_name, [|Var ("q",0,top_type_term,[||])|], [|varx_te|]), varx_te)]
+let varx_te = SVar ("x", 0, TVar "p", [||])
+let preprocess_rules = [(Term (preprocess_name, [|TVar "q"|], [|varx_te|]), varx_te)]
let string_quote_rules =
- [(Term (string_quote_name, [|string_tp|], [|Var ("s", 0, string_tp, [||])|]),
- Var ("s", 0, string_tp, [||]))]
+ [(Term (string_quote_name, [|string_tp|], [|SVar ("s", 0, string_tp, [||])|]),
+ SVar ("s", 0, string_tp, [||]))]
let additional_xslt_rules =
[(Term (additional_xslt_name, [|string_tp|], [||]), code_string " ")]
Modified: trunk/Toss/Term/CodingTest.ml
===================================================================
--- trunk/Toss/Term/CodingTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/CodingTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -8,10 +8,10 @@
let test_code_decode_tt tt =
let tt1 = decode_term_type (code_term_type tt) in
assert_equal ~printer:(fun x -> type_to_string x) tt tt1 in
- let tt1 = Term ("ala", toplevel_type, [||]) in
- let tt2 = Term ("bolek", toplevel_type, [|tt1; tt1|]) in
- let tt3 = Term (Term.fun_type_name, toplevel_type, [|tt1; tt2; tt1|]) in
- let tt4 = Var ("zmienna",0,top_type_term,[||]) in
+ let tt1 = Term ("ala", [||], [||]) in
+ let tt2 = Term ("bolek", [||], [|tt1; tt1|]) in
+ let tt3 = Term (Term.fun_type_name, [||], [|tt1; tt2; tt1|]) in
+ let tt4 = TVar "zmienna" in
test_code_decode_tt tt1;
test_code_decode_tt tt2;
test_code_decode_tt tt3;
@@ -23,11 +23,11 @@
let test_code_decode_te te =
let te1 = decode_term (code_term te) in
assert_equal ~printer:(fun x -> term_to_string x) te te1 in
- let ty = Term ("text", toplevel_type, [||]) in
+ let ty = Term ("text", [||], [||]) in
let term1 = Term ("ala", [|ty|], [||]) in
let term2 = Term ("bolek", [|ty|], [|term1|]) in
let term3 = Term ("cynik", [|ty|], [|term1; term2|]) in
- let term4 = Var ("zmienna", 0, Var ("a1",0,top_type_term,[||]), [| |]) in
+ let term4 = SVar ("zmienna", 0, TVar "a1", [| |]) in
test_code_decode_te term1;
test_code_decode_te term2;
test_code_decode_te term3;
@@ -53,10 +53,10 @@
let sd1 = decode_syntax_definition (code_syntax_definition sd) in
assert_equal ~printer:(fun x -> "syntax definition test") sd sd1 in
let se1 = SyntaxDef.Str "napisek" in
- let se2 = SyntaxDef.Tp (Var ("eee",0,top_type_term,[||])) in
+ let se2 = SyntaxDef.Tp (TVar "eee") in
let sd1 = SyntaxDef.SDtype [se1; se2] in
- let sd2 = SyntaxDef.SDfun ([se2; se1; se1], Term ("aaa", toplevel_type, [||])) in
- let sd3 = SyntaxDef.SDvar ([se2;se2;se1;se1], Term("qza", toplevel_type, [||])) in
+ let sd2 = SyntaxDef.SDfun ([se2; se1; se1], Term ("aaa", [||], [||])) in
+ let sd3 = SyntaxDef.SDvar ([se2;se2;se1;se1], Term("qza", [||], [||])) in
test_code_decode_sd sd1;
test_code_decode_sd sd2;
test_code_decode_sd sd3;
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Term/ParseArc.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/ParseArc.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -11,8 +11,8 @@
[term] does not have [substitution] applied. *)
type parser_elem =
| Token of string
- | PTerm of term * substitution * int (* From [parsed_elems], [cstrn]
- and [endpos] of {!parser_arc}. *)
+ | PTerm of term * substs * int (* From [parsed_elems], [cstrn]
+ and [endpos] of {!parser_arc}. *)
(* Print a parser elem. *)
let elem_str = function
@@ -33,11 +33,13 @@
spos : int; (* Start position of the arc. *)
endpos : int; (* The current end position of the
arc. FIXME: unnecessary? *)
- cstrn : substitution; (* Constraint for the arc. *)
+ cstrn : substs; (* Constraint for the arc. *)
}
(* --- Extending and closing arcs --- *)
+let debug = ref false
+
(* This function takes a parser element and an arc and extends the arc
if the next free position in the arc matches the given
element. Maching means equality for tokens and inference constraint
@@ -76,13 +78,30 @@
precheck_eq ty pty;*)
(* Combine the constraints so far, and extend them to cover
the new parsed element. *)
- let cstrn = combine_mgu_sb t_cstrn arc.cstrn in
+ (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ "extend_arc: sd_n=%s; #parsed=%d\nty=%s; pty=%s\nt=%s\nt_cstrn=%s\narc.cstrn=%s\n%!"
+ arc.sd_n (List.length arc.parsed_elems)
+ (type_to_string ty) (type_to_string pty)
+ (Coding.term_to_string t) (substs_str t_cstrn) (substs_str arc.cstrn)
+ ;*)
+ let cstrn' = combine_mgu_sbs t_cstrn arc.cstrn in
+ (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ "S(ty)=%s; S(pty)=%s\ncstrn'=%s\n%!"
+ (type_to_string (apply_sbs cstrn' ty))
+ (type_to_string (apply_sbs cstrn' pty))
+ (substs_str cstrn');*)
let cstrn =
- mgu cstrn [apply_sb cstrn pty, apply_sb cstrn ty] in
+ mgu cstrn' [apply_sbs cstrn' pty, apply_sbs cstrn' ty] in
+ (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ "cstrn=%s\n%!"
+ (substs_str cstrn);*)
Some
{arc with rem_elems; parsed_elems = elem::arc.parsed_elems;
endpos = t_endpos; cstrn}
- with UNIFY -> None
+ with UNIFY ->
+ (*if !debug && arc.sd_n = "Fif_\?_then_\?_else_\?" then Printf.printf
+ "NO UNIFY\n%!";*)
+ None
(* Extends all the arcs in the given list that can be extended
and removes all other arcs. *)
@@ -105,14 +124,14 @@
if arc.rem_elems <> [] then None else
let args = rev_map match_of_tok arc.parsed_elems in
let res_term = match arc.sd_res with
- | SD_Term ty when ty = toplevel_type ->
+ | SD_Term [||] ->
Term (BuiltinLang.term_type_cons_name, [|BuiltinLang.term_type_tp|],
[|Coding.code_string arc.sd_n;
Coding.code_list
[|BuiltinLang.list_tp BuiltinLang.term_type_tp|]
(fun x -> x) args|])
| SD_Term tp -> Term (arc.sd_n, tp, Array.of_list args)
- | SD_Var tp -> Var (arc.sd_n, 0, tp, Array.of_list args) in
+ | SD_Var tp -> SVar (arc.sd_n, 0, tp, Array.of_list args) in
(* Note that [arc.cstrn] is not applied to [res_term]. *)
Some (PTerm (res_term, arc.cstrn, arc.endpos), arc.spos)
@@ -127,7 +146,7 @@
let elems, sd_res =
match sdef with
| SDtype elems -> incr fresh_suffix;
- freshen elems, SD_Term toplevel_type
+ freshen elems, SD_Term [||]
| SDfun (elems, ty) -> incr fresh_suffix;
freshen elems, SD_Term [|suffix !fresh_suffix ty|]
| SDvar (elems, ty) ->
@@ -139,7 +158,7 @@
rem_elems = elems;
parsed_elems = [];
endpos = spos;
- cstrn = empty_sb;
+ cstrn = empty_sbs;
}
(* TODO: clean-up the description.
@@ -264,9 +283,12 @@
(* --- Final parsing --- *)
let parse_with_sdefs sdefs str =
+ (*Printf.printf "\nparse_with_sdefs: str=%s\n%!" str;
+ if str = "if is digit string from c_a :: [] then added ending cl_a else false"
+ then debug := true;*)
let type_of_pe = function Token _ -> None
| PTerm (te, cstrn, _) ->
- let result = apply_sb cstrn te in
+ let result = apply_sbs cstrn te in
Some result in
let elems = parse sdefs (split_input_string str) in
Aux.map_some type_of_pe elems
Modified: trunk/Toss/Term/ParseArc.mli
===================================================================
--- trunk/Toss/Term/ParseArc.mli 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/ParseArc.mli 2012-07-15 20:43:16 UTC (rev 1745)
@@ -9,8 +9,8 @@
have [substitution] applied. *)
type parser_elem =
| Token of string
- | PTerm of term * substitution * int (** From [parsed_elems], [cstrn]
- and [endpos] of {!parser_arc}. *)
+ | PTerm of term * substs * int (** From [parsed_elems], [cstrn]
+ and [endpos] of {!parser_arc}. *)
(** Print a parser elem. *)
val elem_str : parser_elem -> string
@@ -29,7 +29,7 @@
rev. order (all will be arguments). *)
spos : int; (** Start position of the arc. *)
endpos : int; (** The current end position of the arc. *)
- cstrn : substitution; (** Constraint for the arc. *)
+ cstrn : substs; (** Constraint for the arc. *)
}
Modified: trunk/Toss/Term/ParseArcTest.ml
===================================================================
--- trunk/Toss/Term/ParseArcTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/ParseArcTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -9,15 +9,15 @@
(fun () ->
let elem_eq res e = assert_equal ~printer:(fun x -> x) res (elem_str e) in
let type_decls_list = [
- (list_cons_name, Term (Term.fun_type_name, toplevel_type,
- [|Var ("a",0,top_type_term,[||]);
+ (list_cons_name, Term (Term.fun_type_name, [||],
+ [|TVar "a";
list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], Var ("a",0,top_type_term,[||])) in
+ let var_x_a_sd = SDvar ([Str "x"], TVar "a") in
let sdefs = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let arcs = List.map (fun sd -> create_arc sd (name_of_sd sd) 0) sdefs in
@@ -45,15 +45,15 @@
"parse" >::
(fun () ->
let type_decls_list = [
- (list_cons_name, Term (Term.fun_type_name, toplevel_type,
- [|Var ("a",0,top_type_term,[||]);
+ (list_cons_name, Term (Term.fun_type_name, [||],
+ [|TVar "a";
list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], Var ("a",0,top_type_term,[||])) in
+ let var_x_a_sd = SDvar ([Str "x"], TVar "a") in
let sdefs_basic = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let sdefs = List.map (fun sd -> (name_of_sd sd, sd)) sdefs_basic in
Modified: trunk/Toss/Term/Rewriting.ml
===================================================================
--- trunk/Toss/Term/Rewriting.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/Rewriting.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -14,7 +14,9 @@
let is_left_linear (lhs, _) =
let rec vars = function
| Term (_, _, a) -> List.concat (Array.to_list (Array.map vars a))
- | Var (v, _, _, a) -> v :: List.concat (Array.to_list (Array.map vars a)) in
+ | TVar _ -> []
+ | SVar (v, _, _, a) ->
+ v :: List.concat (Array.to_list (Array.map vars a)) in
let vs = List.sort String.compare (vars lhs) in
let rec has_duplicates = function [] | [_] -> false
| x :: y :: _ when x = y -> true | x :: r -> has_duplicates r in
@@ -40,6 +42,8 @@
exception NO_MATCH
+(* TODO: lukstafi proposes to use ISA-matching for rewriting. *)
+
(* Checking match returning lists to substitute for and detecting clash.
In documentation this is described as STEP 1. (FIXME: docs)
We assume that the rewrite rules are correct and therefore have no
@@ -60,9 +64,11 @@
raise NO_MATCH
| (Term _, _) ->
(true, [])
- | (Var (n, d, _, [||]), t2) ->
+ | (SVar (n, d, _, [||]), t2) ->
(false, [(n, (d, fn_apply d Coding.decode_term t2))])
- | (Var (n, _, _, a), _) ->
+ | (TVar _, _ | _, TVar _) ->
+ failwith "type variable inside rr"
+ | (SVar (n, _, _, a), _) ->
(* Printf.printf "check_clash_match: [2] %s %d\n" n (Array.length a); *)
failwith "functional var on left side of rr" in
match (term1, term2) with (* now term1 = f (args) *)
@@ -99,15 +105,17 @@
match term, result with
| Term (_, oldtys, _), Term (n, _, args) ->
Term (n, oldtys, args)
- | Var (_, _, oldty, _), Term (n, _, args) ->
+ | SVar (_, _, oldty, _), Term (n, _, args) ->
Term (n, [|oldty|], args)
- | Var (_, _, oldty, _), Var (n, d, _, args) ->
- Var (n, d, oldty, args)
- | Term (_, [|oldty|], _), Var (n, d, _, args) ->
- Var (n, d, oldty, args)
+ | SVar (_, _, oldty, _), SVar (n, d, _, args) ->
+ SVar (n, d, oldty, args)
+ | Term (_, [|oldty|], _), SVar (n, d, _, args) ->
+ SVar (n, d, oldty, args)
(* failwith "apply_check_clash: rewriting non-var with var" *)
- | Term _, Var (n, d, _, args) ->
- Var (n, d, term, args)
+ | Term _, SVar (n, d, _, args) ->
+ SVar (n, d, term, args)
+ | TVar _, _ | _, TVar _ ->
+ failwith "rewrite: unexpected type variable"
(* The final rewrite function that takes care of function names in terms. *)
let rewrite (Rules (rules)) term =
@@ -122,14 +130,16 @@
let rec normalise_special_id_one name = function
| Term (n, _, [|a|]) when n = name -> a
| Term (n, t, a) -> Term (n, t, Array.map (normalise_special_id_one name) a)
- | Var (n, d, ty, a) ->
- Var (n, d, ty, Array.map (normalise_special_id_one name) a)
+ | TVar _ -> failwith "normalise_special_id_one: unexpected type variable"
+ | SVar (n, d, ty, a) ->
+ SVar (n, d, ty, Array.map (normalise_special_id_one name) a)
let rec normalise_special_id_all name = function
| Term (n, _, [|a|]) when n = name -> normalise_special_id_all name a
| Term (n, t, a) -> Term (n, t, Array.map (normalise_special_id_all name) a)
- | Var (n, d, ty, a) ->
- Var (n, d, ty, Array.map (normalise_special_id_all name) a)
+ | TVar _ -> failwith "normalise_special_id_all: unexpected type variable"
+ | SVar (n, d, ty, a) ->
+ SVar (n, d, ty, Array.map (normalise_special_id_all name) a)
let normalise_brackets = normalise_special_id_all brackets_name
let normalise_verbatim = normalise_special_id_one verbatim_name
@@ -141,8 +151,9 @@
rr_spec normalised
| Term (n, t, a) ->
Term (n, t, Array.map (normalise_special rr_spec) a)
- | Var (n, d, ty, a) ->
- Var (n, d, ty, Array.map (normalise_special rr_spec) a)
+ | TVar _ -> failwith "normalise_special: unexpected type variable"
+ | SVar (n, d, ty, a) ->
+ SVar (n, d, ty, Array.map (normalise_special rr_spec) a)
let cMEM_USE_INCREASE_FACTOR = 128
@@ -190,9 +201,10 @@
| Term (n, t, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
(steps, Term (n, t, res))
- | Var (n, d, ty, a) ->
+ | TVar _ -> failwith "basic_normalise: unexpected type variable"
+ | SVar (n, d, ty, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
- (steps, Var (n, d, ty, res))
+ (steps, SVar (n, d, ty, res))
let normalise mem rules is_special rewrite_special inp_term =
Modified: trunk/Toss/Term/RewritingTest.ml
===================================================================
--- trunk/Toss/Term/RewritingTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/RewritingTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -10,8 +10,8 @@
let test_rr rl res t =
let rs = new_rules_set rl in
assert_equal ~printer:(fun x-> x) res (term_to_string (rewrite rs t)) in
- let var_x_b = Var ("x", 0, boolean_tp, [||]) in
- let var_y_b = Var ("y", 0, boolean_tp, [||]) in
+ let var_x_b = SVar ("x", 0, boolean_tp, [||]) in
+ let var_y_b = SVar ("y", 0, boolean_tp, [||]) in
let rr1 =
(Term ("Fand",[|boolean_tp|],[|code_bool true;code_bool true|]),code_bool true) in
let rr2 = (Term ("Fand", [|boolean_tp|], [|var_x_b; var_y_b|]), code_bool false) in
@@ -38,8 +38,8 @@
Hashtbl.add rs n (new_rules_set rl);
assert_equal ~printer:(fun x-> x) res
(term_to_string (normalise m rs (fun x -> false) (fun x -> x) t)) in
- let var_x_b = Var ("x", 0, boolean_tp, [||]) in
- let var_y_b = Var ("y", 0, boolean_tp, [||]) in
+ let var_x_b = SVar ("x", 0, boolean_tp, [||]) in
+ let var_y_b = SVar ("y", 0, boolean_tp, [||]) in
let rr1 =
(Term ("Fand",[|boolean_tp|],[|code_bool true;code_bool true|]),code_bool true) in
let rr2 = (Term ("Fand", [|boolean_tp|], [|var_x_b; var_y_b|]), code_bool false) in
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Term/SyntaxDef.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -76,9 +76,9 @@
let rec revnumbers i = if i = 0 then [] else i :: (revnumbers (i-1)) in
let numbers i = List.map string_of_int (List.rev (revnumbers i)) in
let s = concat_map (function Str _ -> [] | Tp _ -> ["a"]) sel in
- let arg_of s1 s2 = Var (s1 ^ "_" ^ s2, 0, top_type_term, [||]) in
+ let arg_of s1 s2 = TVar (s1 ^ "_" ^ s2) in
let args = List.map2 arg_of s (numbers (List.length s)) in
- Term (name_of_sd sd, toplevel_type, of_list args)
+ Term (name_of_sd sd, [||], of_list args)
| _ -> failwith "type of sd on non-type definition"
@@ -89,9 +89,9 @@
match sd with
| SDtype _ -> None
| SDfun (sel, ty)-> Some (if (ts = []) then ty else
- Term (Term.fun_type_name, toplevel_type, of_list (ts @ [ty])))
+ Term (Term.fun_type_name, [||], of_list (ts @ [ty])))
| SDvar (sel, ty)-> Some (if (ts = []) then ty else
- Term (Term.fun_type_name, toplevel_type, of_list (ts @ [ty])))
+ Term (Term.fun_type_name, [||], of_list (ts @ [ty])))
(* Syntax definition for un-applied syntax definition as function. *)
let func_sd_of_sd sd =
@@ -243,16 +243,16 @@
split_sd_name n
else [Some (n)]
+(* FIXME: remainder of the old Speagram distinction between types and terms *)
let rec display_type = function
- | tp when tp = top_type_term -> "ttyyppee" (* FIXME *)
- | Var (n, 0, tp, [||]) when tp = top_type_term -> "?" ^ n
- | Var _ -> failwith "display_type on non-type variable"
- | Term (n, tp, arr) when n = Term.fun_type_name && tp = toplevel_type ->
+ | TVar n -> "?" ^ n
+ | SVar _ -> failwith "display_type on a sharing variable"
+ | Term (n, [||], arr) when n = Term.fun_type_name ->
let l = Array.length arr in
let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
let args = List.map display_type (Array.to_list a) in
"(" ^ (String.concat ", " args) ^ ") --> " ^ (display_type r)
- | Term (n, tp, a) when tp = toplevel_type ->
+ | Term (n, [||], a) ->
let args = List.map display_type (Array.to_list a) in
display_sd (split_sdef_name n) args
| Term _ -> failwith "display_type: non-type term"
@@ -284,7 +284,8 @@
) in
let flat_grammar_name_of_type = function
| Term (n, _, _) -> "$" ^ String.sub n 1 ((String.length n) - 1)
- | Var _ -> "$@object" in
+ | SVar _ -> "$@object"
+ | TVar _ -> "$@object" in
let flat_grammar_name_of_se = function
| Tp ty -> flat_grammar_name_of_type ty
| Str s -> if is_all_letters s then s else raise NONLEXICAL in
Modified: trunk/Toss/Term/SyntaxDefTest.ml
===================================================================
--- trunk/Toss/Term/SyntaxDefTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/SyntaxDefTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -5,7 +5,7 @@
let tests = "SyntaxDef" >::: [
"name of sd" >::
(fun () ->
- let sel1 = [Str "[list]"; Str "of"; Tp (Var ("a",0,top_type_term,[||]))] in
+ let sel1 = [Str "[list]"; Str "of"; Tp (TVar "a")] in
let n = unique_name_of_sd (SDtype sel1) [name_of_sd (SDtype sel1)] in
assert_equal ~printer:(fun x -> x) "T\\lslist\\rs_of_\\?_0\\" n;
);
@@ -20,7 +20,7 @@
assert_equal ~printer:(fun x -> x) res_sn sn in
let sd1 = SDtype [Str "ala_ma_kota"] in
let sd2 = SDtype [Str "\\atala"; Str "_"; Str "\\?"; Str "m\\_a";
- Str "\\\\";Str "maa\\"; Tp (Var ("a",0,top_type_term,[||]));
+ Str "\\\\";Str "maa\\"; Tp (TVar "a");
Str "kot@"] in
test_split "Tala\\_ma\\_kota" "Sala_ma_kota" sd1;
test_split "T\\\\atala_\\__\\\\?_m\\\\\\_a_\\\\\\\\_maa\\\\_\\?_kot\\at"
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/TRS.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -151,7 +151,7 @@
let elem_of_td (n, ty) =
if n.[0] = c then
match ty with
- | Term (name, tp, arr) when name = Term.fun_type_name && tp=toplevel_type->
+ | Term (name, [||], arr) when name = Term.fun_type_name->
let l = Array.length arr in
let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
[(n, Array.to_list a, r)]
@@ -175,7 +175,8 @@
let rec has_vars = function
| Term (_, _, args) -> List.exists has_vars (Array.to_list args)
- | Var _ -> true
+ | TVar _ -> false (* FIXME: rewriting via ISA-matching *)
+ | SVar _ -> true
(* Rewriting special functions given a system. *)
let rec rewrite_special_funs sys = function
@@ -387,7 +388,8 @@
| (te, _) ->
(* FIXME: at step 4 the "types" will get displayed properly *)
let ty = match te with
- | Var (_, _, ty, _) -> ty
+ | SVar (_, _, ty, _) -> ty
+ | TVar _ as ty -> ty
| Term (_, tys, _) -> tys.(0) in
if xml_out then
"<trs-result>\n" ^
Modified: trunk/Toss/Term/TRSTest.ml
===================================================================
--- trunk/Toss/Term/TRSTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/TRSTest.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -53,7 +53,7 @@
(fun () -> test "simple_algo";);
(* FIXME: hangs on trashing memory *)
(*"test entanglement" >::
- (fun () -> test "entanglement";);*)
+ (fun () -> test "entanglement";);*)
"test differentiation" >::
(fun () -> test "differentiation";);
]
Modified: trunk/Toss/Term/Term.ml
===================================================================
--- trunk/Toss/Term/Term.ml 2012-07-10 22:44:46 UTC (rev 1744)
+++ trunk/Toss/Term/Term.ml 2012-07-15 20:43:16 UTC (rev 1745)
@@ -5,74 +5,109 @@
Hierarchical terms have the form: [f(s_1, ..., s_m; t_1, ...,
t_n)] where [f] is a (function/constant/class) symbol, terms [s_1,
- ..., s_m] are called direct supertypes and terms [t_1, ..., t_n]
- are called direct subterms of the term, or [X(s)], where [X] is a
- variable symbol and term [s] is called the type of the variable.
- When [f(s_1, ..., s_m; t_1, ..., t_n)], resp. [X(s)] is not a
- subterm or supertype of another term, we call [f], resp. [X] its
- head symbol. Hierarchical terms are related by [ISA] as formally
+ ..., s_m] are called {i direct supertypes} and terms [t_1, ...,
+ t_n] are called {i direct subterms} of the term; or [X(s)] but not
+ as a direct supertype, where [X] is a sharing variable symbol and
+ term [s] is called the type of the variable, and also its direct
+ supertype (especially when we don't distinguish between variables
+ and other terms); or [?V] (can be a direct supertype), where [?V]
+ is a type variable symbol. For a term [f(s_1, ..., s_m; t_1, ...,
+ t_n)], resp. [X(s)] or [?V], we call [f], resp. [X] or [?V] its
+ head symbol. We call [X(s)] {i sharing variables} and [?V] {i type
+ variables}, and call them variables when not distinguishing
+ between them. Hierarchical terms are related by [ISA] as formally
presented below; we drop "hierarchical" when referring to terms
for convenience.
+ A term [s] is a {i supertype} of [t] when it is a direct
+ supertype of [t], or is a direct supertype of a supertype of
+ [t]. A term [t'] is a {i subterm} of [t] when it is a direct
+ subterm of [t], or is a direct subterm of either a subterm or a
+ supertype of [t]. For terms [s] and [t], by [s=t] we denote
+ sytanctic equality of [s] and [t].
+
+ We require certain conditions to hold on well-formed terms,
+ reiterated when we formally introduce well-formedness:
+
+ {ul
+ {- for any two occurrences of a sharing variable [X(s)] and [X(s')],
+ [s=s'],}
+ {- for any two supertypes [s] and [s'] of a term, if they have the
+ same head symbol, they are syntactically equal: [s=s'].}}
+
+ We define a path in a term as a sequence of symbol-number pairs,
+ where the first symbol is the head symbol of a term or its
+ supertype, the first number is the position in the subterm list in
+ that term or supertype, and the remaining of a path selects a
+ subterm in the indicated subterm recursively. Formally, we say
+ that a term [t] has a subterm [t'] at path [p=(f,i),p'], denoted
+ [t|_p=t'], when either [t] or one of its supertypes is equal to
+ [f(...;t_1,...,t_i,...)] and [t_i|_p'=t']; also, [t|_e=t] for
+ empty path [e].
+
We call the {i upper grounding} of a term [t], [ug(t)], the term
- [t] with all occurrences of [X(s)] for any variable symbol [X] and
- term [s] replaced by [s].
+ [t] with all occurrences of [X(s)] for any sharing variable symbol
+ [X] and term [s] replaced by [s]. We call a term {i type-ground}
+ when it does not contain type variables. We call a {i
+ type-substitution} a substitution for type variables.
- We start by defining [t ISA t'] for [t] and [t'] ground terms
- (i.e. terms without occurrences of variable symbols).
- It holds if and only if one of the following holds:
+ We define [ISA] for type-ground terms first. [t ISA t'] holds if
+ and only if one of the following holds:
{ul
- {- [t' = Type] for the top symbol [Type],}
- {- [s_i ISA g(s'_1, ..., s'_m'; t'_1, ..., t'_n')] for some i,
- where [s(t)=f(s_1, ..., s_m; t_1, ..., t_n)] and
- [r(t')=g(s'_1, ..., s'_m'; t'_1, ..., t'_n')]}
+ {- [s_i ISA t'] for some i, where [t=f(s_1, ..., s_m; t_1, ..., t_n)],}
+ {- [t' = X(s)] and [t ISA s],}
+ {- [t = X(s)], [t' = Y(s')], and [s ISA s'],}
+ {- the following two conditions both hold:
+ {ul
{- [s_i ISA s'_i] for all [i], [t_i ISA t'_i] for all [i],
- where [s()t=f(s_1, ..., s_m; t_1, ..., t_n)] and
- [r(t')=f(s'_1, ..., s'_m; t'_1, ..., t'_n)]}}
+ where [t=f(s_1, ..., s_m; t_1, ..., t_n)] and
+ [t'=f(s'_1, ..., s'_m; t'_1, ..., t'_n)]}
+ {- for any paths [p,p'] in [t'], if they select the same sharing
+ variable, then they are also paths in [t], and [t|_p = t|_p'].}}}}
- Actually we sometimes do not put a special case for the top symbol
- [Type] into algorithms, and therefore we rely on well-formed sets
- of declarations that no term except [Type] has no direct
- supertypes.
+ We consider a sharing variable to be strictly more general than its
+ type. Note that the second part of the last condition only needs
+ to be checked at the root (i.e. only for the originally compared
+ terms, since if it holds, it also holds for subterms and
+ supertypes).
- We define {i ground substitution over variables [V]} by extending
- into a function over terms in the standard way a finite mapping
- from all variables in [V] to terms, requiring that [X(s)] is
- mapped to [t] only when: [t] does not contain variable symbols,
- and [t ISA ug(s)]. By [FV(t)] we denote the free variables of [t].
+ For arbitrary terms [t] and [t'], [t ISA t'] if and only if for
+ every type-substitution [S] such that [S(t)] is type-ground, there
+ exists a type substitution [R] such that [R(t)] is type-ground
+ and [S(t) ISA R(t)].
- [t ISA t'] if and only if for all ground substitutions [s] over
- [FV(t)] there is a ground substitution [r] over [FV(t')] such that
- [s(t) ISA r(t')].
+ Note that we do not ensure neither bottom nor a type-ground top
+ term, but a single type variable is a top term (two terms that
+ both are type variables are ISA-equivalent).
(We present [ISA] as describing generality, "is less (or equally)
general than". Notice that this relation is often presented as
describing the amount of information, the reverse quantity, as "has
more information than".)
- We need two more essential notions.
+ We need two more, also essential notions.
A {i well-formed set of declarations} is defined as a set of terms
such that all of the following conditions hold:
{ul
{- no two terms in it have the same head symbol,}
- {- head symbols of terms in it are not variables,}
- {- there is at most one glb-unification result for any two (or
- more) elements from the set,}
- {- no term except [Type] has no direct supertypes,}
+ {- head symbols of terms in it are not variables (neither sharing
+ nor type variable symbols),}
+ {- when organizing the symbols into a partial order hierarchy
+ according to which supertypes they appear in, there is at most one
+ GLB and at most one LUB for any two symbols,}
{- every symbol used in any term in the set is a head symbol of
some element of the set,}
- {- for any subterm or supertype of a term from the set, its upper
- grounding ISA the element of the set which has the same head
+ {- for any subterm or supertype of a term from the set that is not
+ a variable, it ISA the element of the set which has the same head
symbol.}}
- Note that the last three conditions will be enforced by parsing the
+ Note that the last two conditions will be enforced by parsing the
term to be introduced into the set of declarations, so in the
current module we only need to check the first three
- conditions. (The condition "must have direct supertypes" also
- needs to be ensured in BuiltinLang.)
+ conditions.
A {i well-formed term with respect to a set of declarations} given
a well-formed set of declarations, is a term [t] such that:
@@ -80,36 +115,79 @@
{ul
{- its supertypes and subterms are well-formed (w.r.t. this set of
declarations),}
- {- there is a term [d] in the set of declarations such
- that [t ISA d] and either the head symbol of [t] is a variable or
- it is the same as the head symbol of [d],}
- {- for any two occurrences [X(s)] and [X(s')] of variable symbol
- [X], [s=s'].}}
+ {- either [t] is a type-variable, or there is a term [d] in the
+ set of declarations such that [t ISA d] and either the head symbol
+ of [t] is a sharing variable or it is the same as the head symbol
+ of [d],}
+ {- for any two occurrences of a sharing variable [X(s)] and
+ [X(s')] in [t], [s=s'],}
+ {- for any two supertypes [s] and [s'] of [t], if they have the
+ same head symbol, they are syntactically equal: [s=s'].}}
We limit all terms considered to terms that are well-formed with
respect to a set of declarations (fixed by the context; we will
- drop constantly mentioning "w.r.t. a set of declarations"). In
- particular, we only allow {i well-formed substitutions}:
- substitutions that when applied to a well-formed term, return a
- well-formed term:
+ drop constantly mentioning "w.r.t. a set of declarations").
- A {i well-formed substitution} is defined by extending into a
- function over terms in the standard way a finite mapping from
- variables (terms whose head symbols are variable symbols) to
- terms, requiring that [X(s)] is mapped to [t] only when [t ISA s].
+ The intent of the above definitions is to mix the ideas of
+ parametric polymorphism from type systems with a representational
+ variant of {i Typed Feature Structures} known from the literature,
+ for now reducing sharing constraints to syntactical
+ equality.
- We define matching a pattern [p] against a ground term [t] (where
- [p] and [t] are well-formed) as the problem of deciding [t ISA p]
- by finding the substitution [r] from the definition of
- [ISA]. (Groundness of [t] is not essential as we can rename its
- variables to fresh constants.)
+ {3 "Unification Theory" for Hierarchical Terms}
+ We define {i well-formed substitutions} by extending into a
+ function over terms in the standard way a finite mapping from a
+ set of sharing variables to well-formed terms, requiring that
+ [X(s)] is mapped to [t] only when [t ISA s]. Additionally, all
+ appearances of a sharing variable in any term of the image of the
+ substitution have the same type. When applied to a well-formed
+ term, well-formed substitutions return a well-formed term.
+
+ We introduce an order on either well-formed or type-substitutions,
+ by saying that [S ISA R] when for all [t], [S(t) ISA R(t)].
+
+ We define {i isa-matching} a term [p] (called {i pattern}) against
+ a term [t] (where [p] and [t] are well-formed) as an algorithm to
+ decide [t ISA p] that returns a pair of substitutions: a type
+ subsitution [R] and a well-formed substitution where a sharing
+ variable in [p] is associated with a corresponding subterm in [t],
+ as required by [S(t) ISA R(p)] where [S] is a type-substitution
+ replacing each type-variable [?V] in [t] by a fresh constant [V( ;
+ )], and [R] is the smallest such substitution. The constants [V( ;
+ )] are only conceptual, the original variables [?V] appear if
+ needed in the result.
+
+ We define {i eq-matching} a pattern [p] against a term [t] as the
+ problem of finding a well-formed substitution [R_s] and a
+ type-substitution [R_t] such that [t = R_w(R_t(p))]. Note that if
+ eq-matching [p] against [t] exists, isa-matching also exists and
+ is the same pair of substitutions.
+
We define {i glb-unification} ({i Greatest Lower Bound
- Unification}) of two or more well-formed terms [t_1, ..., t_n] as:
- given that there exist a well-formed term [t] and a well-formed
- substitution [r], such that for all substitutions [s] such that
- [s(r(t_i))] are all ground, for all [i], [s(t) ISA s(r(t_i))].
+ Unification}) of two well-formed terms [t_1, t_2] as the greatest
+ term [t] such that [f(;t,t) ISA f(;t_1,t_2)] (where [f] is an
+ arbitrary symbol) and variables of [t] are included in variables
+ of [t1,t2], together with the smallest type-substitution [R] such
+ that [f(;t,t) ISA R(f(;t_1,t_2))] and the well-formed substitution
+ with sharing variables in [f(;...
[truncated message content] |
|
From: <luk...@us...> - 2012-07-10 22:44:55
|
Revision: 1744
http://toss.svn.sourceforge.net/toss/?rev=1744&view=rev
Author: lukaszkaiser
Date: 2012-07-10 22:44:46 +0000 (Tue, 10 Jul 2012)
Log Message:
-----------
Optimizing SO-finder and its web interface, larger tests.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/DiscreteRuleParser.mly
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/Drawing.mli
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/eval.html
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Makefile
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureParser.mly
trunk/Toss/menhir_conf
trunk/Toss/www/Publications/all.bib
trunk/Toss/www/create.xml
trunk/Toss/www/docs.xml
trunk/Toss/www/index.xml
trunk/Toss/www/play.xml
Added Paths:
-----------
trunk/Toss/www/pub/itrs_qmu.pdf
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Arena/Arena.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -255,28 +255,7 @@
List.map (fun (lab,_) -> lab.lb_rule) l.(player_no).moves in
List.concat (List.map rules_of_loc (Array.to_list game.graph))
-(* Add a defined relation to a structure. *)
-let add_def_rel_single struc (r_name, vars, def_phi) =
- let def_asg = Solver.M.evaluate struc def_phi in
- match def_asg with
- | AssignmentSet.Empty ->
- Structure.add_rel_name r_name (List.length vars) struc
- | _ ->
- let tuples = AssignmentSet.tuples (Structure.elems struc) vars def_asg in
- Structure.add_rels struc r_name tuples
-let add_def_rels struc rels = List.fold_left add_def_rel_single struc rels
-
-let add_def_fun_single struc (f, v, def_re) =
- LOG 1 "adding fun %s def %s" f (Formula.real_str def_re);
- let elems = Structure.elements struc in
- let asg e = AssignmentSet.FO (v, [(e, AssignmentSet.Any)]) in
- let fval e = Solver.M.get_real_val ~asg:(asg e) def_re struc in
- List.fold_left (fun s e-> Structure.change_fun_int s f e (fval e)) struc elems
-
-let add_def_funs struc funs = List.fold_left add_def_fun_single struc funs
-
-
(* The order of following entries matters: [DefPlayers] adds more
players, with consecutive numbers starting from first available;
later [StartStruc], [CurrentStruc], [StateTime] and [StateLoc] entries
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Arena/Arena.mli 2012-07-10 22:44:46 UTC (rev 1744)
@@ -67,13 +67,7 @@
(** 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
-val add_def_funs : Structure.structure ->
- (string * string * Formula.real_expr) list -> Structure.structure
-
-
(** Print a label as a string. *)
val label_str : label -> string
val move_str : (label * int) -> string
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-07-10 22:44:46 UTC (rev 1744)
@@ -38,26 +38,12 @@
"Syntax error in move definition."
}
-real_expr_err:
- | rexp = real_expr { rexp }
- | error
- { Lexer.report_parsing_error $startpos $endpos
- "Syntax error in real expression."
- }
-
-formula_expr_err:
- | phi = formula_expr { phi }
- | error
- { Lexer.report_parsing_error $startpos $endpos
- "Syntax error in formula expression."
- }
-
float_or_int:
| FLOAT { $1 }
| INT { float_of_int $1 }
player_loc_defs:
- | PAYOFF poff = real_expr_err { `Payoff poff }
+ | PAYOFF poff = real_expr { `Payoff poff }
| MOVES moves = separated_list (SEMICOLON, move) { `Moves moves }
| COND hs = separated_list (SEMICOLON, float_or_int) { `Heurs hs }
| error
@@ -90,14 +76,6 @@
"Syntax error in location definition."
}
-rel_def_simple:
- | rel = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
- EQ body = formula_expr_err { (rel, args, body) }
-
-fun_def_simple:
- | COLON f = ID OPEN v = ID CLOSE EQ body = real_expr
- { (f, v, body) }
-
game_move_timed:
| OPENSQ r = id_int t = FLOAT RARR l = INT EMB
emb = separated_list (COMMA, separated_pair (ID, COLON, id_int)) CLOSESQ
@@ -126,35 +104,21 @@
{ DefLoc l }
| PLAYERS_MOD pnames = separated_list (COMMA, id_int)
{ DefPlayers pnames }
- | SET_CMD r = real_expr_err
+ | SET_CMD r = real_expr
{ DefPattern r }
| REL_MOD rel = ID
arg = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
- body = delimited (OPENCUR, formula_expr_err, CLOSECUR)
+ body = delimited (OPENCUR, formula_expr, CLOSECUR)
{ DefRel (rel, arg, body) }
| REL_MOD rel = ID
arg = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
EQ
- body = formula_expr_err
+ body = formula_expr
{ DefRel (rel, arg, body) }
| START model = struct_expr
{ StartStruc model }
- | START model = struct_expr WITH
- defs = separated_list (SEMICOLON, rel_def_simple)
- { StartStruc (Arena.add_def_rels model defs) }
- | START model = struct_expr WITH
- defs = separated_list (SEMICOLON, rel_def_simple) WITH
- funs = separated_list (SEMICOLON, fun_def_simple)
- { StartStruc (Arena.add_def_funs (Arena.add_def_rels model defs) funs) }
| CURRENT model = struct_expr
{ CurrentStruc model }
- | CURRENT model = struct_expr WITH
- defs = separated_list (SEMICOLON, rel_def_simple)
- { CurrentStruc (Arena.add_def_rels model defs) }
- | CURRENT model = struct_expr WITH
- defs = separated_list (SEMICOLON, rel_def_simple) WITH
- funs = separated_list (SEMICOLON, fun_def_simple)
- { StartStruc (Arena.add_def_funs (Arena.add_def_rels model defs) funs) }
| MOVES moves = separated_list (SEMICOLON, game_move_timed)
{ History (moves) }
| TIME_MOD t = FLOAT
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -9,31 +9,7 @@
| Arena.StartStruc struc -> struc
| _ -> failwith "GameTreeTest:struc_of_str: not a structure"
-let rel_str rel struc_str =
- let s = struc_of_str struc_str in
- Structure.rel_str s rel (Structure.rel_graph rel s)
-
let tests = "Arena" >::: [
- "structure with rels parsing" >::
- (fun () ->
- let test p s res = assert_equal ~printer:(fun x -> x) res (rel_str p s) in
- test "P" "START [ 1 - 5 | | - ] with P(a) = :nbr(a)= 2" "P (e2)";
- test "P" "START [ 1 - 5 | | - ] with P(a) = :nbr(a)= 2 with :y(a) = 10*&a"
- "P (e2)";
- test "P" ("START [ 1 - 10 | | - ] with P(z) = &z > 1 and " ^
- "all x, y (&x * &y = &z -> (&x = 1 or &y = 1))")
- "P {e2; e3; e5; e7}";
- test "P" ("START [ 1 - 3 | | - ] with E(x, y) = &y = &x + 1; " ^
- "P(x, y) = &x != &y and tc x, y E(x, y)")
- "P {(e1, e2); (e1, e3); (e2, e3)}";
- test "S" ("START [ 1 - 10 | | - ] with P(z) = &z > 1 and " ^
- "all x, y (&x * &y = &z -> (&x = 1 or &y = 1));" ^
- "E(x, y) = P(x) and P(y) and &x < &y and " ^
- " all z (&x < &z and &z < &y -> not P(z));" ^
- "S(x, y) = x != y and tc x, y E(x, y)")
- "S {(e2, e3); (e2, e5); (e2, e7); (e3, e5); (e3, e7); (e5, e7)}";
- );
-
"simple parsing and printing" >::
(fun () ->
let s = "PLAYERS white, black
@@ -120,20 +96,3 @@
"[rule 0. -> 1 emb x: 1]"
);
]
-
-let bigtests = "ArenaBig" >::: [
- "structure with rels: 3 coloring" >::
- (fun () ->
- let test p s res = assert_equal ~printer:(fun x -> x) res (rel_str p s) in
- test "C" ("START [ 1 - 3 | | - ] with E(x, y) = x != y; " ^
- "C(z) = ex R, G, B all x, y ( (x in R or x in G or x in B)"^
- " and ( E(x,y) -> not ( (x in R and y in R) or (x in G and"^
- " y in G) or (x in B and y in B) ) ) )")
- "C {e1; e2; e3}";
- test "C" ("START [ 1 - 4 | | - ] with E(x, y) = x != y; " ^
- "C(z) = ex R, G, B all x, y ( (x in R or x in G or x in B)"^
- " and ( E(x,y) -> not ( (x in R and y in R) or (x in G and"^
- " y in G) or (x in B and y in B) ) ) )")
- "C:1 {}";
- );
-]
Modified: trunk/Toss/Arena/DiscreteRuleParser.mly
===================================================================
--- trunk/Toss/Arena/DiscreteRuleParser.mly 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Arena/DiscreteRuleParser.mly 2012-07-10 22:44:46 UTC (rev 1744)
@@ -67,9 +67,6 @@
DiscreteRule.compile_formula_rule signat defs phi del_part
add_part pre
}
- | MATCH error
- { Lexer.report_parsing_error $startpos $endpos
- "Syntax error after the discrete rewrite rule MATCH keyword" }
parse_discrete_rule:
discrete_rule_expr EOF { $1 };
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Client/Drawing.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -38,12 +38,15 @@
let defaultCFill = { red=255 ; green = 228 ; blue = 170 ; opacity = 0.5 }
let defaultCStroke = { red=38 ; green = 3 ; blue = 20 ; opacity = 0.5 }
-let defaultCRed = {red=242 ; green=92 ; blue=5 ; opacity = 1. }
+let defaultCRed = {red=232 ; green=42 ; blue=51 ; opacity = 1. }
let defaultCGreen = {red=62 ; green=89 ; blue=24 ; opacity = 1. }
-let defaultCBlue = {red=165 ; green=175 ; blue=170 ; opacity = 1. }
+let defaultCBlue = {red=0 ; green=54 ; blue=76 ; opacity = 1. }
let palette = Hashtbl.create 7
+(* Clear all previous color definitions. *)
+let reset_colors () = Hashtbl.clear palette
+
(* Set a color for a name. *)
let set_color name color =
Hashtbl.add palette name color
@@ -219,7 +222,7 @@
if arity = 1 then
let elems = Structure.Tuples.elements (Structure.rel_graph rel struc) in
let col = get_color rel in
- Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.}, col)]) elems
+ Aux.concat_map (fun a -> [Circle (pos a.(0), {x=5.; y=5.}, col)]) elems
else if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
let c = get_color ~stroke:true rel in
@@ -234,17 +237,19 @@
let fill = "ctx.fillStyle = \""^(color_to_str col)^"\"; ctx.fill();" in
if r.x = r.y then
let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r.x
- in "ctx.beginPath(); "^ s ^ fill ^ " ctx.stroke(); ctx.closePath(); "
+ in ["ctx.beginPath(); "; s; fill; " ctx.stroke(); ctx.closePath(); "]
else
let sc = Printf.sprintf "ctx.scale(%F, %F); " (r.x /.100.) (r.y /.100.) in
let tr = Printf.sprintf "ctx.translate(%F, %F); " p.x p.y in
- "ctx.save(); "^ tr ^sc ^"ctx.beginPath(); ctx.arc(0,0,100,0,2*Math.PI); "^
- fill ^ "ctx.stroke(); ctx.closePath(); ctx.restore(); "
+ ["ctx.save();"; tr;sc; "ctx.beginPath();";"ctx.arc(0,0,100,0,2*Math.PI);";
+ fill; "ctx.stroke(); ctx.closePath(); ctx.restore(); "]
| Line (f, t, col) ->
let fs = Printf.sprintf "ctx.moveTo(%F,%F); " f.x f.y in
let ts = Printf.sprintf "ctx.lineTo(%F,%F); " t.x t.y in
let stroke= "ctx.strokeStyle = \""^(color_to_str col)^"\"; ctx.stroke();" in
- "ctx.beginPath(); " ^ fs ^ ts ^ stroke ^ " ctx.closePath(); "
+ ["ctx.beginPath(); "; fs; ts; stroke; " ctx.closePath(); "]
-let shapes_to_canvas l =
- String.concat " " (List.rev (List.rev_map shape_to_canvas l))
+let shapes_to_canvas ?(attach=[]) l =
+ let shapes = List.fold_left (fun acc shape -> List.rev_append
+ (shape_to_canvas shape) acc) [] l in
+ Array.of_list (attach @ (List.rev shapes))
Modified: trunk/Toss/Client/Drawing.mli
===================================================================
--- trunk/Toss/Client/Drawing.mli 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Client/Drawing.mli 2012-07-10 22:44:46 UTC (rev 1744)
@@ -40,7 +40,10 @@
whether for stroke or fill, or a default red, if name starts with '|'. *)
val get_color : ?stroke : bool -> string -> color
+(** Clear all previous color definitions. *)
+val reset_colors : unit -> unit
+
(** Shapes. *)
type shape =
| Circle of point * point * color (** circle, given middle and radiuses *)
@@ -93,4 +96,4 @@
(** Compile the shapes to a JavaScript program drawing the shape on 'ctx'.
With [result] in JS do: var ctx = canvas.getContext("2d"); eval (result). *)
-val shapes_to_canvas : shape list -> string
+val shapes_to_canvas : ?attach: string list -> shape list -> string array
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Client/JsEval.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -27,46 +27,55 @@
(* --- Main part: communication with JS and evaluation --- *)
let cur_st = ref (Drawing.empty_struc_coords ())
+let cur_parsed_string = ref ""
(* Parse a formula. *)
let formula_of_string s = FormulaParser.parse_formula Lexer.lex
(Lexing.from_string (Aux.strip_spaces s))
(* Parse a structure. *)
-let structure_of_string s =
- let str = "START " ^ (Aux.strip_spaces s) in
- match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string str) with
- | Arena.StartStruc struc -> struc
- | _ -> failwith "not a structure"
+let structure_of_string s = StructureParser.parse_structure
+ Lexer.lex (Lexing.from_string (Aux.strip_spaces s))
-
(* Drawing the structure. *)
let draw_struc_js so_s struc_s =
let err msg =
let js_msg = Js.string ("put_msg('" ^ msg ^ "', 5000);") in
- Js.array [|js_msg; Js.string "Error"|] in
+ Js.array [|Js.string "Error"; js_msg|] in
let error_msg where = function
| Lexer.Parsing_error m when String.length m > 15 &&
String.sub m 0 15 = "File \"\", lines " ->
let ms = String.sub m 15 ((String.index m '\n') - 16) in
let l, c = String.sub ms 0 (String.index ms '-'), String.index ms ',' in
let chars = String.sub ms (c+1) ((String.length ms)-c-1) in
- let l = string_of_int ((int_of_string l) - 1) in
+ let l = if where = "Formula" then l else
+ string_of_int ((int_of_string l) - 1) in
err (where ^ " parsing error in line " ^ l ^ "," ^ chars)
| x -> err (where ^ " error:<br />" ^
(Aux.str_subst_all "\n" "<br/>" (Printexc.to_string x))) in
try
- let st = structure_of_string (Js.to_string struc_s) in
+ let in_string = Js.to_string struc_s in
+ let t = AuxIO.gettimeofday () in
+ let st = if !cur_parsed_string = in_string then !cur_st.Drawing.struc else
+ (let s = structure_of_string in_string in
+ LOG 0 "PUT#Structure constructed at %.3fs" (AuxIO.gettimeofday() -. t);
+ s) in
try
let so = Js.to_string so_s in
let st, so_res = if Aux.strip_spaces so = "" then (st, "No Formula") else
let so_phi = formula_of_string so in
- let st, res = Solver.find_so st so_phi in
+ let st, res = Solver.find_so ~logtime:t ~logprefix:"PUT#" st so_phi in
if res then st, "Formula Satisfied" else st,"Formula Unsatisfiable" in
- let st_c = Drawing.add_coords 1000. 1000. 50. 50. None None st in
+ let st_c = Drawing.add_coords 500. 500. 25. 25. None None st in
cur_st := st_c;
- let draw = Drawing.shapes_to_canvas (Drawing.draw_struc st_c) in
- Js.array [|Js.string ("clear_canvas (); " ^ draw) ; Js.string so_res |]
+ if so_res = "No Formula" then cur_parsed_string := in_string else
+ cur_parsed_string := "";
+ let shapes = Drawing.draw_struc st_c in
+ LOG 0 "PUT#Shapes constructed at %.3fs" (AuxIO.gettimeofday() -. t);
+ let draw = Drawing.shapes_to_canvas ~attach:[so_res; "clear_canvas();"]
+ shapes in
+ LOG 0 "PUT#Canvas commands issued at %.3fs" (AuxIO.gettimeofday() -. t);
+ Js.array (Array.map Js.string draw);
with x -> error_msg "Formula" x
with x -> error_msg "Structure" x
@@ -93,7 +102,7 @@
let mousemove_handle x y i =
match elem_moving i with
- | None -> Js.string ""
+ | None -> Js.array [|Js.string ""|]
| Some e ->
let (x,y), st = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
let p = Drawing.change_coords !cur_st.Drawing.coordC
@@ -101,8 +110,9 @@
let st = Structure.change_fun_int st "x" e p.Drawing.x in
let st = Structure.change_fun_int st "y" e (-1. *. p.Drawing.y) in
cur_st := {!cur_st with Drawing.struc = st };
- let s = Drawing.shapes_to_canvas (Drawing.draw_struc !cur_st) in
- Js.string ("clear_canvas(); " ^ s)
+ let s = Drawing.shapes_to_canvas ~attach:["clear_canvas(); "]
+ (Drawing.draw_struc !cur_st) in
+ Js.array (Array.map Js.string s)
let mouseup_handle x y i =
stop_moving i;
@@ -132,6 +142,7 @@
match Aux.split_charprop (fun c -> c = ':') d with
| [rel; c] -> set_color_def (Aux.strip_spaces rel) (Aux.strip_spaces c)
| _ -> "Incorrect color definition: " ^ (Aux.normalize_spaces d) in
+ Drawing.reset_colors ();
Js.string (String.concat " <br /> " (List.map parse_def defs))
let _ = set_handle "set_colors" set_colors
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Client/eval.html 2012-07-10 22:44:46 UTC (rev 1744)
@@ -13,16 +13,35 @@
var worker = new Worker ("JsEval.js");
var worker_handler = new Object ();
-worker.onmessage = function (m) {
+var killBT = '<button class="obt" style="position: ' +
+ 'absolute; right: 1em; font-weight: bold;" ' +
+ 'onclick="restart_worker()">Kill</button> ';
+
+function init_worker () {
+ worker.onmessage = function (m) {
if (typeof m.data == 'string') {
console.log("" + m.data);
+ if (m.data.substr (m.data.indexOf(']')+2, 4) === "PUT#") {
+ var cont = m.data.substring (m.data.indexOf(']')+6, m.data.length);
+ document.getElementById("working").innerHTML = cont + "... " + killBT;
+ }
} else {
//console.log ("[ASYNCH] back from " + m.data.fname);
var handler = worker_handler[m.data.fname];
handler (m.data.result);
}
+ }
+ select_colors (true);
}
+function restart_worker () {
+ worker.terminate ();
+ worker = new Worker ("JsEval.js");
+ worker_handler = new Object ();
+ init_worker ();
+ put_msg ("Killed", 2000);
+}
+
function ASYNCH (action_name, action_args, should_log, cont) {
worker_handler[action_name] = cont;
worker.postMessage ({fname: action_name, args: action_args});
@@ -38,7 +57,7 @@
ctx.clearRect(0, 0, canvas.width, canvas.height);
ctx.fillStyle = "#ffe4aa";
ctx.strokeStyle = "#260314";
- ctx.lineWidth = 5;
+ ctx.lineWidth = 2;
ctx.lineCap = "round";
ctx.lineJoin = "round";
}
@@ -49,7 +68,7 @@
ctx.clearRect(0, 0, canvas.width, canvas.height);
ctx.fillStyle = "#ffe4aa";
ctx.strokeStyle = "#260314";
- ctx.lineWidth = 5;
+ ctx.lineWidth = 2;
ctx.lineCap = "round";
ctx.lineJoin = "round";
}
@@ -57,7 +76,7 @@
function draw_it_msg (msg) {
if (msg) {
document.getElementById ("working").style.display = 'block';
- document.getElementById ("working").innerHTML = 'Working...';
+ document.getElementById ("working").innerHTML = 'Working... ' + killBT;
}
var rels = document.getElementById ("relations").value;
var pos = document.getElementById ("positions").value;
@@ -69,13 +88,13 @@
ASYNCH ("draw_struc", ["", struc], true, function (a) {
document.getElementById ("working").style.display = 'none';
var ctx = document.getElementById("canvas").getContext("2d");
- eval (a[0])
+ for (var i = 1; i < a.length; i++) { eval (a[i]); }
toggle_to_show ("view");
})
} else {
ASYNCH ("draw_struc", ["", struc], true, function (a) {
var ctx = document.getElementById("canvas").getContext("2d");
- eval (a[0])
+ for (var i = 1; i < a.length; i++) { eval (a[i]); }
})
}
}
@@ -86,7 +105,7 @@
function find_draw_it () {
document.getElementById ("working").style.display = 'block';
- document.getElementById ("working").innerHTML = 'Working...';
+ document.getElementById ("working").innerHTML = 'Working... ' + killBT;
var rels = document.getElementById ("relations").value;
var pos = document.getElementById ("positions").value;
var elemsF = document.getElementById ("no-elems-start").value;
@@ -97,9 +116,9 @@
ASYNCH ("draw_struc", [so, struc], true, function (a) {
document.getElementById ("working").style.display = 'none';
var ctx = document.getElementById("canvas").getContext("2d");
- eval (a[0]);
+ for (var i = 1; i < a.length; i++) { eval (a[i]); }
toggle_to_show ("view");
- if (a[1] !== "Error") { put_msg (a[1], 2000) }
+ if (a[0] !== "Error") { put_msg (a[0], 2000) }
})
}
@@ -170,9 +189,9 @@
ALLOW_MOUSE_MOVE = false;
setTimeout (function () { ALLOW_MOUSE_MOVE = true; }, 100);
var pos = canvasCoords (e.pageX, e.pageY);
- ASYNCH ("mousemove_handle", [pos.x, pos.y, 0], false, function (s) {
+ ASYNCH ("mousemove_handle", [pos.x, pos.y, 0], false, function (a) {
var ctx = document.getElementById("canvas").getContext("2d");
- eval (s);
+ for (var i = 0; i < a.length; i++) { eval (a[i]); }
})
}
}
@@ -184,9 +203,9 @@
setTimeout (function () { ALLOW_MOUSE_MOVE = true; }, 100);
for (var i = 0; i < e.targetTouches.length; i++) {
var p = canvasCoords (e.targetTouches[i].pageX, e.targetTouches[i].pageY);
- ASYNCH ("mousemove_handle", [p.x, p.y, i], false, function (s) {
+ ASYNCH ("mousemove_handle", [p.x, p.y, i], false, function (a) {
var ctx = document.getElementById("canvas").getContext("2d");
- eval (s);
+ for (var i = 0; i < a.length; i++) { eval (a[i]); }
})
}
}
@@ -195,16 +214,30 @@
function handle_elem_click (eid) { console.log (eid); }
function example_basic () {
- document.getElementById ("struc-name").value = "Basic";
+ document.getElementById ("struc-name").value = "Cycle";
document.getElementById ("relations").value =
- "E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)";
+ "E(x, y) = (&y = &x + 1) ∨ (&x=10 ∧ &y=0)";
document.getElementById ("positions").value = ":x(a) = &a;\n" +
":y(a) = &a · (10 - &a) / 10";
- document.getElementById ("no-elems-start").value = "1";
- document.getElementById ("no-elems-end").value = "15";
+ document.getElementById ("no-elems-start").value = "0";
+ document.getElementById ("no-elems-end").value = "10";
draw_it_msg (false);
}
+function example_3x3 () {
+ document.getElementById ("struc-name").value = "3x3 grid";
+ document.getElementById ("relations").value =
+ "C(x, y) = (&y = &x+1) ∧ ¬∃z &x=3*&z + 2;\n" +
+ "R(x, y) = &y = &x+3";
+ document.getElementById ("positions").value =
+ ":x(a) = (&a - :(∃z &a=3*&z + 1) - :(∃z &a=3*&z + 2)*2)*2;\n" +
+ ":y(a) = (:(∃z &a=3*&z + 2)*3 - :(∃z &a=3*&z)*3)*2";
+ document.getElementById ("no-elems-start").value = "0";
+ document.getElementById ("no-elems-end").value = "8";
+ draw_it_msg (false);
+}
+
+
function example_primes () {
document.getElementById ("struc-name").value = "Primes";
document.getElementById ("relations").value =
@@ -215,6 +248,28 @@
draw_it_msg (false);
}
+function example_3dnp_struc () {
+ document.getElementById ("struc-name").value = "Triangles";
+ document.getElementById ("relations").value =
+ "E(x, y) = &y=&x+1 ∨ &y=&x+2 ∨ &x=&y+1 ∨ &x=&y+2";
+ document.getElementById ("positions").value = ":x(a) = &a*2;\n" +
+ ":y(a) = :(∃z &a=3*&z + 2)*9";
+ document.getElementById ("no-elems-start").value = "0";
+ document.getElementById ("no-elems-end").value = "9";
+ draw_it_msg (false);
+}
+
+function example_3col_struc () {
+ document.getElementById ("struc-name").value = "Full 3-partite graph";
+ document.getElementById ("relations").value =
+ "E(x, y) = ¬∃ z (&x=&y+3*&z ∨ &y=&x+3*&z)";
+ document.getElementById ("positions").value = ":x(a) = &a;\n" +
+ ":y(a) = :(∃z &a=3*&z + 1)*5 - :(∃z &a=3*&z + 2)*5";
+ document.getElementById ("no-elems-start").value = "0";
+ document.getElementById ("no-elems-end").value = "18";
+ draw_it_msg (false);
+}
+
function example_tc () {
document.getElementById ("struc-name").value = "Simple TC";
document.getElementById ("relations").value =
@@ -227,7 +282,7 @@
}
function example_heart () {
- document.getElementById ("struc-name").value = "Heart";
+ document.getElementById ("struc-name").value = "Heart drawing";
document.getElementById ("relations").value =
"E(x, y) = (&y = &x + 1 ∧ &x ≠ 18) ∨ (&x=37 ∧ &y=18)";
document.getElementById ("positions").rows = 7;
@@ -243,11 +298,26 @@
draw_it_msg (false);
}
+
+function example_diag () {
+ document.getElementById ("so-name").value = "Diagonal";
+ document.getElementById ("second-order").value =
+ "∀ x,y ( |Diag(x,y) <-> ∃ u (R(x,u) ∧ C(u, y)) )"
+ find_draw_it ();
+}
+
+function example_last_row () {
+ document.getElementById ("so-name").value = "Last row";
+ document.getElementById ("second-order").value =
+ "∀ x (|LastRow(x) <-> ∀ y ¬ C(x, y))";
+ find_draw_it ();
+}
+
function example_matching () {
document.getElementById ("so-name").value = "Matching";
document.getElementById ("second-order").value =
"∀ x,y ( |M(x, y) -> (\n" +
- " ( E(x, y) ∨ E(y, x) ) ∧ ¬∃ z (z≠y ∧ |M(x, z) )\n" +
+ " ( E(x, y) ∨ E(y, x) ) ∧ ¬∃ z (z≠y ∧ (|M(x, z) ∨ |M(z, x)))\n" +
") ) ∧ ∀ x ∃ y |M(x, y)";
find_draw_it ();
}
@@ -268,11 +338,16 @@
find_draw_it ();
}
-function example_tc_so () {
- document.getElementById ("so-name").value = "TC";
+function example_3dnp () {
+ document.getElementById ("so-name").value = "3-DNP";
+ document.getElementById ("second-order").rows = 6;
document.getElementById ("second-order").value =
- "∀ x,y,z ( ( E(x, y) → |Tc(x, y) ) ∧\n" +
- " ( (|Tc(x, y) ∧ |Tc(y, z)) -> |Tc(x, z) ) )";
+ "∀ x ∃ y,u,v (((|R(x) → ¬(|G(x) ∨ |B(x))) ∧\n" +
+ " (|G(x) → ¬(|R(x) ∨ |B(x))) ∧\n" +
+ " (|B(x) → ¬(|R(x) ∨ |G(x)))) ∧\n" +
+ " (|R(x) ∨ (|R(y) ∧ E(x,y))) ∧\n" +
+ " (|G(x) ∨ (|G(u) ∧ E(x,u))) ∧\n" +
+ " (|B(x) ∨ (|B(v) ∧ E(x,v))))";
find_draw_it ();
}
@@ -311,6 +386,7 @@
localStorage["TRelStrucExplRel"+name] = rels;
localStorage["TRelStrucExplPos"+name] = pos;
list_stored_struc ();
+ put_msg ("Structure Saved", 1000);
}
function save_so () {
@@ -318,6 +394,7 @@
var phi = document.getElementById ("second-order").value;
localStorage["TRelStrucExplSOF"+name] = phi;
list_stored_so ();
+ put_msg ("Formula Saved", 1000);
}
function load_struc (name) {
@@ -350,7 +427,7 @@
var li = document.createElement('li');
li.innerHTML ='<button class="obt" onclick="load_struc('+"'"+ n +"'"+')">'
+ n +'</button> <button class="ebtr" onclick="del_struc('+ "'"+ n +"'"+
- ')" style="width: 4em;" title="Delete this structure.">Del</button>';
+ ')" style="width: 2em;" title="Delete this structure.">×</button>';
saved.appendChild (li);
}
}
@@ -365,8 +442,8 @@
var n = k.substring (16, k.length);
var li = document.createElement('li');
li.innerHTML ='<button class="obt" onclick="load_so('+"'"+ n +"'"+')">'
- + n +'</button> <button class="ebtr" onclick="del_so('+ "'"+ n +
- "'" +')" style="width: 4em;" title="Delete this formula.">Del</button>';
+ + n +'</button> <button class="ebtr" onclick="del_so('+ "'"+ n +"'" +
+ ')" style="width: 2em;" title="Delete this formula.">×</button>';
saved.appendChild (li);
}
}
@@ -424,18 +501,18 @@
function toggle (name) {
var bt = document.getElementById ("hide_" + name + "_bt");
- if (bt.innerHTML == "Hide") {
- bt.innerHTML = "Show";
+ if (bt.innerHTML == "«") {
+ bt.innerHTML = "»";
document.getElementById ("div_" + name + "_full").style.display = 'none';
} else {
- bt.innerHTML = "Hide";
+ bt.innerHTML = "«";
document.getElementById ("div_" + name + "_full").style.display = 'block';
}
}
function toggle_to_show (name) {
var bt = document.getElementById ("hide_" + name + "_bt");
- if (bt.innerHTML !== "Hide") { toggle (name); }
+ if (bt.innerHTML !== "«") { toggle (name); }
}
function show_help (content) {
@@ -443,7 +520,8 @@
document.getElementById ("working").style.fontWeight = "normal";
document.getElementById("working").innerHTML = '\
<b>Relational Structures Explorer Help</b> \
-<button class="obt" style="position: absolute; right: 1em;" onclick="hide_working()">Hide</button> ' + content;
+<button class="obt" style="position: absolute; right: 1em; font-weight: bold;"\
+ onclick="hide_working()">×</button> ' + content;
document.getElementById ("working").style.display = "block";
}
@@ -458,8 +536,9 @@
function show_help_saved () {
show_help('\
<p><b>Saved structures and formulas</b> are stored in the browser local \
- storage. Press the <b>Save</b> button in the respective edit field to save \
- a structure or a formula, and later the <b>Del</b> button to delete it.</p>\
+ storage. Press the <b>⇩</b> button in the respective section to \
+ save a structure or a formula, and later the <b>×</b> button to \
+ delete it.</p>\
');
}
@@ -505,12 +584,12 @@
</script>
</head>
-<body onload="init_canvas (); select_colors (true) ; list_stored (); draw_it_msg (false); adjust_to_width()">
+<body onload="init_worker (); init_canvas (); list_stored (); draw_it_msg (false); adjust_to_width()">
<div id="main">
<div id="top">
<div id="logo">
- <a id="leftupperlogo-link" href="eval.html">
+ <a id="leftupperlogo-link" href="index.html">
<img id="leftupperlogo-img" src="img/logo.png" alt="back" />
</a>
</div>
@@ -529,15 +608,15 @@
<div id="div_right_col_full" style="width: 30em;">
<p class="headerp">
- <button class="ebtl" style="width: 4em;" title="Show/Hide structure view."
- id="hide_view_bt" onclick="toggle('view')">Hide</button>
+ <button class="ebtl" style="width: 2em;" title="Show/Hide structure view."
+ id="hide_view_bt" onclick="toggle('view')">«</button>
View Structure
- <button class="ebtr" style="width: 4em;" title="Structure viewing help."
- onclick="show_help_view()">Help</button>
+ <button class="ebtr" style="width: 2em;" title="Structure viewing help."
+ onclick="show_help_view()">?</button>
</p>
<div id="div_view_full" style="width: 30em;">
-<canvas id="canvas" height="1100" width="1100"
+<canvas id="canvas" height="550" width="550"
onmouseup="mouseup_handle(event)"
onmousedown="mousedown_handle(event)"
onmousemove="mousemove_handle(event)"
@@ -549,62 +628,110 @@
</div>
<p class="headerp">
- <button class="ebtl" style="width: 4em;" title="Show/Hide color selector."
- id="hide_colors_bt" onclick="toggle ('colors')">Hide</button>
+ <button class="ebtl" style="width: 2em;" title="Show/Hide color selector."
+ id="hide_colors_bt" onclick="toggle ('colors')">«</button>
Select Colors
- <button class="ebtr" style="width: 4em;" title="Color selector help."
- onclick="show_help_colors()">Help</button>
+ <span style="position: absolute; right: 1px;">
+ <button class="ebt" onclick="select_colors(false)" style="width: 4em;"
+ title="Select these colors.">Select</button><button
+ class="ebt" style="width: 2em;" title="Color selector help."
+ onclick="show_help_colors()">?</button>
+ </span>
</p>
<div id="div_colors_full">
<p>Colors
- <span style="position: absolute; right: 2px;">
- <button class="ebts" style="background-color: #e5effa;";
- onclick="add_field('colors', '#e5effa')"> </button><button
- class="ebts" style="background-color: #a5afaa;";
- onclick="add_field('colors', '#a5afaa')"> </button><button
+ <span style="position: absolute; right: 1px;">
+ <button class="ebts" style="background-color: #a5afaa;";
+ onclick="add_field('colors', '#a5afaa')"> </button><button
+ class="ebts" style="background-color: #00364c;";
+ onclick="add_field('colors', '#00364c')"> </button><button
class="ebts" style="background-color: #93a605;";
onclick="add_field('colors', '#93a605')"> </button><button
class="ebts" style="background-color: #3e5916;";
onclick="add_field('colors', '#3e5916')"> </button><button
- class="ebts" style="background-color: #f28705;";
- onclick="add_field('colors', '#f28705')"> </button><button
- style="background-color: #f25c05;"; class="ebts"
- onclick="add_field('colors', '#f25c05')"> </button><button
+ class="ebts" style="background-color: #f25c05;";
+ onclick="add_field('colors', '#f25c05')"> </button><button
+ style="background-color: #e82a33;"; class="ebts"
+ onclick="add_field('colors', '#e82a33')"> </button><button
style="background-color: #260314;"; class="ebts"
onclick="add_field('colors', '#260314')"> </button>
- <button class="ebt" onclick="select_colors(false)" style="width: 4em;"
- title="Select these colors.">Select</button>
</span>
</p>
<textarea id="colors" rows="1" cols="60" class="textar">
-|R : #f25c05 ; |G : #3e5916 ; |B : #a5afaa</textarea>
+R : #f25c05 ; |R : #e82a33 ; |G : #3e5916 ; |B : #00364c</textarea>
</div>
</div> <!-- end right column -->
<p class="headerp">
- <button class="ebtl" style="width: 4em;" title="Show/Hide structure editing."
- id="hide_struc_bt" onclick="toggle('struc')">Hide</button>
+ <button class="ebtl" style="width: 2em;" title="Show/Hide formula evaluator."
+ id="hide_formula_bt" onclick="toggle ('formula')">«</button>
+ Evaluate Formulas
+ <span style="position: absolute; right: 1px;">
+ <button class="ebt" onclick="save_so()" title="Save current formula."
+ style="width: 2em;">⇩</button><button
+ class="ebt" style="width: 2em;" title="Formula evaluator help."
+ onclick="show_help_formula()">?</button>
+ </span>
+</p>
+
+<div id="div_formula_full">
+<p>
+ Formula Name
+ <input id="so-name" type="text" size="20" value="My Formula 1"
+ style="width: 12em"></input>
+ <button class="ebtr" onclick="find_draw_it()" style="width: 4em;"
+ title="Evaluate the formula.">Eval</button>
+</p>
+
+<p>Formula
+ <span style="position: absolute; right: 2px;">
+ <button class="ebts" title="Not equal. You can also write '<>' or '!='."
+ onclick="add_field('second-order', '≠')">≠</button><button
+ class="ebts" title="Conjunction. You can also write 'and' or '&'."
+ onclick="add_field('second-order', '∧')">∧</button><button
+ class="ebts" title="Disjunction. You can also write 'or' or '|'."
+ onclick="add_field('second-order', '∨')">∨</button><button
+ class="ebts" title="Negation. You can also write 'not' or '~' or '!'."
+ onclick="add_field('second-order', '¬')">¬</button><button
+ class="ebts" title="Implication. You can also write '->'."
+ onclick="add_field('second-order', '→')">→</button><button
+ title="Existential Quantifier. You can also write 'ex' or '\E'."
+ class="ebts" onclick="add_field('second-order', '∃')">∃</button><button
+ title="Universal Quantifier. You can also write 'all' or '\A'."
+ class="ebts" onclick="add_field('second-order', '∀')">∀</button>
+ </span>
+</p>
+<textarea id="second-order" rows="3" cols="60" class="textar">
+</textarea>
+
+</div>
+
+<p class="headerp">
+ <button class="ebtl" style="width: 2em;" title="Show/Hide structure editing."
+ id="hide_struc_bt" onclick="toggle('struc')">«</button>
Edit Structure
- <button class="ebtr" style="width: 4em;" title="Structure editing help."
- onclick="show_help_struc()">Help</button>
+ <span style="position: absolute; right: 1px;">
+ <button class="ebt" style="width: 2em;" title="Save current structure."
+ onclick="save_struc()">⇩</button><button
+ class="ebt" style="width: 2em;" title="Structure editing help."
+ onclick="show_help_struc()">?</button>
+ </span>
</p>
<div id="div_struc_full">
<p>Name
<input id="struc-name" type="text" size="20" value="My Structure 1"
style="width: 12em"></input>
- <span style="position: absolute; right: 2px;">
- <button class="ebt" style="width: 4em;" title="Save current structure."
- onclick="save_struc()">Save</button>
- </span>
+ <button class="ebtr" onclick="draw_it()" style="width: 4em;"
+ title="Draw current structure.">Draw</button>
</p>
<p>Elements
- <input id="no-elems-start" type="text" size="2" value="1"
+ <input id="no-elems-start" type="text" size="2" value="0"
style="width: 4em"></input> —
- <input id="no-elems-end" type="text" size="4" value="15"
+ <input id="no-elems-end" type="text" size="4" value="10"
style="width: 4em"></input>
<span style="position: absolute; right: 2px;">
<button class="ebt" style="width: 2em;" title="Remove last element."
@@ -621,7 +748,7 @@
onclick="add_field('relations', '∧')">∧</button><button
class="ebts" title="Disjunction. You can also write 'or' or '|'."
onclick="add_field('relations', '∨')">∨</button><button
- class="ebts" title="Negation. You can also write 'not'."
+ class="ebts" title="Negation. You can also write 'not' or '~' or '!'.""
onclick="add_field('relations', '¬')">¬</button><button
class="ebts" title="Implication. You can also write '->'."
onclick="add_field('relations', '→')">→</button><button
@@ -629,12 +756,10 @@
class="ebts" onclick="add_field('relations', '∃')">∃</button><button
title="Universal Quantifier. You can also write 'all' or '\A'."
class="ebts" onclick="add_field('relations', '∀')">∀</button>
- <button class="ebt" onclick="draw_it()" style="width: 4em;"
- title="Redraw current structure.">Draw</button>
</span>
</p>
<textarea id="relations" rows="3" cols="60" class="textar">
-E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)
+E(x, y) = (&y = &x + 1) ∨ (&x=10 ∧ &y=0)
</textarea>
<p>Positions
@@ -653,8 +778,6 @@
class="ebts" onclick="add_field('positions', '∃')">∃</button><button
title="Universal Quantifier. You can also write 'all' or '\A'."
class="ebts" onclick="add_field('positions', '∀')">∀</button>
- <button class="ebt" onclick="draw_it()" style="width: 4em;"
- title="Redraw current structure.">Draw</button>
</span>
</p>
<textarea id="positions" rows="3" cols="60" class="textar">
@@ -664,86 +787,68 @@
</div>
<p class="headerp">
- <button class="ebtl" style="width: 4em;" title="Show/Hide formula evaluator."
- id="hide_formula_bt" onclick="toggle ('formula')">Hide</button>
- Evaluate Formulas
- <button class="ebtr" style="width: 4em;" title="Formula evaluator help."
- onclick="show_help_formula()">Help</button>
-</p>
-
-<div id="div_formula_full">
-<p>
- Formula Name
- <input id="so-name" type="text" size="20" value="My Formula 1"
- style="width: 12em"></input>
- <span style="position: absolute; right: 2px;">
- <button class="ebt" onclick="save_so()" title="Save current formula."
- style="width: 4em;">Save</button>
- </span>
-</p>
-
-<p>Formula
- <span style="position: absolute; right: 2px;">
- <button class="ebts" title="Not equal. You can also write '<>' or '!='."
- onclick="add_field('second-order', '≠')">≠</button><button
- class="ebts" title="Conjunction. You can also write 'and' or '&'."
- onclick="add_field('second-order', '∧')">∧</button><button
- class="ebts" title="Disjunction. You can also write 'or' or '|'."
- onclick="add_field('second-order', '∨')">∨</button><button
- class="ebts" title="Negation. You can also write 'not'."
- onclick="add_field('second-order', '¬')">¬</button><button
- class="ebts" title="Implication. You can also write '->'."
- onclick="add_field('second-order', '→')">→</button><button
- title="Existential Quantifier. You can also write 'ex' or '\E'."
- class="ebts" onclick="add_field('second-order', '∃')">∃</button><button
- title="Universal Quantifier. You can also write 'all' or '\A'."
- class="ebts" onclick="add_field('second-order', '∀')">∀</button>
- <button class="ebt" onclick="find_draw_it()" style="width: 4em;"
- title="Evaluate the formula.">Eval</button>
- </span>
-</p>
-<textarea id="second-order" rows="3" cols="60" class="textar">
-</textarea>
-
-</div>
-
-<p class="headerp">
- <button class="ebtl" style="width: 4em;" title="Show/Hide examples & saved."
- id="hide_saved_bt" onclick="toggle('saved')">Hide</button>
+ <button class="ebtl" style="width: 2em;" title="Show/Hide examples & saved."
+ id="hide_saved_bt" onclick="toggle('saved')">«</button>
Examples & Saved
<button class="ebtr" title="Saved structures and formulas help."
- style="width: 4em;" onclick="show_help_saved()">Help</button>
+ style="width: 2em;" onclick="show_help_saved()">?</button>
</p>
<div id="div_saved_full">
-<p>Saved Structures</p>
-<ul id="saved-strucs" style="list-style: square; margin-left: -1.5em">
+<p style="padding-right: 1.5em; text-align: left">Saved Formulas</p>
+<ul id="saved-so" style="list-style: square; margin-left: -1.5em">
<li>Nothing here yet</li>
</ul>
<p>Examples
<span style="position: absolute; right: 1px;">
-<button class="ebt" onclick="example_basic()">Basic</button>
-<button class="ebt" onclick="example_primes()">Primes</button>
-<button class="ebt" onclick="example_tc()">Simple TC</button>
-<button class="ebt" onclick="example_heart()">Heart</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_diag()">Diagonal</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_last_row()">Last row</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_2col()">2-coloring</button>
</span>
</p>
-<p style="padding-right: 1.5em; text-align: left">Saved Formulas</p>
-<ul id="saved-so" style="list-style: square; margin-left: -1.5em">
+<p>
+<span style="position: absolute; right: 1px;">
+<button class="ebt" style="width: 7em;"
+ onclick="example_3col()">3-coloring</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_3dnp()">3-DNP</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_matching()">Matching</button>
+</span>
+</p>
+
+<p>Saved Structures</p>
+<ul id="saved-strucs" style="list-style: square; margin-left: -1.5em">
<li>Nothing here yet</li>
</ul>
<p>Examples
<span style="position: absolute; right: 1px;">
-<button class="ebt" onclick="example_tc_so()">TC</button>
-<button class="ebt" onclick="example_2col()">2-coloring</button>
-<button class="ebt" onclick="example_3col()">3-coloring</button>
-<button class="ebt" onclick="example_matching()">Matching</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_basic()">Cycle</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_3col_struc()">3-partite</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_3x3()">3x3 grid</button>
</span>
</p>
+<p>
+<span style="position: absolute; right: 1px;">
+<button class="ebt" style="width: 7em;"
+ onclick="example_primes()">Primes</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_3dnp_struc()">Triangles</button>
+<button class="ebt" style="width: 7em;"
+ onclick="example_heart()">Heart</button>
+</span>
+</p>
+
</div>
</div>
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -1,7 +1,7 @@
(* Represent Boolean combinations of integer literals. *)
(* 0 : no generation is performed and to_cnf transforms a DNF
- 1 : use Tseitin to construct a CNF with auxiliary variables
+ 1 : use Tseitin to construct a NF with auxiliary variables
2 : use Plaisted-Greenbaum to construct a CNF with auxiliary variables *)
let auxcnf_generation = ref 2
let set_auxcnf i = (auxcnf_generation := i)
@@ -594,6 +594,8 @@
let rec index_formula ?(neg=false) = function
| BVar v -> v
| BNot phi -> - index_formula ~neg:(not neg) phi
+ | BOr [phi] -> index_formula ~neg phi
+ | BAnd [phi] -> index_formula ~neg phi
| BOr bflist ->
let indlist = List.rev_map (index_formula ~neg:neg) bflist in
free_idx := !free_idx + 1;
@@ -641,13 +643,57 @@
List.for_all (fun x -> List.exists (fun y -> y=x) b) a in
List.filter (fun x -> List.for_all (fun y -> x=y || not(subset y x)) cnf) cnf
-let find_model phi =
- let phi1 = to_nnf ~neg:true phi in
- let arg = flatten phi1 in
+(* Check if a CNF formula is satisfiable and find a model.
+ Faster than Sat.sat due to lack of formula registration *)
+let find_sat cnf =
+ MiniSAT.reset ();
+ let vars = Hashtbl.create 15 in
+ let var v = try Hashtbl.find vars v with Not_found ->
+ (let w = MiniSAT.new_var () in Hashtbl.add vars v w; w) in
+ let lit v = let w = var (abs v) in
+ if v > 0 then MiniSAT.pos_lit w else MiniSAT.neg_lit w in
+ let add_clause cl = MiniSAT.add_clause (List.rev_map lit cl) in
+ List.iter add_clause cnf;
+ match MiniSAT.solve () with
+ | MiniSAT.UNSAT -> MiniSAT.reset (); None
+ | MiniSAT.TIMEOUT -> MiniSAT.reset (); failwith "do_sat: timeout"
+ | MiniSAT.SAT ->
+ let res = ref [] in
+ let update v mv =
+ if MiniSAT.value_of mv = 0 then res := (-v) :: !res
+ else if MiniSAT.value_of mv = 1 then res := v :: !res in
+ Hashtbl.iter update vars;
+ MiniSAT.reset ();
+ Some (!res)
+
+(* Print the CNF formula in dimacs format. *)
+let print_dimacs cnf =
+ let maxvar cl = List.fold_left (fun acc b -> max acc (abs b)) 0 cl in
+ let mvar = List.fold_left (fun acc cl -> max acc (maxvar cl)) 0 cnf in
+ let cl_str cl = (String.concat " " (List.map string_of_int cl)) ^ " 0\n" in
+ AuxIO.print ("p cnf " ^ (string_of_int mvar) ^ " " ^
+ (string_of_int (List.length cnf)) ^ "\n");
+ List.iter (fun cl -> AuxIO.print (cl_str cl)) cnf
+
+
+(* Find a model of a Boolean formula. Uses P.-G. conversion. *)
+let find_model ?logtime ?(logprefix="") phi =
+ let arg = flatten (to_nnf ~neg:true phi) in
let (sep, aux_phi) = pg_auxcnf_of_bool_formula arg in
- match Sat.sat (listcnf_of_boolcnf aux_phi) with
- | None -> None
+ (match logtime with None -> () | Some t ->
+ LOG 0 "%sCNF constructed at %.3fs" logprefix (AuxIO.gettimeofday () -. t));
+ let cnf = listcnf_of_boolcnf aux_phi in
+ (* print_dimacs cnf; *)
+ let reg_t = AuxIO.gettimeofday () in
+ let log_finish () =
+ match logtime with None -> () | Some t ->
+ let cur_t = AuxIO.gettimeofday () in
+ LOG 0 "%sSolver finished at %.3fs (ran %.3fs)" logprefix
+ (cur_t-.t) (cur_t-.reg_t) in
+ match find_sat cnf with
+ | None -> log_finish (); None
| Some l ->
+ log_finish ();
let valid = List.filter (fun v -> v < sep && v > -sep) l in
Some (Aux.unique_sorted valid)
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-07-10 22:44:46 UTC (rev 1744)
@@ -54,7 +54,8 @@
val to_nnf : ?neg : bool -> bool_formula -> bool_formula
(** Find a model for a Boolean formula. *)
-val find_model : bool_formula -> int list option
+val find_model : ?logtime : float -> ?logprefix : string ->
+ bool_formula -> int list option
(** Convert a Boolean formula to CNF. If you only want SAT, use find_model. *)
val convert : ?disc_vars: int list -> bool_formula -> int list list
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-07-10 22:44:46 UTC (rev 1744)
@@ -64,6 +64,10 @@
| OPEN real_expr CLOSE { $2 }
| LET_CMD COLON v = ID EQ def = real_expr IN_MOD re = real_expr
{ RLet (":" ^ v, def, re) }
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in real expression."
+ }
real_ineq:
| real_expr GR real_expr
@@ -134,8 +138,11 @@
| LET_CMD rel = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
EQ body = formula_expr IN_MOD phi = formula_expr
{ Let (rel, args, body, phi) } %prec LET_CMD
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in formula expression."
+ }
-
expr_eq_expr: /* only standard equations here for now (no differentials) */
| COLON ID OPEN ID CLOSE EQ real_expr { (($2, $4), $7) }
| COLON ID OPEN INT CLOSE EQ real_expr { (($2, string_of_int $4), $7) }
@@ -146,6 +153,10 @@
%public expr_eq_sys:
| expr_eq_expr { [$1] }
| expr_eq_expr SEMICOLON expr_eq_sys { $1 :: $3 }
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in equation system."
+ }
parse_expr_eqs:
expr_eq_sys EOF { $1 };
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Formula/Lexer.mll 2012-07-10 22:44:46 UTC (rev 1744)
@@ -197,6 +197,7 @@
| "⊕" { XOR }
| "not" { NOT }
| "¬" { NOT }
+ | "~" { NOT }
| "ex" { EX }
| "\\E" { EX }
| "exists" { EX }
Modified: trunk/Toss/Formula/Sat/Sat.ml
===================================================================
--- trunk/Toss/Formula/Sat/Sat.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Formula/Sat/Sat.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -186,7 +186,7 @@
let sat cnf =
register_new_formula (simplify [] cnf);
match solve () with
- None -> None
+ | None -> None
| Some m -> Some m
let is_sat cnf = match sat cnf with Some _ -> true | None -> false
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Makefile 2012-07-10 22:44:46 UTC (rev 1744)
@@ -199,6 +199,9 @@
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Solver -v
+SolverTestsExtra: Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest Solver
+
# Term tests
TermTests: Server/Server.native
cp _build/Server/Server.native TossServer
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Server/Server.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -413,7 +413,7 @@
("-fulltest", Arg.String (fun s -> test_s := s; test_full := true),
"full unit tests for given path, might take longer");
("-extratest", Arg.String (fun s -> test_s := "#EXTRA$" ^ s),
- "extra unit tests, take very long; use 'GGP' or 'Learn' as argument");
+ "extra unit tests, take very long; write 'GGP' or 'Learn' or 'Solver'");
("-noprecache", Arg.Unit (fun ()-> precache := false), "do no pre-caching");
("-nohttpcache", Arg.Unit (fun ()-> cache_html := false),
"re-read files from disk on each HTTP GET request");
@@ -431,6 +431,9 @@
else if !test_s = "#EXTRA$Learn" then
let etst = LearnGameTest.extratests in
ignore (OUnit.run_test_tt ~verbose:true etst)
+ else if !test_s = "#EXTRA$Solver" then
+ let etst = SolverTest.extratests in
+ ignore (OUnit.run_test_tt ~verbose:true etst)
else (
let (name, full) = (!test_s, !test_full) in
let len = String.length name in
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Server/Tests.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -43,7 +43,7 @@
let arena_tests = "Arena", [
"DiscreteRuleTest", [DiscreteRuleTest.tests];
"ContinuousRuleTest", [ContinuousRuleTest.tests];
- "ArenaTest", [ArenaTest.tests; ArenaTest.bigtests];
+ "ArenaTest", [ArenaTest.tests];
]
let play_tests = "Play", [
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-07-06 01:06:25 UTC (rev 1743)
+++ trunk/Toss/Solver/Solver.ml 2012-07-10 22:44:46 UTC (rev 1744)
@@ -299,7 +299,7 @@
| Fun (s, v) ->
(try
let e = List.assoc v assgn in
- Poly.Const (Structure.fun_val model s e)
+ Poly.Const (Structure.fun_val model s e)
with Not_found ->
(*failwith (
"Solver.assignment_of_real_expr: partial function " ^
@@ -322,22 +322,70 @@
let asg = join (eval fp model elems fo_aset guard) r_a in
sum_polys asg (* Note: above "sgn" is irrelevant! *)
| RLet _ as re -> poly_of assgn (FormulaSubst.expand_real_expr re) in
+ let rec crude_val asg = function
+ | Const v -> v
+ | Plus (e1, e2) -> (crude_val asg e1) +. (crude_val asg e2)
+ | Times (e1, e2) -> (crude_val asg e1) *. (crude_val asg e2)
+ | Pow (e1, e2) -> (crude_val asg e1) ** (crude_val asg e2)
+ | Fun (fname, var) ->
+ let e = List.assoc var asg in
+ Structure.fun_val model fname e
+ | RLet _ as re -> crude_val asg (FormulaSubst.expand_real_expr re)
+ | _ -> raise Not_found in
+ let rec crude_eq keep asg = function
+ | Const v -> Const v
+ | Plus (e1, e2) -> Plus (crude_eq keep asg e1, crude_eq keep asg e2)
+ | Times (e1, e2) -> Times (crude_eq keep asg e1, crude_eq keep asg e2)
+ | Pow (e1, e2) -> Pow (crude_eq keep asg e1, crude_eq keep asg e2)
+ | Fun (fname, var) ->
+ if List.mem var keep then Fun (fname, var) else
+ let e = List.assoc var asg in
+ Const (Structure.fun_val model fname e)
+ | RLet _ as re -> crude_eq keep asg (FormulaSubst.expand_real_expr re)
+ | _ -> raise Not_found in
+ let check_sign_op_bool x = function
+ | EQZero -> x = 0. | GZero -> x > 0. | LZero -> x < 0.
+ | GEQZero -> x >= 0. | LEQZero -> x <= 0. | NEQZero -> x <> 0. in
+ let check_sign_op x s = if check_sign_op_bool x s then Any else Empty in
let rec process_vars assgn = function
- | [] ->
- let poly = poly_of assgn p in
- if check then
- if not (RealQuantElim.sat [(poly, sgn)]) then Empty else
- if RealQuantElim.sat [(poly, SignTable.neg_sign_op sgn)] then
- Real [[(poly, sgn)]]
- else Any
- else Real [[(poly, sgn)]]
+ | [] -> (
+ try check_sign_op (crude_val assgn p) sgn with Not_found ->
+ let poly = poly_of assgn p in
+ if check then
+ if not (RealQuantElim.sat [(poly, sgn)]) then Empty else
+ if RealQuantElim.sat [(poly, SignTable.neg_sign_op sgn)] then
+ Real [[(poly, sgn)]]
+ else Any
+ else Real [[(poly, sgn)]]
+ )
| v :: vs ->
- let append_elem_asg acc e =
- let asg = process_vars ((v, e)::assgn) vs in
- if asg = Empty then acc else (e, asg) :: acc in
- let asg_list = List.fold_left append_elem_asg [] (slist elems) in
- if asg_list = [] then Empty else
- FO (var_str v, List.rev asg_list) in
+ try
+ let eq = if vs = [] && sgn = EQZero then crude_eq [v] assgn p else
+ raise Not_found in
+ let eq = FormulaOps.simplify_re eq in
+ let rec calc rhs = function
+ | Plus (Const x, f) -> calc (rhs -.x) f
+ | Times (Const x, f) when x = 0. -> if rhs = 0. then Any else Empty
+ | Times (Const x, f) -> calc (rhs /. x) f
+ | Fun (fn, v) -> (
+ match Structure.elems_with_val model fn rhs with
+ | [] -> Empty
+ | [e] -> FO (var_str v, [(e, Any)])
+ | elst -> let els = Aux.unique_sorted elst in
+ let asg = List.map (fun e -> (e, Any)) els in
+ FO (var_str v, asg)
+ )
+ | _ -> raise Not_found in
+ let res = calc 0. eq in
+ LOG 1 "%s calc: %s" (Formula.real_str eq) (AssignmentSet.str res);
+ res
+ with Not_found ->
+ let append_elem_asg acc e =
+ let asg = process_vars ((v, e)::assgn) vs in
+ if asg = Empty then acc else (e, asg) :: acc in
+ let asg_list = List.fold_left append_elem_asg [] (slist elems) in
+ if asg_list = [] then Empty else
+ FO (var_str v, List.rev asg_list) in
process_vars [] (List.sort cmp_vars (fo_vars_real p))
let eval_counter = ref 0
@@ -400,7 +448,9 @@
let so_to_qbf struc psi =
let assoc_or_zero asgn x = try List.assoc x asgn with Not_found -> 0 in
let ids, rev_ids, free_id = Hashtbl.create 7, Hashtbl.create 7, ref 0 in
- let elems = Structure.elements struc in
+ let elems, dict = Structure.elements struc, ref (Hashtbl.create 7) in
+ let get_dict v = try Hashtbl.find !dict v with Not_found -> [] in
+ let add_dict v x = Hashtbl.replace !dict v (x :: (get_dict v)) in
let get_id x = try Hashtbl.find ids x with Not_found ->
(Hashtbl.add ids x (!free_id +1);
Hashtbl.add rev_ids (!free_id +1) x;
@@ -418,72 +468,62 @@
(* Reduce the Evaluation Problem of SO formulae to QBF *)
let rec so_to_qbf_rec asgn = function
| SO (rel, args) ->
- let v = (compute_id (var_str rel) args asgn) in
- (QVar v, [(var_str rel, v)])
+ let v = (compute_id (var_str rel) args asgn) in
+ add_dict (var_str rel) v;
+ QVar v
| Rel (rel, va) ->
let args = Array.map (assoc_or_zero asgn) va in
- if (Structure.check_rel struc rel args) then (QAnd [], [])
- else (QOr [], [])
- | Eq (var1, var2) ->
- if assoc_or_zero asgn var1 = assoc_or_zero asgn var2 then
- (QAnd [], [])
- else (QOr [], [])
+ if (Structure.check_rel struc rel args) then QAnd [] else QOr []
+ | Eq (v1, v2) ->
+ if assoc_or_zero asgn v1 = assoc_or_zero asgn v2 then QAnd [] else QOr []
| And phil ->
- let resl = (List.rev_map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
- let qphil = (Aux.unique_sorted (List.rev_map (fst) resl)) in
- let dictl = List.fold_left (fun a (_,l) -> List.rev_append l a) [] resl in
- (try (List.find (fun x -> x = QOr []) qphil, [])
- with Not_found -> (make_conj qphil, dictl) )
+ (* let cur_dict = Hashtbl.copy !dict in *)
+ let resl = List.rev_map (so_to_qbf_rec asgn) phil in
+ if List.exists (fun x -> x = QOr []) resl then (
+ (* dict := cur_dict; *) QOr []
+ ) else make_conj resl
| Or phil ->
- let resl = (List.rev_map (fun phi -> (so_to_qbf_rec asgn phi)) p...
[truncated message content] |
|
From: <luk...@us...> - 2012-07-06 01:06:32
|
Revision: 1743
http://toss.svn.sourceforge.net/toss/?rev=1743&view=rev
Author: lukaszkaiser
Date: 2012-07-06 01:06:25 +0000 (Fri, 06 Jul 2012)
Log Message:
-----------
Interface corrections in structure explorer.
Modified Paths:
--------------
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/Drawing.mli
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/Style.css
trunk/Toss/Client/eval.html
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/README
trunk/Toss/www/contact.xml
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/Client/Drawing.ml 2012-07-06 01:06:25 UTC (rev 1743)
@@ -42,6 +42,19 @@
let defaultCGreen = {red=62 ; green=89 ; blue=24 ; opacity = 1. }
let defaultCBlue = {red=165 ; green=175 ; blue=170 ; opacity = 1. }
+let palette = Hashtbl.create 7
+
+(* Set a color for a name. *)
+let set_color name color =
+ Hashtbl.add palette name color
+
+(* Get the color. If not set before, it is the default one, depending on
+ whether for stroke or fill, or a default red, if name starts with '|'.*)
+let get_color ?(stroke=false) name =
+ try Hashtbl.find palette name with Not_found ->
+ if String.length name > 0 && name.[0] = '|' then defaultCRed else
+ if stroke then defaultCStroke else defaultCFill
+
let color_to_str c =
let op = string_of_float c.opacity in
let l = String.length op - 1 in
@@ -205,12 +218,11 @@
let draw_rel (rel, arity) =
if arity = 1 then
let elems = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- let col = match rel with | "|R" -> defaultCRed | "|G" -> defaultCGreen
- | "|B" -> defaultCBlue | _ -> defaultCFill in
+ let col = get_color rel in
Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.}, col)]) elems
else if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- let c = if rel.[0] = '|' then defaultCRed else defaultCStroke in
+ let c = get_color ~stroke:true rel in
Aux.concat_map (fun a -> arrow c (pos_draw a.(0)) (pos_draw a.(1))) tuples
else [] in
elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
Modified: trunk/Toss/Client/Drawing.mli
===================================================================
--- trunk/Toss/Client/Drawing.mli 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/Client/Drawing.mli 2012-07-06 01:06:25 UTC (rev 1743)
@@ -33,7 +33,14 @@
(** Default stroke color. *)
val defaultCStroke : color
+(** Set the color for a name. *)
+val set_color : string -> color -> unit
+(** Get the color. If not set before, it is the default one, depending on
+ whether for stroke or fill, or a default red, if name starts with '|'. *)
+val get_color : ?stroke : bool -> string -> color
+
+
(** Shapes. *)
type shape =
| Circle of point * point * color (** circle, given middle and radiuses *)
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/Client/JsEval.ml 2012-07-06 01:06:25 UTC (rev 1743)
@@ -111,3 +111,27 @@
let _ = set_handle "mouseup_handle" mouseup_handle
let _ = set_handle "mousedown_handle" mousedown_handle
let _ = set_handle "mousemove_handle" mousemove_handle
+
+let set_colors colors_str =
+ let defs = Aux.split_charprop (fun c -> c = ';') (Js.to_string colors_str) in
+ let set_color_def rel c =
+ let b = function '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4
+ | '5' -> 5 | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 | 'a' -> 10
+ | 'A' -> 10 | 'b' -> 11 | 'B' -> 11 | 'c' -> 12 | 'C' -> 12 | 'd' -> 13
+ | 'D' -> 13 | 'e' -> 14 | 'E' -> 14 | 'f' -> 15 | 'F' -> 15 | _ -> -1 in
+ if String.length c <> 7 || c.[0] <> '#' then "Incorrect color: " ^ c else
+ let (r1, r0, g1, g0, b1, b0) =
+ (b c.[1], b c.[2], b c.[3], b c.[4], b c.[5], b c.[6]) in
+ if r0 < 0 || r1 < 0 || g0 < 0 || g1 < 0 || b0 < 0 || b1 < 0 then
+ "Incorrect numbers in color: " ^ c
+ else let col = { Drawing.red = 16*r1+r0 ; Drawing.green = 16*g1+g0 ;
+ Drawing.blue = 16*b1+b0 ; Drawing.opacity = 1. } in
+ Drawing.set_color rel col;
+ "Set " ^ rel ^ " to " ^ c in
+ let parse_def d =
+ match Aux.split_charprop (fun c -> c = ':') d with
+ | [rel; c] -> set_color_def (Aux.strip_spaces rel) (Aux.strip_spaces c)
+ | _ -> "Incorrect color definition: " ^ (Aux.normalize_spaces d) in
+ Js.string (String.concat " <br /> " (List.map parse_def defs))
+
+let _ = set_handle "set_colors" set_colors
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/Client/Style.css 2012-07-06 01:06:25 UTC (rev 1743)
@@ -43,7 +43,6 @@
.bt {
border-color: #260314;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 1px;
color: #260314;
background-color: #fff1d4;
@@ -64,11 +63,24 @@
float: right;
}
-.obt, .boldobt, .gamebt, .ebt, .ebts {
+.textar {
+ font-family: Verdana;
+ font-size: 0.9em;
+ width: 33em;
+}
+
+.headerp {
+ width: 100%;
+ border-bottom: 0px solid;
+ padding-top: 0.5em;
+ text-align: center;
+ font-weight: bold;
+}
+
+.obt, .boldobt, .gamebt, .ebt, .ebts, .ebtr, .ebtl {
text-align: left;
border-color: #260314;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 0px;
color: #260314;
background-color: #fff1d4;
@@ -76,7 +88,8 @@
font-family: Verdana, 'TeXGyreHerosRegular', sans;
}
-.obt:hover, .ebt:hover, .ebts:hover, .boldobt:hover, .gamebt:hover {
+.obt:hover, .ebt:hover, .ebts:hover, .ebtr:hover, .ebtl:hover,
+ .boldobt:hover, .gamebt:hover{
cursor: pointer;
text-decoration: underline;
}
@@ -86,12 +99,22 @@
font-size: 1em;
}
-.ebt, .ebts {
+.ebt, .ebts, .ebtr, .ebtl {
/*font-weight: bold;*/
text-align: center;
border-width: 1px;
}
+.ebtr {
+ position: absolute;
+ right: 1px;
+}
+
+.ebtl {
+ position: absolute;
+ left: 1px;
+}
+
.gamebt {
margin-bottom: 1em;
padding-top: 0.5em;
@@ -104,7 +127,6 @@
text-align: left;
border-color: #260314;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 0px;
color: #260314;
background-color: #fff1d4;
@@ -120,7 +142,6 @@
.dbt {
border-color: #fff1d4;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 0px;
color: #fff1d4;
background-color: #400827;
@@ -235,7 +256,6 @@
top: -1em;
background-color: rgba(255, 241, 228, 0.8);
border-radius: 4px;
- -moz-border-radius: 4px;
opacity: 1;
}
@@ -263,7 +283,6 @@
font-size: 0.8em;
border-color: #fff1d4;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 1px;
position: relative;
top: 2px;
@@ -284,9 +303,6 @@
padding-left: 0.2em;
padding-right: 0.2em;
border-radius: 0px;
- -moz-border-radius: 0px;
- /*font-size: 0.9em;
- -moz-border-radius: 6px 6px 0px 0px; */
}
#speed {
@@ -300,8 +316,7 @@
padding: 0px;
margin: 0px;
border-color: #fff1d4;
- /*border-radius: 4px;
- -moz-border-radius: 4px;*/
+ /*border-radius: 4px; */
border-width: 0px;
}
@@ -328,7 +343,6 @@
margin: 0px;
border-color: #fff1d4;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 0px;
}
@@ -349,7 +363,6 @@
.forminput, .hiddenforminput {
border-color: #fff1d4;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 2px;
position: relative;
top: 2px;
@@ -392,7 +405,6 @@
background-color: #ffffff;
border-color: #fff1d4;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 1px;
}
@@ -516,8 +528,6 @@
padding-bottom: 0.2em;
padding-left: 0.2em;
padding-right: 0.2em;
- /*font-size: 0.9em;
- -moz-border-radius: 6px 6px 0px 0px; */
}
#bottom {
@@ -570,9 +580,6 @@
border-color: #fff1d4;
border-style: solid;
border-width: 0px 0px 0px 2px;
- /*border-width: 0px 2px 2px 2px;
- border-radius: 0px 0px 6px 6px;
- -moz-border-radius: 0px 0px 6px 6px;*/
}
#toss-link {
@@ -819,7 +826,6 @@
width: 6em;
border-color: #260314;
border-radius: 4px;
- -moz-border-radius: 4px;
border-width: 1px;
color: #260314;
background-color: #fff1d4;
@@ -899,13 +905,6 @@
padding: 0px;
}
-#board-left {
- position: relative;
- left: 2em;
- top: 5em;
- width: 30em;
-}
-
#board {
padding-top: 1em;
min-width: 10em;
@@ -1009,9 +1008,9 @@
}
#canvas {
- width: 29em;
- height: 29em;
- border: 2px solid #260314;
+ width: 30em;
+ height: 30em;
+ border: 1px solid #260314;
}
/* SVG styling */
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/Client/eval.html 2012-07-06 01:06:25 UTC (rev 1743)
@@ -5,6 +5,7 @@
<title>Toss Relational Structures Explorer</title>
<meta name="Description" content="Explore Relational Structures." />
<meta http-equiv="X-UA-Compatible" content="chrome=1" />
+ <meta name="viewport" content="initial-scale=0.75" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
<script type="text/javascript">
@@ -46,22 +47,46 @@
var canvas = document.getElementById("canvas");
var ctx = canvas.getContext("2d");
ctx.clearRect(0, 0, canvas.width, canvas.height);
+ ctx.fillStyle = "#ffe4aa";
+ ctx.strokeStyle = "#260314";
+ ctx.lineWidth = 5;
+ ctx.lineCap = "round";
+ ctx.lineJoin = "round";
}
-function draw_it () {
+function draw_it_msg (msg) {
+ if (msg) {
+ document.getElementById ("working").style.display = 'block';
+ document.getElementById ("working").innerHTML = 'Working...';
+ }
var rels = document.getElementById ("relations").value;
var pos = document.getElementById ("positions").value;
var elemsF = document.getElementById ("no-elems-start").value;
var elemsT = document.getElementById ("no-elems-end").value;
var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with \n" +
rels + " with \n" + pos;
- ASYNCH ("draw_struc", ["", struc], true, function (a) {
- var ctx = document.getElementById("canvas").getContext("2d");
- eval (a[0])
- })
+ if (msg) {
+ ASYNCH ("draw_struc", ["", struc], true, function (a) {
+ document.getElementById ("working").style.display = 'none';
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (a[0])
+ toggle_to_show ("view");
+ })
+ } else {
+ ASYNCH ("draw_struc", ["", struc], true, function (a) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (a[0])
+ })
+ }
}
+function draw_it () {
+ draw_it_msg (true);
+}
+
function find_draw_it () {
+ document.getElementById ("working").style.display = 'block';
+ document.getElementById ("working").innerHTML = 'Working...';
var rels = document.getElementById ("relations").value;
var pos = document.getElementById ("positions").value;
var elemsF = document.getElementById ("no-elems-start").value;
@@ -70,8 +95,10 @@
var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with \n" +
rels + " with \n" + pos;
ASYNCH ("draw_struc", [so, struc], true, function (a) {
+ document.getElementById ("working").style.display = 'none';
var ctx = document.getElementById("canvas").getContext("2d");
eval (a[0]);
+ toggle_to_show ("view");
if (a[1] !== "Error") { put_msg (a[1], 2000) }
})
}
@@ -165,42 +192,59 @@
}
}
-
function handle_elem_click (eid) { console.log (eid); }
+function example_basic () {
+ document.getElementById ("struc-name").value = "Basic";
+ document.getElementById ("relations").value =
+ "E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)";
+ document.getElementById ("positions").value = ":x(a) = &a;\n" +
+ ":y(a) = &a · (10 - &a) / 10";
+ document.getElementById ("no-elems-start").value = "1";
+ document.getElementById ("no-elems-end").value = "15";
+ draw_it_msg (false);
+}
+
function example_primes () {
- document.getElementById ("struc-name").value = "Prime Numbers";
+ document.getElementById ("struc-name").value = "Primes";
document.getElementById ("relations").value =
"P(z) = &z > 1 and ∀ x,y \n (&x · &y = &z → (&x = 1 ∨ &y = 1))";
document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = 0";
document.getElementById ("no-elems-start").value = "1";
document.getElementById ("no-elems-end").value = "10";
- draw_it ();
+ draw_it_msg (false);
}
function example_tc () {
- document.getElementById ("struc-name").value = "Transitive Closure";
+ document.getElementById ("struc-name").value = "Simple TC";
document.getElementById ("relations").value =
"E(x, y) = &y = &x + 1;\n" +
"S(x, y) = x ≠ y ∧ tc x,y E(x, y)";
document.getElementById("positions").value=":x(a) = 5·&a;\n:y(a) = &a·&a / 2";
document.getElementById ("no-elems-start").value = "1";
document.getElementById("no-elems-end").value = "4";
- draw_it ();
+ draw_it_msg (false);
}
-function example_basic () {
- document.getElementById ("struc-name").value = "Basic Example";
- document.getElementById ("relations").value =
- "E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)";
- document.getElementById ("positions").value = ":x(a) = &a;\n" +
- ":y(a) = &a · (10 - &a) / 10";
+function example_heart () {
+ document.getElementById ("struc-name").value = "Heart";
+ document.getElementById ("relations").value =
+ "E(x, y) = (&y = &x + 1 ∧ &x ≠ 18) ∨ (&x=37 ∧ &y=18)";
+ document.getElementById ("positions").rows = 7;
+ document.getElementById ("positions").value =
+ ":x(a) = :(&a ≤ 18) · (:(&a ≤ 10) · &a - :(&a > 10) · (&a-20))\n" +
+ " - let :b = &a - 18 in :(&a > 18) · (:(:b ≤ 10) · :b - \n " +
+ " :(:b > 10) · (:b - 20) - 2); \n\n" +
+ ":y(a) = :(&a ≤ 18) · (:(&a ≤ 10) ·&a · (10 - &a) / 10 - \n" +
+ " :(&a > 10)·(&a - 10)) + let :b = &a - 18 in :(&a > 18)·( \n" +
+ " :(:b ≤ 10)·:b · (10-:b) / 10 - :(:b > 10)·(:b - 10) )";
document.getElementById ("no-elems-start").value = "1";
- document.getElementById ("no-elems-end").value = "15";
- draw_it ();
+ document.getElementById ("no-elems-end").value = "37";
+ draw_it_msg (false);
}
function example_matching () {
+ document.getElementById ("so-name").value = "Matching";
document.getElementById ("second-order").value =
"∀ x,y ( |M(x, y) -> (\n" +
" ( E(x, y) ∨ E(y, x) ) ∧ ¬∃ z (z≠y ∧ |M(x, z) )\n" +
@@ -209,6 +253,7 @@
}
function example_2col () {
+ document.getElementById ("so-name").value = "2-coloring";
document.getElementById ("second-order").value =
"∀ x,y ( (|R(x) ∨ |G(x)) ∧ ( E(x,y) → " +
"\n ¬( (|R(x) ∧ |R(y)) ∨ (|G(x) ∧ |G(y)) ) ) )";
@@ -216,26 +261,19 @@
}
function example_3col () {
+ document.getElementById ("so-name").value = "3-coloring";
document.getElementById ("second-order").value =
"∀ x,y ( ( |R(x) ∨ |G(x) ∨ |B(x)) ∧ ( E(x,y) → " +
"\n ¬( (|R(x) ∧ |R(y)) ∨ (|G(x) ∧ |G(y)) ∨ (|B(x) ∧ |B(y)) ) ) )";
find_draw_it ();
}
-function example_heart () {
- document.getElementById ("struc-name").value = "Heart Drawing";
- document.getElementById ("relations").value =
- "E(x, y) = (&y = &x + 1 ∧ &x ≠ 18) ∨ (&x=37 ∧ &y=18)";
- document.getElementById ("positions").value =
- ":x(a) = :(&a ≤ 18) · (:(&a ≤ 10) · &a - :(&a > 10) · (&a - 20)) \n" +
- " - let :b = &a - 18 in :(&a > 18) · (:(:b ≤ 10) · :b - \n " +
- " :(:b > 10) · (:b - 20) - 2); \n\n" +
- ":y(a) = :(&a ≤ 18) · (:(&a ≤ 10) ·&a · (10 - &a) / 10 - \n " +
- " :(&a > 10)·(&a - 10)) + let :b = &a - 18 in \n" +
- " :(&a > 18) · (:(:b ≤ 10) ·:b · (10 - :b) / 10 - :(:b > 10)·(:b - 10))";
- document.getElementById ("no-elems-start").value = "1";
- document.getElementById ("no-elems-end").value = "37";
- draw_it ();
+function example_tc_so () {
+ document.getElementById ("so-name").value = "TC";
+ document.getElementById ("second-order").value =
+ "∀ x,y,z ( ( E(x, y) → |Tc(x, y) ) ∧\n" +
+ " ( (|Tc(x, y) ∧ |Tc(y, z)) -> |Tc(x, z) ) )";
+ find_draw_it ();
}
function add_field (field, s) {
@@ -311,8 +349,8 @@
var n = k.substring (16, k.length);
var li = document.createElement('li');
li.innerHTML ='<button class="obt" onclick="load_struc('+"'"+ n +"'"+')">'
- + n +'</button> (<button class="obt" onclick="del_struc('+ "'"+ n +
- "'" +')" title="Delete this structure.">-</button>)';
+ + n +'</button> <button class="ebtr" onclick="del_struc('+ "'"+ n +"'"+
+ ')" style="width: 4em;" title="Delete this structure.">Del</button>';
saved.appendChild (li);
}
}
@@ -327,8 +365,8 @@
var n = k.substring (16, k.length);
var li = document.createElement('li');
li.innerHTML ='<button class="obt" onclick="load_so('+"'"+ n +"'"+')">'
- + n +'</button> (<button class="obt" onclick="del_so('+ "'"+ n +
- "'" +')" title="Delete this formula.">-</button>)';
+ + n +'</button> <button class="ebtr" onclick="del_so('+ "'"+ n +
+ "'" +')" style="width: 4em;" title="Delete this formula.">Del</button>';
saved.appendChild (li);
}
}
@@ -352,28 +390,21 @@
list_stored_struc ();
}
-function toggle_edit_view () {
- var bt = document.getElementById("editbt");
- if (bt.innerHTML == "Edit") {
- document.getElementById('edit').style.display = 'block';
- document.getElementById('board-left').style.display = 'none';
- bt.innerHTML = "View";
- } else {
- document.getElementById('edit').style.display = 'none';
- document.getElementById('board-left').style.display = 'block';
- bt.innerHTML = "Edit";
- }
-}
-
function adjust_to_width () {
var e = document.getElementById ("edit");
var em_size =
document.defaultView.getComputedStyle(e,null).getPropertyValue('font-size');
var em_size_int = parseInt (em_size.substring (0, em_size.length - 2));
- if (window.innerWidth > 80 * em_size_int) { // enough space for view
- document.getElementById('board-left').style.left = '35em';
- document.getElementById('board-left').style.display = 'block';
- document.getElementById('editbt').style.display = 'none';
+ if (window.innerWidth > 80 * em_size_int) { // enough space for left view
+ document.getElementById('div_right_col_full').style.position = 'absolute';
+ document.getElementById('div_right_col_full').style.top = '-1em';
+ document.getElementById('div_right_col_full').style.left = '35em';
+ } else {
+ toggle ("struc");
+ toggle ("formula");
+ toggle ("colors");
+ put_msg ("This page is best viewed on a screen > 80em wide.<br\>" +
+ "It then switches to two-column layout.", 4000)
}
}
@@ -385,39 +416,96 @@
}, time);
}
-function show_help () {
- document.getElementById ("working").style.textAlign = "left";
+function hide_working () {
+ document.getElementById ("working").style.display = 'none';
+ document.getElementById ("working").style.textAlign = "center";
+ document.getElementById ("working").style.fontWeight = "bold";
+}
+
+function toggle (name) {
+ var bt = document.getElementById ("hide_" + name + "_bt");
+ if (bt.innerHTML == "Hide") {
+ bt.innerHTML = "Show";
+ document.getElementById ("div_" + name + "_full").style.display = 'none';
+ } else {
+ bt.innerHTML = "Hide";
+ document.getElementById ("div_" + name + "_full").style.display = 'block';
+ }
+}
+
+function toggle_to_show (name) {
+ var bt = document.getElementById ("hide_" + name + "_bt");
+ if (bt.innerHTML !== "Hide") { toggle (name); }
+}
+
+function show_help (content) {
+ document.getElementById ("working").style.textAlign = "justify";
document.getElementById ("working").style.fontWeight = "normal";
document.getElementById("working").innerHTML = '\
-<b>Welcome to Relational Structures Explorer</b> \
-<p><b>Relational structures</b> consist of a set of <em>elements</em> and \
-of <em>relations</em> defined by <em>formulas</em>.</p> \
-<p><b>Elements</b> are numbered. You can change their range and you can access \
-the number of the element corresponding to a variable <em>x</em> in a formula \
-by writing <em>&x</em> or <em>:nbr(x)</em>.</p> \
-<p><b>Formulas</b> are written in first-order logic. You can use relation \
-symbols, Boolean combinations and quantifiers. Additionally, you can use \
-arithmetic operations (+-*/^) on element numbers and element positions.</p> \
-<p><b>Positions</b> of elements are determined by their <em>x</em> and \
-<em>y</em> coordinates. Define and access them as in <b>:x(a)</b> and \
-<b>:y(a)</b>. You can again use arithmetic operations and also conditionals \
-on formulas, written <b>:(formula)</b>.</p> \
-<p><b>Relation Finder</b>, placed at the bottom, automatically finds relations \
-that satisfy the given property. Use <b>|</b> in front of the relation symbol \
-to be found, as in <b>|R(x)</b>.</p> \
-';
+<b>Relational Structures Explorer Help</b> \
+<button class="obt" style="position: absolute; right: 1em;" onclick="hide_working()">Hide</button> ' + content;
document.getElementById ("working").style.display = "block";
- setTimeout (function () {
- document.getElementById ("working").style.display = "none";
- document.getElementById ("working").style.textAlign = "center";
- document.getElementById ("working").style.fontWeight = "bold";
- }, 20000);
}
+
+function show_help_view () {
+ show_help('\
+<p><b>Structure view</b> shows the elements and relations in the structure.\
+ You can move the elements with your mouse, but old positions will be restored\
+ when the structure is redrawn.</p>\
+ ');
+}
+
+function show_help_saved () {
+ show_help('\
+<p><b>Saved structures and formulas</b> are stored in the browser local \
+ storage. Press the <b>Save</b> button in the respective edit field to save \
+ a structure or a formula, and later the <b>Del</b> button to delete it.</p>\
+ ');
+}
+
+function show_help_struc () {
+ show_help('\
+<p><b>Structure editor</b> allows to edit the relations in the structure and \
+ to set the positions of elements. It uses formulas of extended first-order \
+ logic with counting. Write <b>&a</b> or <b>:nbr(a)</b> to access the number \
+ of the element which is assigned to the variable <b>a</b>, and <b>:x(a)</b> \
+ and <b>:y(a)</b> for the x- and y-coordinate of its position. Look at the \
+ example structures to see more of the syntax we use.</p>\
+ ');
+}
+
+function show_help_formula () {
+ show_help('\
+<p><b>Formula evaluator</b> allows to check formulas and to find relations \
+ defined in second-order logic. To define a new relation, put <b>|</b> in \
+ front of the relation symbol, e.g., write <b>∃ x,y |R(x,y)</b>. The new \
+ relation will be added to the structure (click example formulas to try).</p> \
+ ');
+}
+
+function show_help_colors () {
+ show_help('\
+<p><b>Color selector</b> allows to assign colors to relations, by giving \
+ a list of the form <b>Relation : #xcolor</b> where <b>xcolor</b> must \
+ be 6-characters long and a valid rgb value in hexadecimal.</p> \
+ ');
+}
+
+function select_colors (silent) {
+ var color_defs = document.getElementById('colors').value;
+ if (silent) {
+ ASYNCH ("set_colors", [color_defs], true, function (a) { ; })
+ } else {
+ ASYNCH ("set_colors", [color_defs], true, function (a) {
+ put_msg (a, 5000);
+ })
+ }
+}
//-->
</script>
</head>
-<body onload="init_canvas (); list_stored (); draw_it (); adjust_to_width()">
+<body onload="init_canvas (); select_colors (true) ; list_stored (); draw_it_msg (false); adjust_to_width()">
<div id="main">
<div id="top">
@@ -429,12 +517,26 @@
<span style="position: relative; left: 2em; top: 0.5em; font-size: 1.2em">
Relational Structures Explorer</span>
<span id="toprighttab" style="display: block;">
- <button class="obt" id="editbt" onclick="toggle_edit_view()">View</button>
- <button class="obt" id="editbt" onclick="show_help()">Help</button>
</span>
</div>
-<div id="board-left" style="display: none;">
+
+<div id="working" style="display: none; width: 30em;"></div>
+
+<div id="edit" style="position: relative; top: 2.5em; left: 2em;
+ width: 30em; margin-bottom: 6em;">
+
+<div id="div_right_col_full" style="width: 30em;">
+
+<p class="headerp">
+ <button class="ebtl" style="width: 4em;" title="Show/Hide structure view."
+ id="hide_view_bt" onclick="toggle('view')">Hide</button>
+ View Structure
+ <button class="ebtr" style="width: 4em;" title="Structure viewing help."
+ onclick="show_help_view()">Help</button>
+</p>
+
+<div id="div_view_full" style="width: 30em;">
<canvas id="canvas" height="1100" width="1100"
onmouseup="mouseup_handle(event)"
onmousedown="mousedown_handle(event)"
@@ -446,10 +548,50 @@
</canvas>
</div>
-<div id="working" style="display: none; width: 30em;"></div>
+<p class="headerp">
+ <button class="ebtl" style="width: 4em;" title="Show/Hide color selector."
+ id="hide_colors_bt" onclick="toggle ('colors')">Hide</button>
+ Select Colors
+ <button class="ebtr" style="width: 4em;" title="Color selector help."
+ onclick="show_help_colors()">Help</button>
+</p>
-<div id="edit" style="position: absolute; top: 4em; left: 2em;">
+<div id="div_colors_full">
+<p>Colors
+ <span style="position: absolute; right: 2px;">
+ <button class="ebts" style="background-color: #e5effa;";
+ onclick="add_field('colors', '#e5effa')"> </button><button
+ class="ebts" style="background-color: #a5afaa;";
+ onclick="add_field('colors', '#a5afaa')"> </button><button
+ class="ebts" style="background-color: #93a605;";
+ onclick="add_field('colors', '#93a605')"> </button><button
+ class="ebts" style="background-color: #3e5916;";
+ onclick="add_field('colors', '#3e5916')"> </button><button
+ class="ebts" style="background-color: #f28705;";
+ onclick="add_field('colors', '#f28705')"> </button><button
+ style="background-color: #f25c05;"; class="ebts"
+ onclick="add_field('colors', '#f25c05')"> </button><button
+ style="background-color: #260314;"; class="ebts"
+ onclick="add_field('colors', '#260314')"> </button>
+ <button class="ebt" onclick="select_colors(false)" style="width: 4em;"
+ title="Select these colors.">Select</button>
+ </span>
+</p>
+<textarea id="colors" rows="1" cols="60" class="textar">
+|R : #f25c05 ; |G : #3e5916 ; |B : #a5afaa</textarea>
+</div>
+</div> <!-- end right column -->
+
+<p class="headerp">
+ <button class="ebtl" style="width: 4em;" title="Show/Hide structure editing."
+ id="hide_struc_bt" onclick="toggle('struc')">Hide</button>
+ Edit Structure
+ <button class="ebtr" style="width: 4em;" title="Structure editing help."
+ onclick="show_help_struc()">Help</button>
+</p>
+
+<div id="div_struc_full">
<p>Name
<input id="struc-name" type="text" size="20" value="My Structure 1"
style="width: 12em"></input>
@@ -475,8 +617,6 @@
<span style="position: absolute; right: 2px;">
<button class="ebts" title="Not equal. You can also write '<>' or '!='."
onclick="add_field('relations', '≠')">≠</button><button
- class="ebts" title="Less or equal. You can also write '=<'."
- onclick="add_field('relations', '≤')">≤</button><button
class="ebts" title="Conjunction. You can also write 'and' or '&'."
onclick="add_field('relations', '∧')">∧</button><button
class="ebts" title="Disjunction. You can also write 'or' or '|'."
@@ -493,7 +633,7 @@
title="Redraw current structure.">Draw</button>
</span>
</p>
-<textarea id="relations" rows="3" cols="60">
+<textarea id="relations" rows="3" cols="60" class="textar">
E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)
</textarea>
@@ -501,8 +641,6 @@
<span style="position: absolute; right: 2px;">
<button class="ebts" title="Not equal. You can also write '<>' or '!='."
onclick="add_field('positions', '≠')">≠</button><button
- class="ebts" title="Less or equal. You can also write '=<'."
- onclick="add_field('positions', '≤')">≤</button><button
class="ebts" title="Conjunction. You can also write 'and' or '&'."
onclick="add_field('positions', '∧')">∧</button><button
class="ebts" title="Disjunction. You can also write 'or' or '|'."
@@ -519,14 +657,23 @@
title="Redraw current structure.">Draw</button>
</span>
</p>
-<textarea id="positions" rows="3" cols="60">
+<textarea id="positions" rows="3" cols="60" class="textar">
:x(a) = &a;
:y(a) = &a · (10 - &a) / 10
</textarea>
+</div>
+<p class="headerp">
+ <button class="ebtl" style="width: 4em;" title="Show/Hide formula evaluator."
+ id="hide_formula_bt" onclick="toggle ('formula')">Hide</button>
+ Evaluate Formulas
+ <button class="ebtr" style="width: 4em;" title="Formula evaluator help."
+ onclick="show_help_formula()">Help</button>
+</p>
-<p style="width:100%; border-top: 1px solid; padding-top: 1em;">
- Formula Name
+<div id="div_formula_full">
+<p>
+ Formula Name
<input id="so-name" type="text" size="20" value="My Formula 1"
style="width: 12em"></input>
<span style="position: absolute; right: 2px;">
@@ -539,8 +686,6 @@
<span style="position: absolute; right: 2px;">
<button class="ebts" title="Not equal. You can also write '<>' or '!='."
onclick="add_field('second-order', '≠')">≠</button><button
- class="ebts" title="Less or equal. You can also write '=<'."
- onclick="add_field('second-order', '≤')">≤</button><button
class="ebts" title="Conjunction. You can also write 'and' or '&'."
onclick="add_field('second-order', '∧')">∧</button><button
class="ebts" title="Disjunction. You can also write 'or' or '|'."
@@ -554,42 +699,54 @@
title="Universal Quantifier. You can also write 'all' or '\A'."
class="ebts" onclick="add_field('second-order', '∀')">∀</button>
<button class="ebt" onclick="find_draw_it()" style="width: 4em;"
- title="Find relations that satisfy the formula.">Find</button>
+ title="Evaluate the formula.">Eval</button>
</span>
</p>
-<textarea id="second-order" rows="3" cols="60">
+<textarea id="second-order" rows="3" cols="60" class="textar">
</textarea>
</div>
-<div style="position: absolute; top: 4em; right: 0.5em; text-align: left">
-<p>Your Structures</p>
+<p class="headerp">
+ <button class="ebtl" style="width: 4em;" title="Show/Hide examples & saved."
+ id="hide_saved_bt" onclick="toggle('saved')">Hide</button>
+ Examples & Saved
+ <button class="ebtr" title="Saved structures and formulas help."
+ style="width: 4em;" onclick="show_help_saved()">Help</button>
+</p>
+
+<div id="div_saved_full">
+<p>Saved Structures</p>
<ul id="saved-strucs" style="list-style: square; margin-left: -1.5em">
<li>Nothing here yet</li>
</ul>
-<p>Examples</p>
-<ul style="list-style: square; margin-left: -1.5em">
-<li><button class="obt" onclick="example_basic()">Basic Example</button></li>
-<li><button class="obt" onclick="example_primes()">Prime Numbers</button></li>
-<li><button class="obt" onclick="example_tc()">Transitive Closure</button></li>
-<li><button class="obt" onclick="example_heart()">Heart Drawing</button></li>
-</ul>
+<p>Examples
+<span style="position: absolute; right: 1px;">
+<button class="ebt" onclick="example_basic()">Basic</button>
+<button class="ebt" onclick="example_primes()">Primes</button>
+<button class="ebt" onclick="example_tc()">Simple TC</button>
+<button class="ebt" onclick="example_heart()">Heart</button>
+</span>
+</p>
-<p style="border-top: 1px solid; padding-top: 1em">Your Formulas</p>
+<p style="padding-right: 1.5em; text-align: left">Saved Formulas</p>
<ul id="saved-so" style="list-style: square; margin-left: -1.5em">
<li>Nothing here yet</li>
</ul>
-<p>Examples</p>
-<ul style="list-style: square; margin-left: -1.5em">
-<li><button class="obt" onclick="example_2col()">2-coloring</button></li>
-<li><button class="obt" onclick="example_3col()">3-coloring</button></li>
-<li><button class="obt" onclick="example_matching()">Matching</button></li>
-</ul>
+<p>Examples
+<span style="position: absolute; right: 1px;">
+<button class="ebt" onclick="example_tc_so()">TC</button>
+<button class="ebt" onclick="example_2col()">2-coloring</button>
+<button class="ebt" onclick="example_3col()">3-coloring</button>
+<button class="ebt" onclick="example_matching()">Matching</button>
+</span>
+</p>
</div>
+</div>
<div id="bottom">
<div id="bottomright">
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-07-06 01:06:25 UTC (rev 1743)
@@ -136,10 +136,12 @@
let rec to_nnf ?(neg=false) = function
| BVar v -> if neg then BVar (-1 * v) else BVar v
| BNot phi -> if neg then to_nnf ~neg:false phi else to_nnf ~neg:true phi
- | BAnd (flist) when neg -> BOr (List.map (to_nnf ~neg:true) flist)
- | BAnd (flist) -> BAnd (List.map (to_nnf ~neg:false) flist)
- | BOr (flist) when neg -> BAnd (List.map (to_nnf ~neg:true) flist)
- | BOr (flist) -> BOr (List.map (to_nnf ~neg:false) flist)
+ | BAnd (flist) when neg ->
+ BOr (List.rev (List.rev_map (to_nnf ~neg:true) flist))
+ | BAnd (flist) -> BAnd (List.rev (List.rev_map (to_nnf ~neg:false) flist))
+ | BOr (flist) when neg ->
+ BAnd (List.rev (List.rev_map (to_nnf ~neg:true) flist))
+ | BOr (flist) -> BOr (List.rev (List.rev_map (to_nnf ~neg:false) flist))
(* Helper function to flatten multiple or's and and's and sort by compare. *)
@@ -640,7 +642,8 @@
List.filter (fun x -> List.for_all (fun y -> x=y || not(subset y x)) cnf) cnf
let find_model phi =
- let arg = flatten (to_nnf ~neg:true phi) in
+ let phi1 = to_nnf ~neg:true phi in
+ let arg = flatten phi1 in
let (sep, aux_phi) = pg_auxcnf_of_bool_formula arg in
match Sat.sat (listcnf_of_boolcnf aux_phi) with
| None -> None
@@ -1005,8 +1008,8 @@
let rec elim_quant_rec = function
| QVar (v) -> BVar (v)
| QNot (f) -> BNot (elim_quant_rec f)
- | QAnd (l) -> BAnd (List.map elim_quant_rec l)
- | QOr (l) -> BOr (List.map elim_quant_rec l)
+ | QAnd (l) -> BAnd (List.rev_map elim_quant_rec l)
+ | QOr (l) -> BOr (List.rev_map elim_quant_rec l)
| QEx (vars, qphi) ->
Hashtbl.clear has_vars_mem;
let inside, len = elim_quant_rec qphi, List.length vars in
Modified: trunk/Toss/README
===================================================================
--- trunk/Toss/README 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/README 2012-07-06 01:06:25 UTC (rev 1743)
@@ -28,6 +28,7 @@
- Diana Fischer
- Tobias Ganzow
- Simon Leßenich
+- Sasha Rubin
- Michał Wójcik
Yet another group of people worked on the oldest version of Toss (around 2004).
Modified: trunk/Toss/www/contact.xml
===================================================================
--- trunk/Toss/www/contact.xml 2012-07-05 00:25:38 UTC (rev 1742)
+++ trunk/Toss/www/contact.xml 2012-07-06 01:06:25 UTC (rev 1743)
@@ -93,6 +93,7 @@
<item>Diana Fischer</item>
<item>Tobias Ganzow</item>
<item>Simon Leßenich</item>
+ <item>Sasha Rubin</item>
<item>Michał Wójcik</item>
</itemize>
<par>Yet another group of people, who worked on the oldest version of Toss
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-05 00:25:45
|
Revision: 1742
http://toss.svn.sourceforge.net/toss/?rev=1742&view=rev
Author: lukaszkaiser
Date: 2012-07-05 00:25:38 +0000 (Thu, 05 Jul 2012)
Log Message:
-----------
Work on the structure explorer interface and making stuff tail-recursive in BoolFormula and Solver.
Modified Paths:
--------------
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/Drawing.mli
trunk/Toss/Client/DrawingTest.ml
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/Style.css
trunk/Toss/Client/eval.html
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/README
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/www/contact.xml
trunk/Toss/www/index.xml
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Client/Drawing.ml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -34,16 +34,19 @@
{ x = q.x *. cosa -. q.y *. sina ; y = q.x *. sina +. q.y *. cosa } +: start
(* Colors in RBGA format. *)
-type color = { red: int; blue: int; green: int; alpha: int }
+type color = { red: int; blue: int; green: int; opacity: float }
-let defaultCFill = { red=255 ; green = 228 ; blue = 170 ; alpha = 0 }
-let defaultCStroke = { red=38 ; green = 3 ; blue = 20 ; alpha = 0 }
-let defaultCRed = {red=242 ; green=92 ; blue=5 ; alpha = 0 }
-let defaultCGreen = {red=62 ; green=89 ; blue=24 ; alpha = 0 }
-let defaultCBlue = {red=165 ; green=175 ; blue=170 ; alpha = 0 }
+let defaultCFill = { red=255 ; green = 228 ; blue = 170 ; opacity = 0.5 }
+let defaultCStroke = { red=38 ; green = 3 ; blue = 20 ; opacity = 0.5 }
+let defaultCRed = {red=242 ; green=92 ; blue=5 ; opacity = 1. }
+let defaultCGreen = {red=62 ; green=89 ; blue=24 ; opacity = 1. }
+let defaultCBlue = {red=165 ; green=175 ; blue=170 ; opacity = 1. }
-let color_to_hex c =
- Printf.sprintf "%s%.2x%.2x%.2x" "#" c.red c.green c.blue
+let color_to_str c =
+ let op = string_of_float c.opacity in
+ let l = String.length op - 1 in
+ let op = if op.[l] = '.' then String.sub op 0 l else op in
+ Printf.sprintf "rgba(%i, %i, %i, %s)" c.red c.green c.blue op
(* Various shapes. *)
type shape =
@@ -207,8 +210,8 @@
Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.}, col)]) elems
else if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- Aux.concat_map (fun a ->
- arrow defaultCStroke (pos_draw a.(0)) (pos_draw a.(1))) tuples
+ let c = if rel.[0] = '|' then defaultCRed else defaultCStroke in
+ Aux.concat_map (fun a -> arrow c (pos_draw a.(0)) (pos_draw a.(1))) tuples
else [] in
elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
@@ -216,7 +219,7 @@
(* Compile the shape to a JavaScript program drawing the shape on 'ctx'. *)
let shape_to_canvas = function
| Circle (p, r, col) ->
- let fill = "ctx.fillStyle = \""^(color_to_hex col)^"\"; ctx.fill();" in
+ let fill = "ctx.fillStyle = \""^(color_to_str col)^"\"; ctx.fill();" in
if r.x = r.y then
let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r.x
in "ctx.beginPath(); "^ s ^ fill ^ " ctx.stroke(); ctx.closePath(); "
@@ -228,7 +231,7 @@
| Line (f, t, col) ->
let fs = Printf.sprintf "ctx.moveTo(%F,%F); " f.x f.y in
let ts = Printf.sprintf "ctx.lineTo(%F,%F); " t.x t.y in
- let stroke= "ctx.strokeStyle = \""^(color_to_hex col)^"\"; ctx.stroke();" in
+ let stroke= "ctx.strokeStyle = \""^(color_to_str col)^"\"; ctx.stroke();" in
"ctx.beginPath(); " ^ fs ^ ts ^ stroke ^ " ctx.closePath(); "
let shapes_to_canvas l =
Modified: trunk/Toss/Client/Drawing.mli
===================================================================
--- trunk/Toss/Client/Drawing.mli 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Client/Drawing.mli 2012-07-05 00:25:38 UTC (rev 1742)
@@ -25,8 +25,15 @@
val rotate : point -> float -> point -> point
(** Colors in RBGA format. *)
-type color = { red: int; blue: int; green: int; alpha: int }
+type color = { red: int; blue: int; green: int; opacity: float }
+(** Default filling color. *)
+val defaultCFill : color
+
+(** Default stroke color. *)
+val defaultCStroke : color
+
+
(** Shapes. *)
type shape =
| Circle of point * point * color (** circle, given middle and radiuses *)
Modified: trunk/Toss/Client/DrawingTest.ml
===================================================================
--- trunk/Toss/Client/DrawingTest.ml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Client/DrawingTest.ml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -8,6 +8,8 @@
let str p = Printf.sprintf "(%F, %F)" p.x p.y in
assert_equal ~printer:(fun l -> String.concat ", " (List.map str l)) pl ql
+let circ p q = Circle (p, q, defaultCFill)
+
let tests = "Drawing" >::: [
"change coords" >::
(fun () ->
@@ -20,10 +22,10 @@
"crossings" >::
(fun () ->
let z, o, hsq2 = {x=0.;y=0.}, {x=1.;y=1.}, (sqrt 2.) *. 0.5 in
- eq_point_list [o*!hsq2; o *! (-1.*.hsq2)] (crossings z o [Circle (z, o)]);
- eq_point_list [{x=1.;y=0.}] (crossings z {x=1.;y=0.} [Circle (o, o)]);
+ eq_point_list [o*!hsq2; o *! (-1.*.hsq2)] (crossings z o [circ z o]);
+ eq_point_list [{x=1.;y=0.}] (crossings z {x=1.;y=0.} [circ o o]);
eq_point_list [{x = 2. ; y = 0.}; {x = -2. ; y = 0.}]
- (crossings z {x=1.; y=0.} [Circle (z, o *! 2.)]);
+ (crossings z {x=1.; y=0.} [circ z (o *! 2.)]);
);
]
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Client/JsEval.ml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -30,11 +30,11 @@
(* Parse a formula. *)
let formula_of_string s = FormulaParser.parse_formula Lexer.lex
- (Lexing.from_string (Aux.normalize_spaces s))
+ (Lexing.from_string (Aux.strip_spaces s))
(* Parse a structure. *)
let structure_of_string s =
- let str = "START " ^ (Aux.normalize_spaces s) in
+ let str = "START " ^ (Aux.strip_spaces s) in
match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string str) with
| Arena.StartStruc struc -> struc
| _ -> failwith "not a structure"
@@ -42,15 +42,33 @@
(* Drawing the structure. *)
let draw_struc_js so_s struc_s =
- let st, so = structure_of_string (Js.to_string struc_s), Js.to_string so_s in
- let st, so_res = if Aux.strip_spaces so = "" then (st, "none") else
- let so_phi = formula_of_string so in
- let st, res = Solver.find_so st so_phi in
- if res then st, "true" else st, "false" in
- let st_c = Drawing.add_coords 1000. 1000. 50. 50. None None st in
- cur_st := st_c;
- let draw = Drawing.shapes_to_canvas (Drawing.draw_struc st_c) in
- Js.array [|Js.string ("clear_canvas (); " ^ draw) ; Js.string so_res |]
+ let err msg =
+ let js_msg = Js.string ("put_msg('" ^ msg ^ "', 5000);") in
+ Js.array [|js_msg; Js.string "Error"|] in
+ let error_msg where = function
+ | Lexer.Parsing_error m when String.length m > 15 &&
+ String.sub m 0 15 = "File \"\", lines " ->
+ let ms = String.sub m 15 ((String.index m '\n') - 16) in
+ let l, c = String.sub ms 0 (String.index ms '-'), String.index ms ',' in
+ let chars = String.sub ms (c+1) ((String.length ms)-c-1) in
+ let l = string_of_int ((int_of_string l) - 1) in
+ err (where ^ " parsing error in line " ^ l ^ "," ^ chars)
+ | x -> err (where ^ " error:<br />" ^
+ (Aux.str_subst_all "\n" "<br/>" (Printexc.to_string x))) in
+ try
+ let st = structure_of_string (Js.to_string struc_s) in
+ try
+ let so = Js.to_string so_s in
+ let st, so_res = if Aux.strip_spaces so = "" then (st, "No Formula") else
+ let so_phi = formula_of_string so in
+ let st, res = Solver.find_so st so_phi in
+ if res then st, "Formula Satisfied" else st,"Formula Unsatisfiable" in
+ let st_c = Drawing.add_coords 1000. 1000. 50. 50. None None st in
+ cur_st := st_c;
+ let draw = Drawing.shapes_to_canvas (Drawing.draw_struc st_c) in
+ Js.array [|Js.string ("clear_canvas (); " ^ draw) ; Js.string so_res |]
+ with x -> error_msg "Formula" x
+ with x -> error_msg "Structure" x
let _ = set_handle "draw_struc" draw_struc_js
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Client/Style.css 2012-07-05 00:25:38 UTC (rev 1742)
@@ -64,7 +64,7 @@
float: right;
}
-.obt, .boldobt, .gamebt, .ebt {
+.obt, .boldobt, .gamebt, .ebt, .ebts {
text-align: left;
border-color: #260314;
border-radius: 4px;
@@ -76,7 +76,7 @@
font-family: Verdana, 'TeXGyreHerosRegular', sans;
}
-.obt:hover, .ebt:hover, .boldobt:hover, .gamebt:hover {
+.obt:hover, .ebt:hover, .ebts:hover, .boldobt:hover, .gamebt:hover {
cursor: pointer;
text-decoration: underline;
}
@@ -86,9 +86,10 @@
font-size: 1em;
}
-.ebt {
+.ebt, .ebts {
/*font-weight: bold;*/
- border-width: 2px;
+ text-align: center;
+ border-width: 1px;
}
.gamebt {
@@ -902,6 +903,7 @@
position: relative;
left: 2em;
top: 5em;
+ width: 30em;
}
#board {
@@ -929,6 +931,7 @@
background-color: #400827;
padding: 1em;
border: 1px solid #260314;
+ z-index: 100;
}
#opening {
@@ -1006,8 +1009,8 @@
}
#canvas {
- width: 28em;
- height: 28em;
+ width: 29em;
+ height: 29em;
border: 2px solid #260314;
}
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Client/eval.html 2012-07-05 00:25:38 UTC (rev 1742)
@@ -53,8 +53,8 @@
var pos = document.getElementById ("positions").value;
var elemsF = document.getElementById ("no-elems-start").value;
var elemsT = document.getElementById ("no-elems-end").value;
- var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with " +
- rels + " with " + pos;
+ var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with \n" +
+ rels + " with \n" + pos;
ASYNCH ("draw_struc", ["", struc], true, function (a) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (a[0])
@@ -67,12 +67,12 @@
var elemsF = document.getElementById ("no-elems-start").value;
var elemsT = document.getElementById ("no-elems-end").value;
var so = document.getElementById ("second-order").value;
- var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with " +
- rels + " with " + pos;
+ var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with \n" +
+ rels + " with \n" + pos;
ASYNCH ("draw_struc", [so, struc], true, function (a) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (a[0]);
- alert (a[1])
+ if (a[1] !== "Error") { put_msg (a[1], 2000) }
})
}
@@ -200,6 +200,14 @@
draw_it ();
}
+function example_matching () {
+ document.getElementById ("second-order").value =
+ "∀ x,y ( |M(x, y) -> (\n" +
+ " ( E(x, y) ∨ E(y, x) ) ∧ ¬∃ z (z≠y ∧ |M(x, z) )\n" +
+ ") ) ∧ ∀ x ∃ y |M(x, y)";
+ find_draw_it ();
+}
+
function example_2col () {
document.getElementById ("second-order").value =
"∀ x,y ( (|R(x) ∨ |G(x)) ∧ ( E(x,y) → " +
@@ -254,7 +262,7 @@
draw_it ();
}
-function save () {
+function save_struc () {
var name = document.getElementById ("struc-name").value;
var elems1 = document.getElementById ("no-elems-start").value;
var elems2 = document.getElementById ("no-elems-end").value;
@@ -264,10 +272,17 @@
localStorage["TRelStrucExplEl2"+name] = elems2;
localStorage["TRelStrucExplRel"+name] = rels;
localStorage["TRelStrucExplPos"+name] = pos;
- list_stored ();
+ list_stored_struc ();
}
-function load (name) {
+function save_so () {
+ var name = document.getElementById ("so-name").value;
+ var phi = document.getElementById ("second-order").value;
+ localStorage["TRelStrucExplSOF"+name] = phi;
+ list_stored_so ();
+}
+
+function load_struc (name) {
document.getElementById ("struc-name").value = name;
document.getElementById ("no-elems-start").value =
localStorage["TRelStrucExplEl1"+name];
@@ -280,7 +295,14 @@
draw_it ();
}
-function list_stored () {
+function load_so (name) {
+ document.getElementById ("so-name").value = name;
+ document.getElementById ("second-order").value =
+ localStorage["TRelStrucExplSOF"+name];
+ find_draw_it ();
+}
+
+function list_stored_struc () {
var saved = document.getElementById("saved-strucs");
while (saved.childNodes.length > 0) { saved.removeChild(saved.firstChild); }
for (var i=0; i < localStorage.length; i++) {
@@ -288,55 +310,109 @@
if (k.substring (0, 16) === "TRelStrucExplEl1") {
var n = k.substring (16, k.length);
var li = document.createElement('li');
- li.innerHTML = '<button class="obt" onclick="load('+ "'"+ n +"'" +')">' +
- n +'</button> (<button class="obt" onclick="del_saved('+ "'"+ n +
+ li.innerHTML ='<button class="obt" onclick="load_struc('+"'"+ n +"'"+')">'
+ + n +'</button> (<button class="obt" onclick="del_struc('+ "'"+ n +
"'" +')" title="Delete this structure.">-</button>)';
saved.appendChild (li);
}
}
}
-function del_saved (name) {
+function list_stored_so () {
+ var saved = document.getElementById("saved-so");
+ while (saved.childNodes.length > 0) { saved.removeChild(saved.firstChild); }
+ for (var i=0; i < localStorage.length; i++) {
+ var k = localStorage.key(i);
+ if (k.substring (0, 16) === "TRelStrucExplSOF") {
+ var n = k.substring (16, k.length);
+ var li = document.createElement('li');
+ li.innerHTML ='<button class="obt" onclick="load_so('+"'"+ n +"'"+')">'
+ + n +'</button> (<button class="obt" onclick="del_so('+ "'"+ n +
+ "'" +')" title="Delete this formula.">-</button>)';
+ saved.appendChild (li);
+ }
+ }
+}
+
+function list_stored () {
+ list_stored_struc ();
+ list_stored_so ();
+}
+
+function del_so (name) {
+ localStorage.removeItem("TRelStrucExplSOF"+name);
+ list_stored_so ();
+}
+
+function del_struc (name) {
localStorage.removeItem("TRelStrucExplEl1"+name);
localStorage.removeItem("TRelStrucExplEl2"+name);
localStorage.removeItem("TRelStrucExplRel"+name);
localStorage.removeItem("TRelStrucExplPos"+name);
- list_stored ();
+ list_stored_struc ();
}
-function toggle_edit () {
+function toggle_edit_view () {
var bt = document.getElementById("editbt");
if (bt.innerHTML == "Edit") {
document.getElementById('edit').style.display = 'block';
- document.getElementById('board-left').style.left = '38em';
- bt.innerHTML = "Hide Edit";
+ document.getElementById('board-left').style.display = 'none';
+ bt.innerHTML = "View";
} else {
document.getElementById('edit').style.display = 'none';
- document.getElementById('board-left').style.left = '2em';
+ document.getElementById('board-left').style.display = 'block';
bt.innerHTML = "Edit";
}
}
-function toggle_view () {
- var bt = document.getElementById("viewbt");
- if (bt.innerHTML == "View") {
- document.getElementById('board-left').style.display = 'block';
- bt.innerHTML = "Hide View";
- } else {
- document.getElementById('board-left').style.display = 'none';
- bt.innerHTML = "View";
- }
-}
-
function adjust_to_width () {
var e = document.getElementById ("edit");
var em_size =
document.defaultView.getComputedStyle(e,null).getPropertyValue('font-size');
var em_size_int = parseInt (em_size.substring (0, em_size.length - 2));
- if (window.innerWidth > 80 * em_size_int) { // enough space for edit
- toggle_edit ()
+ if (window.innerWidth > 80 * em_size_int) { // enough space for view
+ document.getElementById('board-left').style.left = '35em';
+ document.getElementById('board-left').style.display = 'block';
+ document.getElementById('editbt').style.display = 'none';
}
}
+
+function put_msg (content, time) {
+ document.getElementById("working").innerHTML = content;
+ document.getElementById ("working").style.display = "block";
+ setTimeout (function () {
+ document.getElementById ("working").style.display = "none";
+ }, time);
+}
+
+function show_help () {
+ document.getElementById ("working").style.textAlign = "left";
+ document.getElementById ("working").style.fontWeight = "normal";
+ document.getElementById("working").innerHTML = '\
+<b>Welcome to Relational Structures Explorer</b> \
+<p><b>Relational structures</b> consist of a set of <em>elements</em> and \
+of <em>relations</em> defined by <em>formulas</em>.</p> \
+<p><b>Elements</b> are numbered. You can change their range and you can access \
+the number of the element corresponding to a variable <em>x</em> in a formula \
+by writing <em>&x</em> or <em>:nbr(x)</em>.</p> \
+<p><b>Formulas</b> are written in first-order logic. You can use relation \
+symbols, Boolean combinations and quantifiers. Additionally, you can use \
+arithmetic operations (+-*/^) on element numbers and element positions.</p> \
+<p><b>Positions</b> of elements are determined by their <em>x</em> and \
+<em>y</em> coordinates. Define and access them as in <b>:x(a)</b> and \
+<b>:y(a)</b>. You can again use arithmetic operations and also conditionals \
+on formulas, written <b>:(formula)</b>.</p> \
+<p><b>Relation Finder</b>, placed at the bottom, automatically finds relations \
+that satisfy the given property. Use <b>|</b> in front of the relation symbol \
+to be found, as in <b>|R(x)</b>.</p> \
+';
+ document.getElementById ("working").style.display = "block";
+ setTimeout (function () {
+ document.getElementById ("working").style.display = "none";
+ document.getElementById ("working").style.textAlign = "center";
+ document.getElementById ("working").style.fontWeight = "bold";
+ }, 20000);
+}
//-->
</script>
</head>
@@ -353,12 +429,12 @@
<span style="position: relative; left: 2em; top: 0.5em; font-size: 1.2em">
Relational Structures Explorer</span>
<span id="toprighttab" style="display: block;">
- <button class="obt" id="editbt" onclick="toggle_edit()">Edit</button>
- <button class="obt" id="viewbt" onclick="toggle_view()">Hide View</button>
+ <button class="obt" id="editbt" onclick="toggle_edit_view()">View</button>
+ <button class="obt" id="editbt" onclick="show_help()">Help</button>
</span>
</div>
-<div id="board-left">
+<div id="board-left" style="display: none;">
<canvas id="canvas" height="1100" width="1100"
onmouseup="mouseup_handle(event)"
onmousedown="mousedown_handle(event)"
@@ -370,72 +446,118 @@
</canvas>
</div>
-<div id="edit" style="position: absolute; top: 4em; left: 2em; display: none">
+<div id="working" style="display: none; width: 30em;"></div>
+<div id="edit" style="position: absolute; top: 4em; left: 2em;">
+
<p>Name
- <input id="struc-name" type="text" size="20" value="MyStructure1"
- style="width: 10em"></input>
- <button class="ebt" onclick="save()">Save</button>
+ <input id="struc-name" type="text" size="20" value="My Structure 1"
+ style="width: 12em"></input>
+ <span style="position: absolute; right: 2px;">
+ <button class="ebt" style="width: 4em;" title="Save current structure."
+ onclick="save_struc()">Save</button>
+ </span>
</p>
<p>Elements
<input id="no-elems-start" type="text" size="2" value="1"
- style="width: 2em"></input> —
+ style="width: 4em"></input> —
<input id="no-elems-end" type="text" size="4" value="15"
- style="width: 2em"></input>
- <button class="ebt" onclick="add_elem()">+</button>
- <button class="ebt" onclick="del_elem()">-</button>
+ style="width: 4em"></input>
+ <span style="position: absolute; right: 2px;">
+ <button class="ebt" style="width: 2em;" title="Remove last element."
+ onclick="del_elem()">-</button><button title="Add one element."
+ style="width: 2em;" class="ebt" onclick="add_elem()">+</button>
+ </span>
</p>
-<p>Relations
- <button class="ebt" title="Conjunction. You can also write 'and' or '&'."
- onclick="add_field('relations', '∧')">∧</button>
- <button class="ebt" title="Disjunction. You can also write 'or' or '|'."
- onclick="add_field('relations', '∨')">∨</button>
- <button class="ebt" title="Negation. You can also write 'not'."
- onclick="add_field('relations', '¬')">¬</button>
- <button class="ebt" title="Implication. You can also write '->'."
- onclick="add_field('relations', '→')">→</button>
- <button title="Existential Quantifier. You can also write 'ex' or '\E'."
- class="ebt" onclick="add_field('relations', '∃')">∃</button>
- <button title="Universal Quantifier. You can also write 'all' or '\A'."
- class="ebt" onclick="add_field('relations', '∀')">∀</button>
- <button class="ebt" onclick="draw_it()">Redraw</button>
+<p>Relations
+ <span style="position: absolute; right: 2px;">
+ <button class="ebts" title="Not equal. You can also write '<>' or '!='."
+ onclick="add_field('relations', '≠')">≠</button><button
+ class="ebts" title="Less or equal. You can also write '=<'."
+ onclick="add_field('relations', '≤')">≤</button><button
+ class="ebts" title="Conjunction. You can also write 'and' or '&'."
+ onclick="add_field('relations', '∧')">∧</button><button
+ class="ebts" title="Disjunction. You can also write 'or' or '|'."
+ onclick="add_field('relations', '∨')">∨</button><button
+ class="ebts" title="Negation. You can also write 'not'."
+ onclick="add_field('relations', '¬')">¬</button><button
+ class="ebts" title="Implication. You can also write '->'."
+ onclick="add_field('relations', '→')">→</button><button
+ title="Existential Quantifier. You can also write 'ex' or '\E'."
+ class="ebts" onclick="add_field('relations', '∃')">∃</button><button
+ title="Universal Quantifier. You can also write 'all' or '\A'."
+ class="ebts" onclick="add_field('relations', '∀')">∀</button>
+ <button class="ebt" onclick="draw_it()" style="width: 4em;"
+ title="Redraw current structure.">Draw</button>
+ </span>
</p>
-<textarea id="relations" rows="3" cols="70">
+<textarea id="relations" rows="3" cols="60">
E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)
</textarea>
-<p>Positions
- <button class="ebt" onclick="add_field('positions', '+')">+</button>
- <button class="ebt" onclick="add_field('positions', '-')">-</button>
- <button class="ebt" onclick="add_field('positions', '·')">·</button>
- <button class="ebt" onclick="add_field('positions', '/')">/</button>
- <button class="ebt" onclick="add_field('positions', '^')">^</button>
- <button class="ebt" onclick="draw_it()">Redraw</button>
+<p>Positions
+ <span style="position: absolute; right: 2px;">
+ <button class="ebts" title="Not equal. You can also write '<>' or '!='."
+ onclick="add_field('positions', '≠')">≠</button><button
+ class="ebts" title="Less or equal. You can also write '=<'."
+ onclick="add_field('positions', '≤')">≤</button><button
+ class="ebts" title="Conjunction. You can also write 'and' or '&'."
+ onclick="add_field('positions', '∧')">∧</button><button
+ class="ebts" title="Disjunction. You can also write 'or' or '|'."
+ onclick="add_field('positions', '∨')">∨</button><button
+ class="ebts" title="Negation. You can also write 'not'."
+ onclick="add_field('positions', '¬')">¬</button><button
+ class="ebts" title="Implication. You can also write '->'."
+ onclick="add_field('positions', '→')">→</button><button
+ title="Existential Quantifier. You can also write 'ex' or '\E'."
+ class="ebts" onclick="add_field('positions', '∃')">∃</button><button
+ title="Universal Quantifier. You can also write 'all' or '\A'."
+ class="ebts" onclick="add_field('positions', '∀')">∀</button>
+ <button class="ebt" onclick="draw_it()" style="width: 4em;"
+ title="Redraw current structure.">Draw</button>
+ </span>
</p>
-
-<textarea id="positions" rows="3" cols="70">
+<textarea id="positions" rows="3" cols="60">
:x(a) = &a;
:y(a) = &a · (10 - &a) / 10
</textarea>
-<p>Second-Order Finder
- <button class="ebt" title="Conjunction. You can also write 'and' or '&'."
- onclick="add_field('second-order', '∧')">∧</button>
- <button class="ebt" title="Disjunction. You can also write 'or' or '|'."
- onclick="add_field('second-order', '∨')">∨</button>
- <button class="ebt" title="Negation. You can also write 'not'."
- onclick="add_field('second-order', '¬')">¬</button>
- <button class="ebt" title="Implication. You can also write '->'."
- onclick="add_field('second-order', '→')">→</button>
- <button title="Existential Quantifier. You can also write 'ex' or '\E'."
- class="ebt" onclick="add_field('second-order', '∃')">∃</button>
- <button title="Universal Quantifier. You can also write 'all' or '\A'."
- class="ebt" onclick="add_field('second-order', '∀')">∀</button>
- <button class="ebt" onclick="find_draw_it()">Find</button>
+
+<p style="width:100%; border-top: 1px solid; padding-top: 1em;">
+ Formula Name
+ <input id="so-name" type="text" size="20" value="My Formula 1"
+ style="width: 12em"></input>
+ <span style="position: absolute; right: 2px;">
+ <button class="ebt" onclick="save_so()" title="Save current formula."
+ style="width: 4em;">Save</button>
+ </span>
</p>
-<textarea id="second-order" rows="3" cols="70">
+
+<p>Formula
+ <span style="position: absolute; right: 2px;">
+ <button class="ebts" title="Not equal. You can also write '<>' or '!='."
+ onclick="add_field('second-order', '≠')">≠</button><button
+ class="ebts" title="Less or equal. You can also write '=<'."
+ onclick="add_field('second-order', '≤')">≤</button><button
+ class="ebts" title="Conjunction. You can also write 'and' or '&'."
+ onclick="add_field('second-order', '∧')">∧</button><button
+ class="ebts" title="Disjunction. You can also write 'or' or '|'."
+ onclick="add_field('second-order', '∨')">∨</button><button
+ class="ebts" title="Negation. You can also write 'not'."
+ onclick="add_field('second-order', '¬')">¬</button><button
+ class="ebts" title="Implication. You can also write '->'."
+ onclick="add_field('second-order', '→')">→</button><button
+ title="Existential Quantifier. You can also write 'ex' or '\E'."
+ class="ebts" onclick="add_field('second-order', '∃')">∃</button><button
+ title="Universal Quantifier. You can also write 'all' or '\A'."
+ class="ebts" onclick="add_field('second-order', '∀')">∀</button>
+ <button class="ebt" onclick="find_draw_it()" style="width: 4em;"
+ title="Find relations that satisfy the formula.">Find</button>
+ </span>
+</p>
+<textarea id="second-order" rows="3" cols="60">
</textarea>
</div>
@@ -454,10 +576,16 @@
<li><button class="obt" onclick="example_heart()">Heart Drawing</button></li>
</ul>
-<p>Second-Order Formulas</p>
+<p style="border-top: 1px solid; padding-top: 1em">Your Formulas</p>
+<ul id="saved-so" style="list-style: square; margin-left: -1.5em">
+<li>Nothing here yet</li>
+</ul>
+
+<p>Examples</p>
<ul style="list-style: square; margin-left: -1.5em">
<li><button class="obt" onclick="example_2col()">2-coloring</button></li>
<li><button class="obt" onclick="example_3col()">3-coloring</button></li>
+<li><button class="obt" onclick="example_matching()">Matching</button></li>
</ul>
</div>
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -626,11 +626,11 @@
| _ -> raise (FormulaError "Clauses must not contain non-literals!") in
let list_of_clause = function
| BVar v -> [v]
- | BOr (bflist) -> List.map int_of_literal bflist
+ | BOr (bflist) -> List.rev_map int_of_literal bflist
| _ -> raise (FormulaError "This is not a clause!") in
match phi with
| BVar v -> [[v]]
- | BAnd (bflist) -> List.map list_of_clause bflist
+ | BAnd (bflist) -> List.rev_map list_of_clause bflist
| _ -> raise (FormulaError "This is not a CNF!")
Modified: trunk/Toss/README
===================================================================
--- trunk/Toss/README 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/README 2012-07-05 00:25:38 UTC (rev 1742)
@@ -18,7 +18,8 @@
* AUTHORS
The current version of Toss is developed by
-- Łukasz Kaiser (ka...@li...)
+- Łukasz Kaiser (luk...@gm...)
+- Faried Abu Zaid
- Łukasz Stafiniak
Many other friends helped us with discussion and code at some point.
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Solver/Solver.ml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -429,17 +429,17 @@
(QAnd [], [])
else (QOr [], [])
| And phil ->
- let resl = (List.map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
- let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
- let dictl = (List.map snd resl) in
+ let resl = (List.rev_map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
+ let qphil = (Aux.unique_sorted (List.rev_map (fst) resl)) in
+ let dictl = List.fold_left (fun a (_,l) -> List.rev_append l a) [] resl in
(try (List.find (fun x -> x = QOr []) qphil, [])
- with Not_found -> (make_conj qphil, List.concat dictl) )
+ with Not_found -> (make_conj qphil, dictl) )
| Or phil ->
- let resl = (List.map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
- let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
- let dictl = (List.map (snd) resl) in
+ let resl = (List.rev_map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
+ let qphil = (Aux.unique_sorted (List.rev_map (fst) resl)) in
+ let dictl = List.fold_left (fun a (_,l) -> List.rev_append l a) [] resl in
(try (List.find (fun x -> x = QAnd []) qphil, [])
- with Not_found -> (make_disj qphil, List.concat dictl)
+ with Not_found -> (make_disj qphil, dictl)
)
| Not phi ->
let (qphi, dict) = so_to_qbf_rec asgn phi in
@@ -448,12 +448,12 @@
else (QNot qphi, dict)
| Ex ([], phi) -> so_to_qbf_rec asgn phi
| Ex (var::tl, phi) when is_fo var ->
- let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) elems in
- let res = List.map (fun x -> so_to_qbf_rec x (Ex (tl, phi))) asgn_list in
- let (qphil, dictl) =
- ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res) in
+ let asgn_l = List.rev_map (fun x -> (Formula.to_fo var, x)::asgn) elems in
+ let res = List.rev_map (fun x -> so_to_qbf_rec x (Ex (tl, phi))) asgn_l in
+ let qphil = Aux.unique_sorted (List.rev_map fst res) in
+ let dictl = List.fold_left (fun a (_,l) -> List.rev_append l a) [] res in
(try (List.find (fun x -> x = QAnd []) qphil, [])
- with Not_found ->(make_disj qphil, List.concat dictl)
+ with Not_found -> (make_disj qphil, dictl)
)
| Ex (var::tl, phi) when is_so var ->
let (qbf_phi, dict_phi) = (so_to_qbf_rec asgn (Ex (tl, phi))) in
@@ -466,12 +466,12 @@
| Ex (var::tl, phi) -> (*stub*) failwith "not implemented yet (so_qbf_Ex)"
| All ([], phi) -> so_to_qbf_rec asgn phi
| All (var::tl, phi) when is_fo var ->
- let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) elems in
- let res = List.map (fun x -> so_to_qbf_rec x (All (tl, phi))) asgn_list in
- let (qphil, dictl) =
- ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res) in
+ let asgn_l = List.rev_map (fun x -> (Formula.to_fo var, x)::asgn) elems in
+ let res = List.rev_map (fun x ->so_to_qbf_rec x (All (tl, phi))) asgn_l in
+ let qphil = Aux.unique_sorted (List.rev_map fst res) in
+ let dictl = List.fold_left (fun a (_,l) -> List.rev_append l a) [] res in
(try (List.find (fun x -> x = (QOr [])) qphil, [])
- with Not_found -> (make_conj qphil, List.concat dictl)
+ with Not_found -> (make_conj qphil, dictl)
)
| All (var::tl, phi) when is_so var ->
let (qbf_phi, dict_phi) = so_to_qbf_rec asgn (All (tl, phi)) in
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/Solver/SolverTest.ml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -179,17 +179,13 @@
(BoolFormula.qbf_str ~names:names_tbl qbf_res) in
qbf_str_eq "[ a, b | T { a } | ]" "ex |R all x, y (T(x) or |R (x, y))"
- "(ex R.2.1, R.2.2 (R.2.1 and R.2.2))";
+ "(ex R.2.2, R.2.1 (R.2.2 and R.2.1))";
qbf_str_eq "[ a, b | T { a } | ]"
"all |Q all x, y (T(x) or Q(y) or (x = y))" "false";
qbf_str_eq "[ a, b, c | E { (a,b); (b,c); (c,a) } | ]"
("ex |R, |G all x, y ( (|R(x) or |G(x)) and (" ^
" E(x,y) -> not ( (|R(x) and |R(y)) " ^ " or (|G(x) and |G(y)))))")
- ("(ex R.1, R.2, R.3 (ex G.1, G.2, G.3 ((R.1 or G.1) and (R.1 or G.1) " ^
- "and (not ((R.1 and R.2) or (G.1 and G.2))) and (R.2 or G.2) and " ^
- "(R.2 or G.2) and (not ((R.2 and R.3) or (G.2 and G.3))) and " ^
- "(R.3 or G.3) and (R.3 or G.3) and " ^
- "(not ((R.1 and R.3) or (G.1 and G.3))))))");
+ ("(ex R.3, R.2, R.1 (ex G.3, G.2, G.1 ((R.3 or G.3) and (R.3 or G.3) and (not ((R.3 and R.1) or (G.3 and G.1))) and (R.2 or G.2) and (R.2 or G.2) and (not ((R.3 and R.2) or (G.3 and G.2))) and (R.1 or G.1) and (R.1 or G.1) and (not ((R.2 and R.1) or (G.2 and G.1))))))");
let col3 =
("all x, y ( (|R(x) or |G(x) or |B(x)) and (" ^
@@ -198,7 +194,7 @@
let triangle = "[ | E { (a, b); (b, c); (c, a) } | ] " in
let (col3,triangle) = (formula_of_string col3,struc_of_string triangle) in
assert_equal ~printer:(fun x -> x)
- "[a, b, c | E {(a, b); (b, c); (c, a)}; |B (c); |G (b); |R (a) | ]"
+ "[a, b, c | E {(a, b); (b, c); (c, a)}; |B (a); |G (b); |R (c) | ]"
(Structure.str (fst (Solver.find_so triangle col3)));
);
Modified: trunk/Toss/www/contact.xml
===================================================================
--- trunk/Toss/www/contact.xml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/www/contact.xml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -80,9 +80,10 @@
<section title="Team">
<par>Toss originates from our work in the
<a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a> research group.
- Many people contributed, here we name just a few. Current leaders:</par>
+ Many people contributed, here we name just a few. Currently working:</par>
<itemize>
<item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item>
+ <item>Faried Abu Zaid</item>
<item>Łukasz Stafiniak</item>
</itemize>
<par>Friends who helped us a lot with discussion and code.</par>
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-07-03 23:55:21 UTC (rev 1741)
+++ trunk/Toss/www/index.xml 2012-07-05 00:25:38 UTC (rev 1742)
@@ -35,14 +35,22 @@
<section title="News">
<itemize>
+ <newsitem date="04/07/12">
+ First version of Relational Structures Explorer with SO finding</newsitem>
+ <newsitem date="27/06/12">
+ Second-order (SO) evaluation by reduction to QBF</newsitem>
+ <newsitem date="25/06/12">
+ Full support for Unicode in formulas</newsitem>
<newsitem date="07/06/12">
Switching to a new ODE solver which uses the Cash-Karp method</newsitem>
<newsitem date="02/06/12">
- Starting work on an interface for structures and formula evaluation</newsitem>
- <newsitem date="27/05/12">
- First structures defined using the term rewriting system syntax</newsitem>
- <newsitem date="24/05/12">
- Code for Term functions cleaned up and made JS compatible</newsitem>
+ Starting work on an interface for structures and formula
+ evaluation</newsitem>
+ <oldnewsitem date="27/05/12">
+ First structures defined using the term rewriting system
+ syntax</oldnewsitem>
+ <oldnewsitem date="24/05/12">
+ Code for Term functions cleaned up and made JS compatible</oldnewsitem>
<oldnewsitem date="13/05/12">
Toss release 0.8 with full JS compatibility with dynamics</oldnewsitem>
<oldnewsitem date="04/05/12">
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-03 23:55:28
|
Revision: 1741
http://toss.svn.sourceforge.net/toss/?rev=1741&view=rev
Author: lukaszkaiser
Date: 2012-07-03 23:55:21 +0000 (Tue, 03 Jul 2012)
Log Message:
-----------
Second-order eval debugging and interface.
Modified Paths:
--------------
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/Drawing.mli
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/eval.html
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Client/Drawing.ml 2012-07-03 23:55:21 UTC (rev 1741)
@@ -33,31 +33,42 @@
let sina, cosa = sin a, cos a in
{ x = q.x *. cosa -. q.y *. sina ; y = q.x *. sina +. q.y *. cosa } +: start
+(* Colors in RBGA format. *)
+type color = { red: int; blue: int; green: int; alpha: int }
+let defaultCFill = { red=255 ; green = 228 ; blue = 170 ; alpha = 0 }
+let defaultCStroke = { red=38 ; green = 3 ; blue = 20 ; alpha = 0 }
+let defaultCRed = {red=242 ; green=92 ; blue=5 ; alpha = 0 }
+let defaultCGreen = {red=62 ; green=89 ; blue=24 ; alpha = 0 }
+let defaultCBlue = {red=165 ; green=175 ; blue=170 ; alpha = 0 }
+
+let color_to_hex c =
+ Printf.sprintf "%s%.2x%.2x%.2x" "#" c.red c.green c.blue
+
(* Various shapes. *)
type shape =
- | Circle of point * point (* circle, given middle and radiuses *)
- | Line of point * point (* line, given from and to *)
+ | Circle of point * point * color (* circle, given middle and radiuses *)
+ | Line of point * point * color (* line, given from and to *)
let shape_str = function
- | Circle (p, r) -> Printf.sprintf "circle (%F, %F) r (%F, %F)" p.x p.y r.x r.y
- | Line (f, t) -> Printf.sprintf "line (%F, %F) -- (%F, %F)" f.x f.y t.x t.y
+ | Circle (p,r,_)-> Printf.sprintf "circle (%F, %F) r (%F, %F)" p.x p.y r.x r.y
+ | Line (f,t,_) -> Printf.sprintf "line (%F, %F) -- (%F, %F)" f.x f.y t.x t.y
let shapes_str l = String.concat "; " (List.map shape_str l)
(* Shift a shape by [x]. *)
let shift_shape x = function
- | Circle (p, r) -> Circle (p +: x, r)
- | Line (f, t) -> Line (f +: x, t +: x)
+ | Circle (p, r, c) -> Circle (p +: x, r, c)
+ | Line (f, t, c) -> Line (f +: x, t +: x, c)
let shift_shapes x l = List.map (shift_shape x) l
(* Change coordinates in a shape. *)
let change_coords_shape c1 c2 = function
- | Circle (p, r) ->
+ | Circle (p, r, c) ->
let z = {x=0.; y=0.} in
- Circle (change_coords c1 c2 p, change_coords (z, snd c1) (z, snd c2) r)
- | Line (f, t) -> Line (change_coords c1 c2 f, change_coords c1 c2 t)
+ Circle (change_coords c1 c2 p, change_coords (z, snd c1) (z, snd c2) r, c)
+ | Line (f, t, c) -> Line (change_coords c1 c2 f, change_coords c1 c2 t, c)
let change_coords_shapes c1 c2 l = List.map (change_coords_shape c1 c2) l
@@ -69,7 +80,7 @@
(* Calculate where the line [p] -- [q] crosses the shape. *)
let crossing p q = function
- | Circle (m, r) ->
+ | Circle (m, r, _) ->
let norm_coord pt = change_coords (m, r) ({x=0.;y=0.}, {x=1.;y=1.}) pt in
let back_coord pt = change_coords ({x=0.;y=0.}, {x=1.;y=1.}) (m, r) pt in
let p, q = norm_coord p, norm_coord q in
@@ -89,19 +100,19 @@
let xs = quadratic (1. +. d*.d) (2.*.d*.c) (c*.c -. 1.) in
List.map (fun x -> { x = x ; y = d *. (x -. p.x) +. p.y }) xs ) in
List.map back_coord c
- | Line (f, t) -> failwith "crossing not yet implemented for lines"
+ | Line (f, t, _) -> failwith "crossing not yet implemented for lines"
let crossings p q l = Aux.concat_map (crossing p q) l
(* Maximal distance of shape points from (0, 0). *)
let radius_single = function
- | Circle (p, r) -> dist p {x=0.;y=0.} +. (max r.x r.y) (* FIXME *)
- | Line (f, t) -> max (dist f {x=0.;y=0.}) (dist t {x=0.;y=0.})
+ | Circle (p, r, _) -> dist p {x=0.;y=0.} +. (max r.x r.y) (* FIXME *)
+ | Line (f, t, _) -> max (dist f {x=0.;y=0.}) (dist t {x=0.;y=0.})
let radius l = List.fold_left max 0. (List.rev_map radius_single l)
(* Create an arrow from x to y given the shapes of x and y. *)
-let arrow (x, shapes_x) (y, shapes_y) =
+let arrow c (x, shapes_x) (y, shapes_y) =
let len = dist x y in
if len < 0.1 then [] else (
let pl, ql = crossings x y shapes_x, crossings x y shapes_y in
@@ -112,7 +123,8 @@
let p = if pl = [] then x else List.hd pl in
let q = if ql = [] then y else List.hd ql in
let tip = q -: ((y -: q) *! 0.5) in
- [ Line (p, q); Line (q, rotate q 30. tip); Line (q, rotate q (-30.) tip) ]
+ [ Line (p, q, c); Line (q, rotate q 30. tip, c);
+ Line (q, rotate q (-30.) tip, c) ]
)
(* Structure with coordinates for drawing on canvas. *)
@@ -162,7 +174,7 @@
let circles = Structure.rel_graph "Circle" struc in
let radius e =
{x = Structure.fun_val struc "rx" e; y = Structure.fun_val struc "ry" e} in
- let circ e = Circle (get_pos struc e, radius e) in
+ let circ e = Circle (get_pos struc e, radius e, defaultCFill) in
List.map (fun e -> circ e.(0)) (Structure.Tuples.elements circles)
(* Draw an element of a structure with coordinates. *)
@@ -190,29 +202,34 @@
let draw_rel (rel, arity) =
if arity = 1 then
let elems = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.})]) elems
+ let col = match rel with | "|R" -> defaultCRed | "|G" -> defaultCGreen
+ | "|B" -> defaultCBlue | _ -> defaultCFill in
+ Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.}, col)]) elems
else if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- Aux.concat_map (fun a-> arrow (pos_draw a.(0)) (pos_draw a.(1))) tuples
+ Aux.concat_map (fun a ->
+ arrow defaultCStroke (pos_draw a.(0)) (pos_draw a.(1))) tuples
else [] in
elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
(* Compile the shape to a JavaScript program drawing the shape on 'ctx'. *)
let shape_to_canvas = function
- | Circle (p, r) ->
+ | Circle (p, r, col) ->
+ let fill = "ctx.fillStyle = \""^(color_to_hex col)^"\"; ctx.fill();" in
if r.x = r.y then
let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r.x
- in "ctx.beginPath(); "^ s^"ctx.fill(); ctx.stroke(); ctx.closePath(); "
+ in "ctx.beginPath(); "^ s ^ fill ^ " ctx.stroke(); ctx.closePath(); "
else
let sc = Printf.sprintf "ctx.scale(%F, %F); " (r.x /.100.) (r.y /.100.) in
let tr = Printf.sprintf "ctx.translate(%F, %F); " p.x p.y in
"ctx.save(); "^ tr ^sc ^"ctx.beginPath(); ctx.arc(0,0,100,0,2*Math.PI); "^
- "ctx.stroke(); ctx.closePath(); ctx.restore(); "
- | Line (f, t) ->
+ fill ^ "ctx.stroke(); ctx.closePath(); ctx.restore(); "
+ | Line (f, t, col) ->
let fs = Printf.sprintf "ctx.moveTo(%F,%F); " f.x f.y in
let ts = Printf.sprintf "ctx.lineTo(%F,%F); " t.x t.y in
- "ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); ctx.closePath(); "
+ let stroke= "ctx.strokeStyle = \""^(color_to_hex col)^"\"; ctx.stroke();" in
+ "ctx.beginPath(); " ^ fs ^ ts ^ stroke ^ " ctx.closePath(); "
let shapes_to_canvas l =
String.concat " " (List.rev (List.rev_map shape_to_canvas l))
Modified: trunk/Toss/Client/Drawing.mli
===================================================================
--- trunk/Toss/Client/Drawing.mli 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Client/Drawing.mli 2012-07-03 23:55:21 UTC (rev 1741)
@@ -24,11 +24,13 @@
(** Rotate the point [p] around [start] by [angle]. *)
val rotate : point -> float -> point -> point
+(** Colors in RBGA format. *)
+type color = { red: int; blue: int; green: int; alpha: int }
(** Shapes. *)
type shape =
- | Circle of point * point (** circle, given middle and radiuses *)
- | Line of point * point (** line, given from and to *)
+ | Circle of point * point * color (** circle, given middle and radiuses *)
+ | Line of point * point * color (** line, given from and to *)
(** Print shapes. *)
val shapes_str : shape list -> string
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Client/JsEval.ml 2012-07-03 23:55:21 UTC (rev 1741)
@@ -40,37 +40,17 @@
| _ -> failwith "not a structure"
-(* The Formula evaluation and registration in JS. *)
-let js_eval phi struc =
- let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
- let (f, struc) = (formula_of_string phi, structure_of_string struc) in
- Js.string (AssignmentSet.named_str struc (Solver.M.evaluate struc f))
-
-
-(*
-let js_eval_so phi struc =
- let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
- let (f, struc) = (formula_of_string phi, structure_of_string struc) in
- let qbf = (Solver.so_to_qbf struc f) in
- let sat = (Solver.elim_quant_naiv qbf) in
- LOG 0 "Formula: %s" (Formula.str f);
- LOG 0 "QBF Formula: %s" (BoolFormula.qbf_str qbf);
- LOG 0 "SAT Formula: %s" (BoolFormula.str sat);
- Js.string (AssignmentSet.named_str struc (Solver.eval_so struc f))
-*)
-
-let _ = set_handle "eval" js_eval
-
-
-
-
(* Drawing the structure. *)
-let draw_struc_js struc_s =
- let st = structure_of_string (Js.to_string struc_s) in
+let draw_struc_js so_s struc_s =
+ let st, so = structure_of_string (Js.to_string struc_s), Js.to_string so_s in
+ let st, so_res = if Aux.strip_spaces so = "" then (st, "none") else
+ let so_phi = formula_of_string so in
+ let st, res = Solver.find_so st so_phi in
+ if res then st, "true" else st, "false" in
let st_c = Drawing.add_coords 1000. 1000. 50. 50. None None st in
cur_st := st_c;
let draw = Drawing.shapes_to_canvas (Drawing.draw_struc st_c) in
- Js.string ("clear_canvas (); " ^ draw)
+ Js.array [|Js.string ("clear_canvas (); " ^ draw) ; Js.string so_res |]
let _ = set_handle "draw_struc" draw_struc_js
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Client/eval.html 2012-07-03 23:55:21 UTC (rev 1741)
@@ -48,19 +48,33 @@
ctx.clearRect(0, 0, canvas.width, canvas.height);
}
-function eval_it () {
+function draw_it () {
var rels = document.getElementById ("relations").value;
var pos = document.getElementById ("positions").value;
var elemsF = document.getElementById ("no-elems-start").value;
var elemsT = document.getElementById ("no-elems-end").value;
var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with " +
rels + " with " + pos;
- ASYNCH ("draw_struc", [struc], true, function (s) {
+ ASYNCH ("draw_struc", ["", struc], true, function (a) {
var ctx = document.getElementById("canvas").getContext("2d");
- eval (s);
+ eval (a[0])
})
}
+function find_draw_it () {
+ var rels = document.getElementById ("relations").value;
+ var pos = document.getElementById ("positions").value;
+ var elemsF = document.getElementById ("no-elems-start").value;
+ var elemsT = document.getElementById ("no-elems-end").value;
+ var so = document.getElementById ("second-order").value;
+ var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with " +
+ rels + " with " + pos;
+ ASYNCH ("draw_struc", [so, struc], true, function (a) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (a[0]);
+ alert (a[1])
+ })
+}
function canvasCoords (eventPageX, eventPageY) { // From stackoverflow.com
var totalOffsetX = 0;
@@ -157,11 +171,11 @@
function example_primes () {
document.getElementById ("struc-name").value = "Prime Numbers";
document.getElementById ("relations").value =
- "P(z) = &z > 1 and ∀ x, y \n (&x · &y = &z → (&x = 1 ∨ &y = 1))";
+ "P(z) = &z > 1 and ∀ x,y \n (&x · &y = &z → (&x = 1 ∨ &y = 1))";
document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = 0";
document.getElementById ("no-elems-start").value = "1";
document.getElementById ("no-elems-end").value = "10";
- eval_it ();
+ draw_it ();
}
function example_tc () {
@@ -172,7 +186,7 @@
document.getElementById("positions").value=":x(a) = 5·&a;\n:y(a) = &a·&a / 2";
document.getElementById ("no-elems-start").value = "1";
document.getElementById("no-elems-end").value = "4";
- eval_it ();
+ draw_it ();
}
function example_basic () {
@@ -183,19 +197,21 @@
":y(a) = &a · (10 - &a) / 10";
document.getElementById ("no-elems-start").value = "1";
document.getElementById ("no-elems-end").value = "15";
- eval_it ();
+ draw_it ();
}
+function example_2col () {
+ document.getElementById ("second-order").value =
+ "∀ x,y ( (|R(x) ∨ |G(x)) ∧ ( E(x,y) → " +
+ "\n ¬( (|R(x) ∧ |R(y)) ∨ (|G(x) ∧ |G(y)) ) ) )";
+ find_draw_it ();
+}
+
function example_3col () {
- document.getElementById ("formula").value =
- "ex |R, |G, |B all x, y ( \n ( |R(x) or |G(x) or |B(x)) and (" +
- "\n E(x,y) -> not ( ( |R(x) and |R(y)) " +
- "\n or (|G(x) and |G(y)) or (|B(x) and |B(y)) ) ) )";
- document.getElementById ("structure").value =
- "[ | E { (a, b); (b, c); (c, a) } | " +
- "\n x { a -> 1, b -> 2, c -> 3 }; " +
- "\n y { a -> 0, b -> -1, c -> 0 } ]";
- eval_it ();
+ document.getElementById ("second-order").value =
+ "∀ x,y ( ( |R(x) ∨ |G(x) ∨ |B(x)) ∧ ( E(x,y) → " +
+ "\n ¬( (|R(x) ∧ |R(y)) ∨ (|G(x) ∧ |G(y)) ∨ (|B(x) ∧ |B(y)) ) ) )";
+ find_draw_it ();
}
function example_heart () {
@@ -211,28 +227,31 @@
" :(&a > 18) · (:(:b ≤ 10) ·:b · (10 - :b) / 10 - :(:b > 10)·(:b - 10))";
document.getElementById ("no-elems-start").value = "1";
document.getElementById ("no-elems-end").value = "37";
- eval_it ();
+ draw_it ();
}
function add_field (field, s) {
var e = document.getElementById(field);
var cursor = e.selectionStart;
+ var selEnd = e.selectionEnd;
var v1 = e.value.substring(0, cursor);
var v2 = e.value.substring(cursor, e.value.length);
e.value = v1 + s + " " + v2;
e.selectionStart = cursor + 2;
+ e.selectionEnd = selEnd + 2;
+ e.focus();
}
function add_elem () {
var e = document.getElementById ("no-elems-end").value;
document.getElementById ("no-elems-end").value = parseInt(e) + 1;
- eval_it ();
+ draw_it ();
}
function del_elem () {
var e = document.getElementById ("no-elems-end").value;
document.getElementById ("no-elems-end").value = parseInt(e) - 1;
- eval_it ();
+ draw_it ();
}
function save () {
@@ -258,7 +277,7 @@
localStorage["TRelStrucExplRel"+name];
document.getElementById ("positions").value =
localStorage["TRelStrucExplPos"+name];
- eval_it ();
+ draw_it ();
}
function list_stored () {
@@ -322,7 +341,7 @@
</script>
</head>
-<body onload="init_canvas (); list_stored (); eval_it (); adjust_to_width()">
+<body onload="init_canvas (); list_stored (); draw_it (); adjust_to_width()">
<div id="main">
<div id="top">
@@ -381,7 +400,7 @@
class="ebt" onclick="add_field('relations', '∃')">∃</button>
<button title="Universal Quantifier. You can also write 'all' or '\A'."
class="ebt" onclick="add_field('relations', '∀')">∀</button>
- <button class="ebt" onclick="eval_it()">Redraw</button>
+ <button class="ebt" onclick="draw_it()">Redraw</button>
</p>
<textarea id="relations" rows="3" cols="70">
E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)
@@ -393,7 +412,7 @@
<button class="ebt" onclick="add_field('positions', '·')">·</button>
<button class="ebt" onclick="add_field('positions', '/')">/</button>
<button class="ebt" onclick="add_field('positions', '^')">^</button>
- <button class="ebt" onclick="eval_it()">Redraw</button>
+ <button class="ebt" onclick="draw_it()">Redraw</button>
</p>
<textarea id="positions" rows="3" cols="70">
@@ -401,6 +420,24 @@
:y(a) = &a · (10 - &a) / 10
</textarea>
+<p>Second-Order Finder
+ <button class="ebt" title="Conjunction. You can also write 'and' or '&'."
+ onclick="add_field('second-order', '∧')">∧</button>
+ <button class="ebt" title="Disjunction. You can also write 'or' or '|'."
+ onclick="add_field('second-order', '∨')">∨</button>
+ <button class="ebt" title="Negation. You can also write 'not'."
+ onclick="add_field('second-order', '¬')">¬</button>
+ <button class="ebt" title="Implication. You can also write '->'."
+ onclick="add_field('second-order', '→')">→</button>
+ <button title="Existential Quantifier. You can also write 'ex' or '\E'."
+ class="ebt" onclick="add_field('second-order', '∃')">∃</button>
+ <button title="Universal Quantifier. You can also write 'all' or '\A'."
+ class="ebt" onclick="add_field('second-order', '∀')">∀</button>
+ <button class="ebt" onclick="find_draw_it()">Find</button>
+</p>
+<textarea id="second-order" rows="3" cols="70">
+</textarea>
+
</div>
<div style="position: absolute; top: 4em; right: 0.5em; text-align: left">
@@ -417,7 +454,12 @@
<li><button class="obt" onclick="example_heart()">Heart Drawing</button></li>
</ul>
-<!-- <button onclick="example_3col()">3col</button> -->
+<p>Second-Order Formulas</p>
+<ul style="list-style: square; margin-left: -1.5em">
+<li><button class="obt" onclick="example_2col()">2-coloring</button></li>
+<li><button class="obt" onclick="example_3col()">3-coloring</button></li>
+</ul>
+
</div>
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-07-03 23:55:21 UTC (rev 1741)
@@ -639,6 +639,14 @@
List.for_all (fun x -> List.exists (fun y -> y=x) b) a in
List.filter (fun x -> List.for_all (fun y -> x=y || not(subset y x)) cnf) cnf
+let find_model phi =
+ let arg = flatten (to_nnf ~neg:true phi) in
+ let (sep, aux_phi) = pg_auxcnf_of_bool_formula arg in
+ match Sat.sat (listcnf_of_boolcnf aux_phi) with
+ | None -> None
+ | Some l ->
+ let valid = List.filter (fun v -> v < sep && v > -sep) l in
+ Some (Aux.unique_sorted valid)
let convert ?(disc_vars=[]) phi =
(* input is a Boolean combination; output is a list of list of integers
@@ -900,26 +908,29 @@
| QAll of int list * qbf
(* Print a QBF formula. *)
-let rec qbf_str = function
- | QVar v -> var_str v
- | QNot phi -> "(not " ^ (qbf_str phi) ^ ")"
- | QAnd [] -> "true"
- | QOr [] -> "false"
- | QAnd (qbflist) -> qbf_list_str " and " qbflist
- | QOr (qbflist) -> qbf_list_str " or " qbflist
- | QEx (vars, phi) ->
- "(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
- " " ^ qbf_str phi ^ ")"
- | QAll (vars, phi) ->
- "(all " ^ (String.concat ", " (List.map string_of_int vars)) ^
- " " ^ qbf_str phi ^ ")"
+let qbf_str ?names phi =
+ let name s = match names with None -> var_str s | Some tbl ->
+ try Hashtbl.find tbl s with Not_found -> var_str s in
+ let rec qbf_str_rec = function
+ | QVar v -> name v
+ | QNot phi -> "(not " ^ (qbf_str_rec phi) ^ ")"
+ | QAnd [] -> "true"
+ | QOr [] -> "false"
+ | QAnd (qbflist) -> qbf_list_str " and " qbflist
+ | QOr (qbflist) -> qbf_list_str " or " qbflist
+ | QEx (vars, phi) ->
+ "(ex " ^ (String.concat ", " (List.map name vars)) ^
+ " " ^ qbf_str_rec phi ^ ")"
+ | QAll (vars, phi) ->
+ "(all " ^ (String.concat ", " (List.map name vars)) ^
+ " " ^ qbf_str_rec phi ^ ")"
+ and qbf_list_str sep = function
+ | [] -> "[]"
+ | [phi] -> qbf_str_rec phi
+ | lst -> "(" ^ (String.concat sep (List.map qbf_str_rec lst)) ^ ")"
+ in qbf_str_rec phi
-and qbf_list_str sep = function
- | [] -> "[]"
- | [phi] -> qbf_str phi
- | lst -> "(" ^ (String.concat sep (List.map qbf_str lst)) ^ ")"
-
(* Read a qdimacs description of a QBF from [in_ch]. *)
let read_qdimacs in_str =
let in_ch = ref in_str in
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-07-03 23:55:21 UTC (rev 1741)
@@ -53,6 +53,10 @@
(** Convert a Boolean formula to NNF and additionally negate if [neg] is set. *)
val to_nnf : ?neg : bool -> bool_formula -> bool_formula
+(** Find a model for a Boolean formula. *)
+val find_model : bool_formula -> int list option
+
+(** Convert a Boolean formula to CNF. If you only want SAT, use find_model. *)
val convert : ?disc_vars: int list -> bool_formula -> int list list
(** Convert an arbitrary formula to CNF via Boolean combinations. *)
@@ -88,7 +92,7 @@
| QAll of int list * qbf
(** Print a QBF formula. *)
-val qbf_str : qbf -> string
+val qbf_str : ?names: (int, string) Hashtbl.t -> qbf -> string
(** Read a qdimacs description of a QBF from a string. *)
val read_qdimacs : string -> qbf
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Solver/Solver.ml 2012-07-03 23:55:21 UTC (rev 1741)
@@ -398,11 +398,23 @@
(* Compute the QBF equivalent to the given SO formula on the given structure. *)
let so_to_qbf struc psi =
- let ids, free_id, elems = Hashtbl.create 7, ref 0, Structure.elements struc in
+ let assoc_or_zero asgn x = try List.assoc x asgn with Not_found -> 0 in
+ let ids, rev_ids, free_id = Hashtbl.create 7, Hashtbl.create 7, ref 0 in
+ let elems = Structure.elements struc in
let get_id x = try Hashtbl.find ids x with Not_found ->
- (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
- let compute_id var args asgn = get_id (var, args, asgn) in
- let assoc_or_zero asgn x = try List.assoc x asgn with Not_found -> 0 in
+ (Hashtbl.add ids x (!free_id +1);
+ Hashtbl.add rev_ids (!free_id +1) x;
+ incr free_id;
+ !free_id) in
+ let compute_id rel args asgn =
+ let asgnlist = Array.map (assoc_or_zero asgn) args in
+ get_id (rel, asgnlist) in
+ let make_conj qphil =
+ QAnd (List.rev (List.fold_left (fun l f -> match f with
+ QAnd fl -> List.rev_append fl l | _ -> f :: l) [] qphil)) in
+ let make_disj qphil =
+ QOr (List.rev (List.fold_left (fun l f -> match f with
+ QOr fl -> List.rev_append fl l | _ -> f :: l) [] qphil)) in
(* Reduce the Evaluation Problem of SO formulae to QBF *)
let rec so_to_qbf_rec asgn = function
| SO (rel, args) ->
@@ -421,15 +433,13 @@
let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
let dictl = (List.map snd resl) in
(try (List.find (fun x -> x = QOr []) qphil, [])
- with Not_found ->
- (QAnd (List.filter (fun x -> x <> QAnd []) qphil), List.concat dictl)
- )
+ with Not_found -> (make_conj qphil, List.concat dictl) )
| Or phil ->
let resl = (List.map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
let dictl = (List.map (snd) resl) in
- (try ((List.find (fun x -> x = QAnd []) qphil), []) with Not_found ->
- (QOr (List.filter (fun x -> x <> QOr []) qphil), List.concat dictl)
+ (try (List.find (fun x -> x = QAnd []) qphil, [])
+ with Not_found -> (make_disj qphil, List.concat dictl)
)
| Not phi ->
let (qphi, dict) = so_to_qbf_rec asgn phi in
@@ -442,8 +452,8 @@
let res = List.map (fun x -> so_to_qbf_rec x (Ex (tl, phi))) asgn_list in
let (qphil, dictl) =
((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res) in
- (try (List.find (fun x -> x = QAnd []) qphil, []) with Not_found ->
- (QOr (List.filter (fun x-> x <> QOr []) qphil), List.concat dictl)
+ (try (List.find (fun x -> x = QAnd []) qphil, [])
+ with Not_found ->(make_disj qphil, List.concat dictl)
)
| Ex (var::tl, phi) when is_so var ->
let (qbf_phi, dict_phi) = (so_to_qbf_rec asgn (Ex (tl, phi))) in
@@ -460,10 +470,8 @@
let res = List.map (fun x -> so_to_qbf_rec x (All (tl, phi))) asgn_list in
let (qphil, dictl) =
((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res) in
- (try
- ((List.find (fun x -> x = (QOr [])) qphil), [])
- with Not_found ->
- (QAnd (List.filter (fun x -> x <> (QAnd [])) qphil), List.concat dictl)
+ (try (List.find (fun x -> x = (QOr [])) qphil, [])
+ with Not_found -> (make_conj qphil, List.concat dictl)
)
| All (var::tl, phi) when is_so var ->
let (qbf_phi, dict_phi) = so_to_qbf_rec asgn (All (tl, phi)) in
@@ -475,18 +483,44 @@
else (QAll (rel_qbf_vars, qbf_phi), dict_phi)
| All (var::tl, _) -> (*stub*) failwith "not implemented yet (so_qbf_All)"
| _ -> failwith "not implemented yet (so_qbf_Other)"
- in fst (so_to_qbf_rec [] psi)
+ in (fst (so_to_qbf_rec [] psi), rev_ids)
(* Evaluation with second-order variables. *)
let eval_so struc phi =
- let qbf = so_to_qbf struc phi in
- let bf = (* BoolFormula.sat_of_qbf qbf *) BoolFormula.elim_quant qbf in
- let cnf = BoolFormula.convert bf in
- LOG 1 "QBF %s BF %s CNF %s:" (BoolFormula.qbf_str qbf) (BoolFormula.str bf)
- (Sat.cnf_str cnf);
- if Sat.is_sat cnf then Any else Empty
-
+ let fv = FormulaSubst.free_vars phi in
+ if fv <> [] then failwith "eval_so: free variables not allowed yet" else
+ let qbf, rev_ids = so_to_qbf struc phi in
+ let rec no_ex f = match f with QEx (_, g) -> no_ex g | _ -> f in
+ let bf = BoolFormula.elim_quant (no_ex qbf) in
+ LOG 1 "QBF %s BF %s" (BoolFormula.qbf_str qbf) (BoolFormula.str bf);
+ match BoolFormula.find_model bf with
+ | None -> Empty
+ | Some l ->
+ let mkname (rel,arr) = (String.sub rel 1 (String.length rel - 1)) ^"."^
+ (String.concat "." (Array.to_list (Array.map string_of_int arr))) in
+ let vname i =
+ try let n = mkname (Hashtbl.find rev_ids (abs i)) in
+ if i > 0 then n else "-" ^ n
+ with Not_found -> string_of_int i in
+ LOG 1 "%s" (String.concat ", " (List.map vname l));
+ Any
+
+(* Find assignment for second-order variables and add it to the structure. *)
+let find_so struc phi =
+ let fv = FormulaSubst.free_vars phi in
+ if not (List.for_all is_so fv) then failwith "find_so: non-so free vars" else
+ let qbf, rev_ids = so_to_qbf struc phi in
+ let bf = BoolFormula.elim_quant qbf in
+ LOG 1 "QBF %s BF %s" (BoolFormula.qbf_str qbf) (BoolFormula.str bf);
+ match BoolFormula.find_model bf with
+ | None -> (struc, false)
+ | Some l ->
+ let add_var_rel s i = if i < 0 then s else
+ let (rname, tup) = Hashtbl.find rev_ids i in
+ Structure.add_rel s rname tup in
+ (List.fold_left add_var_rel struc l, true)
+
(* Eval with very basic caching. *)
let eval_m struc phi =
if phi = And [] then Any else (
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Solver/Solver.mli 2012-07-03 23:55:21 UTC (rev 1741)
@@ -39,5 +39,9 @@
val eval_counter : int ref
(** Compute the QBF equivalent to the given SO formula on the given structure.*)
-val so_to_qbf : Structure.structure -> Formula.formula -> BoolFormula.qbf
+val so_to_qbf : Structure.structure -> Formula.formula ->
+ BoolFormula.qbf * (int, string * int array) Hashtbl.t
+(** Find assignment for second-order variables and add it to the structure. *)
+val find_so :
+ Structure.structure -> Formula.formula -> Structure.structure * bool
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-07-02 22:31:54 UTC (rev 1740)
+++ trunk/Toss/Solver/SolverTest.ml 2012-07-03 23:55:21 UTC (rev 1741)
@@ -165,20 +165,41 @@
"{ z->1, z->2, z->3 }";
);
- "convert: second-order to QBF" >::
+ "convert: second-order to QBF and find_so" >::
(fun () ->
let qbf_str_eq struc_s phi_s qbf_s =
let phi, struc = formula_of_string phi_s, struc_of_string struc_s in
LOG 1 "%s" (Formula.str phi);
+ let (qbf_res, rev_ids) = Solver.so_to_qbf struc phi in
+ let name (rel, arr) = (String.sub rel 1 (String.length rel - 1)) ^ "." ^
+ (String.concat "." (Array.to_list (Array.map string_of_int arr))) in
+ let names_tbl = Hashtbl.create (Hashtbl.length rev_ids) in
+ Hashtbl.iter (fun k v -> Hashtbl.add names_tbl k (name v)) rev_ids;
assert_equal ~printer:(fun x -> x) qbf_s
- (BoolFormula.qbf_str (Solver.so_to_qbf struc phi)) in(
+ (BoolFormula.qbf_str ~names:names_tbl qbf_res) in
+
qbf_str_eq "[ a, b | T { a } | ]" "ex |R all x, y (T(x) or |R (x, y))"
- "(ex 3, 4 (3 and 4))";
- qbf_str_eq "[ a, b | T { a } | ]" "all |Q all x, y (T(x) or Q(y) or (x = y))"
- "false";
- qbf_str_eq "[ a, b, c | E { (a,b); (b,c); (c,a) } | ]" ("ex |R, |G all x, y ( (|R(x) or |G(x)) and (" ^ " E(x,y) -> not ( (|R(x) and |R(y)) " ^ " or (|G(x) and |G(y)))))")
- "(ex 1, 5, 7, 9, 13, 17, 21, 23, 25, 27, 29, 33 (ex 2, 6, 8, 10, 14, 18, 22, 24, 26, 28, 30, 34 (((1 or 2) and ((5 or 6) and (not ((5 and 7) or (6 and 8)))) and (9 or 10)) and ((13 or 14) and (17 or 18) and ((21 or 22) and (not ((21 and 23) or (22 and 24))))) and (((25 or 26) and (not ((25 and 27) or (26 and 28)))) and (29 or 30) and (33 or 34)))))";
- );
+ "(ex R.2.1, R.2.2 (R.2.1 and R.2.2))";
+ qbf_str_eq "[ a, b | T { a } | ]"
+ "all |Q all x, y (T(x) or Q(y) or (x = y))" "false";
+ qbf_str_eq "[ a, b, c | E { (a,b); (b,c); (c,a) } | ]"
+ ("ex |R, |G all x, y ( (|R(x) or |G(x)) and (" ^
+ " E(x,y) -> not ( (|R(x) and |R(y)) " ^ " or (|G(x) and |G(y)))))")
+ ("(ex R.1, R.2, R.3 (ex G.1, G.2, G.3 ((R.1 or G.1) and (R.1 or G.1) " ^
+ "and (not ((R.1 and R.2) or (G.1 and G.2))) and (R.2 or G.2) and " ^
+ "(R.2 or G.2) and (not ((R.2 and R.3) or (G.2 and G.3))) and " ^
+ "(R.3 or G.3) and (R.3 or G.3) and " ^
+ "(not ((R.1 and R.3) or (G.1 and G.3))))))");
+
+ let col3 =
+ ("all x, y ( (|R(x) or |G(x) or |B(x)) and (" ^
+ " E(x,y) -> not ( (|R(x) and |R(y)) " ^
+ " or (|G(x) and |G(y)) or (|B(x) and |B(y)) ) ) )") in
+ let triangle = "[ | E { (a, b); (b, c); (c, a) } | ] " in
+ let (col3,triangle) = (formula_of_string col3,struc_of_string triangle) in
+ assert_equal ~printer:(fun x -> x)
+ "[a, b, c | E {(a, b); (b, c); (c, a)}; |B (c); |G (b); |R (a) | ]"
+ (Structure.str (fst (Solver.find_so triangle col3)));
);
"eval: second-order" >::
@@ -198,12 +219,15 @@
" or (|G(x) and |G(y)) or (|B(x) and |B(y)) ) ) )") in
let triangle = "[ | E { (a, b); (b, c); (c, a) } | ] " in
eval_eq triangle col3phi "T";
-
- let col2phi = ("ex |R, |G all x, y ( (|R(x) or |G(x)) and (" ^
- " E(x,y) -> not ( (|R(x) and |R(y)) " ^
- " or (|G(x) and |G(y)))))") in
- let triangle = "[ a,b,c | E { (a, b); (b, c); (c, a) } | ] " in
- eval_eq triangle col2phi "F";
+
+ eval_eq ("[ | E { (a, b); (b, a); (a, c); (c, a); (b, c); (c, b); " ^
+ " (a, d); (d, a); (b, d); (d, b); (c, d); (d, c) } | ]")
+ col3phi "{}";
+
+ let col2phi =
+ ("ex |R, |G all x, y ( (|R(x) or |G(x)) and ( E(x, y) -> " ^
+ "not ( (|R(x) and |R(y)) " ^ " or (|G(x) and |G(y)))))") in
+ eval_eq triangle col2phi "{}";
);
"eval: game heuristic tests" >::
@@ -392,19 +416,6 @@
\"" (chess_phi ^ "IsA8(x) and not CheckW()") "{ x->57 }";
);
- "eval: three coloring" >::
- (fun () ->
- eval_eq "[ | E { (a, b); (b, a); (a, c); (c, a); (b, c); (c, b) } | ]"
- ("ex R, G, B all x, y ( (x in R or x in G or x in B) and ( E(x,y) -> "^
- "not( (x in R and y in R) or (x in G and y in G) or " ^
- " (x in B and y in B) ) ) )") "T";
- eval_eq ("[ | E { (a, b); (b, a); (a, c); (c, a); (b, c); (c, b); " ^
- " (a, d); (d, a); (b, d); (d, b); (c, d); (d, c) } | ]")
- ("ex R, G, B all x, y ( (x in R or x in G or x in B) and ( E(x,y) -> "^
- "not( (x in R and y in R) or (x in G and y in G) or " ^
- " (x in B and y in B) ) ) )") "{}";
- );
-
(*"eval: four points problem" >::
(fun () ->
eval_eq "[ | P {x}; Q {y}; Z {z}; S {v} | ]"
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ab...@us...> - 2012-07-02 22:32:02
|
Revision: 1740
http://toss.svn.sourceforge.net/toss/?rev=1740&view=rev
Author: abuzaid
Date: 2012-07-02 22:31:54 +0000 (Mon, 02 Jul 2012)
Log Message:
-----------
Updated SO -> QBF and SO evaluation Tests
Modified Paths:
--------------
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-07-02 22:09:09 UTC (rev 1739)
+++ trunk/Toss/Solver/SolverTest.ml 2012-07-02 22:31:54 UTC (rev 1740)
@@ -166,24 +166,19 @@
);
"convert: second-order to QBF" >::
- (fun () ->(
+ (fun () ->
let qbf_str_eq struc_s phi_s qbf_s =
let phi, struc = formula_of_string phi_s, struc_of_string struc_s in
LOG 1 "%s" (Formula.str phi);
assert_equal ~printer:(fun x -> x) qbf_s
- (BoolFormula.qbf_str (Solver.so_to_qbf struc phi)) in
-
+ (BoolFormula.qbf_str (Solver.so_to_qbf struc phi)) in(
qbf_str_eq "[ a, b | T { a } | ]" "ex |R all x, y (T(x) or |R (x, y))"
- "which result is ok?";
-
- print_endline (Formula.str (formula_of_string "ex |V all |Q ex |R all x, y (T(x) or |R (x, y))"));
- print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex |R all x, y (T(x) or |R (x, y))")));
-
- print_endline (Formula.str (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))"));
- print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))")));
-
- print_endline (Formula.str (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)"));
- print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)"))); )
+ "(ex 3, 4 (3 and 4))";
+ qbf_str_eq "[ a, b | T { a } | ]" "all |Q all x, y (T(x) or Q(y) or (x = y))"
+ "false";
+ qbf_str_eq "[ a, b, c | E { (a,b); (b,c); (c,a) } | ]" ("ex |R, |G all x, y ( (|R(x) or |G(x)) and (" ^ " E(x,y) -> not ( (|R(x) and |R(y)) " ^ " or (|G(x) and |G(y)))))")
+ "(ex 1, 5, 7, 9, 13, 17, 21, 23, 25, 27, 29, 33 (ex 2, 6, 8, 10, 14, 18, 22, 24, 26, 28, 30, 34 (((1 or 2) and ((5 or 6) and (not ((5 and 7) or (6 and 8)))) and (9 or 10)) and ((13 or 14) and (17 or 18) and ((21 or 22) and (not ((21 and 23) or (22 and 24))))) and (((25 or 26) and (not ((25 and 27) or (26 and 28)))) and (29 or 30) and (33 or 34)))))";
+ );
);
"eval: second-order" >::
@@ -203,6 +198,12 @@
" or (|G(x) and |G(y)) or (|B(x) and |B(y)) ) ) )") in
let triangle = "[ | E { (a, b); (b, c); (c, a) } | ] " in
eval_eq triangle col3phi "T";
+
+ let col2phi = ("ex |R, |G all x, y ( (|R(x) or |G(x)) and (" ^
+ " E(x,y) -> not ( (|R(x) and |R(y)) " ^
+ " or (|G(x) and |G(y)))))") in
+ let triangle = "[ a,b,c | E { (a, b); (b, c); (c, a) } | ] " in
+ eval_eq triangle col2phi "F";
);
"eval: game heuristic tests" >::
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-02 22:09:17
|
Revision: 1739
http://toss.svn.sourceforge.net/toss/?rev=1739&view=rev
Author: lukaszkaiser
Date: 2012-07-02 22:09:09 +0000 (Mon, 02 Jul 2012)
Log Message:
-----------
Make multi-touch element moving work on ipad.
Modified Paths:
--------------
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/eval.html
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-07-02 00:27:40 UTC (rev 1738)
+++ trunk/Toss/Client/JsEval.ml 2012-07-02 22:09:09 UTC (rev 1739)
@@ -76,23 +76,25 @@
(* Moving elements in the structure drawing. *)
-let moving_elem = ref (Some 0) (* need to set type for compiler *)
-let _ = moving_elem := None
+let moving_elems = Hashtbl.create 3
+let elem_moving i = try Some (Hashtbl.find moving_elems i) with Not_found-> None
+let start_moving i e = Hashtbl.replace moving_elems i e
+let stop_moving i = Hashtbl.remove moving_elems i
let dist (x1, y1) (x2, y2) = ((x1 -. x2) ** 2. +. (y1 -. y2) ** 2.) ** 0.5
-let mousedown_handle x y =
+let mousedown_handle x y i =
let (x, y), struc = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
let near e = Drawing.in_elem_radius !cur_st e (x, y) in
let near_elems = List.filter near (Structure.elements struc) in
- if near_elems = [] then () else (
- moving_elem := Some (List.hd near_elems);
- LOG 0 "moving %i" (List.hd near_elems);
+ if near_elems = [] then stop_moving i else (
+ start_moving i (List.hd near_elems);
+ LOG 0 "cursor %i moving element %i" i (List.hd near_elems);
);
Js.string ""
-let mousemove_handle x y =
- match !moving_elem with
+let mousemove_handle x y i =
+ match elem_moving i with
| None -> Js.string ""
| Some e ->
let (x,y), st = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
@@ -104,8 +106,8 @@
let s = Drawing.shapes_to_canvas (Drawing.draw_struc !cur_st) in
Js.string ("clear_canvas(); " ^ s)
-let mouseup_handle x y =
- moving_elem := None;
+let mouseup_handle x y i =
+ stop_moving i;
Js.string ""
let _ = set_handle "mouseup_handle" mouseup_handle
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-07-02 00:27:40 UTC (rev 1738)
+++ trunk/Toss/Client/eval.html 2012-07-02 22:09:09 UTC (rev 1739)
@@ -88,51 +88,67 @@
function mouseup_handle (e) {
var pos = canvasCoords (e.pageX, e.pageY);
- ASYNCH ("mouseup_handle", [pos.x, pos.y], true, function (s) {
+ ASYNCH ("mouseup_handle", [pos.x, pos.y, 0], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
}
function touchend_handle (e) {
- var pos = canvasCoords (e.targetTouches[0].pageX, e.targetTouches[0].pageY);
- ASYNCH ("mouseup_handle", [pos.x, pos.y], false, function (s) {
+ for (var i = 0; i < e.targetTouches.length; i++) {
+ var p = canvasCoords (e.targetTouches[i].pageX, e.targetTouches[i].pageY);
+ ASYNCH ("mouseup_handle", [p.x, p.y, i], false, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
- })
+ })
+ }
}
function mousedown_handle (e) {
- var pos = canvasCoords (e.pageX, e.pageY);
- ASYNCH ("mousedown_handle", [pos.x, pos.y], true, function (s) {
+ var pos = canvasCoords (e.pageX, e.pageY);
+ ASYNCH ("mousedown_handle", [pos.x, pos.y, 0], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
}
function touchstart_handle (e) {
- var pos = canvasCoords (e.targetTouches[0].pageX, e.targetTouches[0].pageY);
- ASYNCH ("mousedown_handle", [pos.x, pos.y], false, function (s) {
+ for (var i = 0; i < e.targetTouches.length; i++) {
+ var p = canvasCoords (e.targetTouches[i].pageX, e.targetTouches[i].pageY);
+ ASYNCH ("mousedown_handle", [p.x, p.y, i], false, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
- })
+ })
+ }
}
+var ALLOW_MOUSE_MOVE = true
+
function mousemove_handle (e) {
+ if (ALLOW_MOUSE_MOVE === true) {
+ ALLOW_MOUSE_MOVE = false;
+ setTimeout (function () { ALLOW_MOUSE_MOVE = true; }, 100);
var pos = canvasCoords (e.pageX, e.pageY);
- ASYNCH ("mousemove_handle", [pos.x, pos.y], false, function (s) {
+ ASYNCH ("mousemove_handle", [pos.x, pos.y, 0], false, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
- })
+ })
+ }
}
function touchmove_handle (e) {
- e.preventDefault(); // avoid elastic page scrolling on tablets
- var pos = canvasCoords (e.targetTouches[0].pageX, e.targetTouches[0].pageY);
- ASYNCH ("mousemove_handle", [pos.x, pos.y], false, function (s) {
- var ctx = document.getElementById("canvas").getContext("2d");
- eval (s);
- })
+ e.preventDefault(); // avoid elastic page scrolling on tablets
+ if (ALLOW_MOUSE_MOVE === true) {
+ ALLOW_MOUSE_MOVE = false;
+ setTimeout (function () { ALLOW_MOUSE_MOVE = true; }, 100);
+ for (var i = 0; i < e.targetTouches.length; i++) {
+ var p = canvasCoords (e.targetTouches[i].pageX, e.targetTouches[i].pageY);
+ ASYNCH ("mousemove_handle", [p.x, p.y, i], false, function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+ }
+ }
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-07-02 00:27:50
|
Revision: 1738
http://toss.svn.sourceforge.net/toss/?rev=1738&view=rev
Author: lukaszkaiser
Date: 2012-07-02 00:27:40 +0000 (Mon, 02 Jul 2012)
Log Message:
-----------
Interface work on the structure editor.
Modified Paths:
--------------
trunk/Toss/Client/Style.css
trunk/Toss/Client/eval.html
trunk/Toss/Formula/Lexer.mll
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-06-27 23:29:07 UTC (rev 1737)
+++ trunk/Toss/Client/Style.css 2012-07-02 00:27:40 UTC (rev 1738)
@@ -64,7 +64,7 @@
float: right;
}
-.obt, .boldobt, .gamebt {
+.obt, .boldobt, .gamebt, .ebt {
text-align: left;
border-color: #260314;
border-radius: 4px;
@@ -76,7 +76,7 @@
font-family: Verdana, 'TeXGyreHerosRegular', sans;
}
-.obt:hover {
+.obt:hover, .ebt:hover, .boldobt:hover, .gamebt:hover {
cursor: pointer;
text-decoration: underline;
}
@@ -86,9 +86,9 @@
font-size: 1em;
}
-.boldobt:hover, .gamebt:hover {
- cursor: pointer;
- text-decoration: underline;
+.ebt {
+ /*font-weight: bold;*/
+ border-width: 2px;
}
.gamebt {
@@ -900,8 +900,8 @@
#board-left {
position: relative;
- left: 40em;
- top: -18em;
+ left: 2em;
+ top: 5em;
}
#board {
@@ -1006,8 +1006,8 @@
}
#canvas {
- width: 30em;
- height: 30em;
+ width: 28em;
+ height: 28em;
border: 2px solid #260314;
}
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-27 23:29:07 UTC (rev 1737)
+++ trunk/Toss/Client/eval.html 2012-07-02 00:27:40 UTC (rev 1738)
@@ -2,8 +2,8 @@
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
- <title>Toss Formula Evaluator</title>
- <meta name="Description" content="Evaluate Formulas on Structures." />
+ <title>Toss Relational Structures Explorer</title>
+ <meta name="Description" content="Explore Relational Structures." />
<meta http-equiv="X-UA-Compatible" content="chrome=1" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
@@ -51,8 +51,10 @@
function eval_it () {
var rels = document.getElementById ("relations").value;
var pos = document.getElementById ("positions").value;
- var elems = document.getElementById ("no-elems").value;
- var struc = "[ 1 - " + elems + " | | - ] with " + rels + " with " + pos;
+ var elemsF = document.getElementById ("no-elems-start").value;
+ var elemsT = document.getElementById ("no-elems-end").value;
+ var struc = "[ " + elemsF + " - " + elemsT + " | | - ] with " +
+ rels + " with " + pos;
ASYNCH ("draw_struc", [struc], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
@@ -60,7 +62,7 @@
}
-function canvasCoords (event) { // From stackoverflow.com
+function canvasCoords (eventPageX, eventPageY) { // From stackoverflow.com
var totalOffsetX = 0;
var totalOffsetY = 0;
var canvasX = 0;
@@ -74,8 +76,8 @@
}
while (currentElement = currentElement.offsetParent)
- canvasX = event.pageX - totalOffsetX;
- canvasY = event.pageY - totalOffsetY;
+ canvasX = eventPageX - totalOffsetX;
+ canvasY = eventPageY - totalOffsetY;
// Fix for variable canvas width
canvasX = Math.round( canvasX * (canvas.width / canvas.offsetWidth) );
@@ -85,48 +87,89 @@
}
function mouseup_handle (e) {
- var pos = canvasCoords (e);
+ var pos = canvasCoords (e.pageX, e.pageY);
ASYNCH ("mouseup_handle", [pos.x, pos.y], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
}
+function touchend_handle (e) {
+ var pos = canvasCoords (e.targetTouches[0].pageX, e.targetTouches[0].pageY);
+ ASYNCH ("mouseup_handle", [pos.x, pos.y], false, function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+}
+
function mousedown_handle (e) {
- var pos = canvasCoords (e);
+ var pos = canvasCoords (e.pageX, e.pageY);
ASYNCH ("mousedown_handle", [pos.x, pos.y], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
}
+function touchstart_handle (e) {
+ var pos = canvasCoords (e.targetTouches[0].pageX, e.targetTouches[0].pageY);
+ ASYNCH ("mousedown_handle", [pos.x, pos.y], false, function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+}
+
function mousemove_handle (e) {
- var pos = canvasCoords (e);
+ var pos = canvasCoords (e.pageX, e.pageY);
ASYNCH ("mousemove_handle", [pos.x, pos.y], false, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
}
+function touchmove_handle (e) {
+ e.preventDefault(); // avoid elastic page scrolling on tablets
+ var pos = canvasCoords (e.targetTouches[0].pageX, e.targetTouches[0].pageY);
+ ASYNCH ("mousemove_handle", [pos.x, pos.y], false, function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+}
+
+
function handle_elem_click (eid) { console.log (eid); }
function example_primes () {
+ document.getElementById ("struc-name").value = "Prime Numbers";
document.getElementById ("relations").value =
- "P(z) = &z > 1 and all x, y \n (&x * &y = &z -> (&x = 1 or &y = 1))";
+ "P(z) = &z > 1 and ∀ x, y \n (&x · &y = &z → (&x = 1 ∨ &y = 1))";
document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = 0";
- document.getElementById ("no-elems").value = "10";
+ document.getElementById ("no-elems-start").value = "1";
+ document.getElementById ("no-elems-end").value = "10";
eval_it ();
}
function example_tc () {
+ document.getElementById ("struc-name").value = "Transitive Closure";
document.getElementById ("relations").value =
"E(x, y) = &y = &x + 1;\n" +
- "S(x, y) = x != y and tc x, y E(x, y)";
- document.getElementById ("positions").value = ":x(a) = 10*&a;\n:y(a) = &a*&a";
- document.getElementById ("no-elems").value = "4";
+ "S(x, y) = x ≠ y ∧ tc x,y E(x, y)";
+ document.getElementById("positions").value=":x(a) = 5·&a;\n:y(a) = &a·&a / 2";
+ document.getElementById ("no-elems-start").value = "1";
+ document.getElementById("no-elems-end").value = "4";
eval_it ();
}
+function example_basic () {
+ document.getElementById ("struc-name").value = "Basic Example";
+ document.getElementById ("relations").value =
+ "E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)";
+ document.getElementById ("positions").value = ":x(a) = &a;\n" +
+ ":y(a) = &a · (10 - &a) / 10";
+ document.getElementById ("no-elems-start").value = "1";
+ document.getElementById ("no-elems-end").value = "15";
+ eval_it ();
+}
+
function example_3col () {
document.getElementById ("formula").value =
"ex |R, |G, |B all x, y ( \n ( |R(x) or |G(x) or |B(x)) and (" +
@@ -139,24 +182,131 @@
eval_it ();
}
-function example_heart_drawing () {
+function example_heart () {
+ document.getElementById ("struc-name").value = "Heart Drawing";
document.getElementById ("relations").value =
- "E(x, y) = (&y = &x + 1 and &x != 18) ∨ (&x=37 ∧ &y=18)";
+ "E(x, y) = (&y = &x + 1 ∧ &x ≠ 18) ∨ (&x=37 ∧ &y=18)";
document.getElementById ("positions").value =
- ":x(a) = :(&a <= 18) * (:(&a =< 10) * &a - :(&a > 10) * (&a - 20)) \n" +
- " - let :b = &a - 18 in :(&a > 18) * (:(:b =< 10) * :b - \n " +
- " :(:b > 10) * (:b - 20) - 2); \n\n" +
- ":y(a) = :(&a <= 18) * (:(&a =< 10) *&a · (10 - &a) / 10 - \n " +
- " :(&a > 10)*(&a - 10)) + let :b = &a - 18 in \n" +
- " :(&a > 18) * (:(:b =< 10) *:b · (10 - :b) / 10 - :(:b > 10)*(:b - 10))";
- document.getElementById ("no-elems").value = "37";
+ ":x(a) = :(&a ≤ 18) · (:(&a ≤ 10) · &a - :(&a > 10) · (&a - 20)) \n" +
+ " - let :b = &a - 18 in :(&a > 18) · (:(:b ≤ 10) · :b - \n " +
+ " :(:b > 10) · (:b - 20) - 2); \n\n" +
+ ":y(a) = :(&a ≤ 18) · (:(&a ≤ 10) ·&a · (10 - &a) / 10 - \n " +
+ " :(&a > 10)·(&a - 10)) + let :b = &a - 18 in \n" +
+ " :(&a > 18) · (:(:b ≤ 10) ·:b · (10 - :b) / 10 - :(:b > 10)·(:b - 10))";
+ document.getElementById ("no-elems-start").value = "1";
+ document.getElementById ("no-elems-end").value = "37";
eval_it ();
}
+
+function add_field (field, s) {
+ var e = document.getElementById(field);
+ var cursor = e.selectionStart;
+ var v1 = e.value.substring(0, cursor);
+ var v2 = e.value.substring(cursor, e.value.length);
+ e.value = v1 + s + " " + v2;
+ e.selectionStart = cursor + 2;
+}
+
+function add_elem () {
+ var e = document.getElementById ("no-elems-end").value;
+ document.getElementById ("no-elems-end").value = parseInt(e) + 1;
+ eval_it ();
+}
+
+function del_elem () {
+ var e = document.getElementById ("no-elems-end").value;
+ document.getElementById ("no-elems-end").value = parseInt(e) - 1;
+ eval_it ();
+}
+
+function save () {
+ var name = document.getElementById ("struc-name").value;
+ var elems1 = document.getElementById ("no-elems-start").value;
+ var elems2 = document.getElementById ("no-elems-end").value;
+ var rels = document.getElementById ("relations").value;
+ var pos = document.getElementById ("positions").value;
+ localStorage["TRelStrucExplEl1"+name] = elems1;
+ localStorage["TRelStrucExplEl2"+name] = elems2;
+ localStorage["TRelStrucExplRel"+name] = rels;
+ localStorage["TRelStrucExplPos"+name] = pos;
+ list_stored ();
+}
+
+function load (name) {
+ document.getElementById ("struc-name").value = name;
+ document.getElementById ("no-elems-start").value =
+ localStorage["TRelStrucExplEl1"+name];
+ document.getElementById ("no-elems-end").value =
+ localStorage["TRelStrucExplEl2"+name];
+ document.getElementById ("relations").value =
+ localStorage["TRelStrucExplRel"+name];
+ document.getElementById ("positions").value =
+ localStorage["TRelStrucExplPos"+name];
+ eval_it ();
+}
+
+function list_stored () {
+ var saved = document.getElementById("saved-strucs");
+ while (saved.childNodes.length > 0) { saved.removeChild(saved.firstChild); }
+ for (var i=0; i < localStorage.length; i++) {
+ var k = localStorage.key(i);
+ if (k.substring (0, 16) === "TRelStrucExplEl1") {
+ var n = k.substring (16, k.length);
+ var li = document.createElement('li');
+ li.innerHTML = '<button class="obt" onclick="load('+ "'"+ n +"'" +')">' +
+ n +'</button> (<button class="obt" onclick="del_saved('+ "'"+ n +
+ "'" +')" title="Delete this structure.">-</button>)';
+ saved.appendChild (li);
+ }
+ }
+}
+
+function del_saved (name) {
+ localStorage.removeItem("TRelStrucExplEl1"+name);
+ localStorage.removeItem("TRelStrucExplEl2"+name);
+ localStorage.removeItem("TRelStrucExplRel"+name);
+ localStorage.removeItem("TRelStrucExplPos"+name);
+ list_stored ();
+}
+
+function toggle_edit () {
+ var bt = document.getElementById("editbt");
+ if (bt.innerHTML == "Edit") {
+ document.getElementById('edit').style.display = 'block';
+ document.getElementById('board-left').style.left = '38em';
+ bt.innerHTML = "Hide Edit";
+ } else {
+ document.getElementById('edit').style.display = 'none';
+ document.getElementById('board-left').style.left = '2em';
+ bt.innerHTML = "Edit";
+ }
+}
+
+function toggle_view () {
+ var bt = document.getElementById("viewbt");
+ if (bt.innerHTML == "View") {
+ document.getElementById('board-left').style.display = 'block';
+ bt.innerHTML = "Hide View";
+ } else {
+ document.getElementById('board-left').style.display = 'none';
+ bt.innerHTML = "View";
+ }
+}
+
+function adjust_to_width () {
+ var e = document.getElementById ("edit");
+ var em_size =
+ document.defaultView.getComputedStyle(e,null).getPropertyValue('font-size');
+ var em_size_int = parseInt (em_size.substring (0, em_size.length - 2));
+ if (window.innerWidth > 80 * em_size_int) { // enough space for edit
+ toggle_edit ()
+ }
+}
//-->
</script>
</head>
-<body onload="init_canvas (); eval_it ()">
+<body onload="init_canvas (); list_stored (); eval_it (); adjust_to_width()">
<div id="main">
<div id="top">
@@ -165,46 +315,96 @@
<img id="leftupperlogo-img" src="img/logo.png" alt="back" />
</a>
</div>
+<span style="position: relative; left: 2em; top: 0.5em; font-size: 1.2em">
+ Relational Structures Explorer</span>
+<span id="toprighttab" style="display: block;">
+ <button class="obt" id="editbt" onclick="toggle_edit()">Edit</button>
+ <button class="obt" id="viewbt" onclick="toggle_view()">Hide View</button>
+</span>
</div>
-<div style="position: relative; top: 4em; left: 2em">
+<div id="board-left">
+<canvas id="canvas" height="1100" width="1100"
+ onmouseup="mouseup_handle(event)"
+ onmousedown="mousedown_handle(event)"
+ onmousemove="mousemove_handle(event)"
+ ontouchstart="touchstart_handle(event)"
+ ontouchend="touchend_handle(event)"
+ ontouchmove="touchmove_handle(event)">
+This text is displayed if your browser does not support HTML5 Canvas.
+</canvas>
+</div>
-<p>Relations:</p>
+<div id="edit" style="position: absolute; top: 4em; left: 2em; display: none">
-<textarea id="relations" rows="3" cols="60">
+<p>Name
+ <input id="struc-name" type="text" size="20" value="MyStructure1"
+ style="width: 10em"></input>
+ <button class="ebt" onclick="save()">Save</button>
+</p>
+
+<p>Elements
+ <input id="no-elems-start" type="text" size="2" value="1"
+ style="width: 2em"></input> —
+ <input id="no-elems-end" type="text" size="4" value="15"
+ style="width: 2em"></input>
+ <button class="ebt" onclick="add_elem()">+</button>
+ <button class="ebt" onclick="del_elem()">-</button>
+</p>
+
+<p>Relations
+ <button class="ebt" title="Conjunction. You can also write 'and' or '&'."
+ onclick="add_field('relations', '∧')">∧</button>
+ <button class="ebt" title="Disjunction. You can also write 'or' or '|'."
+ onclick="add_field('relations', '∨')">∨</button>
+ <button class="ebt" title="Negation. You can also write 'not'."
+ onclick="add_field('relations', '¬')">¬</button>
+ <button class="ebt" title="Implication. You can also write '->'."
+ onclick="add_field('relations', '→')">→</button>
+ <button title="Existential Quantifier. You can also write 'ex' or '\E'."
+ class="ebt" onclick="add_field('relations', '∃')">∃</button>
+ <button title="Universal Quantifier. You can also write 'all' or '\A'."
+ class="ebt" onclick="add_field('relations', '∀')">∀</button>
+ <button class="ebt" onclick="eval_it()">Redraw</button>
+</p>
+<textarea id="relations" rows="3" cols="70">
E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)
</textarea>
-<p>Positions:</p>
-<textarea id="positions" rows="3" cols="60">
+<p>Positions
+ <button class="ebt" onclick="add_field('positions', '+')">+</button>
+ <button class="ebt" onclick="add_field('positions', '-')">-</button>
+ <button class="ebt" onclick="add_field('positions', '·')">·</button>
+ <button class="ebt" onclick="add_field('positions', '/')">/</button>
+ <button class="ebt" onclick="add_field('positions', '^')">^</button>
+ <button class="ebt" onclick="eval_it()">Redraw</button>
+</p>
+
+<textarea id="positions" rows="3" cols="70">
:x(a) = &a;
:y(a) = &a · (10 - &a) / 10
</textarea>
-<p>Elements: <input id="no-elems" type="text" size="4" value="15"></input>
- <button onclick="eval_it()">Draw</button>
-</p>
+</div>
-<p>Examples:</p>
+<div style="position: absolute; top: 4em; right: 0.5em; text-align: left">
+<p>Your Structures</p>
+<ul id="saved-strucs" style="list-style: square; margin-left: -1.5em">
+<li>Nothing here yet</li>
+</ul>
-<button onclick="example_primes()">Primes</button>
+<p>Examples</p>
+<ul style="list-style: square; margin-left: -1.5em">
+<li><button class="obt" onclick="example_basic()">Basic Example</button></li>
+<li><button class="obt" onclick="example_primes()">Prime Numbers</button></li>
+<li><button class="obt" onclick="example_tc()">Transitive Closure</button></li>
+<li><button class="obt" onclick="example_heart()">Heart Drawing</button></li>
+</ul>
-<button onclick="example_tc()">TC</button>
-
<!-- <button onclick="example_3col()">3col</button> -->
-
</div>
-<div id="board-left">
-<canvas id="canvas" height="1100" width="1100"
- onmouseup="mouseup_handle(event)"
- onmousedown="mousedown_handle(event)"
- onmousemove="mousemove_handle(event)">
-This text is displayed if your browser does not support HTML5 Canvas.
-</canvas>
-</div>
-
<div id="bottom">
<div id="bottomright">
<a href="http://toss.sourceforge.net" id="toss-link">Contact</a>
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-06-27 23:29:07 UTC (rev 1737)
+++ trunk/Toss/Formula/Lexer.mll 2012-07-02 00:27:40 UTC (rev 1738)
@@ -175,6 +175,7 @@
| "<-" { LARR }
| "<=" { LDARR }
| "->" { RARR }
+ | "→" { RARR }
| "=>" { RDARR }
| "⇒" { RDARR }
| "<->" { LRARR }
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-27 23:29:15
|
Revision: 1737
http://toss.svn.sourceforge.net/toss/?rev=1737&view=rev
Author: lukaszkaiser
Date: 2012-06-27 23:29:07 +0000 (Wed, 27 Jun 2012)
Log Message:
-----------
New code cleanups and tests.
Modified Paths:
--------------
trunk/Toss/Client/eval.html
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Makefile
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Client/eval.html 2012-06-27 23:29:07 UTC (rev 1737)
@@ -138,11 +138,25 @@
"\n y { a -> 0, b -> -1, c -> 0 } ]";
eval_it ();
}
+
+function example_heart_drawing () {
+ document.getElementById ("relations").value =
+ "E(x, y) = (&y = &x + 1 and &x != 18) ∨ (&x=37 ∧ &y=18)";
+ document.getElementById ("positions").value =
+ ":x(a) = :(&a <= 18) * (:(&a =< 10) * &a - :(&a > 10) * (&a - 20)) \n" +
+ " - let :b = &a - 18 in :(&a > 18) * (:(:b =< 10) * :b - \n " +
+ " :(:b > 10) * (:b - 20) - 2); \n\n" +
+ ":y(a) = :(&a <= 18) * (:(&a =< 10) *&a · (10 - &a) / 10 - \n " +
+ " :(&a > 10)*(&a - 10)) + let :b = &a - 18 in \n" +
+ " :(&a > 18) * (:(:b =< 10) *:b · (10 - :b) / 10 - :(:b > 10)*(:b - 10))";
+ document.getElementById ("no-elems").value = "37";
+ eval_it ();
+}
//-->
</script>
</head>
-<body onload="init_canvas ()">
+<body onload="init_canvas (); eval_it ()">
<div id="main">
<div id="top">
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-06-27 23:29:07 UTC (rev 1737)
@@ -1030,37 +1030,37 @@
let res = elim_quant_rec phi in
set_simplification 2;
res
-
-(* reduce QBF to SAT *)
-let sat_of_qbf phi = let ids, free_id = Hashtbl.create 7, ref 0 in
- let get_id x = try Hashtbl.find ids x with Not_found ->
- (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
- let compute_id var asgn = get_id (var, asgn) in
- (* reduce QBF to SAT (recursive helper)*)
- let rec sat_of_qbf_rec phi asgn = (match phi with
- | QVar v -> (try List.assoc v asgn with Not_found -> (BVar v))
- | QAnd l ->
- let resl = (Aux.unique_sorted (List.filter (fun x -> x <> BAnd []) (List.map (fun x -> sat_of_qbf_rec x asgn) l))) in
- (try List.find (fun x -> x = BOr []) resl with Not_found -> (BAnd resl))
- | QOr l ->
- let resl = (Aux.unique_sorted (List.filter (fun x -> x <> BOr []) (List.map (fun x -> sat_of_qbf_rec x asgn) l))) in
- (try List.find (fun x -> x = BAnd []) resl with Not_found -> (BOr resl))
- | QNot f ->
- let res = (sat_of_qbf_rec f asgn) in
- if res = BAnd [] then BOr []
- else if res = BOr [] then BAnd []
- else BNot res
- | QEx (var::vl, f) -> (sat_of_qbf_rec (QEx (vl, f)) ((var, (BVar (get_id (var, asgn))))::asgn))
- | QEx ([], f) -> (sat_of_qbf_rec f asgn)
- | QAll (var::tl, f) ->
- let resl =
- (Aux.unique_sorted (List.filter
- (fun x -> x <> BAnd [])
- [(sat_of_qbf_rec (QAll (tl, f)) ((var, BOr [])::asgn)); (sat_of_qbf_rec (QAll (tl, f)) ((var, BAnd [])::asgn))]
- )) in
- (try (List.find (fun x -> x = BOr []) resl) with Not_found -> (BAnd resl))
- | QAll ([], f) -> (sat_of_qbf_rec f asgn)
- )
- in
- (sat_of_qbf_rec phi [])
+(* Reduce QBF to SAT by taking all possibilities for universal variables *)
+let sat_of_qbf phi =
+ let ids, free_id = Hashtbl.create 7, ref 0 in
+ let get_id x = try Hashtbl.find ids x with Not_found ->
+ (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
+ (* reduce QBF to SAT (recursive helper)*)
+ let rec sat_of_qbf_rec phi asgn =
+ match phi with
+ | QVar v -> (try List.assoc v asgn with Not_found -> (BVar v))
+ | QAnd l ->
+ let resl = Aux.unique_sorted (List.filter (fun x -> x <> BAnd []) (
+ List.rev_map (fun x -> sat_of_qbf_rec x asgn) l)) in
+ (try List.find (fun x -> x = BOr []) resl with Not_found -> (BAnd resl))
+ | QOr l ->
+ let resl = Aux.unique_sorted (List.filter (fun x -> x <> BOr []) (
+ List.rev_map (fun x -> sat_of_qbf_rec x asgn) l)) in
+ (try List.find (fun x -> x = BAnd []) resl with Not_found -> (BOr resl))
+ | QNot f ->
+ let res = sat_of_qbf_rec f asgn in
+ if res = BAnd [] then BOr []
+ else if res = BOr [] then BAnd []
+ else BNot res
+ | QEx (var::vl, f) ->
+ sat_of_qbf_rec (QEx (vl, f)) ((var, BVar (get_id (var, asgn)))::asgn)
+ | QEx ([], f) -> (sat_of_qbf_rec f asgn)
+ | QAll (var::tl, f) ->
+ let redl = [(sat_of_qbf_rec (QAll (tl, f)) ((var, BOr [])::asgn));
+ (sat_of_qbf_rec (QAll (tl, f)) ((var, BAnd [])::asgn))] in
+ let resl = Aux.unique_sorted (List.filter (fun x->x <> BAnd []) redl) in
+ (try (List.find (fun x-> x = BOr []) resl) with Not_found-> (BAnd resl))
+ | QAll ([], f) -> (sat_of_qbf_rec f asgn)
+ in (sat_of_qbf_rec phi [])
+
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-06-27 23:29:07 UTC (rev 1737)
@@ -96,5 +96,5 @@
(** Eliminating quantifiers from QBF formulas. *)
val elim_quant : qbf -> bool_formula
-(** Reduce QBF to SAT by elimination of quantifiers. *)
-val sat_of_qbf : qbf -> bool_formula
\ No newline at end of file
+(** Reduce QBF to SAT by taking all possibilities for universal variables *)
+val sat_of_qbf : qbf -> bool_formula
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Makefile 2012-06-27 23:29:07 UTC (rev 1737)
@@ -186,48 +186,48 @@
# Formula tests
FormulaTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Formula
-FormulaTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Formula -v
+FormulaTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Formula -v
# Solver tests
SolverTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Solver
-SolverTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Solver -v
+SolverTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Solver -v
# Term tests
TermTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Term
-TermTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Term -v
+TermTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Term -v
# Arena tests
ArenaTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Arena
-ArenaTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Arena -v
+ArenaTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Arena -v
# Play tests
PlayTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Play
-PlayTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Play -v
+PlayTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Play -v
# GGP tests
GGPTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest GGP
-GGPTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test GGP -v
+GGPTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest GGP -v
@@ -237,8 +237,8 @@
# Learn tests
LearnTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Learn
-LearnTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Learn -v
+LearnTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Learn -v
@@ -249,16 +249,16 @@
# Client tests
ClientTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Client
-ClientTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Client -v
+ClientTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Client -v
# Server tests
ServerTests: Server/Server.native
cp _build/Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Server
-ServerTestsVerbose: Server/Server.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test Server -v
+ServerTestsFull: Server/Server.native
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Server -v
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Solver/Solver.ml 2012-06-27 23:29:07 UTC (rev 1737)
@@ -396,103 +396,96 @@
List.iter (fun (p, r) -> Hashtbl.add !re_cache_results p r) !ok_re
-
-let so_to_qbf struc psi =
- let ids, free_id = Hashtbl.create 7, ref 0 in
- let get_id x = try Hashtbl.find ids x with Not_found ->
- (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
- let compute_id var args asgn = get_id (var, args, asgn) in
- (* Reduce the Evaluation Problem of SO formulae to QBF *)
-let rec so_to_qbf_rec struc psi asgn = match psi with
- | SO (rel, args) ->
- let v = (compute_id (var_str rel) args asgn) in
- (QVar v, [(var_str rel, v)])
- | Rel (rel, va) ->
- let args = Array.map (fun x -> try List.assoc x asgn with Not_found -> 0) va in
- if (Structure.check_rel struc rel args) then (QAnd [], []) else (QOr [], [])
- | Eq (var1, var2) -> if (try List.assoc var1 asgn with Not_found -> 0) = (try List.assoc var1 asgn with Not_found -> 0) then (QAnd [], []) else (QOr [], [])
- | And phil ->
- let resl = (List.map (fun phi -> (so_to_qbf_rec struc phi asgn)) phil) in
- let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
- let dictl = (List.map (snd) resl) in
- (try
- ((List.find (fun x -> x = QOr []) qphil), [])
- with Not_found -> (
- QAnd (List.filter (fun x -> x <> QAnd []) qphil), List.concat dictl
- ))
-
- | Or phil ->
- let resl = (List.map (fun phi -> (so_to_qbf_rec struc phi asgn)) phil) in
- let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
- let dictl = (List.map (snd) resl) in
- (try ((List.find (fun x -> x = QAnd []) qphil), []) with Not_found -> (QOr (List.filter (fun x -> x <> QOr []) qphil), List.concat dictl))
- | Not phi -> let (qphi, dict) = so_to_qbf_rec struc phi asgn in
- (if qphi = QOr [] then
- (QAnd [], dict)
- else if qphi = QAnd [] then
- (QOr [], dict)
- else
- (QNot qphi, dict))
- | Ex (vl, phi) ->
- (
- match vl with
- | [] -> so_to_qbf_rec struc phi asgn
- | var::tl ->
- if is_fo var then
- let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) (Structure.elements struc) in
- let res = (List.map (fun x -> so_to_qbf_rec struc (Ex (tl, phi)) x) asgn_list) in
- let (qphil, dictl) = ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res)in
- (try ((List.find (fun x -> x = QAnd []) qphil), []) with Not_found -> (QOr (List.filter (fun x -> x <> QOr []) qphil), List.concat dictl))
- else if is_so var then
- let (qbf_phi, dict_phi) = (so_to_qbf_rec struc (Ex (tl, phi)) asgn) in
- let rel_qbf_vars = Aux.unique_sorted (Aux.assoc_all (var_str var) dict_phi) in
- if qbf_phi = QAnd [] then (QAnd [], [])
- else if qbf_phi = QOr [] then (QOr [], [])
- else if (rel_qbf_vars = []) then (qbf_phi, dict_phi)
- else (QEx (rel_qbf_vars, qbf_phi), dict_phi)
- else (* stub *)
- (so_to_qbf_rec struc phi asgn)
- )
- | All (vl, phi) ->
- (
- match vl with
- | [] -> so_to_qbf_rec struc phi asgn
- | var::tl ->
- if is_fo var then
- let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) (Structure.elements struc) in
- let res = (List.map (fun x -> so_to_qbf_rec struc (All (tl, phi)) x) asgn_list) in
- let (qphil, dictl) = ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res)in
- (try
- ((List.find (fun x -> x = (QOr [])) qphil), [])
- with Not_found ->
- (QAnd (List.filter (fun x -> x <> (QAnd [])) qphil), List.concat dictl))
- else if is_so var then
- let (qbf_phi, dict_phi) = so_to_qbf_rec struc (All (tl, phi)) asgn in
- let rel_qbf_vars = Aux.unique_sorted (Aux.assoc_all (var_str var) dict_phi) in
- if qbf_phi = QAnd [] then (QAnd [], [])
- else if qbf_phi = QOr [] then (QOr [], [])
- else if (rel_qbf_vars = []) then (qbf_phi, dict_phi)
- else (QAll (rel_qbf_vars, qbf_phi), dict_phi)
- else (* stub *)
- (so_to_qbf_rec struc phi asgn)
- ) in
-fst (so_to_qbf_rec struc psi [])
+(* Compute the QBF equivalent to the given SO formula on the given structure. *)
+let so_to_qbf struc psi =
+ let ids, free_id, elems = Hashtbl.create 7, ref 0, Structure.elements struc in
+ let get_id x = try Hashtbl.find ids x with Not_found ->
+ (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
+ let compute_id var args asgn = get_id (var, args, asgn) in
+ let assoc_or_zero asgn x = try List.assoc x asgn with Not_found -> 0 in
+ (* Reduce the Evaluation Problem of SO formulae to QBF *)
+ let rec so_to_qbf_rec asgn = function
+ | SO (rel, args) ->
+ let v = (compute_id (var_str rel) args asgn) in
+ (QVar v, [(var_str rel, v)])
+ | Rel (rel, va) ->
+ let args = Array.map (assoc_or_zero asgn) va in
+ if (Structure.check_rel struc rel args) then (QAnd [], [])
+ else (QOr [], [])
+ | Eq (var1, var2) ->
+ if assoc_or_zero asgn var1 = assoc_or_zero asgn var2 then
+ (QAnd [], [])
+ else (QOr [], [])
+ | And phil ->
+ let resl = (List.map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
+ let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
+ let dictl = (List.map snd resl) in
+ (try (List.find (fun x -> x = QOr []) qphil, [])
+ with Not_found ->
+ (QAnd (List.filter (fun x -> x <> QAnd []) qphil), List.concat dictl)
+ )
+ | Or phil ->
+ let resl = (List.map (fun phi -> (so_to_qbf_rec asgn phi)) phil) in
+ let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
+ let dictl = (List.map (snd) resl) in
+ (try ((List.find (fun x -> x = QAnd []) qphil), []) with Not_found ->
+ (QOr (List.filter (fun x -> x <> QOr []) qphil), List.concat dictl)
+ )
+ | Not phi ->
+ let (qphi, dict) = so_to_qbf_rec asgn phi in
+ if qphi = QOr [] then (QAnd [], dict)
+ else if qphi = QAnd [] then(QOr [], dict)
+ else (QNot qphi, dict)
+ | Ex ([], phi) -> so_to_qbf_rec asgn phi
+ | Ex (var::tl, phi) when is_fo var ->
+ let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) elems in
+ let res = List.map (fun x -> so_to_qbf_rec x (Ex (tl, phi))) asgn_list in
+ let (qphil, dictl) =
+ ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res) in
+ (try (List.find (fun x -> x = QAnd []) qphil, []) with Not_found ->
+ (QOr (List.filter (fun x-> x <> QOr []) qphil), List.concat dictl)
+ )
+ | Ex (var::tl, phi) when is_so var ->
+ let (qbf_phi, dict_phi) = (so_to_qbf_rec asgn (Ex (tl, phi))) in
+ let rel_qbf_vars =
+ Aux.unique_sorted (Aux.assoc_all (var_str var) dict_phi) in
+ if qbf_phi = QAnd [] then (QAnd [], [])
+ else if qbf_phi = QOr [] then (QOr [], [])
+ else if (rel_qbf_vars = []) then (qbf_phi, dict_phi)
+ else (QEx (rel_qbf_vars, qbf_phi), dict_phi)
+ | Ex (var::tl, phi) -> (*stub*) failwith "not implemented yet (so_qbf_Ex)"
+ | All ([], phi) -> so_to_qbf_rec asgn phi
+ | All (var::tl, phi) when is_fo var ->
+ let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) elems in
+ let res = List.map (fun x -> so_to_qbf_rec x (All (tl, phi))) asgn_list in
+ let (qphil, dictl) =
+ ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res) in
+ (try
+ ((List.find (fun x -> x = (QOr [])) qphil), [])
+ with Not_found ->
+ (QAnd (List.filter (fun x -> x <> (QAnd [])) qphil), List.concat dictl)
+ )
+ | All (var::tl, phi) when is_so var ->
+ let (qbf_phi, dict_phi) = so_to_qbf_rec asgn (All (tl, phi)) in
+ let rel_qbf_vars =
+ Aux.unique_sorted (Aux.assoc_all (var_str var) dict_phi) in
+ if qbf_phi = QAnd [] then (QAnd [], [])
+ else if qbf_phi = QOr [] then (QOr [], [])
+ else if (rel_qbf_vars = []) then (qbf_phi, dict_phi)
+ else (QAll (rel_qbf_vars, qbf_phi), dict_phi)
+ | All (var::tl, _) -> (*stub*) failwith "not implemented yet (so_qbf_All)"
+ | _ -> failwith "not implemented yet (so_qbf_Other)"
+ in fst (so_to_qbf_rec [] psi)
-
-
(* Evaluation with second-order variables. *)
let eval_so struc phi =
- let qbf = (so_to_qbf struc phi) in
- let bf = (BoolFormula.sat_of_qbf qbf) in
- let cnf = (BoolFormula.convert bf) in
- LOG 0 "QBF:";
- LOG 0 "%s" (BoolFormula.qbf_str qbf);
- LOG 0 "BF:";
- LOG 0 "%s" (BoolFormula.str bf);
- LOG 0 "CNF:";
- LOG 0 "%s" (Sat.cnf_str cnf);
- if (Sat.is_sat cnf) then Any else Empty
+ let qbf = so_to_qbf struc phi in
+ let bf = (* BoolFormula.sat_of_qbf qbf *) BoolFormula.elim_quant qbf in
+ let cnf = BoolFormula.convert bf in
+ LOG 1 "QBF %s BF %s CNF %s:" (BoolFormula.qbf_str qbf) (BoolFormula.str bf)
+ (Sat.cnf_str cnf);
+ if Sat.is_sat cnf then Any else Empty
(* Eval with very basic caching. *)
let eval_m struc phi =
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Solver/Solver.mli 2012-06-27 23:29:07 UTC (rev 1737)
@@ -38,5 +38,6 @@
(** Counter of internal formula evaluations for profiling. *)
val eval_counter : int ref
+(** Compute the QBF equivalent to the given SO formula on the given structure.*)
+val so_to_qbf : Structure.structure -> Formula.formula -> BoolFormula.qbf
-
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-06-27 18:18:35 UTC (rev 1736)
+++ trunk/Toss/Solver/SolverTest.ml 2012-06-27 23:29:07 UTC (rev 1737)
@@ -15,8 +15,8 @@
let eval_eq struc_s phi_s aset_s =
let res = ref "" in
- let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in
- res := AssignmentSet.str (evaluate struc phi);
+ let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in
+ res := AssignmentSet.str (evaluate struc phi);
assert_equal ~printer:(fun x -> x) aset_s !res
@@ -165,41 +165,46 @@
"{ z->1, z->2, z->3 }";
);
- "eval: second-order T" >::
- (fun () ->
- let formula = "all |Q ex |R all x, y (|R (x, y) <-> (|Q(x) and not T(y)))" in
- let struc = "[ a, b | T { a } | ]" in
- (
- eval_eq struc
- formula
- "T";
- )
+ "convert: second-order to QBF" >::
+ (fun () ->(
+ let qbf_str_eq struc_s phi_s qbf_s =
+ let phi, struc = formula_of_string phi_s, struc_of_string struc_s in
+ LOG 1 "%s" (Formula.str phi);
+ assert_equal ~printer:(fun x -> x) qbf_s
+ (BoolFormula.qbf_str (Solver.so_to_qbf struc phi)) in
+
+ qbf_str_eq "[ a, b | T { a } | ]" "ex |R all x, y (T(x) or |R (x, y))"
+ "which result is ok?";
+
+ print_endline (Formula.str (formula_of_string "ex |V all |Q ex |R all x, y (T(x) or |R (x, y))"));
+ print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex |R all x, y (T(x) or |R (x, y))")));
+
+ print_endline (Formula.str (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))"));
+ print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))")));
+
+ print_endline (Formula.str (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)"));
+ print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)"))); )
);
-
- "eval: second-order F" >::
+
+ "eval: second-order" >::
(fun () ->
- let formula = "ex |R all |Q all x (not (|R(x) and |Q(x)) and (|R(x) or |Q(x)))" in
- let struc = "[ a, b | T { a } | ]" in
- (
- eval_eq struc
- formula
- "{}";
- )
+ let phi = "all |Q ex |R all x, y (|R (x, y) <-> (|Q(x) and not T(y)))" in
+ let struc = "[ a, b | T { a } | ]" in
+ eval_eq struc phi "T";
+
+ let formula =
+ "ex |R all |Q all x (not (|R(x) and |Q(x)) and (|R(x) or |Q(x)))" in
+ let struc = "[ a, b | T { a } | ]" in
+ eval_eq struc formula "{}";
+
+ let col3phi =
+ ("ex |R, |G, |B all x, y ( (|R(x) or |G(x) or |B(x)) and (" ^
+ " E(x,y) -> not ( (|R(x) and |R(y)) " ^
+ " or (|G(x) and |G(y)) or (|B(x) and |B(y)) ) ) )") in
+ let triangle = "[ | E { (a, b); (b, c); (c, a) } | ] " in
+ eval_eq triangle col3phi "T";
);
-(*
- "convert: eval second-order to QBF" >::
- (fun () ->(
- print_endline (Formula.str (formula_of_string "ex |V all |Q ex |R all x, y (T(x) or |R (x, y))"));
- print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex |R all x, y (T(x) or |R (x, y))")));
-
- print_endline (Formula.str (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))"));
- print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))")));
-
- print_endline (Formula.str (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)"));
- print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)")));
- )
- );
-*)
+
"eval: game heuristic tests" >::
(fun () ->
let heur_phi = "(((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or
@@ -270,12 +275,10 @@
real_val_eq "[ | R { (a, a); (a, b) } | ] "
"Sum (x, y | R (x, y) : 1)" 2.;
);
-
]
let bigtests = "SolverBig" >::: [
-(*
"eval: bigger tc tests" >::
(fun () ->
let diag_phi_mso =
@@ -442,5 +445,4 @@
eval_eq (grid 2) four_color_f "";
);*)
-*)
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ab...@us...> - 2012-06-27 18:18:44
|
Revision: 1736
http://toss.svn.sourceforge.net/toss/?rev=1736&view=rev
Author: abuzaid
Date: 2012-06-27 18:18:35 +0000 (Wed, 27 Jun 2012)
Log Message:
-----------
deleted useless file
Removed Paths:
-------------
trunk/Toss/Formula/myTest.ml
Deleted: trunk/Toss/Formula/myTest.ml
===================================================================
--- trunk/Toss/Formula/myTest.ml 2012-06-27 17:33:04 UTC (rev 1735)
+++ trunk/Toss/Formula/myTest.ml 2012-06-27 18:18:35 UTC (rev 1736)
@@ -1,6 +0,0 @@
-open Formula
-
-let formula_of_string s =
- FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-
-Hashtbl.iter (fun v a -> Printf.printf "%s: %d" v a) so_arities (Hashtbl.create 10) (formula_of_string "Ex |R (All x |R(x))")
\ No newline at end of file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ab...@us...> - 2012-06-27 17:33:16
|
Revision: 1735
http://toss.svn.sourceforge.net/toss/?rev=1735&view=rev
Author: abuzaid
Date: 2012-06-27 17:33:04 +0000 (Wed, 27 Jun 2012)
Log Message:
-----------
Evaluation of SO-Formulae by reduction to SAT
Modified Paths:
--------------
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/eval.html
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/Formula.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/SolverTest.ml
Added Paths:
-----------
trunk/Toss/Formula/myTest.ml
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Client/JsEval.ml 2012-06-27 17:33:04 UTC (rev 1735)
@@ -43,13 +43,27 @@
(* The Formula evaluation and registration in JS. *)
let js_eval phi struc =
let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
- LOG 0 "Evaluation of %s on %s" phi struc;
let (f, struc) = (formula_of_string phi, structure_of_string struc) in
Js.string (AssignmentSet.named_str struc (Solver.M.evaluate struc f))
-
+
+
+(*
+let js_eval_so phi struc =
+ let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
+ let (f, struc) = (formula_of_string phi, structure_of_string struc) in
+ let qbf = (Solver.so_to_qbf struc f) in
+ let sat = (Solver.elim_quant_naiv qbf) in
+ LOG 0 "Formula: %s" (Formula.str f);
+ LOG 0 "QBF Formula: %s" (BoolFormula.qbf_str qbf);
+ LOG 0 "SAT Formula: %s" (BoolFormula.str sat);
+ Js.string (AssignmentSet.named_str struc (Solver.eval_so struc f))
+*)
+
let _ = set_handle "eval" js_eval
+
+
(* Drawing the structure. *)
let draw_struc_js struc_s =
let st = structure_of_string (Js.to_string struc_s) in
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Client/eval.html 2012-06-27 17:33:04 UTC (rev 1735)
@@ -59,6 +59,7 @@
})
}
+
function canvasCoords (event) { // From stackoverflow.com
var totalOffsetX = 0;
var totalOffsetY = 0;
@@ -128,9 +129,9 @@
function example_3col () {
document.getElementById ("formula").value =
- "ex R, G, B all x, y ( \n (x in R or x in G or x in B) and (" +
- "\n E(x,y) -> not ( (x in R and y in R) " +
- "\n or (x in G and y in G) or (x in B and y in B) ) ) )";
+ "ex |R, |G, |B all x, y ( \n ( |R(x) or |G(x) or |B(x)) and (" +
+ "\n E(x,y) -> not ( ( |R(x) and |R(y)) " +
+ "\n or (|G(x) and |G(y)) or (|B(x) and |B(y)) ) ) )";
document.getElementById ("structure").value =
"[ | E { (a, b); (b, c); (c, a) } | " +
"\n x { a -> 1, b -> 2, c -> 3 }; " +
@@ -161,7 +162,6 @@
</textarea>
<p>Positions:</p>
-
<textarea id="positions" rows="3" cols="60">
:x(a) = &a;
:y(a) = &a · (10 - &a) / 10
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-06-27 17:33:04 UTC (rev 1735)
@@ -911,7 +911,7 @@
"(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
" " ^ qbf_str phi ^ ")"
| QAll (vars, phi) ->
- "(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
+ "(all " ^ (String.concat ", " (List.map string_of_int vars)) ^
" " ^ qbf_str phi ^ ")"
and qbf_list_str sep = function
@@ -1030,3 +1030,37 @@
let res = elim_quant_rec phi in
set_simplification 2;
res
+
+(* reduce QBF to SAT *)
+let sat_of_qbf phi = let ids, free_id = Hashtbl.create 7, ref 0 in
+ let get_id x = try Hashtbl.find ids x with Not_found ->
+ (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
+ let compute_id var asgn = get_id (var, asgn) in
+ (* reduce QBF to SAT (recursive helper)*)
+ let rec sat_of_qbf_rec phi asgn = (match phi with
+ | QVar v -> (try List.assoc v asgn with Not_found -> (BVar v))
+ | QAnd l ->
+ let resl = (Aux.unique_sorted (List.filter (fun x -> x <> BAnd []) (List.map (fun x -> sat_of_qbf_rec x asgn) l))) in
+ (try List.find (fun x -> x = BOr []) resl with Not_found -> (BAnd resl))
+ | QOr l ->
+ let resl = (Aux.unique_sorted (List.filter (fun x -> x <> BOr []) (List.map (fun x -> sat_of_qbf_rec x asgn) l))) in
+ (try List.find (fun x -> x = BAnd []) resl with Not_found -> (BOr resl))
+ | QNot f ->
+ let res = (sat_of_qbf_rec f asgn) in
+ if res = BAnd [] then BOr []
+ else if res = BOr [] then BAnd []
+ else BNot res
+ | QEx (var::vl, f) -> (sat_of_qbf_rec (QEx (vl, f)) ((var, (BVar (get_id (var, asgn))))::asgn))
+ | QEx ([], f) -> (sat_of_qbf_rec f asgn)
+ | QAll (var::tl, f) ->
+ let resl =
+ (Aux.unique_sorted (List.filter
+ (fun x -> x <> BAnd [])
+ [(sat_of_qbf_rec (QAll (tl, f)) ((var, BOr [])::asgn)); (sat_of_qbf_rec (QAll (tl, f)) ((var, BAnd [])::asgn))]
+ )) in
+ (try (List.find (fun x -> x = BOr []) resl) with Not_found -> (BAnd resl))
+ | QAll ([], f) -> (sat_of_qbf_rec f asgn)
+ )
+ in
+ (sat_of_qbf_rec phi [])
+
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-06-27 17:33:04 UTC (rev 1735)
@@ -95,3 +95,6 @@
(** Eliminating quantifiers from QBF formulas. *)
val elim_quant : qbf -> bool_formula
+
+(** Reduce QBF to SAT by elimination of quantifiers. *)
+val sat_of_qbf : qbf -> bool_formula
\ No newline at end of file
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Formula/Formula.ml 2012-06-27 17:33:04 UTC (rev 1735)
@@ -757,3 +757,4 @@
quit2 := max 1. (min 10000. q2);
(y5, h, h *. (min 5. (sf /. e4)))
)
+
Added: trunk/Toss/Formula/myTest.ml
===================================================================
--- trunk/Toss/Formula/myTest.ml (rev 0)
+++ trunk/Toss/Formula/myTest.ml 2012-06-27 17:33:04 UTC (rev 1735)
@@ -0,0 +1,6 @@
+open Formula
+
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+Hashtbl.iter (fun v a -> Printf.printf "%s: %d" v a) so_arities (Hashtbl.create 10) (formula_of_string "Ex |R (All x |R(x))")
\ No newline at end of file
Property changes on: trunk/Toss/Formula/myTest.ml
___________________________________________________________________
Added: svn:mime-type
+ text/plain
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Solver/Solver.ml 2012-06-27 17:33:04 UTC (rev 1735)
@@ -1,11 +1,13 @@
(* Solver for checking if formulas hold on structures. *)
+open BoolFormula
open Bitvector
open AssignmentSet
open Assignments
open Structure
open Formula
+
(* CACHE *)
type cachetbl =
@@ -393,10 +395,105 @@
Hashtbl.clear !re_cache_results;
List.iter (fun (p, r) -> Hashtbl.add !re_cache_results p r) !ok_re
+
+
+let so_to_qbf struc psi =
+ let ids, free_id = Hashtbl.create 7, ref 0 in
+ let get_id x = try Hashtbl.find ids x with Not_found ->
+ (Hashtbl.add ids x (!free_id +1); incr free_id; !free_id ) in
+ let compute_id var args asgn = get_id (var, args, asgn) in
+ (* Reduce the Evaluation Problem of SO formulae to QBF *)
+let rec so_to_qbf_rec struc psi asgn = match psi with
+ | SO (rel, args) ->
+ let v = (compute_id (var_str rel) args asgn) in
+ (QVar v, [(var_str rel, v)])
+ | Rel (rel, va) ->
+ let args = Array.map (fun x -> try List.assoc x asgn with Not_found -> 0) va in
+ if (Structure.check_rel struc rel args) then (QAnd [], []) else (QOr [], [])
+ | Eq (var1, var2) -> if (try List.assoc var1 asgn with Not_found -> 0) = (try List.assoc var1 asgn with Not_found -> 0) then (QAnd [], []) else (QOr [], [])
+ | And phil ->
+ let resl = (List.map (fun phi -> (so_to_qbf_rec struc phi asgn)) phil) in
+ let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
+ let dictl = (List.map (snd) resl) in
+ (try
+ ((List.find (fun x -> x = QOr []) qphil), [])
+ with Not_found -> (
+ QAnd (List.filter (fun x -> x <> QAnd []) qphil), List.concat dictl
+ ))
+
+ | Or phil ->
+ let resl = (List.map (fun phi -> (so_to_qbf_rec struc phi asgn)) phil) in
+ let qphil = (Aux.unique_sorted (List.map (fst) resl)) in
+ let dictl = (List.map (snd) resl) in
+ (try ((List.find (fun x -> x = QAnd []) qphil), []) with Not_found -> (QOr (List.filter (fun x -> x <> QOr []) qphil), List.concat dictl))
+ | Not phi -> let (qphi, dict) = so_to_qbf_rec struc phi asgn in
+ (if qphi = QOr [] then
+ (QAnd [], dict)
+ else if qphi = QAnd [] then
+ (QOr [], dict)
+ else
+ (QNot qphi, dict))
+ | Ex (vl, phi) ->
+ (
+ match vl with
+ | [] -> so_to_qbf_rec struc phi asgn
+ | var::tl ->
+ if is_fo var then
+ let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) (Structure.elements struc) in
+ let res = (List.map (fun x -> so_to_qbf_rec struc (Ex (tl, phi)) x) asgn_list) in
+ let (qphil, dictl) = ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res)in
+ (try ((List.find (fun x -> x = QAnd []) qphil), []) with Not_found -> (QOr (List.filter (fun x -> x <> QOr []) qphil), List.concat dictl))
+ else if is_so var then
+ let (qbf_phi, dict_phi) = (so_to_qbf_rec struc (Ex (tl, phi)) asgn) in
+ let rel_qbf_vars = Aux.unique_sorted (Aux.assoc_all (var_str var) dict_phi) in
+ if qbf_phi = QAnd [] then (QAnd [], [])
+ else if qbf_phi = QOr [] then (QOr [], [])
+ else if (rel_qbf_vars = []) then (qbf_phi, dict_phi)
+ else (QEx (rel_qbf_vars, qbf_phi), dict_phi)
+ else (* stub *)
+ (so_to_qbf_rec struc phi asgn)
+ )
+ | All (vl, phi) ->
+ (
+ match vl with
+ | [] -> so_to_qbf_rec struc phi asgn
+ | var::tl ->
+ if is_fo var then
+ let asgn_list = List.map (fun x -> (Formula.to_fo var, x)::asgn) (Structure.elements struc) in
+ let res = (List.map (fun x -> so_to_qbf_rec struc (All (tl, phi)) x) asgn_list) in
+ let (qphil, dictl) = ((Aux.unique_sorted (List.map (fst) res)), List.map (snd) res)in
+ (try
+ ((List.find (fun x -> x = (QOr [])) qphil), [])
+ with Not_found ->
+ (QAnd (List.filter (fun x -> x <> (QAnd [])) qphil), List.concat dictl))
+ else if is_so var then
+ let (qbf_phi, dict_phi) = so_to_qbf_rec struc (All (tl, phi)) asgn in
+ let rel_qbf_vars = Aux.unique_sorted (Aux.assoc_all (var_str var) dict_phi) in
+ if qbf_phi = QAnd [] then (QAnd [], [])
+ else if qbf_phi = QOr [] then (QOr [], [])
+ else if (rel_qbf_vars = []) then (qbf_phi, dict_phi)
+ else (QAll (rel_qbf_vars, qbf_phi), dict_phi)
+ else (* stub *)
+ (so_to_qbf_rec struc phi asgn)
+ ) in
+fst (so_to_qbf_rec struc psi [])
+
+
+
+
(* Evaluation with second-order variables. *)
-let eval_so struc phi =
- Empty
-
+let eval_so struc phi =
+ let qbf = (so_to_qbf struc phi) in
+ let bf = (BoolFormula.sat_of_qbf qbf) in
+ let cnf = (BoolFormula.convert bf) in
+ LOG 0 "QBF:";
+ LOG 0 "%s" (BoolFormula.qbf_str qbf);
+ LOG 0 "BF:";
+ LOG 0 "%s" (BoolFormula.str bf);
+ LOG 0 "CNF:";
+ LOG 0 "%s" (Sat.cnf_str cnf);
+ if (Sat.is_sat cnf) then Any else Empty
+
(* Eval with very basic caching. *)
let eval_m struc phi =
if phi = And [] then Any else (
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Solver/Solver.mli 2012-06-27 17:33:04 UTC (rev 1735)
@@ -2,7 +2,6 @@
(** {1 Interface} *)
-
(** Interface to the solver. *)
module M : sig
(** Check the formula on the structure. *)
@@ -31,7 +30,8 @@
val set_timeout : (unit -> bool) -> unit
(** Clear timeout function. *)
- val clear_timeout : unit -> unit
+ val clear_timeout : unit -> unit
+
end
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-06-25 18:03:52 UTC (rev 1734)
+++ trunk/Toss/Solver/SolverTest.ml 2012-06-27 17:33:04 UTC (rev 1735)
@@ -34,7 +34,7 @@
let tests = "Solver" >::: [
- "eval: first-order quantifier free" >::
+ "eval: first-order quantifier free" >::
(fun () ->
eval_eq "[ | P { (a1) }; R:1 {} | ]" "P(x0)" "{ x0->1 }";
eval_eq "[ | P:1 {}; R { (a1) } | ]" "P(x0)" "{}";
@@ -165,13 +165,41 @@
"{ z->1, z->2, z->3 }";
);
- "eval: second-order" >::
+ "eval: second-order T" >::
(fun () ->
- eval_eq "[ a, b | T { a } | ]"
- "ex |R all x, y (|R (x, y) <-> (T(x) and not T(y)))"
- "T";
+ let formula = "all |Q ex |R all x, y (|R (x, y) <-> (|Q(x) and not T(y)))" in
+ let struc = "[ a, b | T { a } | ]" in
+ (
+ eval_eq struc
+ formula
+ "T";
+ )
);
-
+
+ "eval: second-order F" >::
+ (fun () ->
+ let formula = "ex |R all |Q all x (not (|R(x) and |Q(x)) and (|R(x) or |Q(x)))" in
+ let struc = "[ a, b | T { a } | ]" in
+ (
+ eval_eq struc
+ formula
+ "{}";
+ )
+ );
+(*
+ "convert: eval second-order to QBF" >::
+ (fun () ->(
+ print_endline (Formula.str (formula_of_string "ex |V all |Q ex |R all x, y (T(x) or |R (x, y))"));
+ print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex |R all x, y (T(x) or |R (x, y))")));
+
+ print_endline (Formula.str (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))"));
+ print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "all |Q all x, y (T(x) or Q(y) or (x = y))")));
+
+ print_endline (Formula.str (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)"));
+ print_endline (BoolFormula.qbf_str (Solver.so_to_qbf (struc_of_string "[ a, b | T { a } | ]") (formula_of_string "ex x all y ((T(x) and T(y)) -> x = y)")));
+ )
+ );
+*)
"eval: game heuristic tests" >::
(fun () ->
let heur_phi = "(((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or
@@ -247,6 +275,7 @@
let bigtests = "SolverBig" >::: [
+(*
"eval: bigger tc tests" >::
(fun () ->
let diag_phi_mso =
@@ -413,5 +442,5 @@
eval_eq (grid 2) four_color_f "";
);*)
-
+*)
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-25 18:03:59
|
Revision: 1734
http://toss.svn.sourceforge.net/toss/?rev=1734&view=rev
Author: lukaszkaiser
Date: 2012-06-25 18:03:52 +0000 (Mon, 25 Jun 2012)
Log Message:
-----------
Test corrections and unicode for formulas.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Client/eval.html
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/FormulaSubstTest.ml
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/RewritingTest.ml
trunk/Toss/Term/tests/sasha_basic.log
trunk/Toss/Term/tests/sasha_basic.trs
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Arena/Arena.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -105,7 +105,7 @@
Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
(fun f (payoff, moves) ->
Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
- (Formula.fprint_real(* _nobra 0 *)) payoff;
+ (Formula.fprint_real ~unicode:false (* _nobra 0 *)) payoff;
if moves <> [] then
Format.fprintf f "@[<1>MOVES@ %a@]@ "
(Aux.fprint_sep_list ";" (fun f ({
@@ -185,11 +185,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 body
+ (Formula.fprint ~unicode:false) body
else
Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ {@,@[<1>%a@,@]}"
drel (Aux.fprint_sep_list "," Format.pp_print_string) args
- Formula.fprint body;
+ (Formula.fprint ~unicode:false) body;
Format.fprintf ppf "@]@ ";
) defined_rels;
Format.fprintf ppf "@[<1>PLAYERS@ %a@]@ "
@@ -268,6 +268,7 @@
let add_def_rels struc rels = List.fold_left add_def_rel_single struc rels
let add_def_fun_single struc (f, v, def_re) =
+ LOG 1 "adding fun %s def %s" f (Formula.real_str def_re);
let elems = Structure.elements struc in
let asg e = AssignmentSet.FO (v, [(e, AssignmentSet.Any)]) in
let fval e = Solver.M.get_real_val ~asg:(asg e) def_re struc in
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -246,14 +246,16 @@
(DiscreteRule.fprint_full print_compiled) r.discrete;
if has_dynamics r then
Format.fprintf f "@ @[<hv>dynamics@ %a@]"
- (Formula.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
+ (Formula.fprint_eqs ~unicode:false ~diff:true)
+ (List.sort Pervasives.compare r.dynamics);
if has_update r then
Format.fprintf f "@ @[<hv>update@ %a@]"
- (Formula.fprint_eqs ~diff:false) (List.sort Pervasives.compare r.update);
- if r.inv <> Formula.And [] then
- Format.fprintf f "@ @[<1>inv@ %a@]" Formula.fprint r.inv;
+ (Formula.fprint_eqs ~unicode:false ~diff:false)
+ (List.sort Pervasives.compare r.update);
+ if r.inv <> Formula.And [] then
+ Format.fprintf f "@ @[<1>inv@ %a@]" (Formula.fprint ~unicode:false) r.inv;
if r.post <> Formula.And [] then
- Format.fprintf f "@ @[<1>post@ %a@]" Formula.fprint r.post;
+ Format.fprintf f "@ @[<1>post@ %a@]" (Formula.fprint ~unicode:false) r.post;
Format.fprintf f "@]"
let fprint = fprint_full false
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -1185,7 +1185,8 @@
(Aux.fprint_sep_list "," matched) r.rule_s;
Format.fprintf f "@]";
if (fst r.pre <> Formula.And [] || snd r.pre <> []) then
- Format.fprintf f "@ @[<1>pre@ %a@]" Formula.fprint (fst r.pre);
+ Format.fprintf f "@ @[<1>pre@ %a@]"
+ (Formula.fprint ~unicode:false) (fst r.pre);
if (snd r.pre <> []) then
let before_str (name, b) = if b then name else "not " ^ name in
let before_s = String.concat ", " (List.map before_str (snd r.pre)) in
@@ -1310,7 +1311,7 @@
Format.fprintf f "@]") in
Format.fprintf f "@[<1>MATCH@ %a@ "
- (Formula.fprint_prec (-1)) r.match_formula;
+ (Formula.fprint_prec false (-1)) r.match_formula;
del_part ();
if del_elems <> [] || r.del_tuples <> []
then Format.fprintf f "@ ";
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Client/eval.html 2012-06-25 18:03:52 UTC (rev 1734)
@@ -156,15 +156,15 @@
<p>Relations:</p>
-<textarea id="relations" rows="3" cols="40">
-E(x, y) = &y = &x + 1
+<textarea id="relations" rows="3" cols="60">
+E(x, y) = (&y = &x + 1) ∨ (&x=15 ∧ &y=1)
</textarea>
<p>Positions:</p>
-<textarea id="positions" rows="3" cols="40">
+<textarea id="positions" rows="3" cols="60">
:x(a) = &a;
-:y(a) = &a * (10 - &a) / 10
+:y(a) = &a · (10 - &a) / 10
</textarea>
<p>Elements: <input id="no-elems" type="text" size="4" value="15"></input>
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/Formula.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -86,13 +86,13 @@
type sign_op = EQZero | GZero | LZero | GEQZero | LEQZero | NEQZero
(* Print a sign_op as string. *)
-let sign_op_str = function
+let sign_op_str ?(unicode=false) = function
| EQZero -> " = 0"
| GZero -> " > 0"
| LZero -> " < 0"
- | GEQZero -> " >= 0"
- | LEQZero -> " =< 0"
- | NEQZero -> " <> 0"
+ | GEQZero -> if unicode then " ≥ 0" else " >= 0"
+ | LEQZero -> if unicode then " ≤ 0" else " =< 0"
+ | NEQZero -> if unicode then " ≠ 0" else " <> 0"
(* This type describes formulas of relational logic with equality.
@@ -165,111 +165,127 @@
let fprint_var f v = Format.pp_print_string f (var_str v)
(* Bracket-savvy encodings: 0 or, 1 and, 2 not ex all *)
-let rec fprint_prec prec f = function
+let rec fprint_prec unicode prec f = function
| Rel (s, vars) ->
Format.fprintf f "%s(%a)" s
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
| Eq (x, y) -> Format.fprintf f "%s = %s" (var_str x) (var_str y)
- | In (x, y) -> Format.fprintf f "%s in %s" (var_str x) (var_str y)
+ | In (x, y) ->
+ if unicode then
+ Format.fprintf f "%s ∈ %s" (var_str x) (var_str y)
+ else
+ Format.fprintf f "%s in %s" (var_str x) (var_str y)
| SO (r, vars) ->
Format.fprintf f "%a(%a)" fprint_var r
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
| RealExpr (p, s) ->
- Format.fprintf f "@[(%a%s)@]" (fprint_real_prec 0) p (sign_op_str s)
+ Format.fprintf f "@[(%a%s)@]" (fprint_real_prec unicode 0)
+ p (sign_op_str ~unicode s)
| Not phi ->
- let lb, rb =
- if prec > 2 then "(", ")" else "", "" in
- Format.fprintf f "@[<1>%snot@ %a%s@]" lb (fprint_prec 2) phi rb
+ let lb, rb = if prec > 2 then "(", ")" else "", "" in
+ if unicode then
+ Format.fprintf f "@[<1>%s¬@ %a%s@]" lb (fprint_prec unicode 2) phi rb
+ else
+ Format.fprintf f "@[<1>%snot@ %a%s@]" lb (fprint_prec unicode 2) phi rb
| And [] -> Format.fprintf f "true"
| Or [] -> Format.fprintf f "false"
- | And [phi] -> fprint_prec prec f phi
- | Or [phi] -> fprint_prec prec f phi
+ | And [phi] -> fprint_prec unicode prec f phi
+ | Or [phi] -> fprint_prec unicode prec f phi
| And flist ->
let lb, rb = if prec = 0 || prec > 1 then "(", ")" else "", "" in
+ let sep = if unicode then " ∧" else " and" in
Format.fprintf f "@[<1>%s%a%s@]" lb
- (Aux.fprint_sep_list " and" (fprint_prec 1)) flist rb
+ (Aux.fprint_sep_list sep (fprint_prec unicode 1)) flist rb
| Or flist ->
let lb, rb = if prec > 0 then "(", ")" else "", "" in
+ let sep = if unicode then " ∨" else " or" in
Format.fprintf f "@[<1>%s%a%s@]" lb
- (Aux.fprint_sep_list " or" (fprint_prec 0)) flist rb
+ (Aux.fprint_sep_list sep (fprint_prec unicode 0)) flist rb
| Ex (x, phi) ->
let lb, rb = if prec > 2 then "(", ")" else "", "" in
- Format.fprintf f "@[<1>%sex@ %a@ %a%s@]" lb
- (Aux.fprint_sep_list "," fprint_var) x (fprint_prec 2) phi rb
+ let quant = if unicode then "∃" else "ex" in
+ Format.fprintf f "@[<1>%s%s@ %a@ %a%s@]" lb quant
+ (Aux.fprint_sep_list "," fprint_var) x (fprint_prec unicode 2) phi rb
| All (x, phi) ->
let lb, rb = if prec > 2 then "(", ")" else "", "" in
- Format.fprintf f "@[<1>%sall@ %a@ %a%s@]" lb
- (Aux.fprint_sep_list "," fprint_var) x (fprint_prec 2) phi rb
+ let quant = if unicode then "∀" else "all" in
+ Format.fprintf f "@[<1>%s%s@ %a@ %a%s@]" lb quant
+ (Aux.fprint_sep_list "," fprint_var) x (fprint_prec unicode 2) phi rb
| Lfp (r, vs, fpphi) ->
Format.fprintf f "@[<1>lfp %a(%a) = (%a)@]" fprint_var r
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vs)
- (fprint_prec prec) fpphi
+ (fprint_prec unicode prec) fpphi
| Gfp (r, vs, fpphi) ->
Format.fprintf f "@[<1>gfp %a(%a) = (%a)@]" fprint_var r
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vs)
- (fprint_prec prec) fpphi
+ (fprint_prec unicode prec) fpphi
| Let (r, args, rphi, inphi) ->
Format.fprintf f "@[<1>let %s(%s) = %a in@]@ %a" r (String.concat ", " args)
- (fprint_prec prec) rphi (fprint_prec prec) inphi
+ (fprint_prec unicode prec) rphi (fprint_prec unicode prec) inphi
(* Bracket-savvy precedences: 0 +, 2 * *)
-and fprint_real_prec prec f = function
+and fprint_real_prec unicode prec f = function
| RVar s -> Format.fprintf f "%s" s
| Const fl -> Format.fprintf f "%F" fl
| Plus (r1, Times (Const fl, r2)) when fl = -1. -> (* r1 - r2 short *)
let lb, rb = if prec > 0 then "(", ")" else "", "" in
Format.fprintf f "@[<1>%s%a@ -@ %a%s@]" lb
- (fprint_real_prec 0) r1 (fprint_real_prec 1) r2 rb
+ (fprint_real_prec unicode 0) r1 (fprint_real_prec unicode 1) r2 rb
| Times (r1, r2) ->
- let lb, rb =
- if prec > 2 then "(", ")" else "", "" in
- Format.fprintf f "@[<1>%s%a@ *@ %a%s@]" lb
- (fprint_real_prec 2) r1 (fprint_real_prec 2) r2 rb
+ let lb, rb = if prec > 2 then "(", ")" else "", "" in
+ let m = if unicode then "·" else "*" in
+ Format.fprintf f "@[<1>%s%a@ %s@ %a%s@]" lb
+ (fprint_real_prec unicode 2) r1 m (fprint_real_prec unicode 2) r2 rb
| Plus (r1, r2) ->
let lb, rb = if prec > 0 then "(", ")" else "", "" in
Format.fprintf f "@[<1>%s%a@ +@ %a%s@]" lb
- (fprint_real_prec 0) r1 (fprint_real_prec 0) r2 rb
+ (fprint_real_prec unicode 0) r1 (fprint_real_prec unicode 0) r2 rb
| Pow (r1, r2) ->
let lb, rb = if prec > 2 then "(", ")" else "", "" in
Format.fprintf f "@[<1>%s%a^%a%s@]" lb
- (fprint_real_prec 4) r1 (fprint_real_prec 4) r2 rb
+ (fprint_real_prec unicode 4) r1 (fprint_real_prec unicode 4) r2 rb
| Fun (s, v) -> Format.fprintf f ":%s(%s)" s (var_str v)
- | Char phi -> Format.fprintf f "@[<1>:(@,%a@,)@]" (fprint_prec 0) phi
+ | Char phi -> Format.fprintf f "@[<1>:(@,%a@,)@]" (fprint_prec unicode 0) phi
| Sum (vl, phi, r) ->
- Format.fprintf f "@[<1>Sum@ (@,%a@ |@ %a@ :@ %a@,)@]"
- (Aux.fprint_sep_list "," fprint_var) vl (fprint_prec 0) phi
- (fprint_real_prec 0) r
+ let sum = if unicode then "∑" else "Sum" in
+ Format.fprintf f "@[<1>%s@ (@,%a@ |@ %a@ :@ %a@,)@]" sum
+ (Aux.fprint_sep_list "," fprint_var) vl (fprint_prec unicode 0) phi
+ (fprint_real_prec unicode 0) r
| RLet (v, lre, inre) ->
Format.fprintf f "@[<1>let %s = %a in %a@]" v
- (fprint_real_prec prec) lre (fprint_real_prec prec) inre
+ (fprint_real_prec unicode prec) lre (fprint_real_prec unicode prec) inre
-let fprint f phi = fprint_prec 0 f phi
-let fprint_real f phi = fprint_real_prec 0 f phi
-let sprint phi = AuxIO.sprint_of_fprint fprint phi
-let print phi = AuxIO.print_of_fprint fprint phi
-let print_real r = AuxIO.print_of_fprint fprint_real r
-let sprint_real r = AuxIO.sprint_of_fprint fprint_real r
-let str f = sprint f
-let real_str r = sprint_real r
+let fprint ?(unicode=false) f phi = fprint_prec unicode 0 f phi
+let fprint_real ?(unicode=false) f phi = fprint_real_prec unicode 0 f phi
+let sprint ?(unicode=false) phi =
+ AuxIO.sprint_of_fprint (fprint_prec unicode 0) phi
+let print ?(unicode=false) phi =
+ AuxIO.print_of_fprint (fprint_prec unicode 0) phi
+let print_real ?(unicode=false) r =
+ AuxIO.print_of_fprint (fprint_real_prec unicode 0) r
+let sprint_real ?(unicode=false) r =
+ AuxIO.sprint_of_fprint (fprint_real_prec unicode 0) r
+let str ?(unicode=false) f = sprint ~unicode f
+let real_str ?(unicode=false) r = sprint_real ~unicode r
type eq_sys = ((string * string) * real_expr) list
(* Print an equation system. *)
-let fprint_eqs ?(diff=false) ppf eqs =
+let fprint_eqs ?(unicode=false) ?(diff=false) ppf eqs =
let sing ppf ((f, a), t) =
let mid_str = if diff then "'" else "" in
Format.fprintf ppf "@[<1>:%s(%s)%s@ =@ @[<1>%a@]@]"
- f a mid_str fprint_real t in
+ f a mid_str (fprint_real ~unicode) t in
Format.fprintf ppf "@[<hv>%a@]" (Aux.fprint_sep_list ";" sing) eqs
(* Print an equation system as a string. *)
-let eq_str ?(diff=false) eqs =
+let eq_str ?(unicode=false) ?(diff=false) eqs =
let sing_str ((f, a), t) =
let mid_str = if diff then "' = " else " = " in
- let l_str = real_str (Fun (f, `FO a)) in
- let r_str = real_str t in
+ let l_str = real_str ~unicode (Fun (f, `FO a)) in
+ let r_str = real_str ~unicode t in
l_str ^ mid_str ^ r_str in
" " ^ (String.concat ";\n " (List.map sing_str eqs))
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/Formula.mli 2012-06-25 18:03:52 UTC (rev 1734)
@@ -42,7 +42,7 @@
type sign_op = EQZero | GZero | LZero | GEQZero | LEQZero | NEQZero
(** Print a sign_op as string. *)
-val sign_op_str : sign_op -> string
+val sign_op_str : ?unicode: bool -> sign_op -> string
(** This type describes formulas of relational logic with equality.
@@ -96,24 +96,25 @@
val var_list_str: [< var] list -> string
(** Print a formula as a string. *)
-val str : formula -> string
+val str : ?unicode: bool -> formula -> string
val mona_str : formula -> string
-val print : formula -> unit
-val sprint : formula -> string
-val fprint : Format.formatter -> formula -> unit
+val print : ?unicode: bool -> formula -> unit
+val sprint : ?unicode: bool -> formula -> string
+val fprint : ?unicode: bool -> Format.formatter -> formula -> unit
(** Print a real_expr as a string. *)
-val real_str : real_expr -> string
-val print_real : real_expr -> unit
-val sprint_real : real_expr -> string
-val fprint_real : Format.formatter -> real_expr -> unit
+val real_str : ?unicode: bool -> real_expr -> string
+val print_real : ?unicode: bool -> real_expr -> unit
+val sprint_real : ?unicode: bool -> real_expr -> string
+val fprint_real : ?unicode: bool -> Format.formatter -> real_expr -> unit
-val fprint_prec : int -> Format.formatter -> formula -> unit
-val fprint_real_prec : int -> Format.formatter -> real_expr -> unit
+val fprint_prec : bool -> int -> Format.formatter -> formula -> unit
+val fprint_real_prec : bool -> int -> Format.formatter -> real_expr -> unit
(** Print an equation system. *)
-val fprint_eqs : ?diff : bool -> Format.formatter -> eq_sys -> unit
-val eq_str : ?diff:bool -> eq_sys -> string
+val fprint_eqs : ?unicode: bool -> ?diff: bool ->
+ Format.formatter -> eq_sys -> unit
+val eq_str : ?unicode: bool -> ?diff: bool -> eq_sys -> string
(** {2 Formula syntax check} *)
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-06-25 18:03:52 UTC (rev 1734)
@@ -62,7 +62,7 @@
{ Formula.Sum ($3, $5, $7) }
| COLON OPEN formula_expr CLOSE { Char (Formula.flatten $3) }
| OPEN real_expr CLOSE { $2 }
- | COLON LET_CMD COLON v = ID EQ def = real_expr IN_MOD re = real_expr
+ | LET_CMD COLON v = ID EQ def = real_expr IN_MOD re = real_expr
{ RLet (":" ^ v, def, re) }
real_ineq:
@@ -125,8 +125,11 @@
| formula_expr MID formula_expr { Or [$1; $3] }
| formula_expr XOR formula_expr { And [Or [$1; $3]; Not (And [$1; $3])] }
| formula_expr RARR formula_expr { Or [Not ($1); $3] }
+ | formula_expr RDARR formula_expr { Or [Not ($1); $3] }
| formula_expr LRARR formula_expr
{ Or [And [Not ($1); Not ($3)]; And [$1; $3]] }
+ | formula_expr LRDARR formula_expr
+ { Or [And [Not ($1); Not ($3)]; And [$1; $3]] }
| OPEN formula_expr CLOSE { $2 }
| LET_CMD rel = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
EQ body = formula_expr IN_MOD phi = formula_expr
Modified: trunk/Toss/Formula/FormulaSubstTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubstTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/FormulaSubstTest.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -110,7 +110,7 @@
"let Next(x, y) = E(x, y) and R(y) in R(a)")
"lfp R(a) = (P(a) or ex y (E(a, y) and y in R))";
exp_eq "let R(x) = P(x) in :(R(a)) > 1" ":(P(a)) > 1";
- exp_eq "(:let :x = 3 in :x) > 1" "3 > 1";
+ exp_eq "(let :x = 3 in :x) > 1" "3 > 1";
);
"fv" >::
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -55,6 +55,12 @@
test_pp "all y (R(x, y) or not P(y))";
test_pp "(:x - (:y + :z) < 0)";
test_pp "(:x - :y + :z < 0)";
+
+ let test_pp_unicode f_s = assert_equal ~printer:(fun x -> x) f_s
+ (str ~unicode:true (flatten (formula_of_string f_s))) in
+ test_pp_unicode "∃ y (R(x, y) ∧ P(y))";
+ test_pp_unicode "∀ y (R(x, y) ∨ ¬ P(y))";
+ test_pp_unicode "(∑ (x | P(x) : 2. · :f(x)) ≥ 0)";
);
"rk4" >::
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/Lexer.mll 2012-06-25 18:03:52 UTC (rev 1734)
@@ -152,24 +152,33 @@
| '&' { AMP }
| '|' { MID }
| "Sum" { SUM }
+ | "∑" { SUM }
| '+' { PLUS }
| '-' { MINUS }
+ | "−" { MINUS }
| '*' { TIMES }
+ | "·" { TIMES }
+ | "×" { TIMES }
| '/' { DIV }
| '^' { POW }
| '>' { GR }
| ">=" { GREQ }
+ | "≥" { GREQ }
| '<' { LT }
| "=<" { EQLT }
+ | "≤" { EQLT }
| '=' { EQ }
| "<>" { LTGR }
| "!=" { NEQ }
+ | "≠" { NEQ }
| "!" { NOT }
| "<-" { LARR }
| "<=" { LDARR }
| "->" { RARR }
| "=>" { RDARR }
+ | "⇒" { RDARR }
| "<->" { LRARR }
+ | "⇔" { LRDARR }
| "<=>" { LRDARR }
| "--" { INTERV }
| '(' { OPEN }
@@ -180,12 +189,20 @@
| ']' { CLOSESQ }
| "in" { IN_MOD }
| "and" { AND }
+ | "∧" { AND }
| "or" { OR }
+ | "∨" { OR }
| "xor" { XOR }
+ | "⊕" { XOR }
| "not" { NOT }
+ | "¬" { NOT }
| "ex" { EX }
+ | "\\E" { EX }
| "exists" { EX }
+ | "∃" { EX }
| "all" { ALL }
+ | "\\A" { ALL }
+ | "∀" { ALL }
| "tc" { TC }
| "TC" { TC }
| "with" { WITH }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Formula/Tokens.mly 2012-06-25 18:03:52 UTC (rev 1734)
@@ -14,7 +14,7 @@
%token CURRENT UNIVERSAL RULE_SPEC STATE_SPEC CLASS LFP GFP EOF
/* List in order of increasing precedence. */
-%nonassoc LET_CMD
+%nonassoc LET_CMD IN_MOD
%nonassoc COND
%left LARR
%right RARR
@@ -26,7 +26,7 @@
%left OR
%left AND
%left COMMA
-%nonassoc EQ IN_MOD
+%nonassoc EQ
%left NOT EX ALL
%%
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Solver/Solver.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -507,6 +507,10 @@
(Array.of_list (List.map var_str all_vs)) [tp] in
acc +. (get_real_val solver tp_asg r struc) in
List.fold_left add_val 0. tps
+ | RLet _ ->
+ let e = FormulaSubst.expand_real_expr expr in
+ LOG 1 "get_real_val: expanded to: %s" (real_str e);
+ get_real_val solver asg e struc
| _ ->
check_timeout "Solver.get_real_val.other";
let rec get_rval = function
@@ -579,8 +583,8 @@
let check struc phi = check_cache (
check solver ~formula:(register_formula_s struc solver phi) struc)
- let get_real_val ?asg re struc = check_cache (
- check_cache (get_real_val_cache ?asg solver struc re))
+ let get_real_val ?asg re struc =
+ check_cache (get_real_val_cache ?asg solver struc re)
let set_timeout t = timeout := t
let clear_timeout () = timeout := (fun () -> false);
Modified: trunk/Toss/Solver/StructureTest.ml
===================================================================
--- trunk/Toss/Solver/StructureTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Solver/StructureTest.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -373,10 +373,7 @@
" in
let (_, st) = struc_from_trs s in
assert_equal ~printer:(fun x -> x)
- ("[F0_0\\, F1_0\\, F2, F3, F4, F5 | R {(F0_0\\, F1_0\\); (F1_0\\, F2);"^
- " (F2, F3); (F3, F4); (F4, F5)} | x {F0_0\\->0., F1_0\\->1.," ^
- " F2->2., F3->3., F4->4., F5->5.}; y {F0_0\\->0., F1_0\\->1.," ^
- " F2->2., F3->3., F4->4., F5->5.}]") (Structure.str st);
+ ("[F0_0\\[ @: Tnatural_number], F1_0\\[ @: Tnatural_number], F2[ @: Tnatural_number], F3[ @: Tnatural_number], F4[ @: Tnatural_number], F5[ @: Tnatural_number] | R {(F0_0\\[ @: Tnatural_number], F1_0\\[ @: Tnatural_number]); (F1_0\\[ @: Tnatural_number], F2[ @: Tnatural_number]); (F2[ @: Tnatural_number], F3[ @: Tnatural_number]); (F3[ @: Tnatural_number], F4[ @: Tnatural_number]); (F4[ @: Tnatural_number], F5[ @: Tnatural_number])} | x {F0_0\\[ @: Tnatural_number]->0., F1_0\\[ @: Tnatural_number]->1., F2[ @: Tnatural_number]->2., F3[ @: Tnatural_number]->3., F4[ @: Tnatural_number]->4., F5[ @: Tnatural_number]->5.}; y {F0_0\\[ @: Tnatural_number]->0., F1_0\\[ @: Tnatural_number]->1., F2[ @: Tnatural_number]->2., F3[ @: Tnatural_number]->3., F4[ @: Tnatural_number]->4., F5[ @: Tnatural_number]->5.}]") (Structure.str st);
);
"sprint simple" >::
Modified: trunk/Toss/Term/Rewriting.ml
===================================================================
--- trunk/Toss/Term/Rewriting.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Term/Rewriting.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -55,10 +55,6 @@
| (Term (n1, _, _), Term (n2, _, [||])) when (n1 = n2) ->
raise NO_MATCH (* used cons vs. functional cons *)
| (Term (n1, _, _), Term (n2, _, _)) when (n1 = n2) ->
- (*Printf.printf "check_clash_match: [1] %s(%d) %s(%d): %a -- %a\n"
- n1 (Array.length a1) n2 (Array.length a2)
- (Aux.array_fprint (fun o t->output_string o (Coding.term_to_string t))) a1
- (Aux.array_fprint (fun o t->output_string o (Coding.term_to_string t))) a2;*)
failwith "curried functions not supported (yet?)"
| (Term (n1, _, _), Term (n2, _, _)) -> (* when (n2.[0] != 'F') *)
raise NO_MATCH
@@ -80,15 +76,12 @@
raise NO_MATCH (* non-0-arg fun and functional term *)
| _ -> failwith "rewriting not this function"
-(* Merging substitutions according to variable names. FIXME: perhaps
- use [Term.combine_mgu_sb], otherwise streamline. *)
+(* Merging substitutions according to variable names.
+ FIXME: perhaps use [Term.combine_mgu_sb], otherwise streamline.
+ NOTE: we assume that the rules are left-linear (checked above). *)
let merge_substs substs =
let merged_substs = Aux.collect substs in
- let mkcm b = (* if List.length b <> 1 then failwith "cm" else *)
- snd (List.hd b) in
- let make_cm (a, b) = (false, (a, mkcm b)) in
- let (clashes, substs) = List.split (map make_cm merged_substs) in
- (exists (fun x -> x) clashes, substs)
+ (false, List.map (fun (a, b) -> (a, snd (List.hd b))) merged_substs)
(* The final function for applying a rewrite rule with clash checking and
@@ -101,7 +94,7 @@
if merge_clash then term
else
let result = Coding.apply_s merged_substs right in
- (* For now, we copy over the supertypes fro the original, as
+ (* For now, we copy over the supertypes from the original, as
the old rewriting ignores supertypes. *)
match term, result with
| Term (_, oldtys, _), Term (n, _, args) ->
@@ -179,21 +172,21 @@
else
let (steps, res) = basic_normalise rr rr_spec m rewritten in
(steps + steps_c + 1, res)
- | Term (n, t, a) when n.[0] = 'F' ->
- (let (prev_steps, prev_res) = basic_normalise_arr rr rr_spec m a in
- let nmlized = Term (n, t, prev_res) in
- let found= try Some (TermHashtbl.find m nmlized) with Not_found -> None in
- match found with Some (r) -> (prev_steps, r) | None ->
- let rewritten = rr nmlized in
- if rewritten = nmlized then (prev_steps, rewritten) else
- let (steps, res) = basic_normalise rr rr_spec m rewritten in
- let memory_size = TermHashtbl.length m in
- let threshold = (memory_size / cMEM_USE_INCREASE_FACTOR) + 1 in
- let size_addon = min (size_up_to 256 nmlized) threshold in
- if steps > threshold + size_addon then
- (TermHashtbl.add m nmlized res; (0, res))
- else (prev_steps + steps + 1, res)
- )
+ | Term (n, t, a) when n.[0] = 'F' -> (
+ let (prev_steps, prev_res) = basic_normalise_arr rr rr_spec m a in
+ let nmlized = Term (n, t, prev_res) in
+ let found= try Some (TermHashtbl.find m nmlized) with Not_found -> None in
+ match found with Some (r) -> (prev_steps, r) | None -> (
+ let rewritten = rr nmlized in
+ if rewritten = nmlized then (prev_steps, nmlized) else (
+ let (steps, res) = basic_normalise rr rr_spec m rewritten in
+ let memory_size = TermHashtbl.length m in
+ let threshold = (memory_size / cMEM_USE_INCREASE_FACTOR) + 1 in
+ let size_addon = min (size_up_to 256 nmlized) threshold in
+ if steps > threshold + size_addon then
+ (TermHashtbl.add m nmlized res; (0, res))
+ else (prev_steps + steps + 1, res)
+ )))
| Term (n, t, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
(steps, Term (n, t, res))
Modified: trunk/Toss/Term/RewritingTest.ml
===================================================================
--- trunk/Toss/Term/RewritingTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Term/RewritingTest.ml 2012-06-25 18:03:52 UTC (rev 1734)
@@ -51,7 +51,7 @@
let t3 = Term ("Fand", [|boolean_tp|], [|var_x_b; t1|]) in
test_ne rrs "Fand[ @: Tboolean] (@V [x @: Tboolean @: 0 ], Ftrue[ @: Tboolean] )" t3;
let t4 = Term (if_then_else_name, [|boolean_tp|], [|var_x_b; t1; t1|]) in
- test_ne rrs ("Fif_\?_then_\?_else_\?[ @: Tboolean] (@V [x @: Tboolean @: 0 ], Fand[ @: Tboolean] (Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] ), Fand[ @: Tboolean] (Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] ) )") t4;
+ test_ne rrs ("Fif_\\?_then_\\?_else_\\?[ @: Tboolean] (@V [x @: Tboolean @: 0 ], Fand[ @: Tboolean] (Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] ), Fand[ @: Tboolean] (Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] ) )") t4;
let t5 = Term ("Ckot", [|char_tp|], [|var_x_b; t1; t1|]) in
test_ne rrs "Ckot[ @: Tchar] (@V [x @: Tboolean @: 0 ], Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] )" t5;
);
Modified: trunk/Toss/Term/tests/sasha_basic.log
===================================================================
--- trunk/Toss/Term/tests/sasha_basic.log 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Term/tests/sasha_basic.log 2012-06-25 18:03:52 UTC (rev 1734)
@@ -255,7 +255,7 @@
hanoi (0 , startPeg , goalPeg) => []
New rewrite rule defined.
-hanoi (noDiscs , startPeg , goalPeg) => hanoi (noDiscs - 1 , startPeg , remainingPeg (startPeg , goalPeg) ) + [ (startPeg , goalPeg) ] + hanoi (noDiscs - 1 , remainingPeg (startPeg , goalPeg) , goalPeg)
+hanoi (noDiscs , startPeg , goalPeg) => hanoi (noDiscs - 1 , startPeg , remainingPeg (startPeg , goalPeg) ) + ( [ (startPeg , goalPeg) ] + hanoi (noDiscs - 1 , remainingPeg (startPeg , goalPeg) , goalPeg) )
Closed context.
Modified: trunk/Toss/Term/tests/sasha_basic.trs
===================================================================
--- trunk/Toss/Term/tests/sasha_basic.trs 2012-06-25 14:30:21 UTC (rev 1733)
+++ trunk/Toss/Term/tests/sasha_basic.trs 2012-06-25 18:03:52 UTC (rev 1734)
@@ -130,8 +130,8 @@
hanoi (0, startPeg, goalPeg) => [];
hanoi (noDiscs, startPeg, goalPeg) =>
hanoi (noDiscs - 1, startPeg, remainingPeg (startPeg, goalPeg)) +
- [(startPeg, goalPeg)] +
- hanoi (noDiscs - 1, remainingPeg (startPeg, goalPeg), goalPeg);
+ ( [(startPeg, goalPeg)] +
+ hanoi (noDiscs - 1, remainingPeg (startPeg, goalPeg), goalPeg) );
***;
// Horner's algorithm for polynomial evaluation;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-25 14:30:33
|
Revision: 1733
http://toss.svn.sourceforge.net/toss/?rev=1733&view=rev
Author: lukstafi
Date: 2012-06-25 14:30:21 +0000 (Mon, 25 Jun 2012)
Log Message:
-----------
New Speagram step 2: doing inference online during parsing. For clean intermediate step, removed dealing with types from rewriting, apart from preserving them on rewritten subterms.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/Coding.ml
trunk/Toss/Term/Coding.mli
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArc.mli
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDef.mli
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/TRSTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermTest.ml
trunk/Toss/Term/tests/short_checks.log
trunk/Toss/Term/tests/short_checks.trs
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Formula/Aux.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -203,6 +203,11 @@
in
List.rev (maps_f [] l)
+let rec find_some f = function
+ | [] -> raise Not_found
+ | a::l ->
+ match f a with None -> find_some f l | Some r -> r
+
let map_reduce mapf redf red0 l =
match List.sort (fun x y -> compare (fst x) (fst y))
(List.map mapf l) with
@@ -707,6 +712,15 @@
true
with Not_found -> false
+let array_iter2 f a b =
+ let len = Array.length a in
+ if len <> Array.length b then
+ raise (Invalid_argument "Aux.array_iter2")
+ else
+ for i = 0 to len - 1 do
+ f (Array.unsafe_get a i) (Array.unsafe_get b i)
+ done
+
let array_replace array i elem =
let a = Array.copy array in a.(i) <- elem; a
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Formula/Aux.mli 2012-06-25 14:30:21 UTC (rev 1733)
@@ -62,6 +62,8 @@
(** Map a list filtering out some elements. *)
val map_some : ('a -> 'b option) -> 'a list -> 'b list
+(** Find the first non-None element. Raise [Not_found] if none exists. *)
+val find_some : ('a -> 'b option) -> 'a list -> 'b
(** Map elements into key-value pairs, and fold values with the same
key. Uses {!List.fold_left}, therefore reverses the order. The
@@ -288,6 +290,11 @@
arrays are of different lengths. *)
val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+(** Iterate an action over all elements of two arrays
+ pointwise. Raises [Invalid_argument "Aux.array_iter2"] if
+ arrays are of different lengths. *)
+val array_iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+
(** Return a copy of [array] with the [i]th element replaced by [elem]. *)
val array_replace : 'a array -> int -> 'a -> 'a array
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -293,7 +293,7 @@
let preprocess_sd = SDfun ([Str "#"; Str "#"; Str "#";
- Tp (Var ("p",0,top_type_term,[||]))], Var ("q",0,top_type_term,[||]))
+ Tp (Var ("p",0,top_type_term,[||]))], Var ("p",0,top_type_term,[||]))
let preprocess_name = name_of_sd preprocess_sd
Modified: trunk/Toss/Term/Coding.ml
===================================================================
--- trunk/Toss/Term/Coding.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/Coding.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -296,13 +296,36 @@
(* --- Term matching and substitutions --- *)
+(* Including supertypes.
let rec matches dict = function
- | (Term (n1, _, a1), Term (n2, _, a2)) when n1=n2 && (length a1 = length a2)->
+ | (Term (n1, t1, a1), Term (n2, t2, a2))
+ when n1=n2 && (length t1 = length t2) && (length a1 = length a2)->
+ Aux.array_for_all2 (fun u v -> matches dict (u, v)) t1 t2 &&
Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, d1, _, a1), Var (n2, d2, _, a2))
+ | (Var (n1, d1, t1, a1), Var (n2, d2, t2, a2))
when n1 = n2 && d1 = d2 && length a1 = length a2 ->
+ matches dict (t1, t2) &&
+ Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
+ | (Var (n1, d1, t1, [||]), te) ->
+ (try
+ let arg = List.assoc n1 (!dict) in
+ let coded_arg = fn_apply d1 code_term arg in
+ te = coded_arg
+ with Not_found ->
+ let decoded_te = fn_apply d1 decode_term te in
+ (dict := (n1, decoded_te) :: (!dict); true)
+ )
+ | _ -> false
+*)
+(* Ignoring supertypes. *)
+let rec matches dict = function
+ | (Term (n1, _, a1), Term (n2, _, a2))
+ when n1=n2 && (length a1 = length a2)->
Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, d1, _, [||]), te) ->
+ | (Var (n1, d1, _, a1), Var (n2, d2, _, a2))
+ when n1 = n2 && d1 = d2 && length a1 = length a2 ->
+ Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
+ | (Var (n1, d1, t1, [||]), te) ->
(try
let arg = List.assoc n1 (!dict) in
let coded_arg = fn_apply d1 code_term arg in
@@ -313,27 +336,50 @@
)
| _ -> false
-
-(* Application of term substitutions (only flat functional substitutes). *)
+(* Application of term substitutions (only flat functional
+ substitutes). Ignoring supertypes. *)
let rec apply_s substs = function
| Var (n, d, _, [||]) as t ->
(* FIXME: why we don't apply substitutions recursively, as below? *)
(try (fn_apply d code_term (List.assoc n substs)) with Not_found -> t)
- | Term (n, tp, a) -> Term (n, map (apply_s substs) tp, map (apply_s substs) a)
+ | Term (n, tp, a) -> Term (n, tp, map (apply_s substs) a)
| Var (n, deg, t, a) ->
try (
let raw_result =
match (List.assoc n substs) with
| Term (name, tps, [||]) ->
- Term (name, map (apply_s substs) tps, map (apply_s substs) a)
+ Term (name, tps, map (apply_s substs) a)
| Var (name, d, ty, [||]) ->
- Var (name, d, apply_s substs ty, map (apply_s substs) a)
+ Var (name, d, ty, map (apply_s substs) a)
| _ -> failwith "functional substitution of non-flat term" in
fn_apply deg code_term raw_result
)
with Not_found -> Var (n, deg, t, map (apply_s substs) a)
+(* Application of term substitutions (only flat functional
+ substitutes). Including supertypes. *)
+let rec apply_st substs = function
+ | Var (n, d, t, [||]) ->
+ (* FIXME: why we don't apply substitutions recursively, as below? *)
+ (try (fn_apply d code_term (List.assoc n substs))
+ with Not_found -> Var (n, d, apply_st substs t, [||]))
+ | Term (n, tp, a) ->
+ Term (n, map (apply_st substs) tp, map (apply_st substs) a)
+ | Var (n, deg, t, a) ->
+ try (
+ let raw_result =
+ match (List.assoc n substs) with
+ | Term (name, tps, [||]) ->
+ Term (name, map (apply_st substs) tps, map (apply_st substs) a)
+ | Var (name, d, ty, [||]) ->
+ Var (name, d, apply_st substs ty, map (apply_st substs) a)
+ | _ -> failwith "functional substitution of non-flat term" in
+ fn_apply deg code_term raw_result
+ )
+ with Not_found ->
+ Var (n, deg, apply_st substs t, map (apply_st substs) a)
+
(* --- Nice Term display based on Syntax Definitions --- *)
let is_some = function Some _ -> true | None -> false
@@ -351,7 +397,21 @@
let args = List.map display_term (Array.to_list a) in
display_sd (split_sdef_name n) args
+let rec display_term_bracketed = function
+ | te when is_some (decode_string_opt te) ->
+ "\"" ^ (decode_string te) ^ "\""
+ | te when is_some (decode_list_opt (fun x -> x) te) ->
+ let str_list = List.map display_term_bracketed
+ (decode_list (fun x -> x) te) in
+ "["^ (String.concat ", " str_list) ^ "]"
+ | Term (n, _, a) ->
+ let args = List.map display_term_bracketed (Array.to_list a) in
+ display_sd_bracketed (split_sdef_name n) args
+ | Var (n, _, _, a) ->
+ let args = List.map display_term_bracketed (Array.to_list a) in
+ display_sd_bracketed (split_sdef_name n) args
+
(* --- Display terms and types as XML --- *)
let rec display_type_xml = function
@@ -405,18 +465,30 @@
(match (decode_term_opt term) with None -> ""
| Some te -> "@T " ^ (term_to_string te))
| Var (v, d, t, [||]) ->
+ (try
"@V [" ^ v ^ " @: " ^ (type_to_string t) ^
" @: "^ string_of_int (d) ^ " ]"
+ with exn -> Printf.printf "Nontype: %s\n%!"(term_to_string t);
+ raise exn)
| Var (v, d, t, a) ->
+ (try
"@V [" ^ v ^ " @: " ^ (type_to_string t) ^
" @: "^ string_of_int (d) ^ " ] (" ^
(term_array_to_string a) ^ " )"
- (* FIXME: we should print types!!! *)
- | Term (n, tp, [||]) -> n ^ "[ @: " ^ type_array_to_string tp ^ "]"
+ with exn -> Printf.printf "Nontype: %s\n%!"(term_to_string t);
+ raise exn)
+ (* FIXME: we should print types!!! *)
+ | Term (n, tp, [||]) ->
+ (try
+ n ^ "[ @: " ^ type_array_to_string tp ^ "]"
+ with exn -> Printf.printf "Nontype: %s\n%!"(term_to_string tp.(0));
+ raise exn)
| Term (n, tp, a) ->
- n ^ "[ @: " ^ type_array_to_string tp ^ "] (" ^ (term_array_to_string a) ^ " )"
+ (try
+ n ^ "[ @: " ^ type_array_to_string tp ^ "] (" ^ (term_array_to_string a) ^ " )"
+ with exn -> Printf.printf "Nontype: %s\n%!"(term_to_string tp.(0));
+ raise exn)
-
(* Parser for terms. *)
let rec parse_term = function
| (Delim "@`") :: rest ->
Modified: trunk/Toss/Term/Coding.mli
===================================================================
--- trunk/Toss/Term/Coding.mli 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/Coding.mli 2012-06-25 14:30:21 UTC (rev 1733)
@@ -63,12 +63,18 @@
(** {2 Term Matching} *)
val matches : (string * term) list ref -> term * term -> bool
+(** Application of term substitutions (only flat functional
+ substitutes). Ignoring supertypes. *)
val apply_s : (string * term) list -> term -> term
+(** Application of term substitutions (only flat functional
+ substitutes). Including supertypes. *)
+val apply_st : (string * term) list -> term -> term
(** {2 Term Display, printing and parsing} *)
val display_term : term -> string
+val display_term_bracketed : term -> string
val display_type_xml : term -> string
val display_term_xml : term -> string
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Term/ParseArc.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/ParseArc.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -7,172 +7,189 @@
(* The type of elements created during parsing.
- Tokens come just from lexer and terms are created during parsing.
- Type is kept together with each term not to recalculate it too often. *)
+ Tokens come just from lexer and terms are created during parsing.
+ [term] does not have [substitution] applied. *)
type parser_elem =
| Token of string
- | Typed_term of term * term
+ | PTerm of term * substitution * int (* From [parsed_elems], [cstrn]
+ and [endpos] of {!parser_arc}. *)
(* Print a parser elem. *)
let elem_str = function
| Token s -> "Tok " ^ s
- | Typed_term (tp, te) ->
- "Te " ^ (Coding.term_to_string te) ^ " : " ^ (type_to_string tp)
+ | PTerm (te, subst, endpos) -> (* FIXME perhaps *)
+ "Te " ^ Coding.term_to_string te
-(* The type of incomplete arcs that appear during parsing;
- The last field is the position where the arc begins
- and the elements on the list are in reverse order
- and the field after the syntax definition is the
- unique name generated for this syntax def. *)
-type parser_arc = Arc of syntax_def * string * parser_elem list * int
+(* Incomplete arcs that appear during parsing. [parsed_elems] do not have
+ [cstrn] applied. *)
+type parser_arc = {
+ sd_n : string; (* The parsed definition's unique name. *)
+ sd_res : sdef_result; (* Its supertypes and whether it's
+ a variable. *)
+ rem_elems : syntax_elem list; (* Its remaining elements. *)
+ parsed_elems : parser_elem list; (* Useful elements parsed so far in
+ rev. order (all will be arguments). *)
+ spos : int; (* Start position of the arc. *)
+ endpos : int; (* The current end position of the
+ arc. FIXME: unnecessary? *)
+ cstrn : substitution; (* Constraint for the arc. *)
+}
-
(* --- Extending and closing arcs --- *)
-exception NOT_EXTENDED
-exception NOT_CLOSED
+(* This function takes a parser element and an arc and extends the arc
+ if the next free position in the arc matches the given
+ element. Maching means equality for tokens and inference constraint
+ satisfaction for terms. Throws NOT_EXTENDED if it was impossible
+ to extend the arc.
-(* Checking if a given parser element matches the given position in a syntax
- definition. Maching means equality for tokens and unification possibility
- when a typed term is put against a type. When a typed term is put against
- a constant string in syntax definition then it does not match and if a token
- is put agains a type then it matches only if its type is the string type. *)
-let matches_position elem sd i =
- let sel = syntax_elems_of_sd sd in
- let sd_elem =
- if (length sel < i) then None else Some (nth sel (i-1)) in
- match (sd_elem, elem) with
- | (None, _) -> false
- | (Some (Str s), Token t) -> s = t
- | (Some (Str s), Typed_term (_,te)) -> false
- | (Some (Tp ty), Token tk) -> ty = BuiltinLang.string_tp
- | (Some (Tp ty), Typed_term (t, _)) ->
- let (ty, t as tp) = suffix 0 ty, suffix 1 t in
- try let _ = mgu [] [tp] in true
- with UNIFY -> false
+ When a term is put against a constant string in syntax definition
+ then it does not match and if a token is put against a term then it
+ matches only if it is a string type. Parsing can be seen as
+ performing "algorithm W" style type inference.
+ Note that the remaining elements were originally generated from a
+ syntax definition by freshening the s.d.'s variables. *)
+let extend_arc elem arc =
+ match arc.rem_elems, elem with
+ | [], _ -> None
+ | Str s::rem_elems, Token t ->
+ if s = t
+ then Some {arc with rem_elems; endpos = arc.endpos + 1}
+ else None
+ | Str s::_, PTerm _ -> None
+ | Tp ty::rem_elems, Token tk ->
+ if ty = BuiltinLang.string_tp
+ then Some
+ {arc with rem_elems; endpos = arc.endpos + 1;
+ parsed_elems = elem::arc.parsed_elems}
+ else None
+ | Tp ty::rem_elems, PTerm (t, t_cstrn, t_endpos) ->
+ (* For now (first-order mgu) we assume single type. *)
+ let pty = type_of t in
+ try
+ (* Purely an optimization step. *)
+ precheck_eq ty pty;
+ (*let ty = Term.apply_sb arc.cstrn ty in
+ let pty = Term.apply_sb t_cstrn pty in
+ precheck_eq ty pty;*)
+ (* Combine the constraints so far, and extend them to cover
+ the new parsed element. *)
+ let cstrn = combine_mgu_sb t_cstrn arc.cstrn in
+ let cstrn =
+ mgu cstrn [apply_sb cstrn pty, apply_sb cstrn ty] in
+ Some
+ {arc with rem_elems; parsed_elems = elem::arc.parsed_elems;
+ endpos = t_endpos; cstrn}
+ with UNIFY -> None
-(* This function takes a parser element and an arc and extends
- the arc if the next free position in the syntax definition
- of the arc matches the given element.
- Throws NOT_EXTENDED if it was impossible to extend the arc. *)
-let extend_arc elem = function
- | Arc (sd, n, l, p) ->
- if matches_position elem sd ((length l) + 1) then
- Arc (sd, n, (elem :: l), p)
- else raise NOT_EXTENDED
-
-
(* Extends all the arcs in the given list that can be extended
and removes all other arcs. *)
let extend_arc_list elem arcs =
- let extend_elem arc = try [extend_arc elem arc] with NOT_EXTENDED -> [] in
- flatten (map extend_elem arcs)
+ Aux.map_some (extend_arc elem) arcs
-(* Divides arcs into complete and incomplete looking at the length
- of the syntax definition input list and the list of parsed elements.
- In other words the arc is complete if nothing can be added to it. *)
-let divide_arcs arcs =
- let is_complete = function
- | Arc (SDtype i, _, l, _) -> length i = length l
- | Arc (SDfun (i, _), _, l, _) -> length i = length l
- | Arc (SDvar (i, _), _, l, _) -> length i = length l in
- (filter is_complete arcs, filter (fun a -> not (is_complete a)) arcs)
+(* Divides arcs into completed and incompleted (the arc is completed if
+ nothing can be added to it). *)
+let completed_arcs arcs =
+ List.partition (fun arc -> arc.rem_elems = []) arcs
-(* Closes an arc, also when an arc is full generates a term
- from it so as the syntax definition prescribes and returns this
- element together with the starting position of the arc.
- It is checked if the generated term is well-typed and
- the type is computetd and kept in the resulting parser element.
- Type declarations are given as a list of pairs that gives
- for each term symbol the type of that symbol.
- Throws NOT_CLOSED if closing fails. *)
-let match_of_tok = function
- | (Str _, _) -> []
- | (Tp _, Token s) -> [Coding.code_string s]
- | (Tp _, Typed_term (_, te)) -> [te]
-
-let close_arc type_decls = function
- | Arc (sd, n, l, spos) when (length l = length (syntax_elems_of_sd sd)) ->
- let elems = syntax_elems_of_sd sd in
- let args = flatten (map match_of_tok (combine elems (rev l))) in
- let res_term = (match sd with
- | SDtype _ ->
+(* Closes an arc when it is completed: returns the corresponding term
+ parser element together with the starting position of the arc. *)
+let close_arc arc =
+ let match_of_tok = function
+ | Token s -> Coding.code_string s
+ | PTerm (t,_,_) -> t in (* t_cstrn is part of arc.cstrn *)
+ if arc.rem_elems <> [] then None else
+ let args = rev_map match_of_tok arc.parsed_elems in
+ let res_term = match arc.sd_res with
+ | SD_Term ty when ty = toplevel_type ->
Term (BuiltinLang.term_type_cons_name, [|BuiltinLang.term_type_tp|],
- [|Coding.code_string n;
+ [|Coding.code_string arc.sd_n;
Coding.code_list
[|BuiltinLang.list_tp BuiltinLang.term_type_tp|]
(fun x -> x) args|])
- | SDfun (_,tp) -> Term (n, [|tp|], Array.of_list args)
- | SDvar (_, _) ->
- (match sd_type sd with
- | None -> failwith "variable syntax definition w/o type"
- | Some (ty) -> Var (n, 0, ty, Array.of_list args) )
- ) in
- (try
- let typ = type_of_term type_decls res_term in
- (Typed_term (typ, res_term), spos)
- with NOT_WELL_TYPED _ ->
- raise NOT_CLOSED)
- | _ -> raise NOT_CLOSED
+ | SD_Term tp -> Term (arc.sd_n, tp, Array.of_list args)
+ | SD_Var tp -> Var (arc.sd_n, 0, tp, Array.of_list args) in
+ (* Note that [arc.cstrn] is not applied to [res_term]. *)
+ Some (PTerm (res_term, arc.cstrn, arc.endpos), arc.spos)
-(* Closes all arcs from the given list that can be closed
- and returns the elements together with starting positions. *)
-let close_arc_list type_decls arcs =
- let close_a a = try [close_arc type_decls a] with NOT_CLOSED -> [] in
- flatten (map close_a arcs)
+(* --- Parsing by adding arcs --- *)
+let fresh_suffix = ref 0
+let reset_fresh_count () = fresh_suffix := 0
+let create_arc sdef sd_n spos =
+ let freshen = List.map
+ (function Str _ as e -> e | Tp t -> Tp (suffix !fresh_suffix t)) in
+ let elems, sd_res =
+ match sdef with
+ | SDtype elems -> incr fresh_suffix;
+ freshen elems, SD_Term toplevel_type
+ | SDfun (elems, ty) -> incr fresh_suffix;
+ freshen elems, SD_Term [|suffix !fresh_suffix ty|]
+ | SDvar (elems, ty) ->
+ (* Do not freshen variable types or their argument types --
+ variables are not polymorphic! *)
+ elems, SD_Var ty in
+ {
+ sd_n; spos; sd_res;
+ rem_elems = elems;
+ parsed_elems = [];
+ endpos = spos;
+ cstrn = empty_sb;
+ }
-(* --- Parsing by adding arcs --- *)
-
-(* Parsing proceeds by going from left to right through the list
+(* TODO: clean-up the description.
+ Parsing proceeds by going from left to right through the list
of tokens and extending the incomplete arcs for each position.
We have our constant set of syntax definitions and in each step
we have a list of incomplete arcs ending in all up to this position
and the new parser elements (starting with just the next token).
We gather the secured incomplete arcs for the next position by doing this:
(1) extend all incomplete arcs (also assuming that each syntax definition
- is a new incomplete arc with empty list of parser elems) ending in
- this position with the new token,
+ is a new incomplete arc with empty list of parser elems) ending in
+ this position with the new token,
(2) secure the arcs that were extended and are still incomplete for the
- next step and close all complete arcs generating new parser elems
+ next step and close all complete arcs generating new parser elems
(3) for each new generated parser element look where its arc was
- starting and try extend all incomplete arcs ending there with
- the new element; repeat recursively until no new elements are generated.
- WARINNG: at the end we need to return also the elements. *)
-let rec extend type_decls sdefs arcs_to pos elem =
- let arcs = (map (fun (sd, n) -> Arc (sd,n,[],pos)) sdefs)@ arcs_to.(pos-1) in
- let (complete_arcs, ready_arcs) = divide_arcs (extend_arc_list elem arcs) in
- let new_els = close_arc_list type_decls complete_arcs in
- let res = map (fun (e, s) -> extend type_decls sdefs arcs_to s e) new_els in
+ starting and try extend all incomplete arcs ending there with
+ the new element; repeat recursively until no new elements are generated.
+ WARINNG: at the end we need to return also the elements. *)
+let rec extend sdefs arcs_to pos elem =
+ let arcs =
+ map (fun (n, sd) -> create_arc sd n pos) sdefs @ arcs_to.(pos-1) in
+ let compl_arcs, ready_arcs =
+ completed_arcs (extend_arc_list elem arcs) in
+ let new_els = Aux.map_some close_arc compl_arcs in
+ let res = map (fun (e, spos) -> extend sdefs arcs_to spos e) new_els in
let (res_arcs, res_elems) = List.split ((ready_arcs, new_els) :: res) in
(flatten res_arcs, flatten res_elems)
-let parse_elems type_decls sdefs elems =
+let parse_elems sdefs elems =
let len = length elems in
let arcs_to = Array.make (len + 1) [] in
let parsed_elems = Array.make (len + 1) [] in
let rec update i = if i > len then () else
- let (arcs_i,el_i) = extend type_decls sdefs arcs_to i (nth elems (i-1)) in
+ let (arcs_i,el_i) = extend sdefs arcs_to i (nth elems (i-1)) in
( arcs_to.(i) <- arcs_i; parsed_elems.(i) <- el_i; update (i+1) ) in
- ( update 1; (arcs_to, parsed_elems) )
+ update 1;
+ (arcs_to, parsed_elems)
-let parse_to_array type_decls sdefs_original strs =
+let parse_to_array sdefs_original strs =
let possible_tok = function Tp _ -> true | Str s -> mem s strs in
let possible_sd sd = for_all possible_tok (syntax_elems_of_sd sd) in
- let sdefs = filter (fun (sd, s) -> possible_sd sd) sdefs_original in
- snd (parse_elems type_decls sdefs (map (fun s -> Token s) strs))
+ let sdefs = filter (fun (n, sd) -> possible_sd sd) sdefs_original in
+ snd (parse_elems sdefs (map (fun s -> Token s) strs))
-let parse type_decls sdefs strs =
- let parsed = (parse_to_array type_decls sdefs strs).(length strs) in
- fst (List.split (filter (fun (_, start) -> start = 1) parsed))
+let parse sdefs strs =
+ let parsed = (parse_to_array sdefs strs).(length strs) in
+ map fst (filter (fun (_, start) -> start = 1) parsed)
(* --- Input splitting --- *)
@@ -244,3 +261,12 @@
let res = first_down (split_string_all split_delims_str) in
LOG 1 "%s" (String.concat " " res);
res
+
+(* --- Final parsing --- *)
+let parse_with_sdefs sdefs str =
+ let type_of_pe = function Token _ -> None
+ | PTerm (te, cstrn, _) ->
+ let result = apply_sb cstrn te in
+ Some result in
+ let elems = parse sdefs (split_input_string str) in
+ Aux.map_some type_of_pe elems
Modified: trunk/Toss/Term/ParseArc.mli
===================================================================
--- trunk/Toss/Term/ParseArc.mli 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/ParseArc.mli 2012-06-25 14:30:21 UTC (rev 1733)
@@ -4,34 +4,52 @@
open Term
open SyntaxDef
-(** Elements used in the parser. *)
+(** The type of elements created during parsing. Tokens come just
+ from lexer and terms are created during parsing. [term] does not
+ have [substitution] applied. *)
type parser_elem =
| Token of string
- | Typed_term of term * Term.term
+ | PTerm of term * substitution * int (** From [parsed_elems], [cstrn]
+ and [endpos] of {!parser_arc}. *)
(** Print a parser elem. *)
val elem_str : parser_elem -> string
-(** Arcs built by the parser. *)
-type parser_arc = Arc of syntax_def * string * parser_elem list * int
+(** Reset the variable suffix count. *)
+val reset_fresh_count : unit -> unit
+(** Incomplete arcs that appear during parsing. [parsed_elems] do not have
+ [cstrn] applied. *)
+type parser_arc = {
+ sd_n : string; (** The parsed definition's unique name. *)
+ sd_res : sdef_result; (** Its supertypes and whether it's
+ a variable. *)
+ rem_elems : syntax_elem list; (** Its remaining elements. *)
+ parsed_elems : parser_elem list; (** Useful elements parsed so far in
+ rev. order (all will be arguments). *)
+ spos : int; (** Start position of the arc. *)
+ endpos : int; (** The current end position of the arc. *)
+ cstrn : substitution; (** Constraint for the arc. *)
+}
+
(** {2 Parsing, done by adding arcs} *)
+val create_arc : syntax_def -> string -> int -> parser_arc
+
(** Extends all the arcs in the given list that can be extended
and removes all other arcs. *)
val extend_arc_list : parser_elem -> parser_arc list -> parser_arc list
-(** Closes all arcs from the given list that can be closed
- and returns the elements together with starting positions. *)
-val close_arc_list : (string, term) Hashtbl.t ->
- parser_arc list -> (parser_elem * int) list
+(** Closes an arc when it is completed: returns the corresponding term
+ parser element together with the starting position of the arc. *)
+val close_arc : parser_arc -> (parser_elem * int) option
+val parse_to_array :
+ (string * syntax_def) list -> string list -> (parser_elem * int) list array
-val parse_to_array : (string, term) Hashtbl.t ->
- (syntax_def * string) list -> string list -> (parser_elem * int) list array
+val parse : (string * syntax_def) list -> string list -> parser_elem list
-val parse : (string, term) Hashtbl.t -> (syntax_def * string) list ->
- string list -> parser_elem list
+val split_input_string : string -> string list
-val split_input_string : string -> string list
+val parse_with_sdefs : (string * syntax_def) list -> string -> term list
Modified: trunk/Toss/Term/ParseArcTest.ml
===================================================================
--- trunk/Toss/Term/ParseArcTest.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/ParseArcTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -20,25 +20,25 @@
let var_x_a_sd = SDvar ([Str "x"], Var ("a",0,top_type_term,[||])) in
let sdefs = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
- let arcs = List.map (fun sd -> Arc (sd, (name_of_sd sd), [], 0)) sdefs in
+ let arcs = List.map (fun sd -> create_arc sd (name_of_sd sd) 0) sdefs in
let var_arc = extend_arc_list (Token "x") arcs in
- let var_closed = fst (List.hd (close_arc_list tps var_arc)) in
- elem_eq "Te @V [Vx @: @? a @: 0 ] : @? a" var_closed;
+ let var_closed = fst (Aux.find_some close_arc var_arc) in
+ elem_eq "Te @V [Vx @: @? a @: 0 ]" var_closed;
let nil_part_arcs = extend_arc_list (Token "[") arcs in
let nil_arc = extend_arc_list (Token "]") nil_part_arcs in
- let nil_closed = fst (List.hd (close_arc_list tps nil_arc)) in
- elem_eq "Te @L[] : T\\?_list (@? a._.5)" nil_closed;
+ let nil_closed = fst (Aux.find_some close_arc nil_arc) in
+ elem_eq "Te @L[]" nil_closed;
let cons_part1_arc = extend_arc_list var_closed arcs in
let cons_part2_arc = extend_arc_list (Token ",") cons_part1_arc in
let cons_arc = extend_arc_list nil_closed cons_part2_arc in
- let cons_closed = fst (List.hd (close_arc_list tps cons_arc)) in
- elem_eq "Te @L[@V [Vx @: @? a @: 0 ]] : T\\?_list (@? a._.6)" cons_closed;
+ let cons_closed = fst (Aux.find_some close_arc cons_arc) in
+ elem_eq "Te @L[@V [Vx @: @? a @: 0 ]]" cons_closed;
let cons_bad_arc = extend_arc_list var_closed cons_part2_arc in
- let cons_bad_closed = close_arc_list tps cons_bad_arc in
+ let cons_bad_closed = Aux.map_some close_arc cons_bad_arc in
assert_equal ~printer:(fun x -> "empty list test") [] cons_bad_closed;
);
@@ -56,16 +56,17 @@
let var_x_a_sd = SDvar ([Str "x"], Var ("a",0,top_type_term,[||])) in
let sdefs_basic = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
- let sdefs = List.map (fun sd -> (sd, name_of_sd sd)) sdefs_basic in
+ let sdefs = List.map (fun sd -> (name_of_sd sd, sd)) sdefs_basic in
let parse_test res l =
- let ls = String.concat ", " (List.map elem_str (parse tps sdefs l)) in
+ let ls = String.concat ", " (List.map elem_str (parse sdefs l)) in
assert_equal ~printer:(fun x -> x) res ls in
- parse_test "Te @V [Vx @: @? a @: 0 ] : @? a" ["x"];
- parse_test "Te @L[@V [Vx @: @? a @: 0 ]] : T\\?_list (@? a._.6)"
+ parse_test "Te @V [Vx @: @? a @: 0 ]" ["x"];
+ parse_test "Te @L[@V [Vx @: @? a @: 0 ]]"
["x"; ","; "["; "]"];
parse_test "" ["x"; ","; "x"];
- parse_test ("Te @L[@V [Vx @: @? a @: 0 ], @V [Vx @: @? a @: 0 ]] : " ^
- "T\\?_list (@? a._.7)") ["x"; ","; "x"; ","; "["; "]"];
+ parse_test
+ ("Te @L[@V [Vx @: @? a @: 0 ], @V [Vx @: @? a @: 0 ]]")
+ ["x"; ","; "x"; ","; "["; "]"];
);
Modified: trunk/Toss/Term/Rewriting.ml
===================================================================
--- trunk/Toss/Term/Rewriting.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/Rewriting.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -33,10 +33,15 @@
(* --- Rewriting with Clash Detection --- *)
+(* For now, rewriting ignores supertypes, which is fast for
+ manipulating only arguments at the bottom level of hierarchy (but
+ reduces the flexibility of "Hierarchical Terms" to providing
+ subtypes for parsing). *)
+
exception NO_MATCH
(* Checking match returning lists to substitute for and detecting clash.
- In documentation this is described as STEP 1.
+ In documentation this is described as STEP 1. (FIXME: docs)
We assume that the rewrite rules are correct and therefore have no
functions on the left side, but we do not check it dynamically here. *)
let check_clash_match (term1, term2) =
@@ -49,7 +54,7 @@
Aux.array_fold_left2 update (false, []) a1 a2
| (Term (n1, _, _), Term (n2, _, [||])) when (n1 = n2) ->
raise NO_MATCH (* used cons vs. functional cons *)
- | (Term (n1, _, a1), Term (n2, _, a2)) when (n1 = n2) ->
+ | (Term (n1, _, _), Term (n2, _, _)) when (n1 = n2) ->
(*Printf.printf "check_clash_match: [1] %s(%d) %s(%d): %a -- %a\n"
n1 (Array.length a1) n2 (Array.length a2)
(Aux.array_fprint (fun o t->output_string o (Coding.term_to_string t))) a1
@@ -75,10 +80,12 @@
raise NO_MATCH (* non-0-arg fun and functional term *)
| _ -> failwith "rewriting not this function"
-(* Merging substitutions according to variable names. *)
+(* Merging substitutions according to variable names. FIXME: perhaps
+ use [Term.combine_mgu_sb], otherwise streamline. *)
let merge_substs substs =
let merged_substs = Aux.collect substs in
- let mkcm b = if List.length b <> 1 then failwith "cm" else snd (List.hd b) in
+ let mkcm b = (* if List.length b <> 1 then failwith "cm" else *)
+ snd (List.hd b) in
let make_cm (a, b) = (false, (a, mkcm b)) in
let (clashes, substs) = List.split (map make_cm merged_substs) in
(exists (fun x -> x) clashes, substs)
@@ -91,7 +98,23 @@
let (clash, substs) = check_clash_match (left, term) in
if clash then term else
let (merge_clash, merged_substs) = merge_substs substs in
- if merge_clash then term else Coding.apply_s merged_substs right
+ if merge_clash then term
+ else
+ let result = Coding.apply_s merged_substs right in
+ (* For now, we copy over the supertypes fro the original, as
+ the old rewriting ignores supertypes. *)
+ match term, result with
+ | Term (_, oldtys, _), Term (n, _, args) ->
+ Term (n, oldtys, args)
+ | Var (_, _, oldty, _), Term (n, _, args) ->
+ Term (n, [|oldty|], args)
+ | Var (_, _, oldty, _), Var (n, d, _, args) ->
+ Var (n, d, oldty, args)
+ | Term (_, [|oldty|], _), Var (n, d, _, args) ->
+ Var (n, d, oldty, args)
+ (* failwith "apply_check_clash: rewriting non-var with var" *)
+ | Term _, Var (n, d, _, args) ->
+ Var (n, d, term, args)
(* The final rewrite function that takes care of function names in terms. *)
let rewrite (Rules (rules)) term =
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Term/SyntaxDef.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -16,6 +16,11 @@
| SDfun of syntax_elem list * term
| SDvar of syntax_elem list * term
+(* Supertypes and whether we define a variable. Minor current and
+ perhaps bigger future use. *)
+type sdef_result =
+ | SD_Term of term array
+ | SD_Var of term
(* --- Basic functions for Syntax Definitions, generating names --- *)
@@ -92,7 +97,7 @@
let func_sd_of_sd sd =
let change = function Tp _ -> [Str "{"; Str "}"] | x -> [x] in
let oldelems = (syntax_elems_of_sd sd) in
- let nelems = List.flatten (List.map change oldelems) in
+ let nelems = Aux.concat_map change oldelems in
let (sels, ty) =
if nelems = oldelems then
(Str "{" :: nelems @ [Str "}"], sd_type sd)
@@ -206,7 +211,31 @@
let display_sd syntax args =
display_sd_full syntax (List.map (fun x -> (x, None)) args)
+let rec display_sd_full_bracketed syntax args =
+ let are_common_type c1 c2 = ((Aux.is_digit c1) && (Aux.is_digit c2)) ||
+ ((not (Aux.is_alphanum c1 || c1 = ')' || c1 = ']')) &&
+ (not (Aux.is_alphanum c2 || c2 = '(' || c2 = '['))) ||
+ ((c1 ='(') && (Aux.is_alphanum c2)) || ((c2=')') && (Aux.is_alphanum c1)) ||
+ ((c1 ='[') && (Aux.is_alphanum c2)) || ((c2=']') && (Aux.is_alphanum c1)) ||
+ ((c1 = '(') && (c2 = ')')) || ((c1 = '[') && (c2 = ']')) in
+ let put_space s1 s2 =
+ if (s1 = "" || s2 = "") then s1 ^ s2 else
+ if s2.[0] = ' ' then s1 ^ s2 else
+ if (are_common_type (s1.[(String.length s1) - 1]) (s2.[0])) then
+ s1 ^ s2
+ else s1 ^ " " ^ s2 in
+ match (syntax, args) with
+ | ([], []) -> ""
+ | (Some s :: xs, a) -> put_space s (display_sd_full_bracketed xs a)
+ | (None :: xs, []) -> " {} " ^ (display_sd_full_bracketed xs [])
+ | (None :: xs, (n, _) :: aas) -> "{" ^ n ^"} "^ (display_sd_full_bracketed xs aas)
+ | ([], a) -> " ("^ (String.concat ", " (List.map (fun (s, _) -> s) a)) ^")"
+
+let display_sd_bracketed syntax args =
+ display_sd_full_bracketed syntax (List.map (fun x -> (x, None)) args)
+
+
(* --- Printing Syntax Definitions and Types in our syntax --- *)
let split_sdef_name n =
@@ -347,7 +376,7 @@
String.concat "" (List.map xslt_for_se sels)
-let xslt_template_for_sd_name (sd, name) =
+let xslt_template_for_sd_name (name, sd) =
try
"<xsl:template match=\"*[@class='" ^ make_xml_compatible (name) ^
"']\">" ^ xslt_content_for_sel (syntax_elems_of_sd sd) ^ "</xsl:template>"
Modified: trunk/Toss/Term/SyntaxDef.mli
===================================================================
--- trunk/Toss/Term/SyntaxDef.mli 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/SyntaxDef.mli 2012-06-25 14:30:21 UTC (rev 1733)
@@ -12,7 +12,13 @@
| SDfun of syntax_elem list * Term.term
| SDvar of syntax_elem list * Term.term
+(** Supertypes and whether we define a variable. Minor current and
+ perhaps bigger future use. *)
+type sdef_result =
+ | SD_Term of Term.term array
+ | SD_Var of Term.term
+
(** {2 Basic functions on Syntax Definitions, generating names} *)
val syntax_elems_of_sd : syntax_def -> syntax_elem list
@@ -29,6 +35,7 @@
val split_sd_name : string -> string option list
val display_sd : string option list -> string list -> string
+val display_sd_bracketed : string option list -> string list -> string
(** {2 Pretty printing Types and Syntax Definitions} *)
@@ -51,4 +58,4 @@
(** {2 XSLT output for Syntax Definitions with names} *)
val make_xml_compatible : string -> string
-val print_xslt : string -> (syntax_def * string) list -> string
+val print_xslt : string -> (string * syntax_def) list -> string
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/TRS.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -13,7 +13,7 @@
names, type declarations, rewrite rules and list of all used names.
For now it also has list of loaded file names to prevent double-loading. *)
type trs = {
- sdefs : (syntax_def * string) list; (* Syntax definitions *)
+ sdefs : (string * syntax_def) list; (* Syntax definitions *)
types : (string, term) Hashtbl.t; (* Types *)
mem : (term TermHashtbl.t); (* Memory used by normalisation *)
rrules : (string, Rewriting.rrules_set) Hashtbl.t; (* Rewriting rules *)
@@ -37,7 +37,7 @@
let tds = match sd_type sd with
| None -> sys.hist
| Some t -> (Hashtbl.add sys.types n t; (n, t) :: sys.hist) in
- let add_sdefs = map (fun sd -> (sd, n)) (sd :: (func_sd_of_sd sd)) in
+ let add_sdefs = map (fun sd -> (n, sd)) (sd :: (func_sd_of_sd sd)) in
{ sys with
sdefs = add_sdefs @ sys.sdefs;
mem = TermHashtbl.create 512;
@@ -68,7 +68,8 @@
let update_on_close_context_term te sys =
match te with
| Term (n, _, [||]) when n = close_context_name ->
- let nsds = filter (function (SDvar _, _) -> false | _-> true) sys.sdefs in
+ reset_fresh_count ();
+ let nsds = filter (function (_, SDvar _) -> false | _-> true) sys.sdefs in
{ sys with sdefs = nsds }
| _ -> sys
@@ -161,9 +162,9 @@
let get_funs_of_sys = get_elems_of_sys 'F'
let get_types_of_sys sys =
- let classes = filter (function (SDtype _, _) -> true | _-> false) sys.sdefs in
+ let classes = filter (function (_,SDtype _) -> true | _-> false) sys.sdefs in
let get_tys sels = filter (function Tp _ -> true | _ -> false) sels in
- let td_of_sd (sd, n) = (n, length (get_tys (syntax_elems_of_sd sd))) in
+ let td_of_sd (n, sd) = (n, length (get_tys (syntax_elems_of_sd sd))) in
map td_of_sd classes
@@ -201,10 +202,7 @@
(* Parse a string using the given system. *)
let parse_with_sys sys str =
- let elems = parse sys.types sys.sdefs (split_input_string str) in
- let type_of_pe = function Token _ -> []
- | Typed_term (_, te) -> [te] in
- flatten (map type_of_pe elems)
+ parse_with_sdefs sys.sdefs str
let is_better sys te1 te2 =
let query = Term (preferred_to_name,[|ternary_truth_value_tp|],
@@ -249,7 +247,7 @@
remove_bracket_duplicates best
let terms_info verb ts =
- let disp t = (display_term t) ^
+ let disp t = (display_term_bracketed t) ^
" [" ^ (term_to_string (normalise_brackets t)) ^ "]" in
if (length ts > 1) then
"Disambiguate " ^ (string_of_int (length ts)) ^ " terms\n" ^
@@ -387,7 +385,10 @@
let path = decode_load_cmd k te in
msg ("Loaded state " ^ path ^ ".") ""
| (te, _) ->
- let ty = type_of_term tydecls te in
+ (* FIXME: at step 4 the "types" will get displayed properly *)
+ let ty = match te with
+ | Var (_, _, ty, _) -> ty
+ | Term (_, tys, _) -> tys.(0) in
if xml_out then
"<trs-result>\n" ^
(display_term_xml te) ^ "\n\n" ^ (display_type_xml ty) ^
@@ -405,7 +406,8 @@
raise (FAILED_PARSE_OR_EXN msg))
| [x] ->
(* FIXME *)
- let te = normalise_with_sys s (Term (preprocess_name, [|Var ("q",0,top_type_term,[||])|], [|x|])) in (
+ let te = normalise_with_sys s
+ (Term (preprocess_name, types_of x, [|x|])) in (
match te with
| Term (te_name, _, [|a|]) when te_name = exception_name ->
let msg = "TRS EXCEPTION:\n" ^ (display_term a) ^ "\n" in
Modified: trunk/Toss/Term/TRS.mli
===================================================================
--- trunk/Toss/Term/TRS.mli 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/TRS.mli 2012-06-25 14:30:21 UTC (rev 1733)
@@ -5,7 +5,7 @@
type trs
(** Get syntax definitions from a TRS. *)
-val syntax_defs_of_sys : trs -> (syntax_def * string) list
+val syntax_defs_of_sys : trs -> (string * syntax_def) list
(** Get set values (chronologically) from a TRS. *)
val set_vals_of_sys : trs -> (string * Term.term * Term.term) list
Modified: trunk/Toss/Term/TRSTest.ml
===================================================================
--- trunk/Toss/Term/TRSTest.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/TRSTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -19,13 +19,14 @@
let proc sys s =
let o = ref "" in
let print_o str = o := !o ^ str ^ "\n" in
+ ParseArc.reset_fresh_count ();
let (sys1, _, m) = process_with_system "" false sys s false print_o
in (sys1, m, !o) in
let s1 = "function ''new'' syntax definition as syntax definition" in
let (sys1, m, _) = proc (basic_system ()) s1 in
assert_equal ~printer:(fun x->x) "New function \"new\" X_1 declared.\n" m;
let (_, m, _) = proc sys1 "[]" in
- assert_equal ~printer:(fun x -> x) "Result: {[] as ?a._.5 list}" m;
+ assert_equal ~printer:(fun x -> x) "Result: {[] as ?a._.4 list}" m;
);
"simple parsing" >::
@@ -97,7 +98,7 @@
);
if (not (!grammar_path = "")) then (
let grammar_str =
- let sys_sdefs = fst (List.split (syntax_defs_of_sys !sys)) in
+ let sys_sdefs = List.map snd (syntax_defs_of_sys !sys) in
print_grammar (flat_grammar_of_sd_list (sys_sdefs)) in
AuxIO.output_file ~fname:!grammar_path grammar_str
);
Modified: trunk/Toss/Term/Term.ml
===================================================================
--- trunk/Toss/Term/Term.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/Term.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -192,21 +192,48 @@
Thanks to F. Baader and T. Nipkow for the book "Term Rewriting and
all That" where the algorithm is explained and similar code is
- given. *)
+ given.
+ When doing first-order operations, we cannot check for
+ well-formedness of substitution, i.e. "typecheck" the
+ variables. *)
+
(* Just an alias for term types substitutions. *)
type substitution = (string * term) list
+let empty_sb = []
+
(* Exists funciton for arrays. *)
let exists f ar = Aux.array_existsi (fun _ e -> f e) ar
+let assoc_sb = List.assoc
+
(* Application of substitutions. *)
-let rec apply subst tp =
+let rec apply_sb subst tp =
match tp with
- | Var (n, _, _, _) as var ->
- (try List.assoc n subst with Not_found -> var)
- | Term (n, t, a) -> Term (n, map (apply subst) t, map (apply subst) a)
+ | Var (n, d, ty, [||]) ->
+ (try List.assoc n subst with Not_found ->
+ Var (n, d, apply_sb subst ty, [||]))
+ | Var (n, d, ty, a) ->
+ (try
+ match List.assoc n subst with
+ | Term (name, tps, [||]) ->
+ Term (name, tps, map (apply_sb subst) a)
+ | Var (name, d, ty, [||]) ->
+ Var (name, d, ty, map (apply_sb subst) a)
+ | _ -> failwith
+ "apply_sb: functional substitution of non-flat term"
+ with Not_found ->
+ Var (n, d, apply_sb subst ty, map (apply_sb subst) a))
+ | Term (n, t, a) ->
+ Term (n, map (apply_sb subst) t, map (apply_sb subst) a)
+let compose_sb s1 s2 =
+ let rec aux = function
+ | [] -> s1
+ | (x, t)::tl -> (x, apply_sb s1 t) :: aux tl in
+ aux s2
+
exception UNIFY
(* The combine function makes a list of pairs from a pair of arrays. *)
@@ -218,6 +245,21 @@
| [] -> raise UNIFY
| hd::tl -> try f hd with UNIFY -> find_unify f tl
+let rec precheck_eq te1 te2 =
+ match te1, te2 with
+ | Term (_, t1, a1), Term (_, t2, a2)
+ when Array.length t1 <> Array.length t2 ||
+ Array.length a1 <> Array.length a2 -> raise UNIFY
+ | Term (n1, t1, a1), Term (n2, t2, a2) when n1 == n2 ->
+ Aux.array_iter2 precheck_eq t1 t2;
+ Aux.array_iter2 precheck_eq a1 a2
+ | Term (n1, t1, a1), Term (n2, t2, a2) when n1 <> n2 ->
+ raise UNIFY
+ | Term (n1, t1, a1), Term (n2, t2, a2) (*when n1 = n2*) ->
+ Aux.array_iter2 precheck_eq t1 t2;
+ Aux.array_iter2 precheck_eq a1 a2
+ | _ -> () (* variable on either side *)
+
(** Returns the matching: [eq_match [] (p,q)] is a well-formed
substitution [r] such that [r(p)=q]. *)
let rec eq_match subst = function
@@ -233,10 +275,7 @@
(try if List.assoc v subst = tp then eq_match subst tps
else raise UNIFY
with Not_found ->
- let subst = (v,tp)::subst in
- let subst = find_unify (eq_match subst)
- (List.map (fun t' -> [t, t']) (tp::to_list t')) in
- eq_match subst tps)
+ eq_match ((v,tp)::subst) tps)
(* for higher-order variable, we do a head-term matching *)
| (Var (v, _, t, a), (Var (_, _, t', a') as tp)) :: tps ->
(try if List.assoc v subst = tp then eq_match subst tps
@@ -248,10 +287,8 @@
(try if List.assoc v subst = tp then eq_match subst tps
else raise UNIFY
with Not_found ->
- let subst = (v,tp)::subst in
- let subst = find_unify (eq_match subst)
- (List.map (fun t' -> [t, t']) (tp::to_list t')) in
- eq_match subst (combine a a' @ tps))
+ (* *)
+ eq_match ((v,tp)::subst) (combine a a' @ tps))
| (_, (Var _)) :: _ -> raise UNIFY
| (Term (f, t, a), Term (g, t', a')) :: tps ->
if f = g
@@ -272,18 +309,12 @@
| (t,t')::tps when t = t' -> mgu subst tps
| (Var (v, _, t, [||]), (Var (_, _, t', _) as tp)) :: tps ->
elim v tp ((t,t') :: tps) subst
- | (Var (v, _, t, [||]), (Term (_, t', _) as tp)) :: tps ->
- (* checking one level of [tp ISA var] *)
- let subst = find_unify (mgu subst)
- (List.map (fun t' -> [t, t']) (tp::to_list t')) in
+ | (Var (v, _, _, [||]), (Term _ as tp)) :: tps ->
elim v tp tps subst
(* for higher-order variable, we do a head-term matching *)
| (Var (v, _, t, a), (Var (_, _, t', a') as tp)) :: tps ->
elim v tp ((t,t') :: combine a a' @ tps) subst
- | (Var (v, _, t, a), (Term (_, t', a') as tp)) :: tps ->
- (* checking one level of [tp ISA var] *)
- let subst = find_unify (mgu subst)
- (List.map (fun t' -> [t, t']) (tp::to_list t')) in
+ | (Var (v, _, _, a), (Term (_, _, a') as tp)) :: tps ->
elim v tp (combine a a' @ tps) subst
| (tp, (Var _ as var)) :: tps -> mgu subst ((var, tp) :: tps)
(* [top_type_term] can be bound to a variable, but otherwise we let
@@ -297,11 +328,27 @@
(* occurs check is only needed if we want to avoid cyclic terms *)
if occurs v tp then raise UNIFY
else
- let app = apply [v, tp] in
+ let app = apply_sb [v, tp] in
let new_tps = List.map (fun (t1,t2) -> app t1, app t2) tps in
let new_subst = (v, tp) :: List.map (fun (n, ty) -> n, app ty) subst in
mgu new_subst new_tps
+let combine_mgu_sb s1 s2 =
+ let eqs, s1 =
+ Aux.partition_map (fun (x, t) ->
+ try Aux.Left (List.assoc x s2, t)
+ with Not_found -> Aux.Right (x, apply_sb s2 t)) s1 in
+ let sb = compose_sb s1 s2 in
+ mgu sb eqs
+
+let type_of = function
+ | Var (_, _, t, _) -> t
+ | Term (_, supt, _) -> supt.(0)
+
+let types_of = function
+ | Var (_, _, t, _) -> [|t|]
+ | Term (_, supt, _) -> supt
+
(** {2 ISA relation operations.} *)
(** Result of comparing two symbols w.r.t. the ISA relation in a
@@ -347,6 +394,7 @@
| Term (n, tp, a) when tp = toplevel_type ->
if (length a = 0) then n else
n ^ " (" ^ (type_array_to_string a) ^ ")"
+ | t when t = top_type_term -> "@U"
| _ -> failwith "non-type term in type_to_string"
@@ -355,7 +403,8 @@
let split_to_list str =
let split_space s = Aux.split_spaces s in
let full_special_split s =
- let l = Aux.split_chars_after '@' ['F';'L';'V';'Y';'T';'`';':';'?'] s in
+ let l = Aux.split_chars_after '@'
+ ['F';'L';'V';'U';'Y';'T';'`';':';'?'] s in
let is_special c = (c = '(') || (c = ')') ||(c = '[') || (c = ']') ||
(c = ',') in
let divide s =
@@ -381,6 +430,8 @@
let rec parse_type = function
| (Aux.Delim "@?") :: (Aux.Text n) :: rest ->
Var (n, 0, top_type_term, [||]), rest
+ | (Aux.Delim "@U") :: rest ->
+ top_type_term, rest
| (Aux.Delim "@F") :: rest ->
(match parse_list rest with
| ([], cont) -> failwith "Function w/o return type."
@@ -410,50 +461,11 @@
let (ty, cont) = parse_type (split_to_list s) in
if cont = [] then ty else failwith "type_of_string: incomplete parse"
+let subst_str subst = String.concat ", "
+ (List.map (fun (s, tp) ->
+ s ^ " <- " ^ (type_to_string tp)) subst)
-(* --- Reconstructing the Type of a Term --- *)
-exception NOT_WELL_TYPED of string
-
-let rec type_sack (i, itys) = function
- | Term (n, _, a) ->
- let ((i, uni_sack, ty_decls), arg_tys) = fold_left type_sack (i ,[]) a in
- (match (suffix i (Hashtbl.find ty_decls n), List.rev arg_tys) with
- | (ty, []) -> ((i+1, uni_sack, ty_decls), ty :: itys)
- | (Term (n, tp, arr), rt) when n = fun_type_name && tp = toplevel_type->
- let l = Array.length arr in
- let (at, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
- (try ((i+1, (List.combine (to_list at) rt) @ uni_sack, ty_decls),
- r :: itys)
- with Invalid_argument _-> raise (NOT_WELL_TYPED "type_sack, term,i.a")
- )
- | _ -> raise (NOT_WELL_TYPED "type_sack, term, end")
- )
- | Var (_, code_degree, var_type, a) ->
- let ((i, uni_sack, ty_decls), arg_tys) = fold_left type_sack (i, []) a in
- (* if code_degree = 0 then var_types.(0) else term_tp in *)
- (match var_type, List.rev arg_tys with
- | (ty, []) -> ((i+1, uni_sack, ty_decls), ty :: itys)
- | (Term (n, tp, arr), rt) when n = fun_type_name && tp = toplevel_type->
- let l = Array.length arr in
- let (at, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
- (try ((i+1, (List.combine (to_list at) rt) @ uni_sack, ty_decls),
- r :: itys)
- with Invalid_argument _-> raise (NOT_WELL_TYPED "type_sack, var, i.a")
- )
- | _ -> raise (NOT_WELL_TYPED "type_sack, var, end")
- )
-
-let type_of_term type_decls te =
- let ((_, sack, _), type_l) = type_sack ((5, [], type_decls), []) te in
- try
- let subst = mgu [] sack in
- match type_l with
- | [ty] -> apply subst ty
- | _ -> raise (NOT_WELL_TYPED "type_of_term, match")
- with UNIFY -> raise (NOT_WELL_TYPED ("type_of_term, unify "))
-
-
(* --- Hashtables for Terms --- *)
module HashableTerm =
Modified: trunk/Toss/Term/Term.mli
===================================================================
--- trunk/Toss/Term/Term.mli 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/Term.mli 2012-06-25 14:30:21 UTC (rev 1733)
@@ -25,20 +25,42 @@
(** List variables in the given term. *)
val vars_in_term : term -> term list
-
val fn_apply : int -> ('a -> 'a) -> 'a -> 'a
(** {2 Type Unification} *)
-(** Just an alias for term types substitutions. *)
-type substitution = (string * term) list
+(** Substitutions are kept abstract to make it easier to evolve term
+ semantics. *)
+type substitution
(** Exception used in unification algorithm on failure. *)
exception UNIFY
-(** Application of substitutions. *)
-val apply : substitution -> term -> term
+(** Operations on substitutions. *)
+val empty_sb : substitution
+(** Find a term corresponding to the name of a variable or raise
+ [Not_found]. *)
+val assoc_sb : string -> substitution -> term
+val apply_sb : substitution -> term -> term
+(** [compose_sb s1 s2] returns [fun x -> s1 (s2 (x))]; usually the domain
+ of[s1] will be disjoint with the domain of [s2]. Order of
+ substitutions matters. *)
+val compose_sb : substitution -> substitution -> substitution
+(** [combine_mgu_sb s1 s2] first-order-unifies the set of equations
+ induced by both substitutions (i.e. the equations [x = t] for
+ [s1(x)=t] or [s2(x)=t]). The order of substitutions does not
+ matter. *)
+val combine_mgu_sb : substitution -> substitution -> substitution
+(** Check whether equality-based matching or unification would
+ fail. Raises [UNIFY]. *)
+val precheck_eq : term -> term -> unit
+
+(** Returns the matching: [eq_match [] (p,q)] is a well-formed
+ substitution [r] such that [r(p)=q]. *)
+val eq_match : substitution -> (term * term) list -> substitution
+
+
(** Returns the Most General Unifier substitution, throws [UNIFY] if
impossible.
@@ -46,6 +68,10 @@
different types in a (well-formed) term. *)
val mgu : substitution -> (term * term) list -> substitution
+(** Temporary: assuming a single type of a term. *)
+val type_of : term -> term
+(** Return the supertypes of a term or type of a variable. *)
+val types_of : term -> term array
(** {2 Parsing and Printing Types} *)
@@ -61,6 +87,7 @@
(** Parsing types in internal format from string. *)
val type_of_string : string -> term
+val subst_str : substitution -> string
(** {2 Hashtable for Terms} *)
@@ -88,12 +115,3 @@
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
end
-
-
-(** {2 Type of a Term and its Reconstruction} *)
-
-(** Thrown on failure of type reconstruction. *)
-exception NOT_WELL_TYPED of string
-
-(** Reconstruct the type of a term. *)
-val type_of_term : (string, term) Hashtbl.t -> term -> term
Modified: trunk/Toss/Term/TermTest.ml
===================================================================
--- trunk/Toss/Term/TermTest.ml 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/TermTest.ml 2012-06-25 14:30:21 UTC (rev 1733)
@@ -8,10 +8,8 @@
Term("pies", toplevel_type, [||]) |]) in
let s = Term ("ala", toplevel_type, [| Term("kot", toplevel_type, [||]);
Var("y",0,top_type_term,[||]) |]) in
- let subst_str subst = String.concat ", " (List.map (fun (s, tp) ->
- s ^ " <- " ^ (type_to_string tp)) subst) in
assert_equal ~printer:(fun x -> x) "y <- pies, x <- kot"
- (subst_str (mgu [] [t, s]));
+ (subst_str (mgu empty_sb [t, s]));
);
"split_to_list" >::
Modified: trunk/Toss/Term/tests/short_checks.log
===================================================================
--- trunk/Toss/Term/tests/short_checks.log 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/tests/short_checks.log 2012-06-25 14:30:21 UTC (rev 1733)
@@ -106,16 +106,16 @@
// false or x.
Result: {false or x as boolean}
-New function "f" X_1 declared.
+New function "fooo" X_1 declared.
-// (f x) = x.
-Result: {f x = x as boolean}
-// (f x) = f y.
-Result: {f x = f y as boolean}
+// (fooo x) = x.
+Result: {fooo x = x as boolean}
+// (fooo x) = fooo y.
+Result: {fooo x = fooo y as boolean}
// x = x.
Result: {true as boolean}
-// (f x) = f x.
+// (fooo x) = fooo x.
Result: {true as boolean}
// x = y.
Result: {x = y as boolean}
Modified: trunk/Toss/Term/tests/short_checks.trs
===================================================================
--- trunk/Toss/Term/tests/short_checks.trs 2012-06-22 13:58:16 UTC (rev 1732)
+++ trunk/Toss/Term/tests/short_checks.trs 2012-06-25 14:30:21 UTC (rev 1733)
@@ -79,16 +79,16 @@
// false or x.
false or x.
-New function ''f'' boolean as boolean.
+New function ''fooo'' boolean as boolean.
-// (f x) = x.
-(f x) = x.
-// (f x) = f y.
-(f x) = f y.
+// (fooo x) = x.
+(fooo x) = x.
+// (fooo x) = fooo y.
+(fooo x) = fooo y.
// x = x.
x = x.
-// (f x) = f x.
-(f x) = f x.
+// (fooo x) = fooo x.
+(fooo x) = fooo x.
// x = y.
x = y.
// 1 = 1.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-22 13:58:22
|
Revision: 1732
http://toss.svn.sourceforge.net/toss/?rev=1732&view=rev
Author: lukaszkaiser
Date: 2012-06-22 13:58:16 +0000 (Fri, 22 Jun 2012)
Log Message:
-----------
Correcting a build bug I introduced with DrawingTest.
Modified Paths:
--------------
trunk/Toss/Makefile
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-06-22 13:48:24 UTC (rev 1731)
+++ trunk/Toss/Makefile 2012-06-22 13:58:16 UTC (rev 1732)
@@ -110,7 +110,7 @@
EXTDEPS = caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo Formula/Resources.ml
-MKPARSED = ./TRSTest.native -v -l "Term/lib"
+MKPARSED = ./TRSTest.native -l "Term/lib"
%.trs.parsed: %.trs
make ./Term/TRSTest.native
@@ -145,7 +145,7 @@
LearnINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
GGPINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play
ServerINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Client
-ClientINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
+ClientINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server,Client
.INC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-22 13:48:36
|
Revision: 1731
http://toss.svn.sourceforge.net/toss/?rev=1731&view=rev
Author: lukstafi
Date: 2012-06-22 13:48:24 +0000 (Fri, 22 Jun 2012)
Log Message:
-----------
New Speagram step 1: term representation and mgu according to specification, old types kept as toplevel terms for now.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/Coding.ml
trunk/Toss/Term/Coding.mli
trunk/Toss/Term/CodingTest.ml
trunk/Toss/Term/Makefile
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/RewritingTest.ml
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDefTest.ml
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRSTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermTest.ml
trunk/Toss/Term/lib/core.trs
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Makefile 2012-06-22 13:48:24 UTC (rev 1731)
@@ -110,7 +110,7 @@
EXTDEPS = caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo Formula/Resources.ml
-MKPARSED = ./TRSTest.native -l "Term/lib"
+MKPARSED = ./TRSTest.native -v -l "Term/lib"
%.trs.parsed: %.trs
make ./Term/TRSTest.native
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Play/HeuristicTest.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -362,6 +362,19 @@
(Formula.real_str loc_heurs.(0).(0));
);
+ "default_heuristic_old: problem with fluent_preconds" >::
+ (fun () ->
+ let (game,state) =
+ state_of_file "./examples/Parsing.toss" in
+ let loc_heurs =
+ Heuristic.default_heuristic_old ~struc:state.Arena.struc
+ ~advr:2.0 game in
+
+ assert_eq_str
+ "0."
+ (Formula.real_str loc_heurs.(0).(0));
+ );
+
"suggest_expansion: tic-tac-toe" >::
(fun () ->
let state = struc_of_string
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -29,12 +29,13 @@
let list_sd = SDtype [Tp term_type_tp; Str "list"]
let list_name = name_of_sd list_sd
-let list_tp t = Term (list_name, [||], [|t|])
-let list_tp_a = list_tp (Var ("a", [||], 0, [||]))
+let list_tp t = Term (list_name, toplevel_type, [|t|])
+let list_tp_a = list_tp (Var ("a", 0, top_type_term, [||]))
let list_nil_sd = SDfun ([Str "["; Str "]"], list_tp_a)
let list_nil_name = name_of_sd list_nil_sd
-let list_cons_sd = SDfun ([Tp (Var ("a",[||],0,[||])); Str ","; Tp list_tp_a],
+let list_cons_sd = SDfun ([Tp (Var ("a",0,top_type_term,[||]));
+ Str ","; Tp list_tp_a],
list_tp_a)
let list_cons_name = name_of_sd list_cons_sd
@@ -130,8 +131,10 @@
Tp term_type_tp; Str ":"; Tp (list_tp bit_tp);
Str "("; Tp (list_tp term_tp); Str ")"], term_tp)
let term_var_cons_name = name_of_sd term_var_cons_sd
-let term_term_cons_sd = SDfun ([Str "term"; Tp string_tp; Str "(";
- Tp (list_tp term_tp); Str ")"], term_tp)
+let term_term_cons_sd =
+ SDfun ([Str "term"; Tp string_tp; Str "(";
+ Tp (list_tp term_type_tp); Str ":"; Tp (list_tp term_tp);
+ Str ")"], term_tp)
let term_term_cons_name = name_of_sd term_term_cons_sd
let rewrite_rule_sd = SDtype ([Str "rewrite"; Str "rule"])
@@ -147,8 +150,9 @@
let input_rewrite_rule_name = name_of_sd input_rewrite_rule_sd
let input_rewrite_rule_tp = type_of_sd input_rewrite_rule_sd
-let let_be_sd = SDfun ([Str "let"; Tp (Var ("a_1",[||],0,[||])); Str "be";
- Tp (Var ("a_1",[||],0,[||]))], input_rewrite_rule_tp)
+let let_be_sd = SDfun ([Str "let"; Tp (Var ("a_1",0,top_type_term,[||]));
+ Str "be"; Tp (Var ("a_1",0,top_type_term,[||]))],
+ input_rewrite_rule_tp)
let let_be_name = name_of_sd let_be_sd
let priority_input_rewrite_rule_sd = SDtype ([Str "priority";
@@ -159,8 +163,10 @@
type_of_sd priority_input_rewrite_rule_sd
let let_major_be_sd =
- SDfun ([Str "let"; Str "major"; Tp (Var ("a_1",[||],0,[||])); Str "be";
- Tp (Var ("a_1",[||],0,[||]))], priority_input_rewrite_rule_tp)
+ SDfun ([Str "let"; Str "major";
+ Tp (Var ("a_1",0,top_type_term,[||])); Str "be";
+ Tp (Var ("a_1",0,top_type_term,[||]))],
+ priority_input_rewrite_rule_tp)
let let_major_be_name = name_of_sd let_major_be_sd
let fun_definition_sd = SDtype ([Str "fun"; Str "definition"])
@@ -185,44 +191,47 @@
let exception_cl_sd = SDtype [Tp term_type_tp; Str "exception"]
let exception_cl_name = name_of_sd exception_cl_sd
-let exception_cl_tp t = Term (exception_cl_name, [||], [|t|])
+let exception_cl_tp t = Term (exception_cl_name, toplevel_type, [|t|])
let exception_sd =
- SDfun ([Str "!"; Str "!"; Tp (Var ("a",[||],0,[||])); Str "!";Str "!";],
- exception_cl_tp (Var ("other_than_a!",[||],0,[||])))
+ SDfun ([Str "!"; Str "!"; Tp (Var ("a",0,top_type_term,[||]));
+ Str "!";Str "!";],
+ exception_cl_tp (Var ("other_than_a!",0,top_type_term,[||])))
let exception_name = name_of_sd exception_sd
let exn_ok_sd =
- SDfun ([Str "+"; Str "+"; Tp (Var ("a",[||],0,[||])); Str "+";Str "+";],
- exception_cl_tp (Var ("a",[||],0,[||]))) (* Here it should be a! *)
+ SDfun ([Str "+"; Str "+"; Tp (Var ("a",0,top_type_term,[||]));
+ Str "+";Str "+";],
+ exception_cl_tp (Var ("a",0,top_type_term,[||]))) (* Here it should be a! *)
let exn_ok_name = name_of_sd exception_sd
(* --- Special functions recognized during Normalisation --- *)
-let brackets_sd = SDfun ([Str "("; Tp (Var ("b",[||],0,[||])); Str ")"],
- Var ("b",[||],0,[||]))
+let brackets_sd = SDfun ([Str "(";
+ Tp (Var ("b",0,top_type_term,[||])); Str ")"],
+ Var ("b",0,top_type_term,[||]))
let brackets_name = name_of_sd brackets_sd
-let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (Var ("b",[||],0,[||]));
- Str "|"; Str ">"], Var ("b",[||],0,[||]))
+let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (Var ("b",0,top_type_term,[||]));
+ Str "|"; Str ">"], Var ("b",0,top_type_term,[||]))
let verbatim_name = name_of_sd verbatim_sd
let if_then_else_sd = SDfun ([Str "if"; Tp boolean_tp; Str "then";
- Tp (Var ("a",[||],0,[||])); Str "else";
- Tp (Var ("a",[||],0,[||]))], Var ("a",[||],0,[||]))
+ Tp (Var ("a",0,top_type_term,[||])); Str "else";
+ Tp (Var ("a",0,top_type_term,[||]))], Var ("a",0,top_type_term,[||]))
let if_then_else_name = name_of_sd if_then_else_sd
-let eq_bool_sd = SDfun ([Tp (Var ("a",[||],0,[||])); Str "=";
- Tp (Var ("a",[||],0,[||]))], boolean_tp)
+let eq_bool_sd = SDfun ([Tp (Var ("a",0,top_type_term,[||])); Str "=";
+ Tp (Var ("a",0,top_type_term,[||]))], boolean_tp)
let eq_bool_name = name_of_sd eq_bool_sd
(* --- Syntax Definitions for special meta-functions --- *)
-let code_as_term_sd = SDfun ([Str "code"; Tp (Var ("a",[||],0,[||]));
+let code_as_term_sd = SDfun ([Str "code"; Tp (Var ("a",0,top_type_term,[||]));
Str "as"; Str "term"], term_tp)
let code_as_term_name = name_of_sd code_as_term_sd
@@ -278,13 +287,13 @@
let set_command_tp = type_of_sd set_command_sd
let set_prop_sd = SDfun ([Str "set"; Tp (string_tp); Str "of";
- Tp (Var ("a",[||],0,[||])); Str "to";
- Tp (Var ("b",[||],0,[||]))], set_command_tp)
+ Tp (Var ("a",0,top_type_term,[||])); Str "to";
+ Tp (Var ("b",0,top_type_term,[||]))], set_command_tp)
let set_prop_name = name_of_sd set_prop_sd
let preprocess_sd = SDfun ([Str "#"; Str "#"; Str "#";
- Tp (Var ("p",[||],0,[||]))], Var ("q",[||],0,[||]))
+ Tp (Var ("p",0,top_type_term,[||]))], Var ("q",0,top_type_term,[||]))
let preprocess_name = name_of_sd preprocess_sd
Modified: trunk/Toss/Term/Coding.ml
===================================================================
--- trunk/Toss/Term/Coding.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/Coding.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -14,9 +14,9 @@
exception DECODE of string
exception CODE of string
-let rec code_list f = function
- | [] -> Term (list_nil_name, [||], [||])
- | x :: xs -> Term (list_cons_name, [||], [|f (x); code_list f xs|])
+let rec code_list tp f = function
+ | [] -> Term (list_nil_name, tp, [||])
+ | x :: xs -> Term (list_cons_name, tp, [|f (x); code_list tp f xs|])
let rec decode_list f = function
@@ -41,8 +41,8 @@
let code_bit = function
- | 0 -> Term (bit_0_cons_name, [||], [||])
- | 1 -> Term (bit_1_cons_name, [||], [||])
+ | 0 -> Term (bit_0_cons_name, [|bit_tp|], [||])
+ | 1 -> Term (bit_1_cons_name, [|bit_tp|], [||])
| _ -> failwith "not bit while coding bit"
@@ -57,7 +57,7 @@
let bits = int_to_bits (Char.code c) in
let rec zeros i = if i <= 0 then [] else 0 :: zeros (i-1) in
let eight_bits = bits @ zeros (8 - List.length bits) in
- Term (char_cons_name, [||], of_list (List.map code_bit eight_bits))
+ Term (char_cons_name, [|char_tp|], of_list (List.map code_bit eight_bits))
let decode_char = function
| Term (n, _, bits) when n = char_cons_name ->
@@ -67,8 +67,8 @@
let code_string s =
let rec char_list i = if i < 0 then [] else s.[i] :: char_list (i-1) in
let chars = List.rev (char_list ((String.length s) - 1)) in
- let char_term = code_list code_char chars in
- Term (string_cons_name, [||], [|char_term|])
+ let char_term = code_list [|list_tp char_tp|] code_char chars in
+ Term (string_cons_name, [|string_tp|], [|char_term|])
let decode_string t =
@@ -86,8 +86,8 @@
let code_bool = function
- | true -> Term (boolean_true_name, [||], [||])
- | false -> Term (boolean_false_name, [||], [||])
+ | true -> Term (boolean_true_name, [|boolean_tp|], [||])
+ | false -> Term (boolean_false_name, [|boolean_tp|], [||])
let decode_bool = function
@@ -97,30 +97,32 @@
let rec code_term_type = function
- | Var (name, [||], 0, [||])->
- Term (term_type_var_name, [||], [|code_string name|])
+ | Var (name, 0, tp, [||]) when tp = top_type_term ->
+ Term (term_type_var_name, [|term_type_tp|], [|code_string name|])
| Var _ -> failwith "code_term_type: non-type variable"
- | Term (name, [||], arr) when name = Term.fun_type_name ->
+ | Term (name, tp, arr) when name = Term.fun_type_name && tp = toplevel_type->
let l = Array.length arr in
let (args_types, return_type) = (Array.sub arr 0 (l-1), arr.(l-1)) in
- Term (term_type_fun_name, [||], [|
- code_list code_term_type (to_list args_types);
+ Term (term_type_fun_name, [|term_type_tp|], [|
+ code_list [|list_tp term_type_tp|] code_term_type (to_list args_types);
code_term_type return_type|])
- | Term (name, [||], args) ->
- Term (term_type_cons_name, [||], [|
+ | Term (name, tp, args) when tp = toplevel_type ->
+ Term (term_type_cons_name, [|term_type_tp|], [|
code_string name;
- code_list code_term_type (to_list args)|])
- | Term _ -> failwith "code_term_type: non-type term"
+ code_list [|list_tp term_type_tp|] code_term_type (to_list args)|])
+ | Term (name, _, _) when name = top_type_name -> failwith
+ "code_term_type: coding top term (the type of a type) not supported"
+ | Term (name, _, _) -> failwith
+ ("code_term_type: non-type term at symbol " ^ name)
-
let rec decode_term_type = function
| Term (s, _, [|coded_name|]) when s = term_type_var_name ->
- Var (decode_string coded_name, [||], 0, [||])
+ Var (decode_string coded_name, 0, top_type_term, [||])
| Term (s, _, [|coded_1; coded_2|]) when s = term_type_fun_name ->
- Term (Term.fun_type_name, [||], of_list (
+ Term (Term.fun_type_name, toplevel_type, of_list (
(decode_list decode_term_type coded_1) @ [decode_term_type coded_2]))
| Term (s, _, [|coded_1; coded_2|]) when s = term_type_cons_name ->
- Term (decode_string coded_1, [||],
+ Term (decode_string coded_1, toplevel_type,
of_list (decode_list decode_term_type coded_2))
| _ -> raise (DECODE "term_type")
@@ -130,35 +132,40 @@
let rec code_term = function
- | Var (name, var_types, deg, args) ->
- Term (term_var_cons_name, [||],
+ | Var (name, deg, var_type, args) ->
+ Term (term_var_cons_name, [|term_tp|],
[|code_string name;
- code_term_type var_types.(0);
- code_list code_bit (int_to_bits deg);
- code_list code_term (to_list args)|])
- | Term (name, _, args) ->
- Term (term_term_cons_name, [||], [|code_string name;
- code_list code_term (to_list args)|])
+ code_term_type var_type;
+ code_list [|list_tp bit_tp|] code_bit (int_to_bits deg);
+ code_list [|list_tp term_tp|] code_term (to_list args)|])
+ | Term (name, types, args) ->
+ Term (term_term_cons_name, [|term_tp|],
+ [|code_string name;
+ code_list [|list_tp term_type_tp|] code_term_type (to_list types);
+ code_list [|list_tp term_tp|] code_term (to_list args)|])
let rec code_term_incr_vars = function
- | Var (name, var_type, deg, args) ->
- Var (name, var_type, deg+1, map code_term_incr_vars args)
- | Term (name, _, args) ->
- Term (term_term_cons_name, [||], [|
- code_string name; code_list code_term_incr_vars (to_list args)|])
+ | Var (name, deg, var_type, args) ->
+ Var (name, deg+1, var_type, map code_term_incr_vars args)
+ | Term (name, types, args) ->
+ Term (term_term_cons_name, [|term_tp|],
+ [|code_string name;
+ code_list [|list_tp term_type_tp|] code_term_type (to_list types);
+ code_list [|list_tp term_tp|] code_term_incr_vars (to_list args)|])
let rec decode_term = function
| Term (s, _, [|coded_name; coded_type; coded_deg; coded_args|])
when s = term_var_cons_name ->
Var (decode_string coded_name,
- [|decode_term_type coded_type|],
bits_to_int (decode_list decode_bit coded_deg),
+ decode_term_type coded_type,
of_list (decode_list decode_term coded_args))
- | Term (s, _, [|coded_name; coded_args|])
+ | Term (s, _, [|coded_name; coded_types; coded_args|])
when s = term_term_cons_name ->
- Term (decode_string coded_name, [||],
+ Term (decode_string coded_name,
+ of_list (decode_list decode_term_type coded_types),
of_list (decode_list decode_term coded_args))
| _ -> raise (DECODE "term")
@@ -170,7 +177,8 @@
let code_rewrite_rule (left, right) =
- Term (rewrite_rule_cons_name, [||], [|code_term left; code_term right|])
+ Term (rewrite_rule_cons_name, [|rewrite_rule_tp|],
+ [|code_term left; code_term right|])
let decode_rewrite_rule = function
@@ -180,7 +188,7 @@
let code_input_rewrite_rule (left, right) =
- Term (let_be_name, [||], [|left; right|])
+ Term (let_be_name, [|input_rewrite_rule_tp|], [|left; right|])
let decode_input_rewrite_rule = function
@@ -189,20 +197,20 @@
let code_priority_input_rewrite_rule (left, right) =
- Term (let_major_be_name, [||], [|left; right|])
+ Term (let_major_be_name, [|priority_input_rewrite_rule_tp|], [|left; right|])
let decode_priority_input_rewrite_rule = function
- | Term (n, [||], [|left; right|]) when n = let_major_be_name -> (left, right)
+ | Term (n, _, [|left; right|]) when n = let_major_be_name -> (left, right)
| _ -> raise (DECODE "priority input rewrite rule")
type fun_definition = string * Term.term list * Term.term
let code_fun_definition (name, args_types, return_type) =
- Term (fun_definition_cons_name, [||], [|
+ Term (fun_definition_cons_name, [|fun_definition_tp|], [|
code_string name;
- code_list code_term_type args_types;
+ code_list [|list_tp term_type_tp|] code_term_type args_types;
code_term_type return_type|])
@@ -218,23 +226,23 @@
let code_type_definition (name, arity) =
let rec var = function
| 0 -> []
- | i -> Var ("a_" ^ (string_of_int i), [||], 0, [||]) :: (var (i-1)) in
- Term (type_of_name, [||],
- [|code_term_type (Term (name, [||], of_list (var arity)))|])
+ | i -> Var ("a_" ^ (string_of_int i), 0, top_type_term, [||]) :: (var (i-1)) in
+ Term (type_of_name, [|type_definition_tp|],
+ [|code_term_type (Term (name, toplevel_type, of_list (var arity)))|])
let decode_type_definition = function
| Term (n, _, [|ty|]) when n = type_of_name ->
(match (decode_term_type ty) with
- | Term (name, [||], args) -> (name, Array.length args)
+ | Term (name, _, args) -> (name, Array.length args)
| _ -> raise (DECODE "type definition 1")
)
| _ -> raise (DECODE "type definition 2")
let code_syntax_element = function
- | Str s -> Term (syntax_element_str_name, [||], [|code_string s|])
- | Tp tt -> Term (syntax_element_tp_name, [||], [|code_term_type tt|])
+ | Str s -> Term (syntax_element_str_name, [|syntax_element_tp|], [|code_string s|])
+ | Tp tt -> Term (syntax_element_tp_name, [|syntax_element_tp|], [|code_term_type tt|])
let decode_syntax_element = function
@@ -246,9 +254,9 @@
let rec code_syntax_element_list = function
- | [se] -> Term (syntax_element_list_elem_name, [||],
+ | [se] -> Term (syntax_element_list_elem_name, [|syntax_element_list_tp|],
[|code_syntax_element se|])
- | se :: ses -> Term (syntax_element_list_cons_name, [||],
+ | se :: ses -> Term (syntax_element_list_cons_name, [|syntax_element_list_tp|],
[|code_syntax_element se; code_syntax_element_list ses|])
| [] -> raise (CODE "syntax element list")
@@ -264,12 +272,12 @@
let code_syntax_definition = function
| SDtype se ->
- Term (syntax_definition_type_name, [||], [|code_syntax_element_list se|])
+ Term (syntax_definition_type_name, [|syntax_definition_tp|], [|code_syntax_element_list se|])
| SDfun (se, res_ty) ->
- Term (syntax_definition_fun_name, [||],
+ Term (syntax_definition_fun_name, [|syntax_definition_tp|],
[|code_syntax_element_list se; code_term_type res_ty|])
| SDvar (se, res_ty) ->
- Term (syntax_definition_var_name, [||],
+ Term (syntax_definition_var_name, [|syntax_definition_tp|],
[|code_syntax_element_list se; code_term_type res_ty|])
@@ -291,10 +299,10 @@
let rec matches dict = function
| (Term (n1, _, a1), Term (n2, _, a2)) when n1=n2 && (length a1 = length a2)->
Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, _, d1, a1), Var (n2, _, d2, a2))
+ | (Var (n1, d1, _, a1), Var (n2, d2, _, a2))
when n1 = n2 && d1 = d2 && length a1 = length a2 ->
Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
- | (Var (n1, _, d1, [||]), te) ->
+ | (Var (n1, d1, _, [||]), te) ->
(try
let arg = List.assoc n1 (!dict) in
let coded_arg = fn_apply d1 code_term arg in
@@ -308,21 +316,22 @@
(* Application of term substitutions (only flat functional substitutes). *)
let rec apply_s substs = function
- | Var (n, _, d, [||]) as t ->
+ | Var (n, d, _, [||]) as t ->
+ (* FIXME: why we don't apply substitutions recursively, as below? *)
(try (fn_apply d code_term (List.assoc n substs)) with Not_found -> t)
- | Term (n, tp, a) -> Term (n, tp, map (apply_s substs) a)
- | Var (n, t, deg, a) ->
+ | Term (n, tp, a) -> Term (n, map (apply_s substs) tp, map (apply_s substs) a)
+ | Var (n, deg, t, a) ->
try (
let raw_result =
match (List.assoc n substs) with
- | Term (name, [||], [||]) ->
- Term (name, [||], map (apply_s substs) a)
- | Var (name, ty, d, [||]) ->
- Var (name, ty, d, map (apply_s substs) a)
+ | Term (name, tps, [||]) ->
+ Term (name, map (apply_s substs) tps, map (apply_s substs) a)
+ | Var (name, d, ty, [||]) ->
+ Var (name, d, apply_s substs ty, map (apply_s substs) a)
| _ -> failwith "functional substitution of non-flat term" in
fn_apply deg code_term raw_result
)
- with Not_found -> Var (n, t, deg, map (apply_s substs) a)
+ with Not_found -> Var (n, deg, t, map (apply_s substs) a)
(* --- Nice Term display based on Syntax Definitions --- *)
@@ -346,7 +355,7 @@
(* --- Display terms and types as XML --- *)
let rec display_type_xml = function
- | Var (n, [||], 0, [||]) ->
+ | Var (n, 0, top_type_term, [||]) ->
"<type_var>" ^ (make_xml_compatible n) ^ "</type_var>"
| Var _ -> failwith "display_type_xml: non-type variable"
| Term (n, _, a) ->
@@ -365,11 +374,11 @@
"<term class=\"" ^ (make_xml_compatible n) ^ "\">\n" ^
(String.concat "\n" (List.map display_term_xml (to_list a))) ^
"\n</term>"
- | Var (n, ty, deg, a) ->
+ | Var (n, deg, ty, a) ->
"<term-variable class=\"" ^ (make_xml_compatible n) ^
"\" deg=\"" ^ (string_of_int deg) ^ "\">" ^
(String.concat "" (List.map display_term_xml (to_list a))) ^
- "<term-variable-type>"^(display_type_xml ty.(0))^"</term-variable-type>" ^
+ "<term-variable-type>"^(display_type_xml ty)^"</term-variable-type>" ^
"</term-variable>"
@@ -380,6 +389,8 @@
let rec term_to_string term =
let term_array_to_string ta =
String.concat ", " (to_list (map term_to_string ta)) in
+ let type_array_to_string ta =
+ String.concat ", " (to_list (map type_to_string ta)) in
match term with
| _ when is_some (decode_string_opt term) ->
let s = (match (decode_string_opt term) with Some s -> s | None -> "") in
@@ -393,17 +404,17 @@
| _ when is_some (decode_term_opt term) ->
(match (decode_term_opt term) with None -> ""
| Some te -> "@T " ^ (term_to_string te))
- | Var (v, t, d, [||]) ->
- "@V [" ^ v ^ " @: " ^ (type_to_string t.(0)) ^
+ | Var (v, d, t, [||]) ->
+ "@V [" ^ v ^ " @: " ^ (type_to_string t) ^
" @: "^ string_of_int (d) ^ " ]"
- | Var (v, t, d, a) ->
- "@V [" ^ v ^ " @: " ^ (type_to_string t.(0)) ^
+ | Var (v, d, t, a) ->
+ "@V [" ^ v ^ " @: " ^ (type_to_string t) ^
" @: "^ string_of_int (d) ^ " ] (" ^
(term_array_to_string a) ^ " )"
- | Term (n, [||], [||]) -> n
- | Term (n, [||], a) ->
- n ^ " (" ^ (term_array_to_string a) ^ " )"
- | Term _ -> failwith "term_to_string: stored types not supported yet"
+ (* FIXME: we should print types!!! *)
+ | Term (n, tp, [||]) -> n ^ "[ @: " ^ type_array_to_string tp ^ "]"
+ | Term (n, tp, a) ->
+ n ^ "[ @: " ^ type_array_to_string tp ^ "] (" ^ (term_array_to_string a) ^ " )"
(* Parser for terms. *)
@@ -417,7 +428,12 @@
)
| (Delim "@L") :: (Delim "[") :: rest ->
(match parse_term_list rest with
- | (l, (Delim "]") :: cont) -> (code_list (fun x -> x) l, cont)
+ | (l, (Delim "]") :: cont) ->
+ let tp = match l with
+ | [] -> top_type_term
+ | Var (_, _, tp, _)::_ -> tp
+ | Term (_, tps, _)::_ -> tps.(0) in
+ code_list [|list_tp tp|] (fun x -> x) l, cont
| _ -> failwith "parse_term: list not closed"
)
| (Delim "@Y") :: rest ->
@@ -430,12 +446,13 @@
(match parse_type rest with
| (ty, (Delim "@:") :: (Text deg) :: (Delim "]") :: cont) ->
let (l, c) = parse_bracketed_list cont in
- (Var (v, [|ty|], int_of_string (deg), of_list l), c)
+ (Var (v, int_of_string (deg), ty, of_list l), c)
| _ -> failwith "parse_term: var not closed"
)
- | (Text n) :: rest ->
+ | (Text n) :: Delim "[" :: Delim "@:" :: rest ->
+ let types, rest = parse_type_list rest in
let (l, cont) = parse_bracketed_list rest in
- (Term (n, [||], of_list l), cont)
+ (Term (n, of_list types, of_list l), cont)
| _ -> failwith "parse_term: bad start"
and parse_text_list = function
| (Text n) :: rest ->
@@ -467,6 +484,16 @@
| (Delim ",") :: rest ->
let (l, cont) = parse_term_list rest in (l, cont)
| l -> ([], l)
+and parse_type_list l =
+ try let (te, cont) = parse_type l in
+ let (lst, c) = parse_type_list_delim cont in
+ (te :: lst, c)
+ with _ -> ([], l)
+and parse_type_list_delim = function
+ | (Delim ",") :: rest ->
+ let (l, cont) = parse_type_list rest in (l, cont)
+ | Delim "]" :: rest -> ([], rest)
+ | rest -> failwith "parse_type_list: not closed with ]"
let term_of_string s =
let (te, cont) = parse_term (split_to_list s) in
@@ -476,27 +503,29 @@
(* --- Rules for special built-in functions --- *)
let brackets_rules =
- [(Term (brackets_name, [||], [|Var ("x", [|Var("a",[||],0,[||])|],0,[||])|]),
- Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]))]
+ [(Term (brackets_name, [|Var ("b",0,top_type_term,[||])|], [|Var ("x", 0, Var("a",0,top_type_term,[||]),[||])|]),
+ Var ("x", 0, Var ("a",0,top_type_term,[||]), [||]))]
let verbatim_rules =
- [(Term (verbatim_name, [||], [|Var ("x",[|Var ("a",[||],0,[||])|],0,[||])|]),
- Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]))]
+ [(Term (verbatim_name, [|Var ("b",0,top_type_term,[||])|], [|Var ("x",0,Var ("a",0,top_type_term,[||]),[||])|]),
+ Var ("x", 0, Var ("a",0,top_type_term,[||]), [||]))]
let if_then_else_rules = [
- (Term (if_then_else_name, [||], [|code_bool true;
- Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]);
- Var ("y", [|Var ("a",[||],0,[||])|], 0, [||])|]),
- Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]));
- (Term (if_then_else_name, [||], [|code_bool false;
- Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]);
- Var ("y", [|Var ("a",[||],0,[||])|], 0, [||])|]),
- Var ("y", [|Var ("a",[||],0,[||])|], 0, [||]))]
+ (Term (if_then_else_name, [|Var ("a",0,top_type_term,[||])|],
+ [|code_bool true;
+ Var ("x",0,Var ("a",0,top_type_term,[||]),[||]);
+ Var ("y",0,Var ("a",0,top_type_term,[||]),[||])|]),
+ Var ("x",0,Var ("a",0,top_type_term,[||]),[||]));
+ (Term (if_then_else_name, [|Var ("a",0,top_type_term,[||])|],
+ [|code_bool false;
+ Var ("x",0,Var ("a",0,top_type_term,[||]),[||]);
+ Var ("y",0,Var ("a",0,top_type_term,[||]),[||])|]),
+ Var ("y",0,Var ("a",0,top_type_term,[||]),[||]))]
-let varx_te = Var ("x", [|Var ("p",[||],0,[||])|], 0, [||])
-let preprocess_rules = [(Term (preprocess_name, [||], [|varx_te|]), varx_te)]
+let varx_te = Var ("x", 0, Var ("p",0,top_type_term,[||]), [||])
+let preprocess_rules = [(Term (preprocess_name, [|Var ("q",0,top_type_term,[||])|], [|varx_te|]), varx_te)]
let string_quote_rules =
- [(Term (string_quote_name, [||], [|Var ("s", [|string_tp|], 0, [||])|]),
- Var ("s", [|string_tp|], 0, [||]))]
+ [(Term (string_quote_name, [|string_tp|], [|Var ("s", 0, string_tp, [||])|]),
+ Var ("s", 0, string_tp, [||]))]
let additional_xslt_rules =
- [(Term (additional_xslt_name, [||], [||]), code_string " ")]
+ [(Term (additional_xslt_name, [|string_tp|], [||]), code_string " ")]
Modified: trunk/Toss/Term/Coding.mli
===================================================================
--- trunk/Toss/Term/Coding.mli 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/Coding.mli 2012-06-22 13:48:24 UTC (rev 1731)
@@ -9,7 +9,7 @@
(** Thrown when decoding fails. *)
exception DECODE of string
-val code_list : ('a -> term) -> 'a list -> term
+val code_list : term array -> ('a -> term) -> 'a list -> term
val decode_list : (term -> 'a) -> term -> 'a list
val decode_list_opt : (term -> 'a) -> term -> 'a list option
val int_to_bits : int -> int list
Modified: trunk/Toss/Term/CodingTest.ml
===================================================================
--- trunk/Toss/Term/CodingTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/CodingTest.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -2,16 +2,16 @@
open Term
open Coding
-let tests = "Term" >::: [
+let tests = "Coding" >::: [
"coding term types" >::
(fun () ->
let test_code_decode_tt tt =
let tt1 = decode_term_type (code_term_type tt) in
assert_equal ~printer:(fun x -> type_to_string x) tt tt1 in
- let tt1 = Term ("ala", [||], [||]) in
- let tt2 = Term ("bolek", [||], [|tt1; tt1|]) in
- let tt3 = Term (Term.fun_type_name, [||], [|tt1; tt2; tt1|]) in
- let tt4 = Var ("zmienna",[||],0,[||]) in
+ let tt1 = Term ("ala", toplevel_type, [||]) in
+ let tt2 = Term ("bolek", toplevel_type, [|tt1; tt1|]) in
+ let tt3 = Term (Term.fun_type_name, toplevel_type, [|tt1; tt2; tt1|]) in
+ let tt4 = Var ("zmienna",0,top_type_term,[||]) in
test_code_decode_tt tt1;
test_code_decode_tt tt2;
test_code_decode_tt tt3;
@@ -23,10 +23,11 @@
let test_code_decode_te te =
let te1 = decode_term (code_term te) in
assert_equal ~printer:(fun x -> term_to_string x) te te1 in
- let term1 = Term ("ala", [||], [||]) in
- let term2 = Term ("bolek", [||], [|term1|]) in
- let term3 = Term ("cynik", [||], [|term1; term2|]) in
- let term4 = Var ("zmienna", [|Var ("a1",[||],0,[||])|], 0, [| |]) in
+ let ty = Term ("text", toplevel_type, [||]) in
+ let term1 = Term ("ala", [|ty|], [||]) in
+ let term2 = Term ("bolek", [|ty|], [|term1|]) in
+ let term3 = Term ("cynik", [|ty|], [|term1; term2|]) in
+ let term4 = Var ("zmienna", 0, Var ("a1",0,top_type_term,[||]), [| |]) in
test_code_decode_te term1;
test_code_decode_te term2;
test_code_decode_te term3;
@@ -52,10 +53,10 @@
let sd1 = decode_syntax_definition (code_syntax_definition sd) in
assert_equal ~printer:(fun x -> "syntax definition test") sd sd1 in
let se1 = SyntaxDef.Str "napisek" in
- let se2 = SyntaxDef.Tp (Var ("eee",[||],0,[||])) in
+ let se2 = SyntaxDef.Tp (Var ("eee",0,top_type_term,[||])) in
let sd1 = SyntaxDef.SDtype [se1; se2] in
- let sd2 = SyntaxDef.SDfun ([se2; se1; se1], Term ("aaa", [||], [||])) in
- let sd3 = SyntaxDef.SDvar ([se2;se2;se1;se1], Term("qza", [||], [||])) in
+ let sd2 = SyntaxDef.SDfun ([se2; se1; se1], Term ("aaa", toplevel_type, [||])) in
+ let sd3 = SyntaxDef.SDvar ([se2;se2;se1;se1], Term("qza", toplevel_type, [||])) in
test_code_decode_sd sd1;
test_code_decode_sd sd2;
test_code_decode_sd sd3;
@@ -66,7 +67,7 @@
let test_display_term res te =
assert_equal ~printer:(fun x -> x) res (display_term te) in
test_display_term "[true, false, true]"
- (code_list code_bool [true; false; true]);
+ (code_list [|BuiltinLang.boolean_tp|] code_bool [true; false; true]);
test_display_term "\"ala ma kota\"" (code_string "ala ma kota");
test_display_term "type ''\"tp\"''"
(code_syntax_definition (SyntaxDef.SDtype ([SyntaxDef.Str "tp"])));
@@ -76,40 +77,40 @@
(fun () ->
let testpp s = assert_equal ~printer:(fun x -> x) s
(term_to_string (term_of_string s)) in
- testpp "ala";
- testpp "ala (a )";
- testpp "ala (a, b )";
+ testpp "ala[ @: text]";
+ testpp "ala[ @: text] (a[ @: param] )";
+ testpp "ala[ @: text] (a[ @: param], b[ @: param] )";
testpp "@V [x @: @? a @: 0 ]";
- testpp "@V [x @: @? a @: 0 ] (p )";
- testpp "@V [x @: @? a @: 0 ] (p, q )";
+ testpp "@V [x @: @? a @: 0 ] (p[ @: param] )";
+ testpp "@V [x @: @? a @: 0 ] (p[ @: param], q[ @: param] )";
testpp "@`kota ma ala@`";
- testpp "pies (@`kota ma ala@` )";
- testpp "a (pies (@`kota ma ala@` ), pies )";
- testpp "a (b (c, d ), e )";
+ testpp "pies[ @: text] (@`kota ma ala@` )";
+ testpp "a[ @: text] (pies[ @: text] (@`kota ma ala@` ), pies[ @: text] )";
+ testpp "a[ @: p] (b[ @: p] (c[ @: p], d[ @: p] ), e[ @: p] )";
testpp "@L[]";
- testpp "@L[a]";
- testpp "@L[a, b]";
+ testpp "@L[a[ @: p]]";
+ testpp "@L[a[ @: p], b[ @: p]]";
);
-
+(* Type reconstruction will be done online while parsing.
"type reconstruction" >::
(fun () ->
let list_tp_a = BuiltinLang.list_tp_a in
- let typesl = [("cons", Term (Term.fun_type_name, [||],
- [|Var ("a",[||],0,[||]); list_tp_a;
- list_tp_a|]));
+ let typesl = [("cons", Term (Term.fun_type_name, toplevel_type,
+ [|Var ("a",0,top_type_term,[||]);
+ list_tp_a; list_tp_a|]));
("nil", list_tp_a);
("true", BuiltinLang.boolean_tp);
- ("1", Term ("int", [||], [||]))] in
+ ("1", Term ("int", toplevel_type, [||]))] in
let types = Hashtbl.create 5 in
List.iter (fun (a, b) -> Hashtbl.add types a b) typesl;
let var_x_a = Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]) in
- let te1 = Term ("cons", [||], [|var_x_a; Term ("nil", [||], [||])|]) in
- let te2 = Term ("cons", [||], [|Term ("true", [||], [||]); te1|]) in
- let te3 = Term ("cons", [||], [|Term ("1", [||], [||]); te1|]) in
+ let te1 = Term ("cons", BuiltinLang.list_tp , [|var_x_a; Term ("nil", [||], [||])|]) in
+ let te2 = Term ("cons", BuiltinLang.list_tp , [|Term ("true", [||], [||]); te1|]) in
+ let te3 = Term ("cons", BuiltinLang.list_tp , [|Term ("1", [||], [||]); te1|]) in
let test_tt res te = assert_equal ~printer:(fun x -> x) res
(type_to_string (type_of_term types te)) in
test_tt "T\\?_list (@? a._.6)" te1;
test_tt "T\\?_list (Tboolean)" te2;
test_tt "T\\?_list (int)" te3;
- );
+ ); *)
]
Modified: trunk/Toss/Term/Makefile
===================================================================
--- trunk/Toss/Term/Makefile 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/Makefile 2012-06-22 13:48:24 UTC (rev 1731)
@@ -1,11 +1,19 @@
-all: coreparsed
+all: allparsed
-MKPARSED = ../TRSTest.native -l "../Term/lib"
+MKPARSED = ../TRSTest.native -v -l "../Term/lib"
coreparsed:
make -C .. ./Term/TRSTest.native
$(MKPARSED) -o lib/core.trs.parsed < lib/core.trs > /dev/null
+allparsed:
+ make -C .. ./Term/TRSTest.native
+ $(MKPARSED) -o lib/core.trs.parsed < lib/core.trs # > /dev/null
+ $(MKPARSED) -o lib/arithmetics.trs.parsed < lib/arithmetics.trs # > /dev/null
+ $(MKPARSED) -o lib/lists.trs.parsed < lib/lists.trs # > /dev/null
+ $(MKPARSED) -o lib/basic.trs.parsed < lib/basic.trs # > /dev/null
+ $(MKPARSED) -o lib/sasha.trs.parsed < lib/sasha.trs # > /dev/null
+
.PHONY:
clean:
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Term/ParseArc.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/ParseArc.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -40,14 +40,16 @@
is put agains a type then it matches only if its type is the string type. *)
let matches_position elem sd i =
let sel = syntax_elems_of_sd sd in
- let sd_elem = if (length sel < i) then None else Some (nth sel (i-1)) in
+ let sd_elem =
+ if (length sel < i) then None else Some (nth sel (i-1)) in
match (sd_elem, elem) with
| (None, _) -> false
| (Some (Str s), Token t) -> s = t
- | (Some (Str s), Typed_term _) -> false
- | (Some (Tp ty), Token _) -> ty = BuiltinLang.string_tp
- | (Some (Tp ty), Typed_term (t, _)) ->
- try let _ = mgu ([(suffix 0 ty, suffix 1 t)], []) in true
+ | (Some (Str s), Typed_term (_,te)) -> false
+ | (Some (Tp ty), Token tk) -> ty = BuiltinLang.string_tp
+ | (Some (Tp ty), Typed_term (t, _)) ->
+ let (ty, t as tp) = suffix 0 ty, suffix 1 t in
+ try let _ = mgu [] [tp] in true
with UNIFY -> false
@@ -99,16 +101,22 @@
let args = flatten (map match_of_tok (combine elems (rev l))) in
let res_term = (match sd with
| SDtype _ ->
- Term (BuiltinLang.term_type_cons_name, [||],
- [|Coding.code_string n; Coding.code_list (fun x -> x) args|])
- | SDfun _ -> Term (n, [||], Array.of_list args)
+ Term (BuiltinLang.term_type_cons_name, [|BuiltinLang.term_type_tp|],
+ [|Coding.code_string n;
+ Coding.code_list
+ [|BuiltinLang.list_tp BuiltinLang.term_type_tp|]
+ (fun x -> x) args|])
+ | SDfun (_,tp) -> Term (n, [|tp|], Array.of_list args)
| SDvar (_, _) ->
(match sd_type sd with
| None -> failwith "variable syntax definition w/o type"
- | Some (ty) -> Var (n, [|ty|], 0, Array.of_list args) )
+ | Some (ty) -> Var (n, 0, ty, Array.of_list args) )
) in
- (try (Typed_term (type_of_term type_decls res_term, res_term), spos)
- with NOT_WELL_TYPED _ -> raise NOT_CLOSED)
+ (try
+ let typ = type_of_term type_decls res_term in
+ (Typed_term (typ, res_term), spos)
+ with NOT_WELL_TYPED _ ->
+ raise NOT_CLOSED)
| _ -> raise NOT_CLOSED
@@ -162,7 +170,7 @@
snd (parse_elems type_decls sdefs (map (fun s -> Token s) strs))
-let parse type_decls sdefs strs =
+let parse type_decls sdefs strs =
let parsed = (parse_to_array type_decls sdefs strs).(length strs) in
fst (List.split (filter (fun (_, start) -> start = 1) parsed))
Modified: trunk/Toss/Term/ParseArcTest.ml
===================================================================
--- trunk/Toss/Term/ParseArcTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/ParseArcTest.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -9,14 +9,15 @@
(fun () ->
let elem_eq res e = assert_equal ~printer:(fun x -> x) res (elem_str e) in
let type_decls_list = [
- (list_cons_name, Term (Term.fun_type_name, [||],
- [|Var ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
+ (list_cons_name, Term (Term.fun_type_name, toplevel_type,
+ [|Var ("a",0,top_type_term,[||]);
+ list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], Var ("a",[||],0,[||])) in
+ let var_x_a_sd = SDvar ([Str "x"], Var ("a",0,top_type_term,[||])) in
let sdefs = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let arcs = List.map (fun sd -> Arc (sd, (name_of_sd sd), [], 0)) sdefs in
@@ -44,14 +45,15 @@
"parse" >::
(fun () ->
let type_decls_list = [
- (list_cons_name, Term (Term.fun_type_name, [||],
- [|Var ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
+ (list_cons_name, Term (Term.fun_type_name, toplevel_type,
+ [|Var ("a",0,top_type_term,[||]);
+ list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], Var ("a",[||],0,[||])) in
+ let var_x_a_sd = SDvar ([Str "x"], Var ("a",0,top_type_term,[||])) in
let sdefs_basic = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let sdefs = List.map (fun sd -> (sd, name_of_sd sd)) sdefs_basic in
Modified: trunk/Toss/Term/Rewriting.ml
===================================================================
--- trunk/Toss/Term/Rewriting.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/Rewriting.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -49,15 +49,20 @@
Aux.array_fold_left2 update (false, []) a1 a2
| (Term (n1, _, _), Term (n2, _, [||])) when (n1 = n2) ->
raise NO_MATCH (* used cons vs. functional cons *)
- | (Term (n1, _, _), Term (n2, _, _)) when (n1 = n2) ->
+ | (Term (n1, _, a1), Term (n2, _, a2)) when (n1 = n2) ->
+ (*Printf.printf "check_clash_match: [1] %s(%d) %s(%d): %a -- %a\n"
+ n1 (Array.length a1) n2 (Array.length a2)
+ (Aux.array_fprint (fun o t->output_string o (Coding.term_to_string t))) a1
+ (Aux.array_fprint (fun o t->output_string o (Coding.term_to_string t))) a2;*)
failwith "curried functions not supported (yet?)"
| (Term (n1, _, _), Term (n2, _, _)) -> (* when (n2.[0] != 'F') *)
raise NO_MATCH
| (Term _, _) ->
(true, [])
- | (Var (n, _, d, [||]), t2) ->
+ | (Var (n, d, _, [||]), t2) ->
(false, [(n, (d, fn_apply d Coding.decode_term t2))])
- | (Var _, _) ->
+ | (Var (n, _, _, a), _) ->
+ (* Printf.printf "check_clash_match: [2] %s %d\n" n (Array.length a); *)
failwith "functional var on left side of rr" in
match (term1, term2) with (* now term1 = f (args) *)
| (Term (n1, _, a1), Term (n2, _, a2))
@@ -101,14 +106,14 @@
let rec normalise_special_id_one name = function
| Term (n, _, [|a|]) when n = name -> a
| Term (n, t, a) -> Term (n, t, Array.map (normalise_special_id_one name) a)
- | Var (n, ty, d, a) ->
- Var (n, ty, d, Array.map (normalise_special_id_one name) a)
+ | Var (n, d, ty, a) ->
+ Var (n, d, ty, Array.map (normalise_special_id_one name) a)
let rec normalise_special_id_all name = function
| Term (n, _, [|a|]) when n = name -> normalise_special_id_all name a
| Term (n, t, a) -> Term (n, t, Array.map (normalise_special_id_all name) a)
- | Var (n, ty, d, a) ->
- Var (n, ty, d, Array.map (normalise_special_id_all name) a)
+ | Var (n, d, ty, a) ->
+ Var (n, d, ty, Array.map (normalise_special_id_all name) a)
let normalise_brackets = normalise_special_id_all brackets_name
let normalise_verbatim = normalise_special_id_one verbatim_name
@@ -120,8 +125,8 @@
rr_spec normalised
| Term (n, t, a) ->
Term (n, t, Array.map (normalise_special rr_spec) a)
- | Var (n, ty, d, a) ->
- Var (n, ty, d, Array.map (normalise_special rr_spec) a)
+ | Var (n, d, ty, a) ->
+ Var (n, d, ty, Array.map (normalise_special rr_spec) a)
let cMEM_USE_INCREASE_FACTOR = 128
@@ -169,9 +174,9 @@
| Term (n, t, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
(steps, Term (n, t, res))
- | Var (n, ty, d, a) ->
+ | Var (n, d, ty, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
- (steps, Var (n, ty, d, res))
+ (steps, Var (n, d, ty, res))
let normalise mem rules is_special rewrite_special inp_term =
Modified: trunk/Toss/Term/RewritingTest.ml
===================================================================
--- trunk/Toss/Term/RewritingTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/RewritingTest.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -10,26 +10,25 @@
let test_rr rl res t =
let rs = new_rules_set rl in
assert_equal ~printer:(fun x-> x) res (term_to_string (rewrite rs t)) in
- let var_x_b = Var ("x", [|boolean_tp|], 0, [||]) in
- let var_y_b = Var ("y", [|boolean_tp|], 0, [||]) in
+ let var_x_b = Var ("x", 0, boolean_tp, [||]) in
+ let var_y_b = Var ("y", 0, boolean_tp, [||]) in
let rr1 =
- (Term ("Fand",[||],[|code_bool true;code_bool true|]),code_bool true) in
- let rr2 = (Term ("Fand", [||], [|var_x_b; var_y_b|]), code_bool false) in
- let t1 = Term ("Fand", [||], [|code_bool true; code_bool true|]) in
- test_rr [rr1; rr2] "Ftrue" t1;
- let t2 = Term ("Fand", [||], [|code_bool true; code_bool false|]) in
- test_rr [rr1; rr2] "Ffalse" t2;
- let t3 = Term ("Fand", [||], [|code_bool false; code_bool true|]) in
- test_rr [rr1; rr2] "Ffalse" t3;
- let t4 = Term ("Fand", [||], [|code_bool false; code_bool false|]) in
- test_rr [rr1; rr2] "Ffalse" t4;
- let t5 = Term ("Fand", [||], [|code_bool false; var_x_b|]) in
- test_rr [rr1; rr2] "Ffalse" t5;
- let t6 = Term ("Fand", [||], [|code_bool true; var_x_b|]) in
- test_rr [rr1; rr2] "Fand (Ftrue, @V [x @: Tboolean @: 0 ] )" t6;
- let t7 = Term ("Fand", [||], [|var_x_b; var_y_b|]) in
- test_rr [rr1; rr2] ("Fand (@V [x @: Tboolean @: 0 ], " ^
- "@V [y @: Tboolean @: 0 ] )") t7;
+ (Term ("Fand",[|boolean_tp|],[|code_bool true;code_bool true|]),code_bool true) in
+ let rr2 = (Term ("Fand", [|boolean_tp|], [|var_x_b; var_y_b|]), code_bool false) in
+ let t1 = Term ("Fand", [|boolean_tp|], [|code_bool true; code_bool true|]) in
+ test_rr [rr1; rr2] "Ftrue[ @: Tboolean]" t1;
+ let t2 = Term ("Fand", [|boolean_tp|], [|code_bool true; code_bool false|]) in
+ test_rr [rr1; rr2] "Ffalse[ @: Tboolean]" t2;
+ let t3 = Term ("Fand", [|boolean_tp|], [|code_bool false; code_bool true|]) in
+ test_rr [rr1; rr2] "Ffalse[ @: Tboolean]" t3;
+ let t4 = Term ("Fand", [|boolean_tp|], [|code_bool false; code_bool false|]) in
+ test_rr [rr1; rr2] "Ffalse[ @: Tboolean]" t4;
+ let t5 = Term ("Fand", [|boolean_tp|], [|code_bool false; var_x_b|]) in
+ test_rr [rr1; rr2] "Ffalse[ @: Tboolean]" t5;
+ let t6 = Term ("Fand", [|boolean_tp|], [|code_bool true; var_x_b|]) in
+ test_rr [rr1; rr2] "Fand[ @: Tboolean] (Ftrue[ @: Tboolean], @V [x @: Tboolean @: 0 ] )" t6;
+ let t7 = Term ("Fand", [|boolean_tp|], [|var_x_b; var_y_b|]) in
+ test_rr [rr1; rr2] ("Fand[ @: Tboolean] (@V [x @: Tboolean @: 0 ], @V [y @: Tboolean @: 0 ] )") t7;
);
"normalise" >::
@@ -39,22 +38,21 @@
Hashtbl.add rs n (new_rules_set rl);
assert_equal ~printer:(fun x-> x) res
(term_to_string (normalise m rs (fun x -> false) (fun x -> x) t)) in
- let var_x_b = Var ("x", [|boolean_tp|], 0, [||]) in
- let var_y_b = Var ("y", [|boolean_tp|], 0, [||]) in
+ let var_x_b = Var ("x", 0, boolean_tp, [||]) in
+ let var_y_b = Var ("y", 0, boolean_tp, [||]) in
let rr1 =
- (Term ("Fand",[||],[|code_bool true;code_bool true|]),code_bool true) in
- let rr2 = (Term ("Fand", [||], [|var_x_b; var_y_b|]), code_bool false) in
+ (Term ("Fand",[|boolean_tp|],[|code_bool true;code_bool true|]),code_bool true) in
+ let rr2 = (Term ("Fand", [|boolean_tp|], [|var_x_b; var_y_b|]), code_bool false) in
let rrs = ("Fand", [rr1; rr2]) in
- let t1 = Term ("Fand", [||], [|code_bool true; code_bool true|]) in
- test_ne rrs "Ftrue" t1;
- let t2 = Term ("Fand", [||], [|code_bool true; t1|]) in
- test_ne rrs "Ftrue" t2;
- let t3 = Term ("Fand", [||], [|var_x_b; t1|]) in
- test_ne rrs "Fand (@V [x @: Tboolean @: 0 ], Ftrue )" t3;
- let t4 = Term (if_then_else_name, [||], [|var_x_b; t1; t1|]) in
- test_ne rrs ("Fif_\\?_then_\\?_else_\\? (@V [x @: Tboolean @: 0 ], Fand "^
- "(Ftrue, Ftrue ), Fand (Ftrue, Ftrue ) )") t4;
- let t5 = Term ("Ckot", [||], [|var_x_b; t1; t1|]) in
- test_ne rrs "Ckot (@V [x @: Tboolean @: 0 ], Ftrue, Ftrue )" t5;
+ let t1 = Term ("Fand", [|boolean_tp|], [|code_bool true; code_bool true|]) in
+ test_ne rrs "Ftrue[ @: Tboolean]" t1;
+ let t2 = Term ("Fand", [|boolean_tp|], [|code_bool true; t1|]) in
+ test_ne rrs "Ftrue[ @: Tboolean]" t2;
+ let t3 = Term ("Fand", [|boolean_tp|], [|var_x_b; t1|]) in
+ test_ne rrs "Fand[ @: Tboolean] (@V [x @: Tboolean @: 0 ], Ftrue[ @: Tboolean] )" t3;
+ let t4 = Term (if_then_else_name, [|boolean_tp|], [|var_x_b; t1; t1|]) in
+ test_ne rrs ("Fif_\?_then_\?_else_\?[ @: Tboolean] (@V [x @: Tboolean @: 0 ], Fand[ @: Tboolean] (Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] ), Fand[ @: Tboolean] (Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] ) )") t4;
+ let t5 = Term ("Ckot", [|char_tp|], [|var_x_b; t1; t1|]) in
+ test_ne rrs "Ckot[ @: Tchar] (@V [x @: Tboolean @: 0 ], Ftrue[ @: Tboolean], Ftrue[ @: Tboolean] )" t5;
);
]
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Term/SyntaxDef.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -70,25 +70,25 @@
| SDtype sel as sd ->
let rec revnumbers i = if i = 0 then [] else i :: (revnumbers (i-1)) in
let numbers i = List.map string_of_int (List.rev (revnumbers i)) in
- let s = List.concat (List.map (function Str _ -> [] | Tp _ -> ["a"]) sel) in
- let arg_of s1 s2 = Var (s1 ^ "_" ^ s2, [||], 0, [||]) in
+ let s = concat_map (function Str _ -> [] | Tp _ -> ["a"]) sel in
+ let arg_of s1 s2 = Var (s1 ^ "_" ^ s2, 0, top_type_term, [||]) in
let args = List.map2 arg_of s (numbers (List.length s)) in
- Term (name_of_sd sd, [||], of_list args)
+ Term (name_of_sd sd, toplevel_type, of_list args)
| _ -> failwith "type of sd on non-type definition"
-(* Type used in type declaration for a syntax definition. *)
+(* Function type corresponding to a syntax definition. *)
let sd_type sd =
let types_of_sels s = List.map (function Str _ -> [] | Tp ty -> [ty]) s in
let ts = List.flatten (types_of_sels (syntax_elems_of_sd sd)) in
match sd with
| SDtype _ -> None
| SDfun (sel, ty)-> Some (if (ts = []) then ty else
- Term (Term.fun_type_name, [||], of_list (ts @ [ty])))
+ Term (Term.fun_type_name, toplevel_type, of_list (ts @ [ty])))
| SDvar (sel, ty)-> Some (if (ts = []) then ty else
- Term (Term.fun_type_name, [||], of_list (ts @ [ty])))
+ Term (Term.fun_type_name, toplevel_type, of_list (ts @ [ty])))
-(* Functional syntax definition corresponding to a given one. *)
+(* Syntax definition for un-applied syntax definition as function. *)
let func_sd_of_sd sd =
let change = function Tp _ -> [Str "{"; Str "}"] | x -> [x] in
let oldelems = (syntax_elems_of_sd sd) in
@@ -215,14 +215,15 @@
else [Some (n)]
let rec display_type = function
- | Var (n, [||], 0, [||]) -> "?" ^ n
+ | tp when tp = top_type_term -> "ttyyppee" (* FIXME *)
+ | Var (n, 0, tp, [||]) when tp = top_type_term -> "?" ^ n
| Var _ -> failwith "display_type on non-type variable"
- | Term (n, [||], arr) when n = Term.fun_type_name ->
+ | Term (n, tp, arr) when n = Term.fun_type_name && tp = toplevel_type ->
let l = Array.length arr in
let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
let args = List.map display_type (Array.to_list a) in
"(" ^ (String.concat ", " args) ^ ") --> " ^ (display_type r)
- | Term (n, [||], a) ->
+ | Term (n, tp, a) when tp = toplevel_type ->
let args = List.map display_type (Array.to_list a) in
display_sd (split_sdef_name n) args
| Term _ -> failwith "display_type: non-type term"
@@ -268,7 +269,7 @@
let rule_of_sd sd =
try let (x, y) = flat_grammar_rule_of_sd sd in [(y, x)]
with NONLEXICAL -> [] in
- let rules = Aux.collect (List.concat (List.map rule_of_sd sdl)) in
+ let rules = Aux.collect (Aux.concat_map rule_of_sd sdl) in
let type_names = fst (List.split rules) in
let type_names_no_obj =
List.filter (fun s -> not (s = "$@object")) type_names in
Modified: trunk/Toss/Term/SyntaxDefTest.ml
===================================================================
--- trunk/Toss/Term/SyntaxDefTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/SyntaxDefTest.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -5,7 +5,7 @@
let tests = "SyntaxDef" >::: [
"name of sd" >::
(fun () ->
- let sel1 = [Str "[list]"; Str "of"; Tp (Var ("a",[||],0,[||]))] in
+ let sel1 = [Str "[list]"; Str "of"; Tp (Var ("a",0,top_type_term,[||]))] in
let n = unique_name_of_sd (SDtype sel1) [name_of_sd (SDtype sel1)] in
assert_equal ~printer:(fun x -> x) "T\\lslist\\rs_of_\\?_0\\" n;
);
@@ -20,7 +20,7 @@
assert_equal ~printer:(fun x -> x) res_sn sn in
let sd1 = SDtype [Str "ala_ma_kota"] in
let sd2 = SDtype [Str "\\atala"; Str "_"; Str "\\?"; Str "m\\_a";
- Str "\\\\";Str "maa\\"; Tp (Var ("a",[||],0,[||]));
+ Str "\\\\";Str "maa\\"; Tp (Var ("a",0,top_type_term,[||]));
Str "kot@"] in
test_split "Tala\\_ma\\_kota" "Sala_ma_kota" sd1;
test_split "T\\\\atala_\\__\\\\?_m\\\\\\_a_\\\\\\\\_maa\\\\_\\?_kot\\at"
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/TRS.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -150,7 +150,7 @@
let elem_of_td (n, ty) =
if n.[0] = c then
match ty with
- | Term (name, [||], arr) when name = Term.fun_type_name ->
+ | Term (name, tp, arr) when name = Term.fun_type_name && tp=toplevel_type->
let l = Array.length arr in
let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
[(n, Array.to_list a, r)]
@@ -180,14 +180,17 @@
let rec rewrite_special_funs sys = function
| Term (n, _, [|a|]) when n = code_as_term_name ->
code_term_incr_vars a
- | Term (n, t, [|a; b|]) when n = eq_bool_name ->
+ | Term (n, _, [|a; b|]) as te when n = eq_bool_name ->
+ (* FIXME: what about equality when a and b are polymorphic? *)
if a = b then (code_bool true) else
- if has_vars a || has_vars b then (Term (n, t, [|a; b|])) else
+ if has_vars a || has_vars b then te else
code_bool false
| Term (n, _, [||]) when n = get_type_definitions_name ->
- code_list code_type_definition (get_types_of_sys sys)
+ code_list [|list_tp term_type_tp|] code_type_definition
+ (get_types_of_sys sys)
| Term (n, _, [||]) when n = get_fun_definitions_name ->
- code_list code_fun_definition (get_funs_of_sys sys)
+ code_list [|list_tp fun_definition_tp|] code_fun_definition
+ (get_funs_of_sys sys)
| te -> te
and normalise_with_sys sys te =
(* This is the main normalisation function. *)
@@ -199,11 +202,13 @@
(* Parse a string using the given system. *)
let parse_with_sys sys str =
let elems = parse sys.types sys.sdefs (split_input_string str) in
- let type_of_pe = function Token _ -> [] | Typed_term (_, te) -> [te] in
+ let type_of_pe = function Token _ -> []
+ | Typed_term (_, te) -> [te] in
flatten (map type_of_pe elems)
let is_better sys te1 te2 =
- let query = Term (preferred_to_name,[||], [|code_term te1; code_term te2|]) in
+ let query = Term (preferred_to_name,[|ternary_truth_value_tp|],
+ [|code_term te1; code_term te2|]) in
let report i =
LOG 1 "%s prefered to %s ? %i" (term_to_string te1) (term_to_string te2) i;
i in
@@ -297,8 +302,12 @@
| Tp _ -> (i := !i+1; "X_" ^ (string_of_int !i)) in
String.concat " " (map msg sels)
+let is_empty_list = function
+ | Term (n, _, _) when n = list_nil_name -> true
+ | _ -> false
+
let recognize_list te =
- if (te = code_list (fun x -> x) []) then ("", false) else
+ if is_empty_list te then ("", false) else
try let _ = decode_list decode_syntax_definition te in
("syntax definitions", true) with
| DECODE _ ->
@@ -394,8 +403,9 @@
let msg = ("NO PARSE: " ^ str) in
(if (not xml_out) then outprint msg else ();
raise (FAILED_PARSE_OR_EXN msg))
- | [x] ->
- let te = normalise_with_sys s (Term (preprocess_name, [||], [|x|])) in (
+ | [x] ->
+ (* FIXME *)
+ let te = normalise_with_sys s (Term (preprocess_name, [|Var ("q",0,top_type_term,[||])|], [|x|])) in (
match te with
| Term (te_name, _, [|a|]) when te_name = exception_name ->
let msg = "TRS EXCEPTION:\n" ^ (display_term a) ^ "\n" in
Modified: trunk/Toss/Term/TRSTest.ml
===================================================================
--- trunk/Toss/Term/TRSTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/TRSTest.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -50,8 +50,9 @@
(fun () -> test "english";);
"test simple_algo" >::
(fun () -> test "simple_algo";);
- "test entanglement" >::
- (fun () -> test "entanglement";);
+ (* FIXME: hangs on trashing memory *)
+ (*"test entanglement" >::
+ (fun () -> test "entanglement";);*)
"test differentiation" >::
(fun () -> test "differentiation";);
]
@@ -101,7 +102,9 @@
AuxIO.output_file ~fname:!grammar_path grammar_str
);
if (not (!xslt_path = "")) then (
- let addon_term = Term (BuiltinLang.additional_xslt_name, [||], [||]) in
+ let addon_term =
+ Term (BuiltinLang.additional_xslt_name,
+ [|BuiltinLang.string_tp|], [||]) in
let addon_str = Coding.decode_string
(normalise_with_sys !sys addon_term) in
let xslt_str = print_xslt addon_str (syntax_defs_of_sys !sys) in
Modified: trunk/Toss/Term/Term.ml
===================================================================
--- trunk/Toss/Term/Term.ml 2012-06-20 21:51:20 UTC (rev 1730)
+++ trunk/Toss/Term/Term.ml 2012-06-22 13:48:24 UTC (rev 1731)
@@ -1,41 +1,199 @@
-(* Contains the type of term types, operations on types and parser for types. *)
+(** Contains the type of hierarchical terms, helper operations and
+ parser for them, and the ISA order relation operations.
+ {3 Specification of Hierarchical Terms}
+
+ Hierarchical terms have the form: [f(s_1, ..., s_m; t_1, ...,
+ t_n)] where [f] is a (function/constant/class) symbol, terms [s_1,
+ ..., s_m] are called direct supertypes and terms [t_1, ..., t_n]
+ are called direct subterms of the term, or [X(s)], where [X] is a
+ variable symbol and term [s] is called the type of the variable.
+ When [f(s_1, ..., s_m; t_1, ..., t_n)], resp. [X(s)] is not a
+ subterm or supertype of another term, we call [f], resp. [X] its
+ head symbol. Hierarchical terms are related by [ISA] as formally
+ presented below; we drop "hierarchical" when referring to terms
+ for convenience.
+
+ We call the {i upper grounding} of a term [t], [ug(t)], the term
+ [t] with all occurrences of [X(s)] for any variable symbol [X] and
+ term [s] replaced by [s].
+
+ We start by defining [t ISA t'] for [t] and [t'] ground terms
+ (i.e. terms without occurrences of variable symbols).
+ It holds if and only if one of the following holds:
+
+ {ul
+ {- [t' = Type] for the top symbol [Type],}
+ {- [s_i ISA g(s'_1, ..., s'_m'; t'_1, ..., t'_n')] for some i,
+ where [s(t)=f(s_1, ..., s_m; t_1, ..., t_n)] and
+ [r(t')=g(s'_1, ..., s'_m'; t'_1, ..., t'_n')]}
+ {- [s_i ISA s'_i] for all [i], [t_i ISA t'_i] for all [i],
+ where [s()t=f(s_1, ..., s_m; t_1, ..., t_n)] and
+ [r(t')=f(s'_1, ..., s'_m; t'_1, ..., t'_n)]}}
+
+ Actually we sometimes do not put a special case for the top symbol
+ [Type] into algorithms, and therefore we rely on well-formed sets
+ of declarations that no term except [Type] has no direct
+ supertypes.
+
+ We define {i ground substitution over variables [V]} by extending
+ into a function over terms in the standard way a finite mapping
+ from all variables in [V] to terms, requiring that [X(s)] is
+ mapped to [t] only when: [t] does not contain variable symbols,
+ and [t ISA ug(s)]. By [FV(t)] we denote the free variables of [t].
+
+ [t ISA t'] if and only if for all ground substitutions [s] over
+ [FV(t)] there is a ground substitution [r] over [FV(t')] such that
+ [s(t) ISA r(t')].
+
+ (We present [ISA] as describing generality, "is less (or equally)
+ general than". Notice that this relation is often presented as
+ describing the amount of information, the reverse quantity, as "has
+ more information than".)
+
+ We need two more essential notions.
+
+ A {i well-formed set of declarations} is defined as a set of terms
+ such that all of the following conditions hold:
+
+ {ul
+ {- no two terms in it have the same head symbol,}
+ {- head symbols of terms in it are not variables,}
+ {- there is at most one glb-unification result for any two (or
+ more) elements from the set,}
+ {- no term except [Type] has no direct supertypes,}
+ {- every symbol used in any term in the set is a head symbol of
+ some element of the set,}
+ {- for any subterm or supertype of a term from the set, its upper
+ grounding ISA the element of the set which has the same head
+ symbol.}}
+
+ Note that the last three conditions will be enforced by parsing the
+ term to be introduced into the set of declarations, so in the
+ current module we only need to check the first three
+ conditions. (The condition "must have direct supe...
[truncated message content] |
|
From: <luk...@us...> - 2012-06-20 21:51:26
|
Revision: 1730
http://toss.svn.sourceforge.net/toss/?rev=1730&view=rev
Author: lukaszkaiser
Date: 2012-06-20 21:51:20 +0000 (Wed, 20 Jun 2012)
Log Message:
-----------
Hierarchical structures possible, used to define shapes for elements.
Modified Paths:
--------------
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/eval.html
trunk/Toss/Makefile
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
Added Paths:
-----------
trunk/Toss/Client/Drawing.mli
trunk/Toss/Client/DrawingTest.ml
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Client/Drawing.ml 2012-06-20 21:51:20 UTC (rev 1730)
@@ -35,48 +35,111 @@
(* Various shapes. *)
-type shapes =
- | Circle of point * float (* circle, given middle and radius *)
- | Rectangle of point * point (* rectangle, given middle and width-height *)
+type shape =
+ | Circle of point * point (* circle, given middle and radiuses *)
| Line of point * point (* line, given from and to *)
-(* Create an arrow from x to y assuming circle of radius [rad] *)
-let arrow rad x y =
+let shape_str = function
+ | Circle (p, r) -> Printf.sprintf "circle (%F, %F) r (%F, %F)" p.x p.y r.x r.y
+ | Line (f, t) -> Printf.sprintf "line (%F, %F) -- (%F, %F)" f.x f.y t.x t.y
+
+let shapes_str l = String.concat "; " (List.map shape_str l)
+
+(* Shift a shape by [x]. *)
+let shift_shape x = function
+ | Circle (p, r) -> Circle (p +: x, r)
+ | Line (f, t) -> Line (f +: x, t +: x)
+
+let shift_shapes x l = List.map (shift_shape x) l
+
+(* Change coordinates in a shape. *)
+let change_coords_shape c1 c2 = function
+ | Circle (p, r) ->
+ let z = {x=0.; y=0.} in
+ Circle (change_coords c1 c2 p, change_coords (z, snd c1) (z, snd c2) r)
+ | Line (f, t) -> Line (change_coords c1 c2 f, change_coords c1 c2 t)
+
+let change_coords_shapes c1 c2 l = List.map (change_coords_shape c1 c2) l
+
+(* Helper function - solve a quadratic equation ax^2 + bx + c = 0. *)
+let quadratic a b c =
+ let d = b *. b -. 4. *. a *. c in
+ if d < 0. then [] else if d = 0. then [-1. *. b /. (2. *. a)] else
+ [(-1.*.b +. (sqrt d)) /. (2. *. a); (-1.*.b -. (sqrt d)) /. (2. *. a)]
+
+(* Calculate where the line [p] -- [q] crosses the shape. *)
+let crossing p q = function
+ | Circle (m, r) ->
+ let norm_coord pt = change_coords (m, r) ({x=0.;y=0.}, {x=1.;y=1.}) pt in
+ let back_coord pt = change_coords ({x=0.;y=0.}, {x=1.;y=1.}) (m, r) pt in
+ let p, q = norm_coord p, norm_coord q in
+ let d = q -: p in (* Now we just cross p--q with the unit circle. *)
+ let c =
+ if d.x = 0. && d.y = 0. then
+ if p.x *. p.x +. p.y *. p.y = 0. then [p] else []
+ else if d.x = 0. then (* x = p.x = q.x crosses unit circle *)
+ if p.x < -1. || p.x > 1. then [] else
+ if p.x = 1. || p.x = -1. then [{ x = p.x ; y = 0. }] else
+ let y = sqrt (1. -. p.x *. p.x) in
+ [{ x = p.x ; y = y }; { x = p.x ; y = -1. *. y }]
+ else ( (* y - p.y = d.y / d.x ( x - p.x ) and unit square *)
+ let d = d.y /. d.x in (* ( d (x - p.x) + p.y )^2 + x^2 = 1 *)
+ let c = p.y -. d *. p.x in (* (d x + c)^2 + x^2 - 1 = 0 *)
+ LOG 1 "p = (%F, %F), q = (%F, %F), d = %F, c = %F" p.x p.y q.x q.y d c;
+ let xs = quadratic (1. +. d*.d) (2.*.d*.c) (c*.c -. 1.) in
+ List.map (fun x -> { x = x ; y = d *. (x -. p.x) +. p.y }) xs ) in
+ List.map back_coord c
+ | Line (f, t) -> failwith "crossing not yet implemented for lines"
+
+let crossings p q l = Aux.concat_map (crossing p q) l
+
+(* Maximal distance of shape points from (0, 0). *)
+let radius_single = function
+ | Circle (p, r) -> dist p {x=0.;y=0.} +. (max r.x r.y) (* FIXME *)
+ | Line (f, t) -> max (dist f {x=0.;y=0.}) (dist t {x=0.;y=0.})
+
+let radius l = List.fold_left max 0. (List.rev_map radius_single l)
+
+(* Create an arrow from x to y given the shapes of x and y. *)
+let arrow (x, shapes_x) (y, shapes_y) =
let len = dist x y in
- if len < 0.1 then [] else
- let d = (y -: x) *! (rad /. len) in
- let q, p = x +: d, y -: d in
- let arr = p -: (d *! 0.5) in
- [ Line (q, p); Line (p, rotate p 30. arr); Line (p, rotate p (-30.) arr) ]
+ if len < 0.1 then [] else (
+ let pl, ql = crossings x y shapes_x, crossings x y shapes_y in
+ let mdist x p q =
+ let f = (dist p x) -. (dist q x) in
+ if f = 0. then 0 else if f > 0. then 1 else -1 in
+ let pl, ql = List.sort (mdist y) pl, List.sort (mdist x) ql in
+ let p = if pl = [] then x else List.hd pl in
+ let q = if ql = [] then y else List.hd ql in
+ let tip = q -: ((y -: q) *! 0.5) in
+ [ Line (p, q); Line (q, rotate q 30. tip); Line (q, rotate q (-30.) tip) ]
+ )
-
(* Structure with coordinates for drawing on canvas. *)
type structure_with_coords = {
struc : Structure.structure ;
coordC: point * point ;
coordS: point * point ;
- radius: float ;
}
let empty_struc_coords () = {
struc = Structure.empty_structure ();
coordC = {x=0.;y=0.}, {x=0.;y=0.};
coordS = {x=0.;y=0.}, {x=0.;y=0.};
- radius = 0.
}
(* Get the position of an element. *)
-let get_pos struc e = (* Canvas positions count "from up" on y, thus -1. *)
+let get_pos_pair struc e = (* Canvas positions count "from up" on y, thus -1. *)
(Structure.fun_val struc "x" e, -1. *. Structure.fun_val struc "y" e)
+let get_pos struc e = let (x, y) = get_pos_pair struc e in {x=x; y=y}
+
(* Create a structure with canvas coordinates given canvas sizes, structure.
The first four parameters are the width, height and margins of canvas,
- the third and fourth are (optional) min and max of structure coordinates. *)
+ the fifth and sixth are (optional) min and max of structure coordinates. *)
let add_coords cwidth cheight cmarginx cmarginy minp maxp struc =
let elems = Structure.elements struc in
- let rad = (* radius for elements *)
- min 45. (max 5. (450. /. float (List.length elems))) in
- let positions = List.map (get_pos struc) elems in
+ let positions = List.map (get_pos_pair struc) elems in
let minp = match minp with Some p -> p | None ->
let (posx, posy) = List.split positions in
{ x = List.fold_left min (List.hd posx) posx;
@@ -86,44 +149,70 @@
{ x = List.fold_left max (List.hd posx) posx;
y = List.fold_left max (List.hd posy) posy } in
let diffp = { x= max (maxp.x -. minp.x) 1.; y= max (maxp.y -. minp.y) 1. } in
+ let diffp = { x= max diffp.x diffp.y; y= max diffp.x diffp.y } in(*no strech*)
let coordC = ({ x= cwidth/.2. +. cmarginx; y= cheight/.2. +. cmarginy},
{ x= cwidth; y= cheight }) in
let coordS = ((maxp +: minp) /: {x = 2.; y = 2.}, diffp) in
- { struc = struc ; coordC = coordC ; coordS = coordS ; radius = rad }
+ { struc = struc ; coordC = coordC ; coordS = coordS }
+(* Read a shape encoded in a structure. *)
+let read_shapes struc =
+ LOG 1 "reading shapes %s" (Structure.str struc);
+ let circles = Structure.rel_graph "Circle" struc in
+ let radius e =
+ {x = Structure.fun_val struc "rx" e; y = Structure.fun_val struc "ry" e} in
+ let circ e = Circle (get_pos struc e, radius e) in
+ List.map (fun e -> circ e.(0)) (Structure.Tuples.elements circles)
+
+(* Draw an element of a structure with coordinates. *)
+let draw_elem st_c e =
+ let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
+ let shapes = read_shapes (Structure.model_val struc "shape" e) in
+ change_coords_shapes coordS coordC (shift_shapes (get_pos struc e) shapes)
+
+(* Check whether the float pair (on canvas) is inside the element radius. *)
+let in_elem_radius st_c e (x, y) =
+ let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
+ let shapes = read_shapes (Structure.model_val struc "shape" e) in
+ let p, r = get_pos struc e, radius (shapes)
+ in dist p (change_coords coordC coordS {x=x; y=y}) < r
+
(* Draw the structure with coordinates [st_c] as a sequence of shapes. *)
let draw_struc st_c =
let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
- let positions = List.map (get_pos struc) (Structure.elements struc) in
- let circ (x,y)= Circle (change_coords coordS coordC {x=x; y=y},st_c.radius) in
- let elem_drawings = List.map circ positions in
+ let elems =
+ List.rev_map (fun e -> (e, draw_elem st_c e)) (Structure.elements struc) in
+ let elem_drawings = Aux.concat_map (fun (_, d) -> d) elems in
(* drawing relations *)
- let pos e =
- let (x,y) = get_pos struc e in
- change_coords coordS coordC {x=x; y=y} in
+ let pos e = change_coords coordS coordC (get_pos struc e) in
+ let pos_draw e = (pos e, List.assoc e elems) in
let draw_rel (rel, arity) =
if arity = 1 then
let elems = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- Aux.concat_map (fun a -> [Circle (pos a.(0), st_c.radius /. 2.)]) elems
+ Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.})]) elems
else if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- Aux.concat_map (fun a -> arrow st_c.radius (pos a.(0)) (pos a.(1))) tuples
+ Aux.concat_map (fun a-> arrow (pos_draw a.(0)) (pos_draw a.(1))) tuples
else [] in
elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
(* Compile the shape to a JavaScript program drawing the shape on 'ctx'. *)
let shape_to_canvas = function
- | Circle (p, r) ->
- let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r in
- "ctx.beginPath(); " ^ s ^ "ctx.fill(); ctx.stroke(); "
- | Rectangle (m, wh) ->
- Printf.sprintf "ctx.fillRect(%F,%F,%F,%F); " m.x m.y wh.x wh.y
+ | Circle (p, r) ->
+ if r.x = r.y then
+ let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r.x
+ in "ctx.beginPath(); "^ s^"ctx.fill(); ctx.stroke(); ctx.closePath(); "
+ else
+ let sc = Printf.sprintf "ctx.scale(%F, %F); " (r.x /.100.) (r.y /.100.) in
+ let tr = Printf.sprintf "ctx.translate(%F, %F); " p.x p.y in
+ "ctx.save(); "^ tr ^sc ^"ctx.beginPath(); ctx.arc(0,0,100,0,2*Math.PI); "^
+ "ctx.stroke(); ctx.closePath(); ctx.restore(); "
| Line (f, t) ->
let fs = Printf.sprintf "ctx.moveTo(%F,%F); " f.x f.y in
let ts = Printf.sprintf "ctx.lineTo(%F,%F); " t.x t.y in
- "ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); "
+ "ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); ctx.closePath(); "
let shapes_to_canvas l =
String.concat " " (List.rev (List.rev_map shape_to_canvas l))
Added: trunk/Toss/Client/Drawing.mli
===================================================================
--- trunk/Toss/Client/Drawing.mli (rev 0)
+++ trunk/Toss/Client/Drawing.mli 2012-06-20 21:51:20 UTC (rev 1730)
@@ -0,0 +1,80 @@
+(** Drawing structures, with compilation to HTML5 canvas commands. *)
+
+(** Points. *)
+type point = { x : float; y : float }
+
+(** Component-wise operations on points. *)
+val ( +: ) : point -> point -> point
+val ( -: ) : point -> point -> point
+val ( *: ) : point -> point -> point
+val ( /: ) : point -> point -> point
+
+(** Scalar operations on points. *)
+val ( +! ) : point -> float -> point
+val ( -! ) : point -> float -> point
+val ( *! ) : point -> float -> point
+val ( /! ) : point -> float -> point
+
+(** Change coordinates from one system to another (given mid-point and size). *)
+val change_coords : point * point -> point * point -> point -> point
+
+(** Distance between two points. *)
+val dist : point -> point -> float
+
+(** Rotate the point [p] around [start] by [angle]. *)
+val rotate : point -> float -> point -> point
+
+
+(** Shapes. *)
+type shape =
+ | Circle of point * point (** circle, given middle and radiuses *)
+ | Line of point * point (** line, given from and to *)
+
+(** Print shapes. *)
+val shapes_str : shape list -> string
+
+(** Shift shapes by a vector. *)
+val shift_shapes : point -> shape list -> shape list
+
+(** Change coordinates in shapes. *)
+val change_coords_shapes : point * point -> point * point ->
+ shape list -> shape list
+
+(** Calculate where the line [p] -- [q] crosses shapes. *)
+val crossings : point -> point -> shape list -> point list
+
+(** Maximal distance of shape points from (0, 0). *)
+val radius : shape list -> float
+
+(** Structure with coordinates for drawing on canvas. *)
+type structure_with_coords = {
+ struc : Structure.structure ;
+ coordC: point * point ;
+ coordS: point * point ;
+}
+
+(** Empty structure with trivial coordinates. *)
+val empty_struc_coords : unit -> structure_with_coords
+
+(** Get the position of an element in a structure as a point. *)
+val get_pos : Structure.structure -> int -> point
+
+(** Read a shape encoded in a structure. *)
+val read_shapes : Structure.structure -> shape list
+
+
+(** Create a structure with canvas coordinates given canvas sizes, structure.
+ The first four parameters are the width, height and margins of canvas,
+ the fifth and sixth are (optional) min and max of structure coordinates. *)
+val add_coords: float -> float -> float -> float -> point option -> point option
+ -> Structure.structure -> structure_with_coords
+
+(** Draw the structure with coordinates [st_c] as a sequence of shapes. *)
+val draw_struc : structure_with_coords -> shape list
+
+(** Check whether the float pair (on canvas) is inside the element radius. *)
+val in_elem_radius : structure_with_coords -> int -> float * float -> bool
+
+(** Compile the shapes to a JavaScript program drawing the shape on 'ctx'.
+ With [result] in JS do: var ctx = canvas.getContext("2d"); eval (result). *)
+val shapes_to_canvas : shape list -> string
Added: trunk/Toss/Client/DrawingTest.ml
===================================================================
--- trunk/Toss/Client/DrawingTest.ml (rev 0)
+++ trunk/Toss/Client/DrawingTest.ml 2012-06-20 21:51:20 UTC (rev 1730)
@@ -0,0 +1,29 @@
+open OUnit
+open Drawing
+
+let eq_point p q =
+ assert_equal ~printer:(fun p -> Printf.sprintf "(%F, %F)" p.x p.y) p q
+
+let eq_point_list pl ql =
+ let str p = Printf.sprintf "(%F, %F)" p.x p.y in
+ assert_equal ~printer:(fun l -> String.concat ", " (List.map str l)) pl ql
+
+let tests = "Drawing" >::: [
+ "change coords" >::
+ (fun () ->
+ let z, o = {x=0.;y=0.}, {x=1.;y=1.} in
+ eq_point o (change_coords (z, o) (z, o) o);
+ eq_point (o *! 2.) (change_coords (z, o) (z, o *! 2.) o);
+ eq_point (o *! 2.) (change_coords (z, o) (o, o) o);
+ );
+
+ "crossings" >::
+ (fun () ->
+ let z, o, hsq2 = {x=0.;y=0.}, {x=1.;y=1.}, (sqrt 2.) *. 0.5 in
+ eq_point_list [o*!hsq2; o *! (-1.*.hsq2)] (crossings z o [Circle (z, o)]);
+ eq_point_list [{x=1.;y=0.}] (crossings z {x=1.;y=0.} [Circle (o, o)]);
+ eq_point_list [{x = 2. ; y = 0.}; {x = -2. ; y = 0.}]
+ (crossings z {x=1.; y=0.} [Circle (z, o *! 2.)]);
+ );
+]
+
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Client/JsEval.ml 2012-06-20 21:51:20 UTC (rev 1730)
@@ -1,5 +1,6 @@
(* Evaluating formulas on structures for JS. *)
+
(* --- Boilerplate code for calling OCaml in the worker thread. --- *)
let js_object = Js.Unsafe.variable "Object"
let js_handler = jsnew js_object ()
@@ -68,11 +69,7 @@
let mousedown_handle x y =
let (x, y), struc = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
- let cc e = let (x, y) = Drawing.get_pos struc e in
- let p = Drawing.change_coords !cur_st.Drawing.coordS
- !cur_st.Drawing.coordC {Drawing.x = x; Drawing.y = y} in
- (p.Drawing.x, p.Drawing.y) in
- let near e = dist (cc e) (x, y) < !cur_st.Drawing.radius in
+ let near e = Drawing.in_elem_radius !cur_st e (x, y) in
let near_elems = List.filter near (Structure.elements struc) in
if near_elems = [] then () else (
moving_elem := Some (List.hd near_elems);
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Client/eval.html 2012-06-20 21:51:20 UTC (rev 1730)
@@ -121,8 +121,8 @@
document.getElementById ("relations").value =
"E(x, y) = &y = &x + 1;\n" +
"S(x, y) = x != y and tc x, y E(x, y)";
- document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = &a*&a";
- document.getElementById ("no-elems").value = "3";
+ document.getElementById ("positions").value = ":x(a) = 10*&a;\n:y(a) = &a*&a";
+ document.getElementById ("no-elems").value = "4";
eval_it ();
}
@@ -164,7 +164,7 @@
<textarea id="positions" rows="3" cols="40">
:x(a) = &a;
-:y(a) = 10 * &a * (10 - &a)
+:y(a) = &a * (10 - &a) / 10
</textarea>
<p>Elements: <input id="no-elems" type="text" size="4" value="15"></input>
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Makefile 2012-06-20 21:51:20 UTC (rev 1730)
@@ -144,7 +144,7 @@
PlayINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
LearnINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
GGPINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play
-ServerINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn
+ServerINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Client
ClientINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
.INC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
@@ -246,6 +246,14 @@
cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest Learn
+# Client tests
+ClientTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Client
+ClientTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Client -v
+
# Server tests
ServerTests: Server/Server.native
cp _build/Server/Server.native TossServer
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Server/Tests.ml 2012-06-20 21:51:20 UTC (rev 1730)
@@ -68,6 +68,10 @@
"LearnGameTest", [LearnGameTest.tests; LearnGameTest.bigtests];
]
+let client_tests = "Client", [
+ "DrawingTest", [DrawingTest.tests];
+]
+
let tests_l = [
formula_tests;
term_tests;
@@ -76,6 +80,7 @@
play_tests;
ggp_tests;
learn_tests;
+ client_tests;
]
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Solver/Structure.ml 2012-06-20 21:51:20 UTC (rev 1730)
@@ -52,6 +52,7 @@
elements : Elems.t ;
relations : Tuples.t StringMap.t ;
functions : (float IntMap.t) StringMap.t ;
+ models : (structure IntMap.t) StringMap.t ;
incidence : (TIntMap.t) StringMap.t ;
names : int StringMap.t ;
inv_names : string IntMap.t ;
@@ -103,6 +104,7 @@
elements = Elems.empty ;
relations = StringMap.empty ;
functions = StringMap.empty ;
+ models = StringMap.empty ;
incidence = StringMap.empty ;
names = StringMap.empty ;
inv_names = IntMap.empty ;
@@ -136,8 +138,13 @@
(* Return the value of function [f] on [e] in [struc]. *)
let fun_val struc f e =
let f_vals = StringMap.find f struc.functions in
- IntMap.find e f_vals
+ IntMap.find e f_vals
+(* Return the model assigned by [f] to [e] in [struc]. *)
+let model_val struc f e =
+ let f_vals = StringMap.find f struc.models in
+ IntMap.find e f_vals
+
(* Return the list of functions. *)
let f_signature struc =
StringMap.fold (fun f _ acc -> f :: acc) struc.functions []
@@ -356,6 +363,21 @@
let change_fun struc fn elem x = change_fun_int struc fn (elem_nbr struc elem) x
+
+(* Add model assignment [e] -> [s] to function [fn] in structure [struc].
+ Assumes [e] is already an element of [struc]. *)
+let add_model struc fn (e, s) =
+ let new_models =
+ try
+ let assgns = StringMap.find fn struc.models in
+ StringMap.add fn (IntMap.add e s assgns) struc.models
+ with Not_found ->
+ StringMap.add fn (IntMap.add e s IntMap.empty) struc.models in
+ { struc with models = new_models }
+
+let add_models st fn ms = List.fold_left (fun s a -> add_model s fn a) st ms
+
+
(* ------------ GLOBAL FUNCTIONS TO CREATE STRUCTURES FROM LISTS ------------ *)
(** Map a function over an array threading an accumulator. *)
@@ -401,10 +423,18 @@
| None -> empty_structure ()
| Some s -> s in
add_from_lists struc els rels funs
-
+
+let circle_structure rx ry =
+ create_from_lists ["e"] [("Circle", None, [[|"e"|]])]
+ [("rx", [("e", rx)]); ("ry", [("e", ry)]);
+ ("x", [("e", 0.)]); ("y", [("e", 0.)])]
+
let create_from_lists_position ?struc els rels =
let s = create_from_lists ?struc els rels [] in
let elems = List.sort (fun x y -> x - y) (Elems.elements s.elements) in
+ let circ = circle_structure (cBOARD_DX /. 3.) (cBOARD_DX /. 3.) in
+ let shapes = List.map (fun e -> (e, circ)) elems in
+ let s = add_models s "shape" shapes in
let zero = List.map (fun e -> (e, 0.)) elems in
let (_, next) = List.fold_left (fun (cur, acc) e ->
(cur +. cBOARD_DX, (e, cur) :: acc)) (0., []) elems in
@@ -414,6 +444,9 @@
let create_from_lists_range start ?struc els rels =
let s = create_from_lists ?struc els rels [] in
let elems = List.sort (fun x y -> x - y) (Elems.elements s.elements) in
+ let circ = circle_structure (1. /. 3.) (1. /. 3.) in
+ let shapes = List.map (fun e -> (e, circ)) elems in
+ let s = add_models s "shape" shapes in
let zero = List.map (fun e -> (e, 0.)) elems in
let (_, nextnbr) = List.fold_left (fun (cur, acc) e ->
(cur +. 1., (e, cur) :: acc)) (start, []) elems in
@@ -1336,6 +1369,7 @@
let col_index =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in
+ let shape = circle_structure (cBOARD_DX /. 3.) (cBOARD_DX /. 3.) in
for r = 1 to r_max do
for c = 1 to c_max do
if List.hd !fields = [] then
@@ -1361,6 +1395,7 @@
if r > 1 && elem <> -1 && board_els.(c-1).(r-2) <> -1 then
struc := add_rel !struc col [|board_els.(c-1).(r-2); elem|];
if elem <> -1 then begin
+ struc := add_model !struc "shape" (elem, shape);
struc := add_fun !struc "x"
(elem, x0 +. dx *. float_of_int (c-1));
struc := add_fun !struc "y"
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Solver/Structure.mli 2012-06-20 21:51:20 UTC (rev 1730)
@@ -98,6 +98,9 @@
(** Return the value of function [f] on [e] in [struc]. *)
val fun_val : structure -> string -> int -> float
+(** Return the model assigned by [f] to [e] in [struc]. *)
+val model_val : structure -> string -> int -> structure
+
(** Return the list of functions. *)
val f_signature : structure -> string list
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-19 21:22:24
|
Revision: 1729
http://toss.svn.sourceforge.net/toss/?rev=1729&view=rev
Author: lukaszkaiser
Date: 2012-06-19 21:22:16 +0000 (Tue, 19 Jun 2012)
Log Message:
-----------
Small update to formula evaluator.
Modified Paths:
--------------
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/Style.css
trunk/Toss/Client/eval.html
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-06-18 22:53:51 UTC (rev 1728)
+++ trunk/Toss/Client/Drawing.ml 2012-06-19 21:22:16 UTC (rev 1729)
@@ -103,7 +103,10 @@
let (x,y) = get_pos struc e in
change_coords coordS coordC {x=x; y=y} in
let draw_rel (rel, arity) =
- if arity = 2 then
+ if arity = 1 then
+ let elems = Structure.Tuples.elements (Structure.rel_graph rel struc) in
+ Aux.concat_map (fun a -> [Circle (pos a.(0), st_c.radius /. 2.)]) elems
+ else if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
Aux.concat_map (fun a -> arrow st_c.radius (pos a.(0)) (pos a.(1))) tuples
else [] in
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-06-18 22:53:51 UTC (rev 1728)
+++ trunk/Toss/Client/JsEval.ml 2012-06-19 21:22:16 UTC (rev 1729)
@@ -68,10 +68,11 @@
let mousedown_handle x y =
let (x, y), struc = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
- let p = Drawing.change_coords !cur_st.Drawing.coordC
- !cur_st.Drawing.coordS {Drawing.x = x; Drawing.y = y} in
- let near e = dist (Drawing.get_pos struc e) (p.Drawing.x, p.Drawing.y) <
- !cur_st.Drawing.radius in
+ let cc e = let (x, y) = Drawing.get_pos struc e in
+ let p = Drawing.change_coords !cur_st.Drawing.coordS
+ !cur_st.Drawing.coordC {Drawing.x = x; Drawing.y = y} in
+ (p.Drawing.x, p.Drawing.y) in
+ let near e = dist (cc e) (x, y) < !cur_st.Drawing.radius in
let near_elems = List.filter near (Structure.elements struc) in
if near_elems = [] then () else (
moving_elem := Some (List.hd near_elems);
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-06-18 22:53:51 UTC (rev 1728)
+++ trunk/Toss/Client/Style.css 2012-06-19 21:22:16 UTC (rev 1729)
@@ -898,6 +898,12 @@
padding: 0px;
}
+#board-left {
+ position: relative;
+ left: 40em;
+ top: -18em;
+}
+
#board {
padding-top: 1em;
min-width: 10em;
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-18 22:53:51 UTC (rev 1728)
+++ trunk/Toss/Client/eval.html 2012-06-19 21:22:16 UTC (rev 1729)
@@ -16,16 +16,18 @@
if (typeof m.data == 'string') {
console.log("" + m.data);
} else {
- console.log ("[ASYNCH] back from " + m.data.fname);
+ //console.log ("[ASYNCH] back from " + m.data.fname);
var handler = worker_handler[m.data.fname];
handler (m.data.result);
}
}
-function ASYNCH (action_name, action_args, cont) {
+function ASYNCH (action_name, action_args, should_log, cont) {
worker_handler[action_name] = cont;
worker.postMessage ({fname: action_name, args: action_args});
- console.log ("[ASYNCH] " + action_name + " (" + action_args + ")");
+ if (should_log) {
+ console.log ("[ASYNCH] " + action_name + " (" + action_args + ")");
+ }
}
function init_canvas () {
@@ -47,17 +49,14 @@
}
function eval_it () {
- var phi = document.getElementById ("formula").value;
- var struc = document.getElementById ("structure").value;
- ASYNCH ("draw_struc", [struc], function (s) {
+ var rels = document.getElementById ("relations").value;
+ var pos = document.getElementById ("positions").value;
+ var elems = document.getElementById ("no-elems").value;
+ var struc = "[ 1 - " + elems + " | | - ] with " + rels + " with " + pos;
+ ASYNCH ("draw_struc", [struc], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
- document.getElementById ("result").innerHTML = "Evaluating...";
- ASYNCH ("eval", [phi, struc], function (resp) {
- var res = document.getElementById ("result");
- res.innerHTML = resp;
- })
}
function canvasCoords (event) { // From stackoverflow.com
@@ -86,7 +85,7 @@
function mouseup_handle (e) {
var pos = canvasCoords (e);
- ASYNCH ("mouseup_handle", [pos.x, pos.y], function (s) {
+ ASYNCH ("mouseup_handle", [pos.x, pos.y], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
@@ -94,7 +93,7 @@
function mousedown_handle (e) {
var pos = canvasCoords (e);
- ASYNCH ("mousedown_handle", [pos.x, pos.y], function (s) {
+ ASYNCH ("mousedown_handle", [pos.x, pos.y], true, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
@@ -102,7 +101,7 @@
function mousemove_handle (e) {
var pos = canvasCoords (e);
- ASYNCH ("mousemove_handle", [pos.x, pos.y], function (s) {
+ ASYNCH ("mousemove_handle", [pos.x, pos.y], false, function (s) {
var ctx = document.getElementById("canvas").getContext("2d");
eval (s);
})
@@ -111,18 +110,19 @@
function handle_elem_click (eid) { console.log (eid); }
function example_primes () {
- document.getElementById ("formula").value = "P(x)";
- document.getElementById ("structure").value = "[ 1 - 10 | | - ] with " +
- "\nP(z) = &z > 1 and all x, y \n (&x * &y = &z -> (&x = 1 or &y = 1))";
+ document.getElementById ("relations").value =
+ "P(z) = &z > 1 and all x, y \n (&x * &y = &z -> (&x = 1 or &y = 1))";
+ document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = 0";
+ document.getElementById ("no-elems").value = "10";
eval_it ();
}
function example_tc () {
- document.getElementById ("formula").value = "S(x, y)";
- document.getElementById ("structure").value =
- "[ 1 - 3 | | - ] with " +
- "\nE(x, y) = &y = &x + 1;" +
- "\nS(x, y) = x != y and tc x, y E(x, y)";
+ document.getElementById ("relations").value =
+ "E(x, y) = &y = &x + 1;\n" +
+ "S(x, y) = x != y and tc x, y E(x, y)";
+ document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = &a*&a";
+ document.getElementById ("no-elems").value = "3";
eval_it ();
}
@@ -152,29 +152,36 @@
</div>
</div>
-<div style="position: relative; top: 4em; left: 1em">
+<div style="position: relative; top: 4em; left: 2em">
-<textarea id="formula" rows="3" cols="40">
-E(x, y)</textarea>
+<p>Relations:</p>
-<textarea id="structure" rows="3" cols="40">
-[ 1 - 15 | | - ] with
+<textarea id="relations" rows="3" cols="40">
E(x, y) = &y = &x + 1
-with :y(a) = 10 * &a * (10 - &a)</textarea>
+</textarea>
-<button onclick="eval_it()">Eval and Draw</button>
+<p>Positions:</p>
-Examples:
+<textarea id="positions" rows="3" cols="40">
+:x(a) = &a;
+:y(a) = 10 * &a * (10 - &a)
+</textarea>
+<p>Elements: <input id="no-elems" type="text" size="4" value="15"></input>
+ <button onclick="eval_it()">Draw</button>
+</p>
+
+<p>Examples:</p>
+
<button onclick="example_primes()">Primes</button>
<button onclick="example_tc()">TC</button>
-<button onclick="example_3col()">3col</button>
+<!-- <button onclick="example_3col()">3col</button> -->
-<p id="result"> </p>
+</div>
-<div id="board">
+<div id="board-left">
<canvas id="canvas" height="1100" width="1100"
onmouseup="mouseup_handle(event)"
onmousedown="mousedown_handle(event)"
@@ -183,7 +190,6 @@
</canvas>
</div>
-</div>
<div id="bottom">
<div id="bottomright">
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-18 22:53:57
|
Revision: 1728
http://toss.svn.sourceforge.net/toss/?rev=1728&view=rev
Author: lukaszkaiser
Date: 2012-06-18 22:53:51 +0000 (Mon, 18 Jun 2012)
Log Message:
-----------
Moving structure elements by mouse.
Modified Paths:
--------------
trunk/Toss/Client/Drawing.ml
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/eval.html
Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml 2012-06-17 23:30:42 UTC (rev 1727)
+++ trunk/Toss/Client/Drawing.ml 2012-06-18 22:53:51 UTC (rev 1728)
@@ -49,16 +49,34 @@
let arr = p -: (d *! 0.5) in
[ Line (q, p); Line (p, rotate p 30. arr); Line (p, rotate p (-30.) arr) ]
-(* Draw the structure [struc] as a sequence of shapes.
+
+(* Structure with coordinates for drawing on canvas. *)
+type structure_with_coords = {
+ struc : Structure.structure ;
+ coordC: point * point ;
+ coordS: point * point ;
+ radius: float ;
+}
+
+let empty_struc_coords () = {
+ struc = Structure.empty_structure ();
+ coordC = {x=0.;y=0.}, {x=0.;y=0.};
+ coordS = {x=0.;y=0.}, {x=0.;y=0.};
+ radius = 0.
+}
+
+(* Get the position of an element. *)
+let get_pos struc e = (* Canvas positions count "from up" on y, thus -1. *)
+ (Structure.fun_val struc "x" e, -1. *. Structure.fun_val struc "y" e)
+
+(* Create a structure with canvas coordinates given canvas sizes, structure.
The first four parameters are the width, height and margins of canvas,
- the third and fourth one are min and max of structure coordinates. *)
-let draw_struc cwidth cheight cmarginx cmarginy minp maxp struc =
+ the third and fourth are (optional) min and max of structure coordinates. *)
+let add_coords cwidth cheight cmarginx cmarginy minp maxp struc =
let elems = Structure.elements struc in
let rad = (* radius for elements *)
min 45. (max 5. (450. /. float (List.length elems))) in
- let get_pos e = (* Canvas positions count "from up" on y, thus -1. *)
- (Structure.fun_val struc "x" e, -1. *. Structure.fun_val struc "y" e) in
- let positions = List.map get_pos elems in
+ let positions = List.map (get_pos struc) elems in
let minp = match minp with Some p -> p | None ->
let (posx, posy) = List.split positions in
{ x = List.fold_left min (List.hd posx) posx;
@@ -71,17 +89,27 @@
let coordC = ({ x= cwidth/.2. +. cmarginx; y= cheight/.2. +. cmarginy},
{ x= cwidth; y= cheight }) in
let coordS = ((maxp +: minp) /: {x = 2.; y = 2.}, diffp) in
- let circ (x, y) = Circle (change_coords coordS coordC {x=x; y=y}, rad) in
+ { struc = struc ; coordC = coordC ; coordS = coordS ; radius = rad }
+
+
+(* Draw the structure with coordinates [st_c] as a sequence of shapes. *)
+let draw_struc st_c =
+ let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
+ let positions = List.map (get_pos struc) (Structure.elements struc) in
+ let circ (x,y)= Circle (change_coords coordS coordC {x=x; y=y},st_c.radius) in
let elem_drawings = List.map circ positions in
(* drawing relations *)
- let pos e = let (x,y) = get_pos e in change_coords coordS coordC {x=x; y=y} in
- let draw_rel (rel, arity) =
+ let pos e =
+ let (x,y) = get_pos struc e in
+ change_coords coordS coordC {x=x; y=y} in
+ let draw_rel (rel, arity) =
if arity = 2 then
let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
- Aux.concat_map (fun a -> arrow rad (pos a.(0)) (pos a.(1))) tuples
+ Aux.concat_map (fun a -> arrow st_c.radius (pos a.(0)) (pos a.(1))) tuples
else [] in
elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
+
(* Compile the shape to a JavaScript program drawing the shape on 'ctx'. *)
let shape_to_canvas = function
| Circle (p, r) ->
@@ -95,4 +123,4 @@
"ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); "
let shapes_to_canvas l =
- Js.string (String.concat " " (List.rev (List.rev_map shape_to_canvas l)))
+ String.concat " " (List.rev (List.rev_map shape_to_canvas l))
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-06-17 23:30:42 UTC (rev 1727)
+++ trunk/Toss/Client/JsEval.ml 2012-06-18 22:53:51 UTC (rev 1728)
@@ -25,6 +25,7 @@
(* --- Main part: communication with JS and evaluation --- *)
+let cur_st = ref (Drawing.empty_struc_coords ())
(* Parse a formula. *)
let formula_of_string s = FormulaParser.parse_formula Lexer.lex
@@ -37,12 +38,7 @@
| Arena.StartStruc struc -> struc
| _ -> failwith "not a structure"
-let draw_struc_js struc_s =
- let st = structure_of_string (Js.to_string struc_s) in
- Drawing.shapes_to_canvas (Drawing.draw_struc 1000. 1000. 50. 50. None None st)
-let _ = set_handle "draw_struc" draw_struc_js
-
(* The Formula evaluation and registration in JS. *)
let js_eval phi struc =
let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
@@ -51,3 +47,55 @@
Js.string (AssignmentSet.named_str struc (Solver.M.evaluate struc f))
let _ = set_handle "eval" js_eval
+
+
+(* Drawing the structure. *)
+let draw_struc_js struc_s =
+ let st = structure_of_string (Js.to_string struc_s) in
+ let st_c = Drawing.add_coords 1000. 1000. 50. 50. None None st in
+ cur_st := st_c;
+ let draw = Drawing.shapes_to_canvas (Drawing.draw_struc st_c) in
+ Js.string ("clear_canvas (); " ^ draw)
+
+let _ = set_handle "draw_struc" draw_struc_js
+
+
+(* Moving elements in the structure drawing. *)
+let moving_elem = ref (Some 0) (* need to set type for compiler *)
+let _ = moving_elem := None
+
+let dist (x1, y1) (x2, y2) = ((x1 -. x2) ** 2. +. (y1 -. y2) ** 2.) ** 0.5
+
+let mousedown_handle x y =
+ let (x, y), struc = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
+ let p = Drawing.change_coords !cur_st.Drawing.coordC
+ !cur_st.Drawing.coordS {Drawing.x = x; Drawing.y = y} in
+ let near e = dist (Drawing.get_pos struc e) (p.Drawing.x, p.Drawing.y) <
+ !cur_st.Drawing.radius in
+ let near_elems = List.filter near (Structure.elements struc) in
+ if near_elems = [] then () else (
+ moving_elem := Some (List.hd near_elems);
+ LOG 0 "moving %i" (List.hd near_elems);
+ );
+ Js.string ""
+
+let mousemove_handle x y =
+ match !moving_elem with
+ | None -> Js.string ""
+ | Some e ->
+ let (x,y), st = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
+ let p = Drawing.change_coords !cur_st.Drawing.coordC
+ !cur_st.Drawing.coordS {Drawing.x = x; Drawing.y = y} in
+ let st = Structure.change_fun_int st "x" e p.Drawing.x in
+ let st = Structure.change_fun_int st "y" e (-1. *. p.Drawing.y) in
+ cur_st := {!cur_st with Drawing.struc = st };
+ let s = Drawing.shapes_to_canvas (Drawing.draw_struc !cur_st) in
+ Js.string ("clear_canvas(); " ^ s)
+
+let mouseup_handle x y =
+ moving_elem := None;
+ Js.string ""
+
+let _ = set_handle "mouseup_handle" mouseup_handle
+let _ = set_handle "mousedown_handle" mousedown_handle
+let _ = set_handle "mousemove_handle" mousemove_handle
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-17 23:30:42 UTC (rev 1727)
+++ trunk/Toss/Client/eval.html 2012-06-18 22:53:51 UTC (rev 1728)
@@ -28,12 +28,9 @@
console.log ("[ASYNCH] " + action_name + " (" + action_args + ")");
}
-function eval_it () {
- var phi = document.getElementById ("formula").value;
- var struc = document.getElementById ("structure").value;
- ASYNCH ("draw_struc", [struc], function (s) {
- canvas = document.getElementById("canvas");
- ctx = canvas.getContext("2d");
+function init_canvas () {
+ var canvas = document.getElementById("canvas");
+ var ctx = canvas.getContext("2d");
ctx.setTransform(1, 0, 0, 1, 0, 0);
ctx.clearRect(0, 0, canvas.width, canvas.height);
ctx.fillStyle = "#ffe4aa";
@@ -41,7 +38,20 @@
ctx.lineWidth = 5;
ctx.lineCap = "round";
ctx.lineJoin = "round";
- eval(s);
+}
+
+function clear_canvas () {
+ var canvas = document.getElementById("canvas");
+ var ctx = canvas.getContext("2d");
+ ctx.clearRect(0, 0, canvas.width, canvas.height);
+}
+
+function eval_it () {
+ var phi = document.getElementById ("formula").value;
+ var struc = document.getElementById ("structure").value;
+ ASYNCH ("draw_struc", [struc], function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
})
document.getElementById ("result").innerHTML = "Evaluating...";
ASYNCH ("eval", [phi, struc], function (resp) {
@@ -50,6 +60,54 @@
})
}
+function canvasCoords (event) { // From stackoverflow.com
+ var totalOffsetX = 0;
+ var totalOffsetY = 0;
+ var canvasX = 0;
+ var canvasY = 0;
+ var canvas = document.getElementById("canvas");
+ var currentElement = canvas;
+
+ do {
+ totalOffsetX += currentElement.offsetLeft;
+ totalOffsetY += currentElement.offsetTop;
+ }
+ while (currentElement = currentElement.offsetParent)
+
+ canvasX = event.pageX - totalOffsetX;
+ canvasY = event.pageY - totalOffsetY;
+
+ // Fix for variable canvas width
+ canvasX = Math.round( canvasX * (canvas.width / canvas.offsetWidth) );
+ canvasY = Math.round( canvasY * (canvas.height / canvas.offsetHeight) );
+
+ return {x:canvasX, y:canvasY}
+}
+
+function mouseup_handle (e) {
+ var pos = canvasCoords (e);
+ ASYNCH ("mouseup_handle", [pos.x, pos.y], function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+}
+
+function mousedown_handle (e) {
+ var pos = canvasCoords (e);
+ ASYNCH ("mousedown_handle", [pos.x, pos.y], function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+}
+
+function mousemove_handle (e) {
+ var pos = canvasCoords (e);
+ ASYNCH ("mousemove_handle", [pos.x, pos.y], function (s) {
+ var ctx = document.getElementById("canvas").getContext("2d");
+ eval (s);
+ })
+}
+
function handle_elem_click (eid) { console.log (eid); }
function example_primes () {
@@ -83,7 +141,7 @@
</script>
</head>
-<body>
+<body onload="init_canvas ()">
<div id="main">
<div id="top">
@@ -117,7 +175,10 @@
<p id="result"> </p>
<div id="board">
-<canvas id="canvas" height="1100" width="1100">
+<canvas id="canvas" height="1100" width="1100"
+ onmouseup="mouseup_handle(event)"
+ onmousedown="mousedown_handle(event)"
+ onmousemove="mousemove_handle(event)">
This text is displayed if your browser does not support HTML5 Canvas.
</canvas>
</div>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-17 23:30:48
|
Revision: 1727
http://toss.svn.sourceforge.net/toss/?rev=1727&view=rev
Author: lukaszkaiser
Date: 2012-06-17 23:30:42 +0000 (Sun, 17 Jun 2012)
Log Message:
-----------
Drawing using HTML canvas in formula evaluator.
Modified Paths:
--------------
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/Style.css
trunk/Toss/Client/eval.html
Added Paths:
-----------
trunk/Toss/Client/Drawing.ml
Added: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml (rev 0)
+++ trunk/Toss/Client/Drawing.ml 2012-06-17 23:30:42 UTC (rev 1727)
@@ -0,0 +1,98 @@
+(* Drawing structures, with compilation to HTML5 canvas through JS. *)
+
+type point = { x : float; y : float }
+
+(* Operations on points. *)
+let add_points p1 p2 = { x = p1.x +. p2.x ; y = p1.y +. p2.y }
+let sub_points p1 p2 = { x = p1.x -. p2.x ; y = p1.y -. p2.y }
+let mul_points p1 p2 = { x = p1.x *. p2.x ; y = p1.y *. p2.y }
+let div_points p1 p2 = { x = p1.x /. p2.x ; y = p1.y /. p2.y }
+let ( +: ) = add_points
+let ( -: ) = sub_points
+let ( *: ) = mul_points
+let ( /: ) = div_points
+let sc_add_point p s = { x = p.x +. s ; y = p.y +. s }
+let sc_sub_point p s = { x = p.x -. s ; y = p.y -. s }
+let sc_mul_point p s = { x = p.x *. s ; y = p.y *. s }
+let sc_div_point p s = { x = p.x /. s ; y = p.y /. s }
+let ( +! ) = sc_add_point
+let ( -! ) = sc_sub_point
+let ( *! ) = sc_mul_point
+let ( /! ) = sc_div_point
+
+
+(* Change coordinates from one system to another (given mid-point and size). *)
+let change_coords (m1, s1) (m2, s2) p = (((p -: m1) /: s1) *: s2) +: m2
+
+(* Distance between two points. *)
+let dist p1 p2 = ((p1.x -. p2.x) ** 2. +. (p1.y -. p2.y) ** 2.) ** 0.5
+
+(* Rotate the point [p] around [start] by [angle]. *)
+let rotate start angle p =
+ let q, a = p -: start, (angle /. 45.) *. (atan 1.0) in
+ let sina, cosa = sin a, cos a in
+ { x = q.x *. cosa -. q.y *. sina ; y = q.x *. sina +. q.y *. cosa } +: start
+
+
+(* Various shapes. *)
+type shapes =
+ | Circle of point * float (* circle, given middle and radius *)
+ | Rectangle of point * point (* rectangle, given middle and width-height *)
+ | Line of point * point (* line, given from and to *)
+
+(* Create an arrow from x to y assuming circle of radius [rad] *)
+let arrow rad x y =
+ let len = dist x y in
+ if len < 0.1 then [] else
+ let d = (y -: x) *! (rad /. len) in
+ let q, p = x +: d, y -: d in
+ let arr = p -: (d *! 0.5) in
+ [ Line (q, p); Line (p, rotate p 30. arr); Line (p, rotate p (-30.) arr) ]
+
+(* Draw the structure [struc] as a sequence of shapes.
+ The first four parameters are the width, height and margins of canvas,
+ the third and fourth one are min and max of structure coordinates. *)
+let draw_struc cwidth cheight cmarginx cmarginy minp maxp struc =
+ let elems = Structure.elements struc in
+ let rad = (* radius for elements *)
+ min 45. (max 5. (450. /. float (List.length elems))) in
+ let get_pos e = (* Canvas positions count "from up" on y, thus -1. *)
+ (Structure.fun_val struc "x" e, -1. *. Structure.fun_val struc "y" e) in
+ let positions = List.map get_pos elems in
+ let minp = match minp with Some p -> p | None ->
+ let (posx, posy) = List.split positions in
+ { x = List.fold_left min (List.hd posx) posx;
+ y = List.fold_left min (List.hd posy) posy } in
+ let maxp = match maxp with Some p -> p | None ->
+ let (posx, posy) = List.split positions in
+ { x = List.fold_left max (List.hd posx) posx;
+ y = List.fold_left max (List.hd posy) posy } in
+ let diffp = { x= max (maxp.x -. minp.x) 1.; y= max (maxp.y -. minp.y) 1. } in
+ let coordC = ({ x= cwidth/.2. +. cmarginx; y= cheight/.2. +. cmarginy},
+ { x= cwidth; y= cheight }) in
+ let coordS = ((maxp +: minp) /: {x = 2.; y = 2.}, diffp) in
+ let circ (x, y) = Circle (change_coords coordS coordC {x=x; y=y}, rad) in
+ let elem_drawings = List.map circ positions in
+ (* drawing relations *)
+ let pos e = let (x,y) = get_pos e in change_coords coordS coordC {x=x; y=y} in
+ let draw_rel (rel, arity) =
+ if arity = 2 then
+ let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
+ Aux.concat_map (fun a -> arrow rad (pos a.(0)) (pos a.(1))) tuples
+ else [] in
+ elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
+
+(* Compile the shape to a JavaScript program drawing the shape on 'ctx'. *)
+let shape_to_canvas = function
+ | Circle (p, r) ->
+ let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r in
+ "ctx.beginPath(); " ^ s ^ "ctx.fill(); ctx.stroke(); "
+ | Rectangle (m, wh) ->
+ Printf.sprintf "ctx.fillRect(%F,%F,%F,%F); " m.x m.y wh.x wh.y
+ | Line (f, t) ->
+ let fs = Printf.sprintf "ctx.moveTo(%F,%F); " f.x f.y in
+ let ts = Printf.sprintf "ctx.lineTo(%F,%F); " t.x t.y in
+ "ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); "
+
+let shapes_to_canvas l =
+ Js.string (String.concat " " (List.rev (List.rev_map shape_to_canvas l)))
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-06-16 17:01:17 UTC (rev 1726)
+++ trunk/Toss/Client/JsEval.ml 2012-06-17 23:30:42 UTC (rev 1727)
@@ -25,47 +25,6 @@
(* --- Main part: communication with JS and evaluation --- *)
-(* Translate a structure into an "info_obj" format used by State.js. *)
-let js_of_struc struc =
- let elems = Structure.elements struc in
- LOG 0 "js_of_struc: preparing structure elements...";
- let get_pos e = Structure.fun_val struc "x" e,Structure.fun_val struc "y" e in
- let minx, maxx, miny, maxy =
- let (posx, posy) = List.split (List.map get_pos elems) in
- let mkfl f l = List.fold_left f (List.hd l) (List.tl l) in
- let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
- minl posx, maxl posx, minl posy, maxl posy in
- (* elems in JS are arrays of element name and position *)
- let elems = Array.of_list (List.map (fun e ->
- let e0 = Js.string (Structure.elem_name struc e) in
- let x, y = get_pos e in
- Js.array [|js_any e0; js_any (Js.float x); js_any (Js.float y)|]
- ) elems) in
- (* rels in JS are arrays of element names, with additional "name" field *)
- let num = Js.number_of_float in
- LOG 0 "js_of_struc: preparing relations...";
- let rels_all =
- (Aux.concat_map
- (fun (rel, _) ->
- let tups = Structure.Tuples.elements
- (Structure.rel_graph rel struc) in
- let tups = List.map
- (fun args -> Js.array
- (Array.map (fun e-> Js.string (Structure.elem_name struc e)) args))
- tups in
- List.map (fun args -> (args, Js.string rel)) tups)
- (Structure.rel_signature struc)) in
- let rels, rel_names = List.split rels_all in
- let info_obj = jsnew js_object () in
- let js = Js.string in
- Js.Unsafe.set info_obj (js"maxx") (num maxx);
- Js.Unsafe.set info_obj (js"minx") (num minx);
- Js.Unsafe.set info_obj (js"maxy") (num maxy);
- Js.Unsafe.set info_obj (js"miny") (num miny);
- Js.Unsafe.set info_obj (js"elems") (Js.array elems);
- Js.Unsafe.set info_obj (js"rels") (Js.array (Array.of_list rels));
- Js.Unsafe.set info_obj (js"rel_names") (Js.array (Array.of_list rel_names));
- info_obj
(* Parse a formula. *)
let formula_of_string s = FormulaParser.parse_formula Lexer.lex
@@ -78,12 +37,12 @@
| Arena.StartStruc struc -> struc
| _ -> failwith "not a structure"
-(* Parse a structure from a JS string and return in "info_obj" format. *)
-let info_obj_of_string s = js_of_struc (structure_of_string (Js.to_string s))
+let draw_struc_js struc_s =
+ let st = structure_of_string (Js.to_string struc_s) in
+ Drawing.shapes_to_canvas (Drawing.draw_struc 1000. 1000. 50. 50. None None st)
-let _ = set_handle "info_obj" info_obj_of_string
+let _ = set_handle "draw_struc" draw_struc_js
-
(* The Formula evaluation and registration in JS. *)
let js_eval phi struc =
let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-06-16 17:01:17 UTC (rev 1726)
+++ trunk/Toss/Client/Style.css 2012-06-17 23:30:42 UTC (rev 1727)
@@ -999,6 +999,11 @@
border: 1px solid #260314;
}
+#canvas {
+ width: 30em;
+ height: 30em;
+ border: 2px solid #260314;
+}
/* SVG styling */
#svg {
Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html 2012-06-16 17:01:17 UTC (rev 1726)
+++ trunk/Toss/Client/eval.html 2012-06-17 23:30:42 UTC (rev 1727)
@@ -1,5 +1,5 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xmlns:svg="http://www.w3.org/2000/svg" xml:lang="en" lang="en">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>Toss Formula Evaluator</title>
@@ -7,7 +7,6 @@
<meta http-equiv="X-UA-Compatible" content="chrome=1" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
- <script type="text/javascript" src="State.js"> </script>
<script type="text/javascript">
<!--
var worker = new Worker ("JsEval.js");
@@ -29,12 +28,20 @@
console.log ("[ASYNCH] " + action_name + " (" + action_args + ")");
}
-function eval () {
+function eval_it () {
var phi = document.getElementById ("formula").value;
var struc = document.getElementById ("structure").value;
- ASYNCH ("info_obj", [struc], function (obj) {
- var struc = new State ("nogame", obj, 0);
- struc.draw_model ("nogame");
+ ASYNCH ("draw_struc", [struc], function (s) {
+ canvas = document.getElementById("canvas");
+ ctx = canvas.getContext("2d");
+ ctx.setTransform(1, 0, 0, 1, 0, 0);
+ ctx.clearRect(0, 0, canvas.width, canvas.height);
+ ctx.fillStyle = "#ffe4aa";
+ ctx.strokeStyle = "#260314";
+ ctx.lineWidth = 5;
+ ctx.lineCap = "round";
+ ctx.lineJoin = "round";
+ eval(s);
})
document.getElementById ("result").innerHTML = "Evaluating...";
ASYNCH ("eval", [phi, struc], function (resp) {
@@ -49,7 +56,7 @@
document.getElementById ("formula").value = "P(x)";
document.getElementById ("structure").value = "[ 1 - 10 | | - ] with " +
"\nP(z) = &z > 1 and all x, y \n (&x * &y = &z -> (&x = 1 or &y = 1))";
- eval ();
+ eval_it ();
}
function example_tc () {
@@ -58,7 +65,7 @@
"[ 1 - 3 | | - ] with " +
"\nE(x, y) = &y = &x + 1;" +
"\nS(x, y) = x != y and tc x, y E(x, y)";
- eval ();
+ eval_it ();
}
function example_3col () {
@@ -70,7 +77,7 @@
"[ | E { (a, b); (b, c); (c, a) } | " +
"\n x { a -> 1, b -> 2, c -> 3 }; " +
"\n y { a -> 0, b -> -1, c -> 0 } ]";
- eval ();
+ eval_it ();
}
//-->
</script>
@@ -93,11 +100,11 @@
E(x, y)</textarea>
<textarea id="structure" rows="3" cols="40">
-[ 1 - 5 | | - ] with
-E(x, y) = &x = &y + 1
-with :y(a) = -10 * &a</textarea>
+[ 1 - 15 | | - ] with
+E(x, y) = &y = &x + 1
+with :y(a) = 10 * &a * (10 - &a)</textarea>
-<button onclick="eval()">Eval and Draw</button>
+<button onclick="eval_it()">Eval and Draw</button>
Examples:
@@ -109,9 +116,14 @@
<p id="result"> </p>
-<div id="board"> </div>
+<div id="board">
+<canvas id="canvas" height="1100" width="1100">
+This text is displayed if your browser does not support HTML5 Canvas.
+</canvas>
</div>
+</div>
+
<div id="bottom">
<div id="bottomright">
<a href="http://toss.sourceforge.net" id="toss-link">Contact</a>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-16 17:01:27
|
Revision: 1726
http://toss.svn.sourceforge.net/toss/?rev=1726&view=rev
Author: lukaszkaiser
Date: 2012-06-16 17:01:17 +0000 (Sat, 16 Jun 2012)
Log Message:
-----------
Merging TermType and Term, rest of old Term are now in Coding.
Modified Paths:
--------------
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/BuiltinLang.mli
trunk/Toss/Term/BuiltinLangTest.ml
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArc.mli
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/RewritingTest.ml
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDef.mli
trunk/Toss/Term/SyntaxDefTest.ml
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/TRSTest.ml
Added Paths:
-----------
trunk/Toss/Term/Coding.ml
trunk/Toss/Term/Coding.mli
trunk/Toss/Term/CodingTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermTest.ml
Removed Paths:
-------------
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermTest.ml
trunk/Toss/Term/TermType.ml
trunk/Toss/Term/TermType.mli
trunk/Toss/Term/TermTypeTest.ml
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Server/Tests.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -14,10 +14,10 @@
]
let term_tests = "Term", [
- "TermTypeTest", [TermTypeTest.tests];
+ "TermTest", [TermTest.tests];
"SyntaxDefTest", [SyntaxDefTest.tests];
"BuiltinLangTest", [BuiltinLangTest.tests];
- "TermTest", [TermTest.tests];
+ "CodingTest", [CodingTest.tests];
"RewritingTest", [RewritingTest.tests];
"ParseArcTest", [ParseArcTest.tests];
"TRSTest", [TRSTest.tests; TRSTest.bigtests];
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Solver/Structure.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -529,17 +529,17 @@
let trs_set_struc s = function
| ("addrel", te_rel, te_arglist) ->
- let rname = Term.decode_string te_rel in
- let args = Term.decode_list Term.term_to_string te_arglist in
+ let rname = Coding.decode_string te_rel in
+ let args = Coding.decode_list Coding.term_to_string te_arglist in
let (struc, args) = List.fold_left (fun (st, a) e ->
let (s1, i) = find_or_new_elem st e in (s1, i :: a)) (s, []) args in
add_rel struc rname (Array.of_list (List.rev args))
| (str, te, arg) when String.length str > 3 && String.sub str 0 3 = "fun" ->
let fname = String.sub str 3 ((String.length str) - 3) in
- let (struc, i) = find_or_new_elem s (Term.term_to_string te) in
- let v = Term.decode_bit_list arg in
+ let (struc, i) = find_or_new_elem s (Coding.term_to_string te) in
+ let v = Coding.decode_bit_list arg in
add_fun struc fname (i, float v)
- | _-> raise (Term.DECODE "Structure.trs_set_struc not a structure update set")
+ | _-> raise (Coding.DECODE "Structure.trs_set_struc not a struc update set")
let struc_from_trs str =
let (o, trs, _) = TRS.run_shell_str str in
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -1,6 +1,6 @@
(* Basic Built-in TRS Language Syntax. *)
-open TermType
+open Term
open SyntaxDef
@@ -29,12 +29,12 @@
let list_sd = SDtype [Tp term_type_tp; Str "list"]
let list_name = name_of_sd list_sd
-let list_tp t = TTerm (list_name, [|t|])
-let list_tp_a = list_tp (TVar ("a", [||], 0, [||]))
+let list_tp t = Term (list_name, [||], [|t|])
+let list_tp_a = list_tp (Var ("a", [||], 0, [||]))
let list_nil_sd = SDfun ([Str "["; Str "]"], list_tp_a)
let list_nil_name = name_of_sd list_nil_sd
-let list_cons_sd = SDfun ([Tp (TVar ("a",[||],0,[||])); Str ","; Tp list_tp_a],
+let list_cons_sd = SDfun ([Tp (Var ("a",[||],0,[||])); Str ","; Tp list_tp_a],
list_tp_a)
let list_cons_name = name_of_sd list_cons_sd
@@ -147,8 +147,8 @@
let input_rewrite_rule_name = name_of_sd input_rewrite_rule_sd
let input_rewrite_rule_tp = type_of_sd input_rewrite_rule_sd
-let let_be_sd = SDfun ([Str "let"; Tp (TVar ("a_1",[||],0,[||])); Str "be";
- Tp (TVar ("a_1",[||],0,[||]))], input_rewrite_rule_tp)
+let let_be_sd = SDfun ([Str "let"; Tp (Var ("a_1",[||],0,[||])); Str "be";
+ Tp (Var ("a_1",[||],0,[||]))], input_rewrite_rule_tp)
let let_be_name = name_of_sd let_be_sd
let priority_input_rewrite_rule_sd = SDtype ([Str "priority";
@@ -159,8 +159,8 @@
type_of_sd priority_input_rewrite_rule_sd
let let_major_be_sd =
- SDfun ([Str "let"; Str "major"; Tp (TVar ("a_1",[||],0,[||])); Str "be";
- Tp (TVar ("a_1",[||],0,[||]))], priority_input_rewrite_rule_tp)
+ SDfun ([Str "let"; Str "major"; Tp (Var ("a_1",[||],0,[||])); Str "be";
+ Tp (Var ("a_1",[||],0,[||]))], priority_input_rewrite_rule_tp)
let let_major_be_name = name_of_sd let_major_be_sd
let fun_definition_sd = SDtype ([Str "fun"; Str "definition"])
@@ -185,44 +185,44 @@
let exception_cl_sd = SDtype [Tp term_type_tp; Str "exception"]
let exception_cl_name = name_of_sd exception_cl_sd
-let exception_cl_tp t = TTerm (exception_cl_name, [|t|])
+let exception_cl_tp t = Term (exception_cl_name, [||], [|t|])
let exception_sd =
- SDfun ([Str "!"; Str "!"; Tp (TVar ("a",[||],0,[||])); Str "!";Str "!";],
- exception_cl_tp (TVar ("other_than_a!",[||],0,[||])))
+ SDfun ([Str "!"; Str "!"; Tp (Var ("a",[||],0,[||])); Str "!";Str "!";],
+ exception_cl_tp (Var ("other_than_a!",[||],0,[||])))
let exception_name = name_of_sd exception_sd
let exn_ok_sd =
- SDfun ([Str "+"; Str "+"; Tp (TVar ("a",[||],0,[||])); Str "+";Str "+";],
- exception_cl_tp (TVar ("a",[||],0,[||]))) (* Here it should be a! *)
+ SDfun ([Str "+"; Str "+"; Tp (Var ("a",[||],0,[||])); Str "+";Str "+";],
+ exception_cl_tp (Var ("a",[||],0,[||]))) (* Here it should be a! *)
let exn_ok_name = name_of_sd exception_sd
(* --- Special functions recognized during Normalisation --- *)
-let brackets_sd = SDfun ([Str "("; Tp (TVar ("b",[||],0,[||])); Str ")"],
- TVar ("b",[||],0,[||]))
+let brackets_sd = SDfun ([Str "("; Tp (Var ("b",[||],0,[||])); Str ")"],
+ Var ("b",[||],0,[||]))
let brackets_name = name_of_sd brackets_sd
-let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (TVar ("b",[||],0,[||]));
- Str "|"; Str ">"], TVar ("b",[||],0,[||]))
+let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (Var ("b",[||],0,[||]));
+ Str "|"; Str ">"], Var ("b",[||],0,[||]))
let verbatim_name = name_of_sd verbatim_sd
let if_then_else_sd = SDfun ([Str "if"; Tp boolean_tp; Str "then";
- Tp (TVar ("a",[||],0,[||])); Str "else";
- Tp (TVar ("a",[||],0,[||]))], TVar ("a",[||],0,[||]))
+ Tp (Var ("a",[||],0,[||])); Str "else";
+ Tp (Var ("a",[||],0,[||]))], Var ("a",[||],0,[||]))
let if_then_else_name = name_of_sd if_then_else_sd
-let eq_bool_sd = SDfun ([Tp (TVar ("a",[||],0,[||])); Str "=";
- Tp (TVar ("a",[||],0,[||]))], boolean_tp)
+let eq_bool_sd = SDfun ([Tp (Var ("a",[||],0,[||])); Str "=";
+ Tp (Var ("a",[||],0,[||]))], boolean_tp)
let eq_bool_name = name_of_sd eq_bool_sd
(* --- Syntax Definitions for special meta-functions --- *)
-let code_as_term_sd = SDfun ([Str "code"; Tp (TVar ("a",[||],0,[||]));
+let code_as_term_sd = SDfun ([Str "code"; Tp (Var ("a",[||],0,[||]));
Str "as"; Str "term"], term_tp)
let code_as_term_name = name_of_sd code_as_term_sd
@@ -278,13 +278,13 @@
let set_command_tp = type_of_sd set_command_sd
let set_prop_sd = SDfun ([Str "set"; Tp (string_tp); Str "of";
- Tp (TVar ("a",[||],0,[||])); Str "to";
- Tp (TVar ("b",[||],0,[||]))], set_command_tp)
+ Tp (Var ("a",[||],0,[||])); Str "to";
+ Tp (Var ("b",[||],0,[||]))], set_command_tp)
let set_prop_name = name_of_sd set_prop_sd
let preprocess_sd = SDfun ([Str "#"; Str "#"; Str "#";
- Tp (TVar ("p",[||],0,[||]))], TVar ("q",[||],0,[||]))
+ Tp (Var ("p",[||],0,[||]))], Var ("q",[||],0,[||]))
let preprocess_name = name_of_sd preprocess_sd
Modified: trunk/Toss/Term/BuiltinLang.mli
===================================================================
--- trunk/Toss/Term/BuiltinLang.mli 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/BuiltinLang.mli 2012-06-16 17:01:17 UTC (rev 1726)
@@ -7,7 +7,7 @@
val bit_sd : syntax_def
val bit_name : string
-val bit_tp : TermType.term_type
+val bit_tp : Term.term
val bit_0_cons_sd : syntax_def
val bit_0_cons_name : string
val bit_1_cons_sd : syntax_def
@@ -15,18 +15,18 @@
val char_sd : syntax_def
val char_name : string
-val char_tp : TermType.term_type
+val char_tp : Term.term
val char_cons_sd : syntax_def
val char_cons_name : string
val term_type_sd : syntax_def
val term_type_name : string
-val term_type_tp : TermType.term_type
+val term_type_tp : Term.term
val list_sd : syntax_def
val list_name : string
-val list_tp : TermType.term_type -> TermType.term_type
-val list_tp_a : TermType.term_type
+val list_tp : Term.term -> Term.term
+val list_tp_a : Term.term
val list_nil_sd : syntax_def
val list_nil_name : string
val list_cons_sd : syntax_def
@@ -34,13 +34,13 @@
val string_sd : syntax_def
val string_name : string
-val string_tp : TermType.term_type
+val string_tp : Term.term
val string_cons_sd : syntax_def
val string_cons_name : string
val boolean_sd : syntax_def
val boolean_name : string
-val boolean_tp : TermType.term_type
+val boolean_tp : Term.term
val boolean_true_sd : syntax_def
val boolean_true_name : string
val boolean_false_sd : syntax_def
@@ -48,7 +48,7 @@
val ternary_truth_value_sd : syntax_def
val ternary_truth_value_name : string
-val ternary_truth_value_tp : TermType.term_type
+val ternary_truth_value_tp : Term.term
val ternary_true_sd : syntax_def
val ternary_true_name : string
val ternary_unknown_sd : syntax_def
@@ -65,21 +65,21 @@
val syntax_element_sd : syntax_def
val syntax_element_name : string
-val syntax_element_tp : TermType.term_type
+val syntax_element_tp : Term.term
val syntax_element_str_sd : syntax_def
val syntax_element_str_name : string
val syntax_element_tp_sd : syntax_def
val syntax_element_tp_name : string
val syntax_element_list_sd : syntax_def
val syntax_element_list_name : string
-val syntax_element_list_tp : TermType.term_type
+val syntax_element_list_tp : Term.term
val syntax_element_list_elem_sd : syntax_def
val syntax_element_list_elem_name : string
val syntax_element_list_cons_sd : syntax_def
val syntax_element_list_cons_name : string
val syntax_definition_sd : syntax_def
val syntax_definition_name : string
-val syntax_definition_tp : TermType.term_type
+val syntax_definition_tp : Term.term
val syntax_definition_type_sd : syntax_def
val syntax_definition_type_name : string
val syntax_definition_fun_sd : syntax_def
@@ -92,34 +92,34 @@
val term_sd : syntax_def
val term_name : string
-val term_tp : TermType.term_type
+val term_tp : Term.term
val term_var_cons_sd : syntax_def
val term_var_cons_name : string
val term_term_cons_sd : syntax_def
val term_term_cons_name : string
val rewrite_rule_sd : syntax_def
val rewrite_rule_name : string
-val rewrite_rule_tp : TermType.term_type
+val rewrite_rule_tp : Term.term
val rewrite_rule_cons_sd : syntax_def
val rewrite_rule_cons_name : string
val input_rewrite_rule_sd : syntax_def
val input_rewrite_rule_name : string
-val input_rewrite_rule_tp : TermType.term_type
+val input_rewrite_rule_tp : Term.term
val let_be_sd : syntax_def
val let_be_name : string
val priority_input_rewrite_rule_sd : syntax_def
val priority_input_rewrite_rule_name : string
-val priority_input_rewrite_rule_tp : TermType.term_type
+val priority_input_rewrite_rule_tp : Term.term
val let_major_be_sd : syntax_def
val let_major_be_name : string
val fun_definition_sd : syntax_def
val fun_definition_name : string
-val fun_definition_tp : TermType.term_type
+val fun_definition_tp : Term.term
val fun_definition_cons_sd : syntax_def
val fun_definition_cons_name : string
val type_definition_sd : syntax_def
val type_definition_name : string
-val type_definition_tp : TermType.term_type
+val type_definition_tp : Term.term
val type_of_sd_sd : syntax_def
val type_of_name : string
@@ -165,7 +165,7 @@
val outside_paths_sd : syntax_def
val outside_paths_name : string
-val outside_paths_tp : TermType.term_type
+val outside_paths_tp : Term.term
val path_library_sd : syntax_def
val path_library_name : string
@@ -175,26 +175,20 @@
val load_command_sd : syntax_def
val load_command_name : string
-val load_command_tp : TermType.term_type
+val load_command_tp : Term.term
val load_file_sd : syntax_def
val load_file_name : string
val sys_commands_sd : syntax_def
val sys_commands_name : string
-val sys_commands_tp : TermType.term_type
+val sys_commands_tp : Term.term
val close_context_sd : syntax_def
val close_context_name : string
-(*val remove_command_sd : syntax_def
-val remove_command_name : string
-val remove_command_tp : TermType.term_type
-val system_remove_sd : syntax_def
-val system_remove_name : string*)
-
val set_command_sd : syntax_def
val set_command_name : string
-val set_command_tp : TermType.term_type
+val set_command_tp : Term.term
val set_prop_sd : syntax_def
val set_prop_name : string
Modified: trunk/Toss/Term/BuiltinLangTest.ml
===================================================================
--- trunk/Toss/Term/BuiltinLangTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/BuiltinLangTest.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -1,12 +1,12 @@
open OUnit
-open TermType
+open Term
open BuiltinLang
let tests = "BuiltinLang" >::: [
"type names" >::
(fun () ->
let test_type_name res tp =
- assert_equal ~printer:(fun x -> x) res (TermType.type_to_string tp) in
+ assert_equal ~printer:(fun x -> x) res (Term.type_to_string tp) in
test_type_name "T\\?_list (@? a)" list_tp_a;
test_type_name "Tbit" bit_tp;
test_type_name "Tchar" char_tp;
Copied: trunk/Toss/Term/Coding.ml (from rev 1725, trunk/Toss/Term/Term.ml)
===================================================================
--- trunk/Toss/Term/Coding.ml (rev 0)
+++ trunk/Toss/Term/Coding.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -0,0 +1,502 @@
+(* Contains the type of typed terms, functions calculating type and
+ reconstruction for a term and printing and parsing for terms. *)
+
+open Array
+open Aux
+
+open Term
+open SyntaxDef
+open BuiltinLang
+
+
+(* --- Coding basic things as Terms --- *)
+
+exception DECODE of string
+exception CODE of string
+
+let rec code_list f = function
+ | [] -> Term (list_nil_name, [||], [||])
+ | x :: xs -> Term (list_cons_name, [||], [|f (x); code_list f xs|])
+
+
+let rec decode_list f = function
+ | Term (n, _, [||]) when n = list_nil_name -> []
+ | Term (n, _, [|x; xs|]) when n = list_cons_name -> (f x):: (decode_list f xs)
+ | _ -> raise (DECODE "list")
+
+
+let decode_list_opt f l = try Some (decode_list f l) with DECODE _ -> None
+
+let rec int_to_bits = function
+ | 0 -> [0]
+ | 1 -> [1]
+ | i -> if i mod 2 = 0 then 0 :: int_to_bits (i/2) else 1 :: int_to_bits (i/2)
+
+
+let bits_to_int i =
+ let rec bits_to_int_rec start = function
+ | [] -> 0
+ | x :: xs -> x * start + bits_to_int_rec (2*start) xs in
+ bits_to_int_rec 1 i
+
+
+let code_bit = function
+ | 0 -> Term (bit_0_cons_name, [||], [||])
+ | 1 -> Term (bit_1_cons_name, [||], [||])
+ | _ -> failwith "not bit while coding bit"
+
+
+let decode_bit = function
+ | Term (n, _, [||]) when n = bit_0_cons_name -> 0
+ | Term (n, _, [||]) when n = bit_1_cons_name -> 1
+ | _ -> raise (DECODE "bit")
+
+let decode_bit_list bl = bits_to_int (decode_list decode_bit bl)
+
+let code_char c =
+ let bits = int_to_bits (Char.code c) in
+ let rec zeros i = if i <= 0 then [] else 0 :: zeros (i-1) in
+ let eight_bits = bits @ zeros (8 - List.length bits) in
+ Term (char_cons_name, [||], of_list (List.map code_bit eight_bits))
+
+let decode_char = function
+ | Term (n, _, bits) when n = char_cons_name ->
+ Char.chr (bits_to_int (to_list (map decode_bit bits)))
+ | _ -> raise (DECODE "char")
+
+let code_string s =
+ let rec char_list i = if i < 0 then [] else s.[i] :: char_list (i-1) in
+ let chars = List.rev (char_list ((String.length s) - 1)) in
+ let char_term = code_list code_char chars in
+ Term (string_cons_name, [||], [|char_term|])
+
+
+let decode_string t =
+ let rec string_of_list_i s i = function
+ | [] -> s
+ | x :: xs -> (s.[i] <- x; string_of_list_i s (i+1) xs) in
+ let string_of_list l = string_of_list_i (String.create (List.length l)) 0 l in
+ match t with
+ | Term (n, _, [|c|]) when n = string_cons_name ->
+ string_of_list (decode_list decode_char c)
+ | _ -> raise (DECODE "string")
+
+
+let decode_string_opt t = try Some (decode_string t) with DECODE _ -> None
+
+
+let code_bool = function
+ | true -> Term (boolean_true_name, [||], [||])
+ | false -> Term (boolean_false_name, [||], [||])
+
+
+let decode_bool = function
+ | Term (n, _, [||]) when n = boolean_true_name -> true
+ | Term (n, _, [||]) when n = boolean_false_name -> false
+ | _ -> raise (DECODE "bool")
+
+
+let rec code_term_type = function
+ | Var (name, [||], 0, [||])->
+ Term (term_type_var_name, [||], [|code_string name|])
+ | Var _ -> failwith "code_term_type: non-type variable"
+ | Term (name, [||], arr) when name = Term.fun_type_name ->
+ let l = Array.length arr in
+ let (args_types, return_type) = (Array.sub arr 0 (l-1), arr.(l-1)) in
+ Term (term_type_fun_name, [||], [|
+ code_list code_term_type (to_list args_types);
+ code_term_type return_type|])
+ | Term (name, [||], args) ->
+ Term (term_type_cons_name, [||], [|
+ code_string name;
+ code_list code_term_type (to_list args)|])
+ | Term _ -> failwith "code_term_type: non-type term"
+
+
+let rec decode_term_type = function
+ | Term (s, _, [|coded_name|]) when s = term_type_var_name ->
+ Var (decode_string coded_name, [||], 0, [||])
+ | Term (s, _, [|coded_1; coded_2|]) when s = term_type_fun_name ->
+ Term (Term.fun_type_name, [||], of_list (
+ (decode_list decode_term_type coded_1) @ [decode_term_type coded_2]))
+ | Term (s, _, [|coded_1; coded_2|]) when s = term_type_cons_name ->
+ Term (decode_string coded_1, [||],
+ of_list (decode_list decode_term_type coded_2))
+ | _ -> raise (DECODE "term_type")
+
+
+let decode_term_type_opt t =
+ try Some (decode_term_type t) with DECODE _ -> None
+
+
+let rec code_term = function
+ | Var (name, var_types, deg, args) ->
+ Term (term_var_cons_name, [||],
+ [|code_string name;
+ code_term_type var_types.(0);
+ code_list code_bit (int_to_bits deg);
+ code_list code_term (to_list args)|])
+ | Term (name, _, args) ->
+ Term (term_term_cons_name, [||], [|code_string name;
+ code_list code_term (to_list args)|])
+
+
+let rec code_term_incr_vars = function
+ | Var (name, var_type, deg, args) ->
+ Var (name, var_type, deg+1, map code_term_incr_vars args)
+ | Term (name, _, args) ->
+ Term (term_term_cons_name, [||], [|
+ code_string name; code_list code_term_incr_vars (to_list args)|])
+
+
+let rec decode_term = function
+ | Term (s, _, [|coded_name; coded_type; coded_deg; coded_args|])
+ when s = term_var_cons_name ->
+ Var (decode_string coded_name,
+ [|decode_term_type coded_type|],
+ bits_to_int (decode_list decode_bit coded_deg),
+ of_list (decode_list decode_term coded_args))
+ | Term (s, _, [|coded_name; coded_args|])
+ when s = term_term_cons_name ->
+ Term (decode_string coded_name, [||],
+ of_list (decode_list decode_term coded_args))
+ | _ -> raise (DECODE "term")
+
+
+let decode_term_opt t = try Some (decode_term t) with DECODE _ -> None
+
+
+type rewrite_rule = term * term
+
+
+let code_rewrite_rule (left, right) =
+ Term (rewrite_rule_cons_name, [||], [|code_term left; code_term right|])
+
+
+let decode_rewrite_rule = function
+ | Term (n, _, [|left; right|]) when n = rewrite_rule_cons_name ->
+ (decode_term left, decode_term right)
+ | _ -> raise (DECODE "rewrite rule")
+
+
+let code_input_rewrite_rule (left, right) =
+ Term (let_be_name, [||], [|left; right|])
+
+
+let decode_input_rewrite_rule = function
+ | Term (n, _, [|left; right|]) when n = let_be_name -> (left, right)
+ | _ -> raise (DECODE "input rewrite rule")
+
+
+let code_priority_input_rewrite_rule (left, right) =
+ Term (let_major_be_name, [||], [|left; right|])
+
+
+let decode_priority_input_rewrite_rule = function
+ | Term (n, [||], [|left; right|]) when n = let_major_be_name -> (left, right)
+ | _ -> raise (DECODE "priority input rewrite rule")
+
+
+type fun_definition = string * Term.term list * Term.term
+
+let code_fun_definition (name, args_types, return_type) =
+ Term (fun_definition_cons_name, [||], [|
+ code_string name;
+ code_list code_term_type args_types;
+ code_term_type return_type|])
+
+
+let decode_fun_definition = function
+ | Term (n, _, [|name; args; ret|]) when n = fun_definition_cons_name ->
+ (decode_string name, decode_list decode_term_type args,
+ decode_term_type ret)
+ | _ -> raise (DECODE "function definition")
+
+
+type type_definition = string * int
+
+let code_type_definition (name, arity) =
+ let rec var = function
+ | 0 -> []
+ | i -> Var ("a_" ^ (string_of_int i), [||], 0, [||]) :: (var (i-1)) in
+ Term (type_of_name, [||],
+ [|code_term_type (Term (name, [||], of_list (var arity)))|])
+
+
+let decode_type_definition = function
+ | Term (n, _, [|ty|]) when n = type_of_name ->
+ (match (decode_term_type ty) with
+ | Term (name, [||], args) -> (name, Array.length args)
+ | _ -> raise (DECODE "type definition 1")
+ )
+ | _ -> raise (DECODE "type definition 2")
+
+
+let code_syntax_element = function
+ | Str s -> Term (syntax_element_str_name, [||], [|code_string s|])
+ | Tp tt -> Term (syntax_element_tp_name, [||], [|code_term_type tt|])
+
+
+let decode_syntax_element = function
+ | Term (s, _, [|strt|]) when s = syntax_element_str_name ->
+ Str (decode_string strt)
+ | Term (s, _, [|tt|]) when s = syntax_element_tp_name ->
+ Tp (decode_term_type tt)
+ | _ -> raise (DECODE "syntax element")
+
+
+let rec code_syntax_element_list = function
+ | [se] -> Term (syntax_element_list_elem_name, [||],
+ [|code_syntax_element se|])
+ | se :: ses -> Term (syntax_element_list_cons_name, [||],
+ [|code_syntax_element se; code_syntax_element_list ses|])
+ | [] -> raise (CODE "syntax element list")
+
+
+let rec decode_syntax_element_list = function
+ | Term (name, _, [|coded_se|]) when name = syntax_element_list_elem_name ->
+ [decode_syntax_element coded_se]
+ | Term (name, _, [|coded_se; coded_ses|])
+ when name = syntax_element_list_cons_name ->
+ (decode_syntax_element coded_se) :: (decode_syntax_element_list coded_ses)
+ | _ -> raise (DECODE "syntax element list")
+
+
+let code_syntax_definition = function
+ | SDtype se ->
+ Term (syntax_definition_type_name, [||], [|code_syntax_element_list se|])
+ | SDfun (se, res_ty) ->
+ Term (syntax_definition_fun_name, [||],
+ [|code_syntax_element_list se; code_term_type res_ty|])
+ | SDvar (se, res_ty) ->
+ Term (syntax_definition_var_name, [||],
+ [|code_syntax_element_list se; code_term_type res_ty|])
+
+
+let decode_syntax_definition = function
+ | Term (str, _, [|t1|]) when str = syntax_definition_type_name ->
+ SDtype (decode_syntax_element_list t1)
+ | Term (str, _, [|t1; t2|]) ->
+ let se = decode_syntax_element_list t1 in
+ let res_ty = decode_term_type t2 in
+ if str = syntax_definition_fun_name then SDfun (se, res_ty) else
+ if str = syntax_definition_var_name then SDvar (se, res_ty) else
+ raise (DECODE "syntax definition 1")
+ | _ -> raise (DECODE "syntax definition 2")
+
+
+
+(* --- Term matching and substitutions --- *)
+
+let rec matches dict = function
+ | (Term (n1, _, a1), Term (n2, _, a2)) when n1=n2 && (length a1 = length a2)->
+ Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
+ | (Var (n1, _, d1, a1), Var (n2, _, d2, a2))
+ when n1 = n2 && d1 = d2 && length a1 = length a2 ->
+ Aux.array_for_all2 (fun u v -> matches dict (u, v)) a1 a2
+ | (Var (n1, _, d1, [||]), te) ->
+ (try
+ let arg = List.assoc n1 (!dict) in
+ let coded_arg = fn_apply d1 code_term arg in
+ te = coded_arg
+ with Not_found ->
+ let decoded_te = fn_apply d1 decode_term te in
+ (dict := (n1, decoded_te) :: (!dict); true)
+ )
+ | _ -> false
+
+
+(* Application of term substitutions (only flat functional substitutes). *)
+let rec apply_s substs = function
+ | Var (n, _, d, [||]) as t ->
+ (try (fn_apply d code_term (List.assoc n substs)) with Not_found -> t)
+ | Term (n, tp, a) -> Term (n, tp, map (apply_s substs) a)
+ | Var (n, t, deg, a) ->
+ try (
+ let raw_result =
+ match (List.assoc n substs) with
+ | Term (name, [||], [||]) ->
+ Term (name, [||], map (apply_s substs) a)
+ | Var (name, ty, d, [||]) ->
+ Var (name, ty, d, map (apply_s substs) a)
+ | _ -> failwith "functional substitution of non-flat term" in
+ fn_apply deg code_term raw_result
+ )
+ with Not_found -> Var (n, t, deg, map (apply_s substs) a)
+
+
+(* --- Nice Term display based on Syntax Definitions --- *)
+
+let is_some = function Some _ -> true | None -> false
+
+let rec display_term = function
+ | te when is_some (decode_string_opt te) ->
+ "\"" ^ (decode_string te) ^ "\""
+ | te when is_some (decode_list_opt (fun x -> x) te) ->
+ let str_list = List.map display_term (decode_list (fun x -> x) te) in
+ "["^ (String.concat ", " str_list) ^ "]"
+ | Term (n, _, a) ->
+ let args = List.map display_term (Array.to_list a) in
+ display_sd (split_sdef_name n) args
+ | Var (n, _, _, a) ->
+ let args = List.map display_term (Array.to_list a) in
+ display_sd (split_sdef_name n) args
+
+
+(* --- Display terms and types as XML --- *)
+
+let rec display_type_xml = function
+ | Var (n, [||], 0, [||]) ->
+ "<type_var>" ^ (make_xml_compatible n) ^ "</type_var>"
+ | Var _ -> failwith "display_type_xml: non-type variable"
+ | Term (n, _, a) ->
+ "<type class=\"" ^ (make_xml_compatible n) ^ "\">\n" ^
+ (String.concat "\n" (List.map display_type_xml (to_list a))) ^
+ "\n</type>"
+
+let rec display_term_xml = function
+ | te when is_some (decode_string_opt te) ->
+ "<term-string>" ^ (make_xml_compatible (decode_string te)) ^
+ "</term-string>"
+ | te when is_some (decode_list_opt (fun x -> x) te) ->
+ let str_list = List.map display_term_xml (decode_list (fun x -> x) te) in
+ "<term-list>"^ (String.concat " " str_list) ^ "</term-list>"
+ | Term (n, _, a) ->
+ "<term class=\"" ^ (make_xml_compatible n) ^ "\">\n" ^
+ (String.concat "\n" (List.map display_term_xml (to_list a))) ^
+ "\n</term>"
+ | Var (n, ty, deg, a) ->
+ "<term-variable class=\"" ^ (make_xml_compatible n) ^
+ "\" deg=\"" ^ (string_of_int deg) ^ "\">" ^
+ (String.concat "" (List.map display_term_xml (to_list a))) ^
+ "<term-variable-type>"^(display_type_xml ty.(0))^"</term-variable-type>" ^
+ "</term-variable>"
+
+
+
+(* --- Term parsing and printing --- *)
+
+(* Printing terms. *)
+let rec term_to_string term =
+ let term_array_to_string ta =
+ String.concat ", " (to_list (map term_to_string ta)) in
+ match term with
+ | _ when is_some (decode_string_opt term) ->
+ let s = (match (decode_string_opt term) with Some s -> s | None -> "") in
+ "@`" ^ (Aux.normalize_spaces s) ^ "@`"
+ | _ when is_some (decode_list_opt (fun x -> x) term) ->
+ (match (decode_list_opt (fun x -> x) term) with None -> ""
+ | Some l -> "@L["^ (String.concat ", " (List.map term_to_string l))^"]")
+ | _ when is_some (decode_term_type_opt term) ->
+ (match (decode_term_type_opt term) with None -> ""
+ | Some ty -> "@Y " ^ (type_to_string ty))
+ | _ when is_some (decode_term_opt term) ->
+ (match (decode_term_opt term) with None -> ""
+ | Some te -> "@T " ^ (term_to_string te))
+ | Var (v, t, d, [||]) ->
+ "@V [" ^ v ^ " @: " ^ (type_to_string t.(0)) ^
+ " @: "^ string_of_int (d) ^ " ]"
+ | Var (v, t, d, a) ->
+ "@V [" ^ v ^ " @: " ^ (type_to_string t.(0)) ^
+ " @: "^ string_of_int (d) ^ " ] (" ^
+ (term_array_to_string a) ^ " )"
+ | Term (n, [||], [||]) -> n
+ | Term (n, [||], a) ->
+ n ^ " (" ^ (term_array_to_string a) ^ " )"
+ | Term _ -> failwith "term_to_string: stored types not supported yet"
+
+
+(* Parser for terms. *)
+let rec parse_term = function
+ | (Delim "@`") :: rest ->
+ (match parse_text_list rest with
+ | (s, (Delim "@`") :: cont) ->
+ (if s = "" then code_string "" else
+ code_string (String.sub s 0 ((String.length s) - 1))), cont
+ | _ -> failwith "parse_term: string not closed"
+ )
+ | (Delim "@L") :: (Delim "[") :: rest ->
+ (match parse_term_list rest with
+ | (l, (Delim "]") :: cont) -> (code_list (fun x -> x) l, cont)
+ | _ -> failwith "parse_term: list not closed"
+ )
+ | (Delim "@Y") :: rest ->
+ let (ty, cont) = parse_type rest in
+ (code_term_type ty, cont)
+ | (Delim "@T") :: rest ->
+ let (te, cont) = parse_term rest in
+ (code_term te, cont)
+ | (Delim "@V") :: (Delim "[") :: (Text v) :: (Delim "@:") :: rest ->
+ (match parse_type rest with
+ | (ty, (Delim "@:") :: (Text deg) :: (Delim "]") :: cont) ->
+ let (l, c) = parse_bracketed_list cont in
+ (Var (v, [|ty|], int_of_string (deg), of_list l), c)
+ | _ -> failwith "parse_term: var not closed"
+ )
+ | (Text n) :: rest ->
+ let (l, cont) = parse_bracketed_list rest in
+ (Term (n, [||], of_list l), cont)
+ | _ -> failwith "parse_term: bad start"
+and parse_text_list = function
+ | (Text n) :: rest ->
+ let (tl, c) = parse_text_list rest in (n ^ " " ^ tl, c)
+ | (Delim "(") :: rest ->
+ let (tl, c) = parse_text_list rest in ("(" ^ tl, c)
+ | (Delim ")") :: rest ->
+ let (tl, c) = parse_text_list rest in (")" ^ tl, c)
+ | (Delim "[") :: rest ->
+ let (tl, c) = parse_text_list rest in ("[" ^ tl, c)
+ | (Delim "]") :: rest ->
+ let (tl, c) = parse_text_list rest in ("]" ^ tl, c)
+ | (Delim ",") :: rest ->
+ let (tl, c) = parse_text_list rest in ("," ^ tl, c)
+ | l -> ("", l)
+and parse_bracketed_list = function
+ | (Delim "(") :: rest ->
+ (match parse_term_list rest with
+ | (l, (Delim ")") :: cont) -> (l, cont)
+ | _ -> failwith "parse_bracketed_list: not closed"
+ )
+ | l -> ([], l)
+and parse_term_list l =
+ try let (te, cont) = parse_term l in
+ let (lst, c) = parse_term_list_delim cont in
+ (te :: lst, c)
+ with _ -> ([], l)
+and parse_term_list_delim = function
+ | (Delim ",") :: rest ->
+ let (l, cont) = parse_term_list rest in (l, cont)
+ | l -> ([], l)
+
+let term_of_string s =
+ let (te, cont) = parse_term (split_to_list s) in
+ if cont = [] then te else failwith "term_of_string: incomplete parse"
+
+
+(* --- Rules for special built-in functions --- *)
+
+let brackets_rules =
+ [(Term (brackets_name, [||], [|Var ("x", [|Var("a",[||],0,[||])|],0,[||])|]),
+ Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]))]
+let verbatim_rules =
+ [(Term (verbatim_name, [||], [|Var ("x",[|Var ("a",[||],0,[||])|],0,[||])|]),
+ Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]))]
+let if_then_else_rules = [
+ (Term (if_then_else_name, [||], [|code_bool true;
+ Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]);
+ Var ("y", [|Var ("a",[||],0,[||])|], 0, [||])|]),
+ Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]));
+ (Term (if_then_else_name, [||], [|code_bool false;
+ Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]);
+ Var ("y", [|Var ("a",[||],0,[||])|], 0, [||])|]),
+ Var ("y", [|Var ("a",[||],0,[||])|], 0, [||]))]
+
+let varx_te = Var ("x", [|Var ("p",[||],0,[||])|], 0, [||])
+let preprocess_rules = [(Term (preprocess_name, [||], [|varx_te|]), varx_te)]
+
+let string_quote_rules =
+ [(Term (string_quote_name, [||], [|Var ("s", [|string_tp|], 0, [||])|]),
+ Var ("s", [|string_tp|], 0, [||]))]
+
+let additional_xslt_rules =
+ [(Term (additional_xslt_name, [||], [||]), code_string " ")]
Copied: trunk/Toss/Term/Coding.mli (from rev 1725, trunk/Toss/Term/Term.mli)
===================================================================
--- trunk/Toss/Term/Coding.mli (rev 0)
+++ trunk/Toss/Term/Coding.mli 2012-06-16 17:01:17 UTC (rev 1726)
@@ -0,0 +1,87 @@
+(** Contains the type of typed terms, functions calculating type and
+ reconstruction for a term, and printing and parsing for terms. *)
+
+(** {2 Coding basic things as Terms and decoding them} *)
+
+open SyntaxDef
+open Term
+
+(** Thrown when decoding fails. *)
+exception DECODE of string
+
+val code_list : ('a -> term) -> 'a list -> term
+val decode_list : (term -> 'a) -> term -> 'a list
+val decode_list_opt : (term -> 'a) -> term -> 'a list option
+val int_to_bits : int -> int list
+val bits_to_int : int list -> int
+val code_bit : int -> term
+val decode_bit : term -> int
+val decode_bit_list : term -> int
+val code_char : char -> term
+val decode_char : term -> char
+val code_string : string -> term
+val decode_string : term -> string
+val decode_string_opt : term -> string option
+val code_bool : bool -> term
+val decode_bool : term -> bool
+val code_term_type : term -> term
+val decode_term_type : term -> term
+val code_term : term -> term
+val code_term_incr_vars : term -> term
+val decode_term : term -> term
+
+(** {2 Rewriting rules and definitions, their coding and decoding} *)
+
+(** The type of Rewriting Rules. *)
+type rewrite_rule = term * term
+
+val code_rewrite_rule : rewrite_rule -> term
+val decode_rewrite_rule : term -> rewrite_rule
+val code_input_rewrite_rule : rewrite_rule -> term
+val decode_input_rewrite_rule : term -> rewrite_rule
+val code_priority_input_rewrite_rule : rewrite_rule -> term
+val decode_priority_input_rewrite_rule : term -> rewrite_rule
+
+(** The type of Function Definitions. *)
+type fun_definition = string * term list * term
+
+val code_fun_definition : fun_definition -> term
+val decode_fun_definition : term -> fun_definition
+
+(** The type of Type Definitons *)
+type type_definition = string * int
+
+val code_type_definition : type_definition -> term
+val decode_type_definition : term -> type_definition
+val decode_syntax_element : term -> SyntaxDef.syntax_elem
+val code_syntax_element_list : SyntaxDef.syntax_elem list -> term
+val decode_syntax_element_list : term -> SyntaxDef.syntax_elem list
+val code_syntax_definition : SyntaxDef.syntax_def -> term
+val decode_syntax_definition : term -> SyntaxDef.syntax_def
+
+
+(** {2 Term Matching} *)
+
+val matches : (string * term) list ref -> term * term -> bool
+val apply_s : (string * term) list -> term -> term
+
+
+(** {2 Term Display, printing and parsing} *)
+
+val display_term : term -> string
+val display_type_xml : term -> string
+val display_term_xml : term -> string
+
+val term_to_string : term -> string
+val parse_term : Aux.split_result list -> term * Aux.split_result list
+val term_of_string : string -> term
+
+
+(** {2 Rewriting Rules for special built-in functions} *)
+
+val brackets_rules : (term * term) list
+val verbatim_rules : (term * term) list
+val if_then_else_rules : (term * term) list
+val preprocess_rules : (term * term) list
+val additional_xslt_rules : (term * term) list
+val string_quote_rules : (term * term) list
Copied: trunk/Toss/Term/CodingTest.ml (from rev 1725, trunk/Toss/Term/TermTest.ml)
===================================================================
--- trunk/Toss/Term/CodingTest.ml (rev 0)
+++ trunk/Toss/Term/CodingTest.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -0,0 +1,115 @@
+open OUnit
+open Term
+open Coding
+
+let tests = "Term" >::: [
+ "coding term types" >::
+ (fun () ->
+ let test_code_decode_tt tt =
+ let tt1 = decode_term_type (code_term_type tt) in
+ assert_equal ~printer:(fun x -> type_to_string x) tt tt1 in
+ let tt1 = Term ("ala", [||], [||]) in
+ let tt2 = Term ("bolek", [||], [|tt1; tt1|]) in
+ let tt3 = Term (Term.fun_type_name, [||], [|tt1; tt2; tt1|]) in
+ let tt4 = Var ("zmienna",[||],0,[||]) in
+ test_code_decode_tt tt1;
+ test_code_decode_tt tt2;
+ test_code_decode_tt tt3;
+ test_code_decode_tt tt4;
+ );
+
+ "coding terms" >::
+ (fun () ->
+ let test_code_decode_te te =
+ let te1 = decode_term (code_term te) in
+ assert_equal ~printer:(fun x -> term_to_string x) te te1 in
+ let term1 = Term ("ala", [||], [||]) in
+ let term2 = Term ("bolek", [||], [|term1|]) in
+ let term3 = Term ("cynik", [||], [|term1; term2|]) in
+ let term4 = Var ("zmienna", [|Var ("a1",[||],0,[||])|], 0, [| |]) in
+ test_code_decode_te term1;
+ test_code_decode_te term2;
+ test_code_decode_te term3;
+ test_code_decode_te term4;
+ );
+
+ "coding type definitions" >::
+ (fun () ->
+ let test_code_decode_td td =
+ let td1 = decode_type_definition (code_type_definition td) in
+ assert_equal ~printer:(fun x -> "type definition test") td td1 in
+ let td0 = ("numerek", 0) in
+ let td1 = ("listek", 1) in
+ let td2 = ("parka", 2) in
+ test_code_decode_td td0;
+ test_code_decode_td td1;
+ test_code_decode_td td2;
+ );
+
+ "coding syntax definitions" >::
+ (fun () ->
+ let test_code_decode_sd sd =
+ let sd1 = decode_syntax_definition (code_syntax_definition sd) in
+ assert_equal ~printer:(fun x -> "syntax definition test") sd sd1 in
+ let se1 = SyntaxDef.Str "napisek" in
+ let se2 = SyntaxDef.Tp (Var ("eee",[||],0,[||])) in
+ let sd1 = SyntaxDef.SDtype [se1; se2] in
+ let sd2 = SyntaxDef.SDfun ([se2; se1; se1], Term ("aaa", [||], [||])) in
+ let sd3 = SyntaxDef.SDvar ([se2;se2;se1;se1], Term("qza", [||], [||])) in
+ test_code_decode_sd sd1;
+ test_code_decode_sd sd2;
+ test_code_decode_sd sd3;
+ );
+
+ "display term" >::
+ (fun () ->
+ let test_display_term res te =
+ assert_equal ~printer:(fun x -> x) res (display_term te) in
+ test_display_term "[true, false, true]"
+ (code_list code_bool [true; false; true]);
+ test_display_term "\"ala ma kota\"" (code_string "ala ma kota");
+ test_display_term "type ''\"tp\"''"
+ (code_syntax_definition (SyntaxDef.SDtype ([SyntaxDef.Str "tp"])));
+ );
+
+ "parsing and printing" >::
+ (fun () ->
+ let testpp s = assert_equal ~printer:(fun x -> x) s
+ (term_to_string (term_of_string s)) in
+ testpp "ala";
+ testpp "ala (a )";
+ testpp "ala (a, b )";
+ testpp "@V [x @: @? a @: 0 ]";
+ testpp "@V [x @: @? a @: 0 ] (p )";
+ testpp "@V [x @: @? a @: 0 ] (p, q )";
+ testpp "@`kota ma ala@`";
+ testpp "pies (@`kota ma ala@` )";
+ testpp "a (pies (@`kota ma ala@` ), pies )";
+ testpp "a (b (c, d ), e )";
+ testpp "@L[]";
+ testpp "@L[a]";
+ testpp "@L[a, b]";
+ );
+
+ "type reconstruction" >::
+ (fun () ->
+ let list_tp_a = BuiltinLang.list_tp_a in
+ let typesl = [("cons", Term (Term.fun_type_name, [||],
+ [|Var ("a",[||],0,[||]); list_tp_a;
+ list_tp_a|]));
+ ("nil", list_tp_a);
+ ("true", BuiltinLang.boolean_tp);
+ ("1", Term ("int", [||], [||]))] in
+ let types = Hashtbl.create 5 in
+ List.iter (fun (a, b) -> Hashtbl.add types a b) typesl;
+ let var_x_a = Var ("x", [|Var ("a",[||],0,[||])|], 0, [||]) in
+ let te1 = Term ("cons", [||], [|var_x_a; Term ("nil", [||], [||])|]) in
+ let te2 = Term ("cons", [||], [|Term ("true", [||], [||]); te1|]) in
+ let te3 = Term ("cons", [||], [|Term ("1", [||], [||]); te1|]) in
+ let test_tt res te = assert_equal ~printer:(fun x -> x) res
+ (type_to_string (type_of_term types te)) in
+ test_tt "T\\?_list (@? a._.6)" te1;
+ test_tt "T\\?_list (Tboolean)" te2;
+ test_tt "T\\?_list (int)" te3;
+ );
+]
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Term/ParseArc.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/ParseArc.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -2,9 +2,8 @@
and checks if terms are well-typed when closing arcs. *)
open List
-open TermType
+open Term
open SyntaxDef
-open Term
(* The type of elements created during parsing.
@@ -12,13 +11,13 @@
Type is kept together with each term not to recalculate it too often. *)
type parser_elem =
| Token of string
- | Typed_term of term_type * term
+ | Typed_term of term * term
(* Print a parser elem. *)
let elem_str = function
| Token s -> "Tok " ^ s
| Typed_term (tp, te) ->
- "Te " ^ (term_to_string te) ^ " : " ^ (type_to_string tp)
+ "Te " ^ (Coding.term_to_string te) ^ " : " ^ (type_to_string tp)
(* The type of incomplete arcs that appear during parsing;
@@ -91,7 +90,7 @@
Throws NOT_CLOSED if closing fails. *)
let match_of_tok = function
| (Str _, _) -> []
- | (Tp _, Token s) -> [code_string s]
+ | (Tp _, Token s) -> [Coding.code_string s]
| (Tp _, Typed_term (_, te)) -> [te]
let close_arc type_decls = function
@@ -99,13 +98,14 @@
let elems = syntax_elems_of_sd sd in
let args = flatten (map match_of_tok (combine elems (rev l))) in
let res_term = (match sd with
- | SDtype _ -> Term (BuiltinLang.term_type_cons_name,
- [|code_string n; code_list (fun x -> x) args|])
- | SDfun _ -> Term (n, Array.of_list args)
+ | SDtype _ ->
+ Term (BuiltinLang.term_type_cons_name, [||],
+ [|Coding.code_string n; Coding.code_list (fun x -> x) args|])
+ | SDfun _ -> Term (n, [||], Array.of_list args)
| SDvar (_, _) ->
(match sd_type sd with
| None -> failwith "variable syntax definition w/o type"
- | Some (ty) -> Var (n, ty, 0, Array.of_list args) )
+ | Some (ty) -> Var (n, [|ty|], 0, Array.of_list args) )
) in
(try (Typed_term (type_of_term type_decls res_term, res_term), spos)
with NOT_WELL_TYPED _ -> raise NOT_CLOSED)
Modified: trunk/Toss/Term/ParseArc.mli
===================================================================
--- trunk/Toss/Term/ParseArc.mli 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/ParseArc.mli 2012-06-16 17:01:17 UTC (rev 1726)
@@ -1,13 +1,13 @@
(** Contains the bottom-up chart-based parser that uses syntax definitions
and checks if terms are well-typed when closing arcs. **)
-open TermType
+open Term
open SyntaxDef
(** Elements used in the parser. *)
type parser_elem =
| Token of string
- | Typed_term of term_type * Term.term
+ | Typed_term of term * Term.term
(** Print a parser elem. *)
val elem_str : parser_elem -> string
@@ -24,14 +24,14 @@
(** Closes all arcs from the given list that can be closed
and returns the elements together with starting positions. *)
-val close_arc_list : (string, term_type) Hashtbl.t ->
+val close_arc_list : (string, term) Hashtbl.t ->
parser_arc list -> (parser_elem * int) list
-val parse_to_array : (string, term_type) Hashtbl.t ->
+val parse_to_array : (string, term) Hashtbl.t ->
(syntax_def * string) list -> string list -> (parser_elem * int) list array
-val parse : (string, term_type) Hashtbl.t -> (syntax_def * string) list ->
+val parse : (string, term) Hashtbl.t -> (syntax_def * string) list ->
string list -> parser_elem list
val split_input_string : string -> string list
Modified: trunk/Toss/Term/ParseArcTest.ml
===================================================================
--- trunk/Toss/Term/ParseArcTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/ParseArcTest.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -1,23 +1,22 @@
open OUnit
-open TermType
+open Term
open SyntaxDef
open BuiltinLang
open ParseArc
let tests = "ParseArc" >::: [
-
"extend and close arc list" >::
(fun () ->
let elem_eq res e = assert_equal ~printer:(fun x -> x) res (elem_str e) in
let type_decls_list = [
- (list_cons_name, TTerm (TermType.fun_type_name,
- [|TVar ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
+ (list_cons_name, Term (Term.fun_type_name, [||],
+ [|Var ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], TVar ("a",[||],0,[||])) in
+ let var_x_a_sd = SDvar ([Str "x"], Var ("a",[||],0,[||])) in
let sdefs = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let arcs = List.map (fun sd -> Arc (sd, (name_of_sd sd), [], 0)) sdefs in
@@ -45,14 +44,14 @@
"parse" >::
(fun () ->
let type_decls_list = [
- (list_cons_name, TTerm (TermType.fun_type_name,
- [|TVar ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
+ (list_cons_name, Term (Term.fun_type_name, [||],
+ [|Var ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], TVar ("a",[||],0,[||])) in
+ let var_x_a_sd = SDvar ([Str "x"], Var ("a",[||],0,[||])) in
let sdefs_basic = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let sdefs = List.map (fun sd -> (sd, name_of_sd sd)) sdefs_basic in
Modified: trunk/Toss/Term/Rewriting.ml
===================================================================
--- trunk/Toss/Term/Rewriting.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/Rewriting.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -1,7 +1,6 @@
(* Contains the functions responsible for rewriting and normalization. *)
open List
-open TermType
open SyntaxDef
open BuiltinLang
open Term
@@ -14,7 +13,7 @@
let is_left_linear (lhs, _) =
let rec vars = function
- | Term (_, a) -> List.concat (Array.to_list (Array.map vars a))
+ | Term (_, _, a) -> List.concat (Array.to_list (Array.map vars a))
| Var (v, _, _, a) -> v :: List.concat (Array.to_list (Array.map vars a)) in
let vs = List.sort String.compare (vars lhs) in
let rec has_duplicates = function [] | [_] -> false
@@ -25,11 +24,11 @@
let add_first_rule (Rules (rrs)) rr =
if is_left_linear rr then Rules (rr :: rrs) else
- failwith ("Non linear: " ^ (Term.display_term (fst rr)))
+ failwith ("Non linear: " ^ (Coding.display_term (fst rr)))
let add_last_rule (Rules (rrs)) rr =
if is_left_linear rr then Rules (rrs @ [rr]) else
- failwith ("Non linear: " ^ (Term.display_term (fst rr)))
+ failwith ("Non linear: " ^ (Coding.display_term (fst rr)))
(* --- Rewriting with Clash Detection --- *)
@@ -42,32 +41,32 @@
functions on the left side, but we do not check it dynamically here. *)
let check_clash_match (term1, term2) =
let rec check_clash_match_in = function
- | (Term (n1, a1), Term (n2, a2))
+ | (Term (n1, _, a1), Term (n2, _, a2))
when (n1 = n2) && (Array.length a1 = Array.length a2) ->
let update (clash, substs) t1 t2 =
let (new_clash, new_substs) = check_clash_match_in (t1, t2) in
(clash || new_clash, new_substs @ substs) in
Aux.array_fold_left2 update (false, []) a1 a2
- | (Term (n1, _), Term (n2, [||])) when (n1 = n2) ->
+ | (Term (n1, _, _), Term (n2, _, [||])) when (n1 = n2) ->
raise NO_MATCH (* used cons vs. functional cons *)
- | (Term (n1, _), Term (n2, _)) when (n1 = n2) ->
+ | (Term (n1, _, _), Term (n2, _, _)) when (n1 = n2) ->
failwith "curried functions not supported (yet?)"
- | (Term (n1, _), Term (n2, _)) -> (* when (n2.[0] != 'F') *)
+ | (Term (n1, _, _), Term (n2, _, _)) -> (* when (n2.[0] != 'F') *)
raise NO_MATCH
| (Term _, _) ->
(true, [])
| (Var (n, _, d, [||]), t2) ->
- (false, [(n, (d, fn_apply d decode_term t2))])
+ (false, [(n, (d, fn_apply d Coding.decode_term t2))])
| (Var _, _) ->
failwith "functional var on left side of rr" in
match (term1, term2) with (* now term1 = f (args) *)
- | (Term (n1, a1), Term (n2, a2))
+ | (Term (n1, _, a1), Term (n2, _, a2))
when (n1 = n2) && (Array.length a1 = Array.length a2) ->
let update (clash, substs) t1 t2 =
let (new_clash, new_substs) = check_clash_match_in (t1, t2) in
(clash || new_clash, new_substs @ substs) in
Aux.array_fold_left2 update (false, []) a1 a2
- | (Term (n1, _), Term (n2, [||])) when (n1 = n2) ->
+ | (Term (n1, _, _), Term (n2, _, [||])) when (n1 = n2) ->
raise NO_MATCH (* non-0-arg fun and functional term *)
| _ -> failwith "rewriting not this function"
@@ -87,7 +86,7 @@
let (clash, substs) = check_clash_match (left, term) in
if clash then term else
let (merge_clash, merged_substs) = merge_substs substs in
- if merge_clash then term else apply_s merged_substs right
+ if merge_clash then term else Coding.apply_s merged_substs right
(* The final rewrite function that takes care of function names in terms. *)
let rewrite (Rules (rules)) term =
@@ -100,14 +99,14 @@
(* --- Normalisation --- *)
let rec normalise_special_id_one name = function
- | Term (n, [|a|]) when n = name -> a
- | Term (n, a) -> Term (n, Array.map (normalise_special_id_one name) a)
+ | Term (n, _, [|a|]) when n = name -> a
+ | Term (n, t, a) -> Term (n, t, Array.map (normalise_special_id_one name) a)
| Var (n, ty, d, a) ->
Var (n, ty, d, Array.map (normalise_special_id_one name) a)
let rec normalise_special_id_all name = function
- | Term (n, [|a|]) when n = name -> normalise_special_id_all name a
- | Term (n, a) -> Term (n, Array.map (normalise_special_id_all name) a)
+ | Term (n, _, [|a|]) when n = name -> normalise_special_id_all name a
+ | Term (n, t, a) -> Term (n, t, Array.map (normalise_special_id_all name) a)
| Var (n, ty, d, a) ->
Var (n, ty, d, Array.map (normalise_special_id_all name) a)
@@ -115,12 +114,12 @@
let normalise_verbatim = normalise_special_id_one verbatim_name
let rec normalise_special rr_spec = function
- | Term (n, [|a|]) as te when n = verbatim_name -> te
- | Term (n, a) when n.[0] = 'F' ->
- let normalised = Term (n, Array.map (normalise_special rr_spec) a) in
+ | Term (n, _, [|a|]) as te when n = verbatim_name -> te
+ | Term (n, t, a) when n.[0] = 'F' ->
+ let normalised = Term (n, t, Array.map (normalise_special rr_spec) a) in
rr_spec normalised
- | Term (n, a) ->
- Term (n, Array.map (normalise_special rr_spec) a)
+ | Term (n, t, a) ->
+ Term (n, t, Array.map (normalise_special rr_spec) a)
| Var (n, ty, d, a) ->
Var (n, ty, d, Array.map (normalise_special rr_spec) a)
@@ -137,24 +136,24 @@
(steps := !steps + fst (res); snd (res))) th_arr in
(!steps, res_arr)
and basic_normalise rr rr_spec m = function
- | Term (n, [|Term (f, a); r|]) when n = let_major_be_name ->
+ | Term (n, t, [|Term (f, ft, a); r|]) when n = let_major_be_name ->
let (steps_l, na) = basic_normalise_arr rr rr_spec m a in
let (steps_r, rs) = basic_normalise rr rr_spec m r in
- (steps_l + steps_r, Term (n, [|Term (f, na); rs|]))
- | Term (n, [|a|]) as te when n = verbatim_name -> (0, te)
- | Term (nm, [|c; y; n|]) when nm = if_then_else_name ->
+ (steps_l + steps_r, Term (n, t, [|Term (f, ft, na); rs|]))
+ | Term (n, _, [|a|]) as te when n = verbatim_name -> (0, te)
+ | Term (nm, nt, [|c; y; n|]) when nm = if_then_else_name ->
let (steps_c, norm_cond) = basic_normalise rr rr_spec m c in
- let norm_cond_te = Term (nm, [|norm_cond; y; n|]) in
+ let norm_cond_te = Term (nm, nt, [|norm_cond; y; n|]) in
let rewritten = rr norm_cond_te in
if (rewritten = norm_cond_te) then
- (steps_c, Term (nm, [|norm_cond; normalise_special rr_spec y;
- normalise_special rr_spec n|]))
+ (steps_c, Term (nm, nt, [|norm_cond; normalise_special rr_spec y;
+ normalise_special rr_spec n|]))
else
let (steps, res) = basic_normalise rr rr_spec m rewritten in
(steps + steps_c + 1, res)
- | Term (n, a) when n.[0] = 'F' ->
+ | Term (n, t, a) when n.[0] = 'F' ->
(let (prev_steps, prev_res) = basic_normalise_arr rr rr_spec m a in
- let nmlized = Term (n, prev_res) in
+ let nmlized = Term (n, t, prev_res) in
let found= try Some (TermHashtbl.find m nmlized) with Not_found -> None in
match found with Some (r) -> (prev_steps, r) | None ->
let rewritten = rr nmlized in
@@ -167,9 +166,9 @@
(TermHashtbl.add m nmlized res; (0, res))
else (prev_steps + steps + 1, res)
)
- | Term (n, a) ->
+ | Term (n, t, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
- (steps, Term (n, res))
+ (steps, Term (n, t, res))
| Var (n, ty, d, a) ->
let (steps, res) = basic_normalise_arr rr rr_spec m a in
(steps, Var (n, ty, d, res))
@@ -178,9 +177,9 @@
let normalise mem rules is_special rewrite_special inp_term =
let term = normalise_brackets inp_term in
let rr = function
- | Term (n, a) as te when (is_special n) ->
+ | Term (n, _, a) as te when (is_special n) ->
rewrite_special (normalise_verbatim te)
- | Term (n, a) as te ->
+ | Term (n, _, a) as te ->
(try rewrite (Hashtbl.find rules n) te with Not_found -> te)
| te -> te in
let (_, normalised) =
Modified: trunk/Toss/Term/RewritingTest.ml
===================================================================
--- trunk/Toss/Term/RewritingTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/RewritingTest.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -1,7 +1,8 @@
open OUnit
+open Term
open BuiltinLang
-open Term
open Rewriting
+open Coding
let tests = "Rewriting" >::: [
"rewrite" >::
@@ -9,24 +10,24 @@
let test_rr rl res t =
let rs = new_rules_set rl in
assert_equal ~printer:(fun x-> x) res (term_to_string (rewrite rs t)) in
- let var_x_b = Var ("x", boolean_tp, 0, [||]) in
- let var_y_b = Var ("y", boolean_tp, 0, [||]) in
- let rr1 =
- (Term ("Fand", [|code_bool true; code_bool true|]), code_bool true) in
- let rr2 = (Term ("Fand", [|var_x_b; var_y_b|]), code_bool false) in
- let t1 = Term ("Fand", [|code_bool true; code_bool true|]) in
+ let var_x_b = Var ("x", [|boolean_tp|], 0, [||]) in
+ let var_y_b = Var ("y", [|boolean_tp|], 0, [||]) in
+ let rr1 =
+ (Term ("Fand",[||],[|code_bool true;code_bool true|]),code_bool true) in
+ let rr2 = (Term ("Fand", [||], [|var_x_b; var_y_b|]), code_bool false) in
+ let t1 = Term ("Fand", [||], [|code_bool true; code_bool true|]) in
test_rr [rr1; rr2] "Ftrue" t1;
- let t2 = Term ("Fand", [|code_bool true; code_bool false|]) in
+ let t2 = Term ("Fand", [||], [|code_bool true; code_bool false|]) in
test_rr [rr1; rr2] "Ffalse" t2;
- let t3 = Term ("Fand", [|code_bool false; code_bool true|]) in
+ let t3 = Term ("Fand", [||], [|code_bool false; code_bool true|]) in
test_rr [rr1; rr2] "Ffalse" t3;
- let t4 = Term ("Fand", [|code_bool false; code_bool false|]) in
+ let t4 = Term ("Fand", [||], [|code_bool false; code_bool false|]) in
test_rr [rr1; rr2] "Ffalse" t4;
- let t5 = Term ("Fand", [|code_bool false; var_x_b|]) in
+ let t5 = Term ("Fand", [||], [|code_bool false; var_x_b|]) in
test_rr [rr1; rr2] "Ffalse" t5;
- let t6 = Term ("Fand", [|code_bool true; var_x_b|]) in
+ let t6 = Term ("Fand", [||], [|code_bool true; var_x_b|]) in
test_rr [rr1; rr2] "Fand (Ftrue, @V [x @: Tboolean @: 0 ] )" t6;
- let t7 = Term ("Fand", [|var_x_b; var_y_b|]) in
+ let t7 = Term ("Fand", [||], [|var_x_b; var_y_b|]) in
test_rr [rr1; rr2] ("Fand (@V [x @: Tboolean @: 0 ], " ^
"@V [y @: Tboolean @: 0 ] )") t7;
);
@@ -38,22 +39,22 @@
Hashtbl.add rs n (new_rules_set rl);
assert_equal ~printer:(fun x-> x) res
(term_to_string (normalise m rs (fun x -> false) (fun x -> x) t)) in
- let var_x_b = Var ("x", boolean_tp, 0, [||]) in
- let var_y_b = Var ("y", boolean_tp, 0, [||]) in
+ let var_x_b = Var ("x", [|boolean_tp|], 0, [||]) in
+ let var_y_b = Var ("y", [|boolean_tp|], 0, [||]) in
let rr1 =
- (Term ("Fand", [|code_bool true; code_bool true|]), code_bool true) in
- let rr2 = (Term ("Fand", [|var_x_b; var_y_b|]), code_bool false) in
+ (Term ("Fand",[||],[|code_bool true;code_bool true|]),code_bool true) in
+ let rr2 = (Term ("Fand", [||], [|var_x_b; var_y_b|]), code_bool false) in
let rrs = ("Fand", [rr1; rr2]) in
- let t1 = Term ("Fand", [|code_bool true; code_bool true|]) in
+ let t1 = Term ("Fand", [||], [|code_bool true; code_bool true|]) in
test_ne rrs "Ftrue" t1;
- let t2 = Term ("Fand", [|code_bool true; t1|]) in
+ let t2 = Term ("Fand", [||], [|code_bool true; t1|]) in
test_ne rrs "Ftrue" t2;
- let t3 = Term ("Fand", [|var_x_b; t1|]) in
+ let t3 = Term ("Fand", [||], [|var_x_b; t1|]) in
test_ne rrs "Fand (@V [x @: Tboolean @: 0 ], Ftrue )" t3;
- let t4 = Term (if_then_else_name, [|var_x_b; t1; t1|]) in
+ let t4 = Term (if_then_else_name, [||], [|var_x_b; t1; t1|]) in
test_ne rrs ("Fif_\\?_then_\\?_else_\\? (@V [x @: Tboolean @: 0 ], Fand "^
"(Ftrue, Ftrue ), Fand (Ftrue, Ftrue ) )") t4;
- let t5 = Term ("Ckot", [|var_x_b; t1; t1|]) in
+ let t5 = Term ("Ckot", [||], [|var_x_b; t1; t1|]) in
test_ne rrs "Ckot (@V [x @: Tboolean @: 0 ], Ftrue, Ftrue )" t5;
);
]
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Term/SyntaxDef.ml 2012-06-15 21:24:23 UTC (rev 1725)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-06-16 17:01:17 UTC (rev 1726)
@@ -4,17 +4,17 @@
open Array
open Aux
-open TermType
+open Term
(* The type of syntax elements. *)
-type syntax_elem = Str of string | Tp of term_type
+type syntax_elem = Str of string | Tp of term
(* The type of syntax definitions. *)
type syntax_def =
| SDtype of syntax_elem list
- | SDfun of syntax_elem list * term_type
- | SDvar of syntax_elem list * term_type
+ | SDfun of syntax_elem list * term
+ | SDvar of syntax_elem list * term
(* --- Basic functions for Syntax Definitions, generating names --- *)
@@ -71,9 +71,9 @@
let rec revnumbers i = if i = 0 then [] else i :: (revnumbers (i-1)) in
let numbers i = List.map string_of_int (List.rev (revnumbers i)) in
let s = List.concat (List.map (function Str _ -> [] | Tp _ -> ["a"]) sel) in
- let arg_of s1 s2 = TVar (s1 ^ "_" ^ s2, [||], 0, [||]) in
+ let arg_of s1 s2 = Var (s1 ^ "_" ^ s2, [||], 0, [||]) in
let args = List.map2 arg_of s (numbers (List.length s)) in
- TTerm (name_of_sd sd, of_list args)
+ Term (name_of_sd sd, [||], of_list args)
| _ -> failwith "type of sd on non-type definition"
@@ -84,9 +84,9 @@
match sd with
| SDtype _ -> None
| SDfun (sel, ty)-> Some (if (ts = []) then ty else
- TTerm (TermType.fun_type_name, of_list (ts @ [ty])))
+ Term (Term.fun_type_name, [||], of_list (ts @ [ty])))
| SDvar (sel, ty)-> Some (if (ts = []) then ty else
- TTerm (TermType.fun_type_name, of_list (ts @ [...
[truncated message content] |
|
From: <luk...@us...> - 2012-06-15 21:24:30
|
Revision: 1725
http://toss.svn.sourceforge.net/toss/?rev=1725&view=rev
Author: lukaszkaiser
Date: 2012-06-15 21:24:23 +0000 (Fri, 15 Jun 2012)
Log Message:
-----------
First step in merging Term with TermType.
Modified Paths:
--------------
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDefTest.ml
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/TermTest.ml
trunk/Toss/Term/TermType.ml
trunk/Toss/Term/TermType.mli
trunk/Toss/Term/TermTypeTest.ml
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -29,12 +29,12 @@
let list_sd = SDtype [Tp term_type_tp; Str "list"]
let list_name = name_of_sd list_sd
-let list_tp t = Term_type (list_name, [|t|])
-let list_tp_a = list_tp (Type_var "a")
+let list_tp t = TTerm (list_name, [|t|])
+let list_tp_a = list_tp (TVar ("a", [||], 0, [||]))
let list_nil_sd = SDfun ([Str "["; Str "]"], list_tp_a)
let list_nil_name = name_of_sd list_nil_sd
-let list_cons_sd = SDfun ([Tp (Type_var "a"); Str ","; Tp list_tp_a],
+let list_cons_sd = SDfun ([Tp (TVar ("a",[||],0,[||])); Str ","; Tp list_tp_a],
list_tp_a)
let list_cons_name = name_of_sd list_cons_sd
@@ -147,8 +147,8 @@
let input_rewrite_rule_name = name_of_sd input_rewrite_rule_sd
let input_rewrite_rule_tp = type_of_sd input_rewrite_rule_sd
-let let_be_sd = SDfun ([Str "let"; Tp (Type_var "a_1"); Str "be";
- Tp (Type_var "a_1")], input_rewrite_rule_tp)
+let let_be_sd = SDfun ([Str "let"; Tp (TVar ("a_1",[||],0,[||])); Str "be";
+ Tp (TVar ("a_1",[||],0,[||]))], input_rewrite_rule_tp)
let let_be_name = name_of_sd let_be_sd
let priority_input_rewrite_rule_sd = SDtype ([Str "priority";
@@ -158,8 +158,9 @@
let priority_input_rewrite_rule_tp =
type_of_sd priority_input_rewrite_rule_sd
-let let_major_be_sd = SDfun ([Str "let"; Str "major"; Tp (Type_var "a_1");
- Str "be"; Tp (Type_var "a_1")], priority_input_rewrite_rule_tp)
+let let_major_be_sd =
+ SDfun ([Str "let"; Str "major"; Tp (TVar ("a_1",[||],0,[||])); Str "be";
+ Tp (TVar ("a_1",[||],0,[||]))], priority_input_rewrite_rule_tp)
let let_major_be_name = name_of_sd let_major_be_sd
let fun_definition_sd = SDtype ([Str "fun"; Str "definition"])
@@ -184,43 +185,44 @@
let exception_cl_sd = SDtype [Tp term_type_tp; Str "exception"]
let exception_cl_name = name_of_sd exception_cl_sd
-let exception_cl_tp t = Term_type (exception_cl_name, [|t|])
+let exception_cl_tp t = TTerm (exception_cl_name, [|t|])
let exception_sd =
- SDfun ([Str "!"; Str "!"; Tp (Type_var "a"); Str "!";Str "!";],
- exception_cl_tp (Type_var "other_than_a!"))
+ SDfun ([Str "!"; Str "!"; Tp (TVar ("a",[||],0,[||])); Str "!";Str "!";],
+ exception_cl_tp (TVar ("other_than_a!",[||],0,[||])))
let exception_name = name_of_sd exception_sd
let exn_ok_sd =
- SDfun ([Str "+"; Str "+"; Tp (Type_var "a"); Str "+";Str "+";],
- exception_cl_tp (Type_var "a")) (* Here it should be a! *)
+ SDfun ([Str "+"; Str "+"; Tp (TVar ("a",[||],0,[||])); Str "+";Str "+";],
+ exception_cl_tp (TVar ("a",[||],0,[||]))) (* Here it should be a! *)
let exn_ok_name = name_of_sd exception_sd
(* --- Special functions recognized during Normalisation --- *)
-let brackets_sd = SDfun ([Str "("; Tp (Type_var "b"); Str ")"],
- Type_var "b")
+let brackets_sd = SDfun ([Str "("; Tp (TVar ("b",[||],0,[||])); Str ")"],
+ TVar ("b",[||],0,[||]))
let brackets_name = name_of_sd brackets_sd
-let verbatim_sd =
- SDfun ([Str "<"; Str "|"; Tp (Type_var "b"); Str "|"; Str ">"], Type_var "b")
+let verbatim_sd = SDfun ([Str "<"; Str "|"; Tp (TVar ("b",[||],0,[||]));
+ Str "|"; Str ">"], TVar ("b",[||],0,[||]))
let verbatim_name = name_of_sd verbatim_sd
let if_then_else_sd = SDfun ([Str "if"; Tp boolean_tp; Str "then";
- Tp (Type_var "a"); Str "else"; Tp (Type_var "a")], Type_var "a")
+ Tp (TVar ("a",[||],0,[||])); Str "else";
+ Tp (TVar ("a",[||],0,[||]))], TVar ("a",[||],0,[||]))
let if_then_else_name = name_of_sd if_then_else_sd
-let eq_bool_sd = SDfun ([Tp (Type_var "a"); Str "="; Tp (Type_var "a")],
- boolean_tp)
+let eq_bool_sd = SDfun ([Tp (TVar ("a",[||],0,[||])); Str "=";
+ Tp (TVar ("a",[||],0,[||]))], boolean_tp)
let eq_bool_name = name_of_sd eq_bool_sd
(* --- Syntax Definitions for special meta-functions --- *)
-let code_as_term_sd = SDfun ([Str "code"; Tp (Type_var "a");
+let code_as_term_sd = SDfun ([Str "code"; Tp (TVar ("a",[||],0,[||]));
Str "as"; Str "term"], term_tp)
let code_as_term_name = name_of_sd code_as_term_sd
@@ -276,12 +278,13 @@
let set_command_tp = type_of_sd set_command_sd
let set_prop_sd = SDfun ([Str "set"; Tp (string_tp); Str "of";
- Tp (Type_var "a"); Str "to"; Tp (Type_var "b")], set_command_tp)
+ Tp (TVar ("a",[||],0,[||])); Str "to";
+ Tp (TVar ("b",[||],0,[||]))], set_command_tp)
let set_prop_name = name_of_sd set_prop_sd
-let preprocess_sd =
- SDfun ([Str "#"; Str "#"; Str "#"; Tp (Type_var "p")], Type_var "q")
+let preprocess_sd = SDfun ([Str "#"; Str "#"; Str "#";
+ Tp (TVar ("p",[||],0,[||]))], TVar ("q",[||],0,[||]))
let preprocess_name = name_of_sd preprocess_sd
Modified: trunk/Toss/Term/ParseArcTest.ml
===================================================================
--- trunk/Toss/Term/ParseArcTest.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/ParseArcTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -10,13 +10,14 @@
(fun () ->
let elem_eq res e = assert_equal ~printer:(fun x -> x) res (elem_str e) in
let type_decls_list = [
- (list_cons_name, Fun_type ([|Type_var "a"; list_tp_a|], list_tp_a));
+ (list_cons_name, TTerm (TermType.fun_type_name,
+ [|TVar ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], Type_var "a") in
+ let var_x_a_sd = SDvar ([Str "x"], TVar ("a",[||],0,[||])) in
let sdefs = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let arcs = List.map (fun sd -> Arc (sd, (name_of_sd sd), [], 0)) sdefs in
@@ -44,13 +45,14 @@
"parse" >::
(fun () ->
let type_decls_list = [
- (list_cons_name, Fun_type ([|Type_var "a"; list_tp_a|], list_tp_a));
+ (list_cons_name, TTerm (TermType.fun_type_name,
+ [|TVar ("a",[||],0,[||]); list_tp_a; list_tp_a|]));
(list_nil_name, list_tp_a);
(boolean_true_name, boolean_tp);
(boolean_false_name, boolean_tp)] in
let tps = Hashtbl.create 7 in
List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list;
- let var_x_a_sd = SDvar ([Str "x"], Type_var "a") in
+ let var_x_a_sd = SDvar ([Str "x"], TVar ("a",[||],0,[||])) in
let sdefs_basic = [list_cons_sd; list_nil_sd;
boolean_true_sd; boolean_false_sd; var_x_a_sd] in
let sdefs = List.map (fun sd -> (sd, name_of_sd sd)) sdefs_basic in
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Term/SyntaxDef.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -71,22 +71,23 @@
let rec revnumbers i = if i = 0 then [] else i :: (revnumbers (i-1)) in
let numbers i = List.map string_of_int (List.rev (revnumbers i)) in
let s = List.concat (List.map (function Str _ -> [] | Tp _ -> ["a"]) sel) in
- let arg_of s1 s2 = Type_var (s1 ^ "_" ^ s2) in
+ let arg_of s1 s2 = TVar (s1 ^ "_" ^ s2, [||], 0, [||]) in
let args = List.map2 arg_of s (numbers (List.length s)) in
- Term_type (name_of_sd sd, of_list args)
+ TTerm (name_of_sd sd, of_list args)
| _ -> failwith "type of sd on non-type definition"
(* Type used in type declaration for a syntax definition. *)
let sd_type sd =
let types_of_sels s = List.map (function Str _ -> [] | Tp ty -> [ty]) s in
- let ts = of_list (List.flatten (types_of_sels (syntax_elems_of_sd sd))) in
+ let ts = List.flatten (types_of_sels (syntax_elems_of_sd sd)) in
match sd with
| SDtype _ -> None
- | SDfun (sel, ty)-> Some (if (length ts = 0) then ty else Fun_type (ts, ty))
- | SDvar (sel, ty)-> Some (if (length ts = 0) then ty else Fun_type (ts, ty))
+ | SDfun (sel, ty)-> Some (if (ts = []) then ty else
+ TTerm (TermType.fun_type_name, of_list (ts @ [ty])))
+ | SDvar (sel, ty)-> Some (if (ts = []) then ty else
+ TTerm (TermType.fun_type_name, of_list (ts @ [ty])))
-
(* Functional syntax definition corresponding to a given one. *)
let func_sd_of_sd sd =
let change = function Tp _ -> [Str "{"; Str "}"] | x -> [x] in
@@ -214,13 +215,16 @@
else [Some (n)]
let rec display_type = function
- | Type_var n -> "?" ^ n
- | Term_type (n, a) ->
+ | TVar (n, [||], 0, [||]) -> "?" ^ n
+ | TVar _ -> failwith "display_type on non-type variable"
+ | TTerm (n, arr) when n = TermType.fun_type_name ->
+ let l = Array.length arr in
+ let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
let args = List.map display_type (Array.to_list a) in
+ "(" ^ (String.concat ", " args) ^ ") --> " ^ (display_type r)
+ | TTerm (n, a) ->
+ let args = List.map display_type (Array.to_list a) in
display_sd (split_sdef_name n) args
- | Fun_type (a, r) ->
- let args = List.map display_type (Array.to_list a) in
- "(" ^ (String.concat ", " args) ^ ") --> " ^ (display_type r)
let pretty_print_sd sd =
let pretty_print_se = function
@@ -248,9 +252,8 @@
!is_ok
) in
let flat_grammar_name_of_type = function
- | Term_type (n, _) -> "$" ^ String.sub n 1 ((String.length n) - 1)
- | Fun_type _ -> "$@fun"
- | Type_var _ -> "$@object" in
+ | TTerm (n, _) -> "$" ^ String.sub n 1 ((String.length n) - 1)
+ | TVar _ -> "$@object" in
let flat_grammar_name_of_se = function
| Tp ty -> flat_grammar_name_of_type ty
| Str s -> if is_all_letters s then s else raise NONLEXICAL in
Modified: trunk/Toss/Term/SyntaxDefTest.ml
===================================================================
--- trunk/Toss/Term/SyntaxDefTest.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/SyntaxDefTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -5,7 +5,7 @@
let tests = "SyntaxDef" >::: [
"name of sd" >::
(fun () ->
- let sel1 = [Str "[list]"; Str "of"; Tp (Type_var "a")] in
+ let sel1 = [Str "[list]"; Str "of"; Tp (TVar ("a",[||],0,[||]))] in
let n = unique_name_of_sd (SDtype sel1) [name_of_sd (SDtype sel1)] in
assert_equal ~printer:(fun x -> x) "T\\lslist\\rs_of_\\?_0\\" n;
);
@@ -20,7 +20,8 @@
assert_equal ~printer:(fun x -> x) res_sn sn in
let sd1 = SDtype [Str "ala_ma_kota"] in
let sd2 = SDtype [Str "\\atala"; Str "_"; Str "\\?"; Str "m\\_a";
- Str "\\\\";Str "maa\\"; Tp (Type_var "a");Str "kot@"] in
+ Str "\\\\";Str "maa\\"; Tp (TVar ("a",[||],0,[||]));
+ Str "kot@"] in
test_split "Tala\\_ma\\_kota" "Sala_ma_kota" sd1;
test_split "T\\\\atala_\\__\\\\?_m\\\\\\_a_\\\\\\\\_maa\\\\_\\?_kot\\at"
"S\\@ala|S_|S\\?|Sm\\_a|S\\\\|Smaa\\|N|Skot@" sd2;
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/TRS.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -150,7 +150,10 @@
let elem_of_td (n, ty) =
if n.[0] = c then
match ty with
- | Fun_type (a, r) -> [(n, Array.to_list a, r)]
+ | TTerm (name, arr) when name = TermType.fun_type_name ->
+ let l = Array.length arr in
+ let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
+ [(n, Array.to_list a, r)]
| _ -> [(n, [], ty)]
else [] in
flatten (map elem_of_td tdecls)
@@ -200,10 +203,13 @@
let is_better sys te1 te2 =
let query = Term (preferred_to_name, [|code_term te1; code_term te2|]) in
+ let report i =
+ LOG 1 "%s prefered to %s ? %i" (term_to_string te1) (term_to_string te2) i;
+ i in
match normalise_with_sys sys query with
- | Term (n, [||]) when n = ternary_true_name -> 1
- | Term (n, [||]) when n = ternary_false_name -> -1
- | te -> 0
+ | Term (n, [||]) when n = ternary_true_name -> report 1
+ | Term (n, [||]) when n = ternary_false_name -> report (-1)
+ | te -> report 0
let is_best sys ht terms te =
let cmp a b =
@@ -232,6 +238,7 @@
| t :: tes ->
(* we rehash terms here because often first or first-parsed is best *)
let terms = t :: (rev tes) in
+ LOG 1 "finding best of %i" (List.length terms);
let best = filter (is_best sys (Hashtbl.create 64) terms) terms in
remove_bracket_duplicates best
@@ -326,7 +333,7 @@
match in_pair with
| (te, _) when is_some (decode_sd_opt te) -> msg (
match decode_syntax_definition te with
- |SDtype (sels) -> "New class " ^ (msg_for_sels sels) ^ " declared."
+ | SDtype (sels) -> "New class " ^ (msg_for_sels sels) ^ " declared."
| SDfun (sels, _) -> "New function " ^ (msg_for_sels sels) ^" declared."
| SDvar (sels, _) -> "New variable " ^ (msg_for_sels sels) ^" declared."
) ""
Modified: trunk/Toss/Term/Term.ml
===================================================================
--- trunk/Toss/Term/Term.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/Term.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -118,12 +118,15 @@
let rec code_term_type = function
- | Type_var name -> Term (term_type_var_name, [|code_string name|])
- | Fun_type (args_types, return_type) ->
+ | TVar (name, [||], 0, [||])-> Term (term_type_var_name, [|code_string name|])
+ | TVar _ -> failwith "code_term_type: non-type variable"
+ | TTerm (name, arr) when name = TermType.fun_type_name ->
+ let l = Array.length arr in
+ let (args_types, return_type) = (Array.sub arr 0 (l-1), arr.(l-1)) in
Term (term_type_fun_name, [|
code_list code_term_type (to_list args_types);
code_term_type return_type|])
- | Term_type (name, args) ->
+ | TTerm (name, args) ->
Term (term_type_cons_name, [|
code_string name;
code_list code_term_type (to_list args)|])
@@ -131,13 +134,13 @@
let rec decode_term_type = function
| Term (s, [|coded_name|]) when s = term_type_var_name ->
- Type_var (decode_string coded_name)
+ TVar (decode_string coded_name, [||], 0, [||])
| Term (s, [|coded_1; coded_2|]) when s = term_type_fun_name ->
- Fun_type (of_list (decode_list decode_term_type coded_1),
- decode_term_type coded_2)
+ TTerm (TermType.fun_type_name, of_list (
+ (decode_list decode_term_type coded_1) @ [decode_term_type coded_2]))
| Term (s, [|coded_1; coded_2|]) when s = term_type_cons_name ->
- Term_type (decode_string coded_1,
- of_list (decode_list decode_term_type coded_2))
+ TTerm (decode_string coded_1,
+ of_list (decode_list decode_term_type coded_2))
| _ -> raise (DECODE "term_type")
@@ -233,15 +236,15 @@
let code_type_definition (name, arity) =
let rec var = function
| 0 -> []
- | i -> Type_var ("a_" ^ (string_of_int i)) :: (var (i-1)) in
+ | i -> TVar ("a_" ^ (string_of_int i), [||], 0, [||]) :: (var (i-1)) in
Term (type_of_name,
- [|code_term_type (Term_type (name, of_list (var arity)))|])
+ [|code_term_type (TTerm (name, of_list (var arity)))|])
let decode_type_definition = function
| Term (n, [|ty|]) when n = type_of_name ->
(match (decode_term_type ty) with
- Term_type (name, args) -> (name, Array.length args)
+ TTerm (name, args) -> (name, Array.length args)
| _ -> raise (DECODE "type definition 1")
)
| _ -> raise (DECODE "type definition 2")
@@ -364,17 +367,19 @@
(* --- Display terms and types as XML --- *)
let rec display_type_xml = function
- | Type_var n -> "<type_var>" ^ (make_xml_compatible n) ^ "</type_var>"
- | Term_type (n, a) ->
+ | TVar (n, [||], 0, [||]) ->
+ "<type_var>" ^ (make_xml_compatible n) ^ "</type_var>"
+ | TVar _ -> failwith "display_type_xml: non-type variable"
+ | TTerm (n, a) ->
"<type class=\"" ^ (make_xml_compatible n) ^ "\">\n" ^
(String.concat "\n" (List.map display_type_xml (to_list a))) ^
"\n</type>"
- | Fun_type (a, r) ->
+(* | Fun_type (a, r) ->
"<funtype>\n<funtype-arg-types>\n" ^
(String.concat "\n" (List.map display_type_xml (to_list a))) ^
"\n</funtype-arg-types>\n<funtype-return-type>\n" ^
(display_type_xml r) ^
- "</funtype-return-type>\n</funtype>"
+ "</funtype-return-type>\n</funtype>" *)
let rec display_term_xml = function
@@ -504,7 +509,9 @@
let ((i, uni_sack, ty_decls), arg_tys) = fold_left type_sack (i ,[]) a in
(match (suffix i (Hashtbl.find ty_decls n), List.rev arg_tys) with
| (ty, []) -> ((i+1, uni_sack, ty_decls), ty :: itys)
- | (Fun_type (at, r), rt) ->
+ | (TTerm (n, arr), rt) when n = TermType.fun_type_name ->
+ let l = Array.length arr in
+ let (at, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
(try ((i+1, (List.combine (to_list at) rt) @ uni_sack, ty_decls),
r :: itys)
with Invalid_argument _-> raise (NOT_WELL_TYPED "type_sack, term,i.a")
@@ -516,7 +523,9 @@
let real_var_type = if code_degree = 0 then var_type else term_tp in
(match (real_var_type, List.rev arg_tys) with
| (ty, []) -> ((i+1, uni_sack, ty_decls), ty :: itys)
- | (Fun_type (at, r), rt) ->
+ | (TTerm (n, arr), rt) when n = TermType.fun_type_name ->
+ let l = Array.length arr in
+ let (at, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
(try ((i+1, (List.combine (to_list at) rt) @ uni_sack, ty_decls),
r :: itys)
with Invalid_argument _-> raise (NOT_WELL_TYPED "type_sack, var, i.a")
@@ -549,20 +558,22 @@
(* --- Rules for special built-in functions --- *)
let brackets_rules =
- [(Term (brackets_name, [|Var ("x", Type_var "a", 0, [||])|]),
- Var ("x", Type_var "a", 0, [||]))]
+ [(Term (brackets_name, [|Var ("x", TVar ("a",[||],0,[||]), 0, [||])|]),
+ Var ("x", TVar ("a",[||],0,[||]), 0, [||]))]
let verbatim_rules =
- [(Term (verbatim_name, [|Var ("x", Type_var "a", 0, [||])|]),
- Var ("x", Type_var "a", 0, [||]))]
+ [(Term (verbatim_name, [|Var ("x", TVar ("a",[||],0,[||]), 0, [||])|]),
+ Var ("x", TVar ("a",[||],0,[||]), 0, [||]))]
let if_then_else_rules = [
(Term (if_then_else_name, [|code_bool true;
- Var ("x", Type_var "a", 0, [||]); Var ("y", Type_var "a", 0, [||])|]),
- Var ("x", Type_var "a", 0, [||]));
+ Var ("x", TVar ("a",[||],0,[||]), 0, [||]);
+ Var ("y", TVar ("a",[||],0,[||]), 0, [||])|]),
+ Var ("x", TVar ("a",[||],0,[||]), 0, [||]));
(Term (if_then_else_name, [|code_bool false;
- Var ("x", Type_var "a", 0, [||]); Var ("y", Type_var "a", 0, [||])|]),
- Var ("y", Type_var "a", 0, [||]))]
+ Var ("x", TVar ("a",[||],0,[||]), 0, [||]);
+ Var ("y", TVar ("a",[||],0,[||]), 0, [||])|]),
+ Var ("y", TVar ("a",[||],0,[||]), 0, [||]))]
-let varx_te = Var ("x", Type_var "p", 0, [||])
+let varx_te = Var ("x", TVar ("p",[||],0,[||]), 0, [||])
let preprocess_rules = [(Term (preprocess_name, [|varx_te|]), varx_te)]
let string_quote_rules =
Modified: trunk/Toss/Term/TermTest.ml
===================================================================
--- trunk/Toss/Term/TermTest.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/TermTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -8,10 +8,10 @@
let test_code_decode_tt tt =
let tt1 = decode_term_type (code_term_type tt) in
assert_equal ~printer:(fun x -> type_to_string x) tt tt1 in
- let tt1 = Term_type ("ala", [| |]) in
- let tt2 = Term_type ("bolek", [|tt1; tt1|]) in
- let tt3 = Fun_type ([|tt1; tt2|], tt1) in
- let tt4 = Type_var "zmienna" in
+ let tt1 = TTerm ("ala", [| |]) in
+ let tt2 = TTerm ("bolek", [|tt1; tt1|]) in
+ let tt3 = TTerm (TermType.fun_type_name, [|tt1; tt2; tt1|]) in
+ let tt4 = TVar ("zmienna",[||],0,[||]) in
test_code_decode_tt tt1;
test_code_decode_tt tt2;
test_code_decode_tt tt3;
@@ -26,7 +26,7 @@
let term1 = Term ("ala", [| |]) in
let term2 = Term ("bolek", [|term1|]) in
let term3 = Term ("cynik", [|term1; term2|]) in
- let term4 = Var ("zmienna", Type_var "a1", 0, [| |]) in
+ let term4 = Var ("zmienna", TVar ("a1",[||],0,[||]), 0, [| |]) in
test_code_decode_te term1;
test_code_decode_te term2;
test_code_decode_te term3;
@@ -52,10 +52,10 @@
let sd1 = decode_syntax_definition (code_syntax_definition sd) in
assert_equal ~printer:(fun x -> "syntax definition test") sd sd1 in
let se1 = SyntaxDef.Str "napisek" in
- let se2 = SyntaxDef.Tp (Type_var "eee") in
+ let se2 = SyntaxDef.Tp (TVar ("eee",[||],0,[||])) in
let sd1 = SyntaxDef.SDtype [se1; se2] in
- let sd2 = SyntaxDef.SDfun ([se2; se1; se1], Term_type ("aaa",[| |])) in
- let sd3 = SyntaxDef.SDvar ([se2; se2; se1; se1], Term_type("qza",[||])) in
+ let sd2 = SyntaxDef.SDfun ([se2; se1; se1], TTerm ("aaa",[| |])) in
+ let sd3 = SyntaxDef.SDvar ([se2; se2; se1; se1], TTerm("qza",[||])) in
test_code_decode_sd sd1;
test_code_decode_sd sd2;
test_code_decode_sd sd3;
@@ -94,13 +94,15 @@
"type reconstruction" >::
(fun () ->
let list_tp_a = BuiltinLang.list_tp_a in
- let typesl = [("cons", Fun_type ([|Type_var "a"; list_tp_a|], list_tp_a));
+ let typesl = [("cons", TTerm (TermType.fun_type_name,
+ [|TVar ("a",[||],0,[||]); list_tp_a;
+ list_tp_a|]));
("nil", list_tp_a);
("true", BuiltinLang.boolean_tp);
- ("1", Term_type ("int", [||]))] in
+ ("1", TTerm ("int", [||]))] in
let types = Hashtbl.create 5 in
List.iter (fun (a, b) -> Hashtbl.add types a b) typesl;
- let var_x_a = Var ("x", Type_var "a", 0, [||]) in
+ let var_x_a = Var ("x", TVar ("a",[||],0,[||]), 0, [||]) in
let te1 = Term ("cons", [|var_x_a; Term ("nil", [||])|]) in
let te2 = Term ("cons", [|Term ("true", [||]); te1|]) in
let te3 = Term ("cons", [|Term ("1", [||]); te1|]) in
Modified: trunk/Toss/Term/TermType.ml
===================================================================
--- trunk/Toss/Term/TermType.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/TermType.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -5,16 +5,15 @@
(* The type of term types. *)
type term_type =
- | Term_type of string * term_type array
- | Fun_type of term_type array * term_type
- | Type_var of string
+ | TTerm of string * term_type array
+ | TVar of string * term_type array * int * term_type array
+let fun_type_name = "fffuuunnntyppe"
(* Suffix type variables to rename them. *)
let rec suffix i = function
- | Term_type (n, a) -> Term_type (n, map (fun t -> suffix i t) a)
- | Fun_type (a, r) -> Fun_type (map (fun t -> suffix i t) a, suffix i r)
- | Type_var n -> Type_var (n ^ "._." ^ (string_of_int i))
+ | TTerm (n, a) -> TTerm (n, map (fun t -> suffix i t) a)
+ | TVar (n, a, b, c) -> TVar (n ^ "._." ^ (string_of_int i), a, b, c)
(* --- Type Unification --- *)
@@ -28,12 +27,11 @@
(* Application of substitutions. *)
let rec apply subst tp =
let rec apply_var v = function
- | [] -> Type_var v
+ | [] -> TVar (v, [||], 0, [||])
| (n, ty) :: ss -> if (v = n) then ty else apply_var v ss in
match tp with
- | Type_var n -> apply_var n subst
- | Term_type (n, a) -> Term_type (n, map (apply subst) a)
- | Fun_type (a, r) -> Fun_type (map (apply subst) a, apply subst r)
+ | TVar (n, _, _, _) -> apply_var n subst
+ | TTerm (n, a) -> TTerm (n, map (apply subst) a)
exception UNIFY
@@ -47,19 +45,23 @@
where this algorithm is explained and similar code is given for terms. *)
let rec mgu = function
| ([], subst) -> subst
- | ((Type_var v, tp) :: tps, subst) ->
- if (Type_var v = tp) then mgu (tps, subst) else elim (v, tp, tps, subst)
- | ((tp, Type_var v) :: tps, subst) -> elim (v, tp, tps, subst)
- | ((Term_type (f, ts), Term_type (g, rs)) :: tps, subst) ->
- if f = g then mgu ((combine ts rs) @ tps, subst) else raise UNIFY
- | ((Fun_type (a1, r1), Fun_type (a2, r2)) :: tps, subst) ->
- mgu ((r1, r2) :: ((combine a1 a2) @ tps), subst)
- | _ -> raise UNIFY
+ | ((TVar (v, [||], 0, [||]) as var, tp) :: tps, subst) ->
+ if (var = tp) then mgu (tps, subst) else elim (v, tp, tps, subst)
+ | ((tp, TVar (v, [||], 0, [||])) :: tps, subst) -> elim (v, tp, tps, subst)
+ | ((TVar _, _) :: _, _) -> failwith "non-type var in type mgu (left)"
+ | ((_, TVar _) :: _, _) -> failwith "non-type var in type mgu (right)"
+ | ((TTerm (f, ts), TTerm (g, rs)) :: tps, subst) ->
+ if f = g then if f = fun_type_name then (
+ let l1, l2 = Array.length ts, Array.length rs in
+ let (a1, r1) = (Array.sub ts 0 (l1-1), ts.(l1-1)) in
+ let (a2, r2) = (Array.sub rs 0 (l2-1), rs.(l2-1)) in
+ mgu ((r1, r2) :: ((combine a1 a2) @ tps), subst)
+ ) else
+ mgu ((combine ts rs) @ tps, subst) else raise UNIFY
and elim (v, tp, tps, subst) =
let rec occurs s = function
- | Type_var n -> s = n
- | Term_type (_, a) -> exists (occurs s) a
- | Fun_type (a, r) -> (occurs s r) || exists (occurs s) a in
+ | TVar (n, _, _, _) -> s = n
+ | TTerm (_, a) -> exists (occurs s) a in
if occurs v tp then raise UNIFY else
let app = apply [(v, tp)] in
let new_tps = List.map (fun (t1,t2) -> (app t1, app t2)) tps in
@@ -74,17 +76,21 @@
let type_array_to_string ta =
String.concat ", " (to_list (map type_to_string ta)) in
match tp with
- | Type_var n -> "@? " ^ n
- | Term_type (n, a) ->
- if (length a = 0) then n else
- n ^ " (" ^ (type_array_to_string a) ^ ")"
- | Fun_type (a, r) ->
+ | TVar (n, [||], 0, [||]) -> "@? " ^ n
+ | TVar _ -> failwith "non-type var in type_to_string"
+ | TTerm (n, arr) when n = fun_type_name ->
+ let l = Array.length arr in
+ let (a, r) = (Array.sub arr 0 (l-1), arr.(l-1)) in
if (length a = 0) then
"@F (" ^ (type_to_string r) ^ ")"
else
"@F (" ^ (type_to_string r) ^ ", " ^ (type_array_to_string a) ^ ")"
+ | TTerm (n, a) ->
+ if (length a = 0) then n else
+ n ^ " (" ^ (type_array_to_string a) ^ ")"
+
(* Lexer for types and terms. *)
let split_to_list str =
let split_space s = Aux.split_spaces s in
@@ -113,15 +119,15 @@
split_special r1
let rec parse_type = function
- | (Aux.Delim "@?") :: (Aux.Text n) :: rest -> (Type_var n, rest)
+ | (Aux.Delim "@?") :: (Aux.Text n) :: rest -> (TVar (n, [||], 0, [||]), rest)
| (Aux.Delim "@F") :: rest ->
(match parse_list rest with
| ([], cont) -> failwith "Function w/o return type."
- | (r :: a, cont) -> (Fun_type (of_list a, r), cont)
+ | (r :: a, cont) -> (TTerm (fun_type_name, of_list (a @ [r])), cont)
)
| (Aux.Text n) :: rest ->
let (args, cont) = parse_list rest in
- (Term_type (n, of_list args), cont)
+ (TTerm (n, of_list args), cont)
| _ -> failwith "parse_type: no parse"
and parse_list = function
| (Aux.Delim "(") :: rest ->
Modified: trunk/Toss/Term/TermType.mli
===================================================================
--- trunk/Toss/Term/TermType.mli 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/TermType.mli 2012-06-15 21:24:23 UTC (rev 1725)
@@ -3,10 +3,10 @@
(** The type of term types. *)
type term_type =
- | Term_type of string * term_type array
- | Fun_type of term_type array * term_type
- | Type_var of string
+ | TTerm of string * term_type array
+ | TVar of string * term_type array * int * term_type array
+val fun_type_name : string
(** Suffix all type variables, useful for renaming. *)
val suffix : int -> term_type -> term_type
Modified: trunk/Toss/Term/TermTypeTest.ml
===================================================================
--- trunk/Toss/Term/TermTypeTest.ml 2012-06-15 15:23:31 UTC (rev 1724)
+++ trunk/Toss/Term/TermTypeTest.ml 2012-06-15 21:24:23 UTC (rev 1725)
@@ -4,8 +4,8 @@
let tests = "TermType" >::: [
"mgu" >::
(fun () ->
- let t = Term_type ("ala", [| Type_var("x"); Term_type("pies", [||]) |]) in
- let s = Term_type ("ala", [| Term_type("kot", [||]); Type_var("y") |]) in
+ let t = TTerm ("ala", [| TVar("x",[||],0,[||]); TTerm("pies", [||]) |]) in
+ let s = TTerm ("ala", [| TTerm("kot", [||]); TVar("y",[||],0,[||]) |]) in
let subst_str subst = String.concat ", " (List.map (fun (s, tp) ->
s ^ " <- " ^ (type_to_string tp)) subst) in
assert_equal ~printer:(fun x -> x) "y <- pies, x <- kot"
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-15 15:23:40
|
Revision: 1724
http://toss.svn.sourceforge.net/toss/?rev=1724&view=rev
Author: lukaszkaiser
Date: 2012-06-15 15:23:31 +0000 (Fri, 15 Jun 2012)
Log Message:
-----------
Allowing non-PNF QBFs and adding a separate SO evaluation function.
Modified Paths:
--------------
trunk/Toss/Client/State.js
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-06-09 20:09:07 UTC (rev 1723)
+++ trunk/Toss/Client/State.js 2012-06-15 15:23:31 UTC (rev 1724)
@@ -227,7 +227,7 @@
document.getElementById("svg").appendChild(r);
} else {
var circ = SHAPES.circle (
- elem.x, elem.y, 30,
+ elem.x, elem.y, SHAPES.circle_size,
[["id", "elem_" + elem.id], ["class", elem_class(elem.id)],
["onclick", "handle_elem_click('" + elem.id + "')"]]);
document.getElementById("svg").appendChild(circ);
@@ -269,9 +269,13 @@
if (sqrt * sqrt == this.elems.length && (sqrt > 4 || game=="Tic-Tac-Toe")) {
SHAPES.elem_size_x = SVG_WIDTH / (2.0 * (sqrt-1));
SHAPES.elem_size_y = SVG_HEIGHT / (2.0 * (sqrt-1));
+ } else if (this.elems.length < 30) {
+ SHAPES.elem_size_x = SVG_WIDTH / 20;
+ SHAPES.elem_size_y = SVG_HEIGHT / 20;
} else {
SHAPES.elem_size_x = SVG_WIDTH / 20;
- SHAPES.elem_size_y = SVG_HEIGHT / 20;
+ SHAPES.elem_size_y = SVG_WIDTH / 20;
+ SHAPES.circle_size = 300 / this.elems.length;
}
draw_background (game);
for (var i = 0; i < this.elems.length; i++) {
@@ -305,6 +309,7 @@
function Shapes () {
this.elem_size_x = 25; // suggested size of elements
this.elem_size_y = 25; // suggested size of elements
+ this.circle_size = 30;
var DEFpawn = '<g transform="translate(-22.5,-22.5)"> \
<path \
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-06-09 20:09:07 UTC (rev 1723)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-06-15 15:23:31 UTC (rev 1724)
@@ -892,13 +892,21 @@
(* Type for quantified Boolean formulas. *)
type qbf =
- | QFree of bool_formula
+ | QVar of int
+ | QNot of qbf
+ | QAnd of qbf list
+ | QOr of qbf list
| QEx of int list * qbf
| QAll of int list * qbf
(* Print a QBF formula. *)
let rec qbf_str = function
- | QFree phi -> str phi
+ | QVar v -> var_str v
+ | QNot phi -> "(not " ^ (qbf_str phi) ^ ")"
+ | QAnd [] -> "true"
+ | QOr [] -> "false"
+ | QAnd (qbflist) -> qbf_list_str " and " qbflist
+ | QOr (qbflist) -> qbf_list_str " or " qbflist
| QEx (vars, phi) ->
"(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
" " ^ qbf_str phi ^ ")"
@@ -906,7 +914,12 @@
"(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
" " ^ qbf_str phi ^ ")"
+and qbf_list_str sep = function
+ | [] -> "[]"
+ | [phi] -> qbf_str phi
+ | lst -> "(" ^ (String.concat sep (List.map qbf_str lst)) ^ ")"
+
(* Read a qdimacs description of a QBF from [in_ch]. *)
let read_qdimacs in_str =
let in_ch = ref in_str in
@@ -970,8 +983,7 @@
for i = 1 to (no_cl-1) do
cls := (read_clause (sinput_line ())) :: !cls
done;
- QFree (
- BAnd (List.map (fun lits -> BOr (List.map lit_of_int lits)) !cls))
+ QAnd (List.map (fun lits -> QOr (List.map (fun v -> QVar v) lits)) !cls)
) in
read_phi () in
@@ -980,7 +992,10 @@
(* Eliminating quantifiers from QBF formulas. *)
let rec elim_quant_rec = function
- | QFree (phi) -> phi
+ | QVar (v) -> BVar (v)
+ | QNot (f) -> BNot (elim_quant_rec f)
+ | QAnd (l) -> BAnd (List.map elim_quant_rec l)
+ | QOr (l) -> BOr (List.map elim_quant_rec l)
| QEx (vars, qphi) ->
Hashtbl.clear has_vars_mem;
let inside, len = elim_quant_rec qphi, List.length vars in
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-06-09 20:09:07 UTC (rev 1723)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-06-15 15:23:31 UTC (rev 1724)
@@ -5,7 +5,7 @@
(** This type describes formulas of relational logic with equality.
We allow only simple boolean junctors, other are resolved during parsing. *)
type bool_formula =
- BVar of int
+ | BVar of int
| BNot of bool_formula
| BAnd of bool_formula list
| BOr of bool_formula list
@@ -80,7 +80,10 @@
(** Type for quantified Boolean formulas. *)
type qbf =
- | QFree of bool_formula
+ | QVar of int
+ | QNot of qbf
+ | QAnd of qbf list
+ | QOr of qbf list
| QEx of int list * qbf
| QAll of int list * qbf
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-06-09 20:09:07 UTC (rev 1723)
+++ trunk/Toss/Solver/Solver.ml 2012-06-15 15:23:31 UTC (rev 1724)
@@ -393,6 +393,9 @@
Hashtbl.clear !re_cache_results;
List.iter (fun (p, r) -> Hashtbl.add !re_cache_results p r) !ok_re
+(* Evaluation with second-order variables. *)
+let eval_so struc phi =
+ Empty
(* Eval with very basic caching. *)
let eval_m struc phi =
@@ -405,12 +408,21 @@
res
with Not_found ->
LOG 1 "Eval_m %s" (str phi);
- let els = Assignments.set_to_set_list (Structure.elems struc) in
- check_timeout "Solver.eval_m.not_found";
- let asg = eval [] struc els Any phi in
- incr eval_counter;
- Hashtbl.add !cache_results phi (asg, phi_rels phi);
- asg
+ let vars = FormulaSubst.all_vars phi in
+ if List.exists (fun v -> Formula.is_so v) vars then (
+ check_timeout "Solver.eval_m.not_found_so";
+ let asg = eval_so struc phi in
+ incr eval_counter;
+ Hashtbl.add !cache_results phi (asg, phi_rels phi);
+ asg
+ ) else (
+ let els = Assignments.set_to_set_list (Structure.elems struc) in
+ check_timeout "Solver.eval_m.not_found_noso";
+ let asg = eval [] struc els Any phi in
+ incr eval_counter;
+ Hashtbl.add !cache_results phi (asg, phi_rels phi);
+ asg
+ )
)
(* Evaluate real expressions. Result is represented as assignments with
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-06-09 20:09:07 UTC (rev 1723)
+++ trunk/Toss/Solver/SolverTest.ml 2012-06-15 15:23:31 UTC (rev 1724)
@@ -165,6 +165,13 @@
"{ z->1, z->2, z->3 }";
);
+ "eval: second-order" >::
+ (fun () ->
+ eval_eq "[ a, b | T { a } | ]"
+ "ex |R all x, y (|R (x, y) <-> (T(x) and not T(y)))"
+ "T";
+ );
+
"eval: game heuristic tests" >::
(fun () ->
let heur_phi = "(((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
