walther@59866
|
1 |
(* Title: "BaseDefinitions/rewrite-order.sml"
|
walther@59860
|
2 |
Author: Walther Neuper
|
walther@59860
|
3 |
(c) due to copyright terms
|
walther@59860
|
4 |
*)
|
walther@59860
|
5 |
|
walther@59860
|
6 |
"-----------------------------------------------------------------------------------------------";
|
walther@59860
|
7 |
"table of contents -----------------------------------------------------------------------------";
|
walther@59860
|
8 |
"-----------------------------------------------------------------------------------------------";
|
walther@60324
|
9 |
"-------- identify difference in term-order between isa=NEW, isa2+OLD --------------------------";
|
walther@60324
|
10 |
"-------- check simple terms -------------------------------------------------------------------";
|
walther@60324
|
11 |
"-------- check all 'not >' in trace of Test_simplify on: x + 1 + - 1 * 2 = 0 ------------------";
|
walther@59860
|
12 |
"-----------------------------------------------------------------------------------------------";
|
walther@59860
|
13 |
"-----------------------------------------------------------------------------------------------";
|
walther@59860
|
14 |
"-----------------------------------------------------------------------------------------------";
|
walther@59860
|
15 |
|
walther@59860
|
16 |
|
walther@60324
|
17 |
"-------- identify difference in term-order between isa=NEW, isa2+OLD --------------------------";
|
walther@60324
|
18 |
"-------- identify difference in term-order between isa=NEW, isa2+OLD --------------------------";
|
walther@60324
|
19 |
"-------- identify difference in term-order between isa=NEW, isa2+OLD --------------------------";
|
Walther@60565
|
20 |
val form = TermC.parse_test @{context} "x + -2 ::real"
|
walther@60324
|
21 |
val Repeat {rew_ord = ("sqrt_right", rew_ord_), erls, ...} = Test_simplify;
|
Walther@60500
|
22 |
val ctxt = Proof_Context.init_global @{theory Test};
|
Walther@60500
|
23 |
(*Rewrite.trace_on := false; (*true false*)*)
|
walther@60324
|
24 |
(** )val NONE = ( *isa*)
|
walther@60324
|
25 |
(**)val SOME (form', _) = (*isa2*)
|
Walther@60500
|
26 |
rewrite_ ctxt rew_ord_ erls true @{thm radd_commute} form;
|
walther@60324
|
27 |
(*
|
walther@60324
|
28 |
-------------------- code in rew_sub -------------------------------------------------------
|
walther@60330
|
29 |
(
|
walther@60324
|
30 |
@{print}{a = "@@@rew_sub.ord.rew: ", perm = TermC.perm lhs rhs, tless = not (tless bdv (t', t))};
|
walther@60324
|
31 |
if TermC.perm lhs rhs andalso not (tless bdv (t', t)) (*ordered rewriting*)
|
walther@60324
|
32 |
then (trace_eq2 i "not >" thy t t'; raise NO_REWRITE)
|
walther@60324
|
33 |
else (t'', p'', [], true)
|
walther@60330
|
34 |
)
|
walther@60324
|
35 |
-------------------- output with Rewrite.trace_on := true; ---------------------------------
|
walther@60324
|
36 |
## eval asms: "x + -2 = -2 + x"
|
walther@60324
|
37 |
{a = "@@@rew_sub.ord.rew: ", b = true, c = false}
|
walther@60324
|
38 |
*)
|
walther@60324
|
39 |
"~~~~~ fun rewrite_ , args:"; val (thy, rew_ord, erls, bool, thm, term) =
|
walther@60324
|
40 |
(@{theory Test}, rew_ord_, erls, true, @{thm radd_commute}, form);
|
walther@60324
|
41 |
|
walther@60324
|
42 |
"~~~~~ fun rewrite__ , args:"; val (thy, i, bdv, tless, rls, put_asm, thm, ct) =
|
Walther@60477
|
43 |
(thy, 1, []: Subst.T, rew_ord, erls, bool, thm, term);
|
walther@60324
|
44 |
|
walther@60324
|
45 |
val (t', asms, _(*lrd*), rew) =
|
Walther@60500
|
46 |
rew_sub ctxt i bdv tless rls put_asm ([(*root of the term*)]: TermC.path)
|
walther@60324
|
47 |
(TermC.inst_bdv bdv (Eval.norm (Thm.prop_of thm))) ct;
|
walther@60324
|
48 |
"~~~~~ fun rew_sub , args:"; val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) =
|
walther@60324
|
49 |
(thy, i, bdv, tless, rls, put_asm, ([(*root of the term*)]: TermC.path),
|
walther@60324
|
50 |
(TermC.inst_bdv bdv (Eval.norm (Thm.prop_of thm))), ct);
|
walther@60324
|
51 |
val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl) r
|
walther@60324
|
52 |
val r' = (Envir.subst_term (Pattern.match thy (lhs, t) (Vartab.empty, Vartab.empty)) r)
|
walther@60324
|
53 |
handle Pattern.MATCH => raise NO_REWRITE
|
walther@60324
|
54 |
val p' = map HOLogic.dest_Trueprop ((fst o Logic.strip_prems) (Logic.count_prems r', [], r'))
|
walther@60324
|
55 |
val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl) r'
|
Walther@60500
|
56 |
val _ = trace_in2 ctxt i "eval asms" r';
|
walther@60324
|
57 |
val (t'', p'') = (*conditional rewriting*)
|
Walther@60500
|
58 |
let val (simpl_p', nofalse) = Rewrite.eval__true ctxt (i + 1) p' bdv rls
|
walther@60324
|
59 |
in
|
walther@60324
|
60 |
if nofalse
|
Walther@60500
|
61 |
then (trace_in4 ctxt i "asms accepted" p' simpl_p'; (t',simpl_p'))(* uncond.rew.from above*)
|
Walther@60500
|
62 |
else (trace_in5 ctxt i "asms false" p'; raise NO_REWRITE) (* don't go into subtm.of cond*)
|
walther@60324
|
63 |
end;
|
walther@60324
|
64 |
(*if*) TermC.perm lhs rhs andalso not (tless bdv (t', t)); (*ordered rewriting*)
|
walther@60324
|
65 |
not (tless bdv (t', t)); (*isa = true , isa2 = false*)
|
walther@60324
|
66 |
(tless bdv (t', t)); (*isa = false, isa2 = true*)
|
walther@60324
|
67 |
(*WHAT IS ..:
|
walther@60324
|
68 |
tless <-- Repeat {rew_ord = ("sqrt_right", rew_ord_), erls, ...} = Test_simplify; ..in Test_Some.thy
|
walther@60324
|
69 |
rew_ord_ <-- sqrt_right false @{theory "Pure"} ..in Test.thy
|
walther@60324
|
70 |
sqrt_right ..in Root.thy
|
walther@60324
|
71 |
CHECK THIS ...(same error as with ^^^^^^^^^tless
|
walther@60324
|
72 |
CHECK THIS ...(same error as with code copied into Test_Some.thy
|
walther@60324
|
73 |
*)
|
walther@60324
|
74 |
if (sqrt_right false @{theory "Pure"} bdv (t', t)) (*isa = false, isa2 = true*)
|
walther@60324
|
75 |
(** )then error "sqrt_right: special case NOT ok" else (); ( *isa*)
|
walther@60324
|
76 |
(**)then () else error "sqrt_right: special case OK"; (*isa2*)
|
walther@60324
|
77 |
"~~~~~ fun sqrt_right , args:"; val ((pr:bool), thy, (_: subst), tu) =
|
walther@60324
|
78 |
(false, @{theory "Pure"}, bdv, (t', t));
|
walther@60324
|
79 |
|
walther@60324
|
80 |
"~~~~~ fun term_ord' , args:"; val (pr, _(*thy*), (t, u)) = (pr, thy(***), tu);
|
walther@60324
|
81 |
(*//----------------------------- open local ------------------------------------------------\\* )
|
walther@60324
|
82 |
val EQUAL =
|
walther@60324
|
83 |
(*case*) int_ord (size_of_term' t, size_of_term' u) (*of*);
|
walther@60324
|
84 |
val (f, ts) = strip_comb t and (g, us) = strip_comb u
|
walther@60324
|
85 |
val EQUAL =
|
walther@60324
|
86 |
(*case*) hd_ord (f, g) (*of*);
|
walther@60324
|
87 |
|
walther@60324
|
88 |
(**)val GREATER = (*isa*)
|
walther@60324
|
89 |
(** )val LESS = ( *isa2*)
|
walther@60324
|
90 |
terms_ord str pr (ts, us)
|
walther@60324
|
91 |
"~~~~~ and terms_ord , args:"; val (_(*str*), pr, (ts, us)) = (str, pr, (ts, us));
|
walther@60324
|
92 |
|
walther@60324
|
93 |
list_ord (term_ord' pr (ThyC.get_theory "Isac_Knowledge")) (ts, us);
|
walther@60324
|
94 |
(*+*)list_ord: ('a * 'b -> order) -> 'a list * 'b list -> order;
|
walther@60324
|
95 |
(*+*)term_ord' pr (ThyC.get_theory "Isac_Knowledge"): term * term -> order;
|
walther@60324
|
96 |
"~~~~~ fun list_ord , args:"; val (elem_ord, (xs, ys)) =
|
walther@60324
|
97 |
((term_ord' pr (ThyC.get_theory "Isac_Knowledge")), (ts, us));
|
walther@60324
|
98 |
(*+*)UnparseC.terms xs = "[\"- 2\", \"x\"]"; (*isa == ?*)
|
walther@60324
|
99 |
(*+*)UnparseC.terms ys = "[\"x\", \"- 2\"]"; (*isa == ?*)
|
walther@60324
|
100 |
val EQUAL =
|
walther@60324
|
101 |
(*case*) int_ord (length xs, length ys) (*of*);
|
walther@60324
|
102 |
|
walther@60324
|
103 |
val GREATER =
|
walther@60324
|
104 |
dict_ord elem_ord (xs, ys);
|
walther@60324
|
105 |
"~~~~~ fun dict_ord , args:"; val ( elem_ord, (x :: xs, y :: ys)) = (elem_ord, (xs, ys))
|
walther@60324
|
106 |
val GREATER =
|
walther@60324
|
107 |
(*case*) elem_ord (x, y) (*of*);
|
walther@60324
|
108 |
val return = GREATER;
|
walther@60324
|
109 |
( *\\----------------------------- open local ------------------------------------------------//*)
|
walther@60324
|
110 |
|
walther@60324
|
111 |
|
walther@60324
|
112 |
"-------- check simple terms -------------------------------------------------------------------";
|
walther@60324
|
113 |
"-------- check simple terms -------------------------------------------------------------------";
|
walther@60324
|
114 |
"-------- check simple terms -------------------------------------------------------------------";
|
walther@60324
|
115 |
val rew_ord_ = sqrt_right false @{theory "Pure"};
|
walther@60324
|
116 |
|
walther@60324
|
117 |
if rew_ord_ [] (@{term "1::real"}, @{term "2::real"}) = true then () else error "";
|
walther@60324
|
118 |
if rew_ord_ [] (@{term "3::real"}, @{term "2::real"}) = false then () else error "";
|
walther@60324
|
119 |
|
walther@60324
|
120 |
if rew_ord_ [] (@{term "-1::real"}, @{term "-2::real"}) = true then () else error "";
|
walther@60324
|
121 |
if rew_ord_ [] (@{term "-3::real"}, @{term "-2::real"}) = false then () else error "";
|
walther@60324
|
122 |
|
walther@60324
|
123 |
if rew_ord_ [] (@{term "1::real"}, @{term "-1::real"}) = false then () else error "";
|
walther@60324
|
124 |
if rew_ord_ [] (@{term "-1::real"}, @{term "1::real"}) = true then () else error "";
|
walther@60324
|
125 |
|
walther@60324
|
126 |
if rew_ord_ [] (@{term "x::real"}, @{term "2::real"}) = false then () else error "";
|
walther@60324
|
127 |
if rew_ord_ [] (@{term "3::real"}, @{term "x::real"}) = true then () else error "";
|
walther@60324
|
128 |
|
walther@60324
|
129 |
|
walther@60324
|
130 |
"-------- check all 'not >' in trace of Test_simplify on: x + 1 + - 1 * 2 = 0 ------------------";
|
walther@60324
|
131 |
"-------- check all 'not >' in trace of Test_simplify on: x + 1 + - 1 * 2 = 0 ------------------";
|
walther@60324
|
132 |
"-------- check all 'not >' in trace of Test_simplify on: x + 1 + - 1 * 2 = 0 ------------------";
|
walther@60324
|
133 |
(* the rewrite-order for rewriting single theorems in a Rule_Set is taken from
|
walther@60324
|
134 |
*)
|
walther@60324
|
135 |
val Repeat {rew_ord = ("sqrt_right", rew_ord_), erls, ...} = Test_simplify;
|
walther@60324
|
136 |
(*# rls: Test_simplify on: x + 1 + - 1 * 2 = 0 ..selected "not >:" from trace:*)
|
walther@60324
|
137 |
|
walther@60324
|
138 |
(*## not >: "x + 1 + - 1 * 2" > "x + 1 + - 1 * 2" *)
|
walther@60324
|
139 |
if rew_ord_ [] (@{term "x + 1 + - 1 * 2::real"}, @{term "x + 1 + - 1 * 2::real"}) = false
|
walther@60324
|
140 |
then () else error "term_ord' 1";
|
walther@60324
|
141 |
|
walther@60324
|
142 |
(*## not >: "1 + x + - 1 * 2" > "- 1 * 2 + (1 + x)" *)
|
walther@60324
|
143 |
if rew_ord_ [] (@{term "1 + x + - 1 * 2::real"}, @{term "- 1 * 2 + (1 + x)::real"}) = true
|
walther@60324
|
144 |
then () else error "term_ord' 2";
|
walther@60324
|
145 |
|
walther@60324
|
146 |
(*## not >: "1 + x" > "x + 1" *)
|
walther@60324
|
147 |
if rew_ord_ [] (@{term "1 + x::real"}, @{term "x + 1::real"}) = true
|
walther@60324
|
148 |
then () else error "term_ord' 3";
|
walther@60324
|
149 |
|
walther@60324
|
150 |
(*## not >: "- 1 * 2" > "2 * - 1" *)
|
walther@60324
|
151 |
if rew_ord_ [] (@{term "- 1 * 2::real"}, @{term "2 * - 1::real"}) = true
|
walther@60324
|
152 |
then () else error "term_ord' 4";
|
walther@60324
|
153 |
|
walther@60324
|
154 |
(*## not >: "1 + (x + - 2)" > "x + - 2 + 1" *)
|
walther@60324
|
155 |
if rew_ord_ [] (@{term "1 + (x + - 2)::real"}, @{term "x + - 2 + 1::real"}) = true
|
walther@60324
|
156 |
then () else error "term_ord' 5";
|
walther@60324
|
157 |
|
walther@60324
|
158 |
(*## not >: "x + - 2" > "- 2 + x"*)
|
walther@60324
|
159 |
if rew_ord_ [] (@{term "x + - 2::real"}, @{term "- 2 + x ::real"}) = false
|
walther@60324
|
160 |
then () else error "term_ord' 5a"; (*<<<<<<<<<<<<<<----------------- false in trace isa2*)
|
walther@60324
|
161 |
|
walther@60324
|
162 |
(*--------------------------------- ordered rew. (NOT) inhibited*)
|
walther@60324
|
163 |
|
walther@60324
|
164 |
(*## not >: "1 + (-2 + x)" > "-2 + x + 1" *)
|
walther@60324
|
165 |
if rew_ord_ [] (@{term "1 + (-2 + x)::real"}, @{term "-2 + x + 1::real"}) = true
|
walther@60324
|
166 |
then () else error "term_ord' 6";
|
walther@60324
|
167 |
|
walther@60324
|
168 |
(*## not >: "- 2 + x" > "x + - 2" *)
|
walther@60324
|
169 |
if rew_ord_ [] (@{term "- 2 + x::real"}, @{term "x + - 2::real"}) = true
|
walther@60324
|
170 |
then () else error "term_ord' 7";
|
walther@60324
|
171 |
|
walther@60324
|
172 |
(*## not >: "- 2 + (1 + x)" > "1 + (- 2 + x)" *)
|
walther@60324
|
173 |
if rew_ord_ [] (@{term "- 2 + (1 + x)::real"}, @{term "1 + (- 2 + x)::real"}) = true
|
walther@60324
|
174 |
then () else error "term_ord' 8";
|
walther@60324
|
175 |
|
walther@60324
|
176 |
(*## not > "- 1 + x" > "x + - 1" *)
|
walther@60324
|
177 |
if rew_ord_ [] (@{term "- 1 + x::real"}, @{term "x + - 1::real"}) = true
|
walther@60324
|
178 |
then () else error "term_ord' 9";
|