test/Tools/isac/ProgLang/rewrite.sml
author Walther Neuper <neuper@ist.tugraz.at>
Thu, 28 Jul 2011 10:58:17 +0200
branchdecompose-isar
changeset 42223 14faebbac7bb
parent 42201 622e82c76fd7
child 42224 46e72a5805b1
permissions -rw-r--r--
tuned
neuper@38036
     1
(* Title: tests for ProgLang/rewrite.sml
neuper@37906
     2
   TODO.WN0509 collect typical tests from systest here !!!!!
neuper@38036
     3
   Author: Walther Neuper 050908
neuper@37906
     4
   (c) copyright due to lincense terms.
neuper@37906
     5
neuper@38022
     6
12345678901234567890123456789012345678901234567890123456789012345678901234567890
neuper@38022
     7
        10        20        30        40        50        60        70        80
neuper@37906
     8
*)
neuper@37906
     9
neuper@38022
    10
"--------------------------------------------------------";
neuper@38022
    11
"table of contents --------------------------------------";
neuper@38022
    12
"--------------------------------------------------------";
neuper@38022
    13
"----------- assemble rewrite ---------------------------";
neuper@38022
    14
"----------- test rewriting without Isac's thys ---------";
neuper@38022
    15
"----------- conditional rewriting without Isac's thys --";
neuper@38022
    16
"----------- step through 'and rew_sub': ----------------";
neuper@38025
    17
"----------- step through 'fun rewrite_terms_'  ---------";
neuper@38022
    18
"----------- rewrite_inst_ bdvs -------------------------";
neuper@38022
    19
"----------- check diff 2002--2009-3 --------------------";
neuper@38039
    20
"----------- compare all prepat's existing 2010 ---------";
neuper@38039
    21
"----------- fun app_rev, Rrls, -------------------------";
neuper@42223
    22
"----------- 2011 thms with axclasses -------------------";
neuper@38022
    23
"--------------------------------------------------------";
neuper@38022
    24
"--------------------------------------------------------";
neuper@38022
    25
"--------------------------------------------------------";
neuper@37906
    26
neuper@38036
    27
neuper@38022
    28
"----------- assemble rewrite ---------------------------";
neuper@38022
    29
"----------- assemble rewrite ---------------------------";
neuper@38022
    30
"----------- assemble rewrite ---------------------------";
neuper@37906
    31
"===== rewriting by thm with 'a";
neuper@41924
    32
(*show_types := true;*)
akargl@42188
    33
neuper@37906
    34
val thy = @{theory Complex_Main};
neuper@37906
    35
val ctxt = @{context};
neuper@37906
    36
val thm = @{thm add_commute};
neuper@37906
    37
val t = (term_of o the) (parse thy "((r + u) + t) + s");
neuper@37906
    38
"----- from old: fun rewrite__";
neuper@37906
    39
val bdv = [];
neuper@37906
    40
val r = (((inst_bdv bdv) o norm o #prop o rep_thm) thm);
neuper@37906
    41
"----- from old: and rew_sub";
neuper@41942
    42
val (LHS,RHS) = (dest_equals' o strip_trueprop 
neuper@37906
    43
   	      o Logic.strip_imp_concl) r;
neuper@37906
    44
(* old
neuper@41942
    45
val insts = Pattern.match thy (LHS,t) (Vartab.empty, Vartab.empty);*)
neuper@37906
    46
"----- fun match_rew in Pure/pattern.ML";
neuper@41942
    47
val rtm = the_default RHS (Term.rename_abs LHS t RHS);
neuper@37906
    48
neuper@38022
    49
writeln(Syntax.string_of_term ctxt rtm);
neuper@41942
    50
writeln(Syntax.string_of_term ctxt LHS);
neuper@38022
    51
writeln(Syntax.string_of_term ctxt t);
neuper@37906
    52
neuper@41942
    53
(Pattern.match thy (LHS, t) (Vartab.empty, Vartab.empty));
neuper@41942
    54
val (rew, RHS) = (Envir.subst_term 
neuper@41942
    55
  (Pattern.match thy (LHS, t) (Vartab.empty, Vartab.empty)) rtm, rtm);
neuper@37906
    56
(*lookup in isabelle?trace?response...*)
neuper@37906
    57
writeln(Syntax.string_of_term ctxt rew);
neuper@41942
    58
writeln(Syntax.string_of_term ctxt RHS);
neuper@37906
    59
"===== rewriting: prep insertion into rew_sub";
neuper@37906
    60
val thy = @{theory Complex_Main};
neuper@37906
    61
val ctxt = @{context};
neuper@37906
    62
val thm =  @{thm nonzero_mult_divide_cancel_right};
neuper@37906
    63
val r = Thm.prop_of thm;
neuper@37906
    64
val tm = @{term "x*2 / 2::real"};
neuper@37906
    65
"----- and rew_sub";
neuper@41942
    66
val (LHS, RHS) = (HOLogic.dest_eq o HOLogic.dest_Trueprop
neuper@37906
    67
                  o Logic.strip_imp_concl) r;
neuper@41942
    68
val r' = Envir.subst_term (Pattern.match thy (LHS, tm) 
neuper@37906
    69
                                (Vartab.empty, Vartab.empty)) r;
neuper@37906
    70
val p' = (fst o Logic.strip_prems) (Logic.count_prems r', [], r');
neuper@37906
    71
val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop 
neuper@37906
    72
            o Logic.strip_imp_concl) r';
neuper@37906
    73
neuper@37906
    74
(*is displayed on top of <response> buffer...*)
neuper@37906
    75
Pretty.writeln (ProofContext.pretty_term_abbrev @{context} r');
neuper@37906
    76
Pretty.writeln (ProofContext.pretty_term_abbrev @{context} t');
akargl@42188
    77
(**)
neuper@37906
    78
neuper@38022
    79
"----------- test rewriting without Isac's thys ---------";
neuper@38022
    80
"----------- test rewriting without Isac's thys ---------";
neuper@38022
    81
"----------- test rewriting without Isac's thys ---------";
neuper@38022
    82
neuper@37906
    83
"===== rewriting with Isabelle2009-1 only, i.e without isac-hacks";
neuper@37906
    84
val thy = @{theory Complex_Main};
neuper@37906
    85
val ctxt = @{context};
neuper@37906
    86
val thm =  @{thm add_commute};
neuper@37906
    87
val tm = @{term "x + y*z::real"};
neuper@37906
    88
neuper@37906
    89
val SOME (r,_) = (rewrite_ thy dummy_ord e_rls false thm tm)
neuper@38022
    90
  handle _ => error "rewrite.sml diff.behav. in rewriting";
neuper@37906
    91
(*is displayed on _TOP_ of <response> buffer...*)
neuper@37906
    92
Pretty.writeln (ProofContext.pretty_term_abbrev @{context} r);
neuper@38022
    93
if r = @{term "y*z + x::real"}
neuper@38022
    94
then () else error "rewrite.sml diff.result in rewriting";
neuper@37906
    95
neuper@37906
    96
"----- rewriting a subterm";
neuper@37906
    97
val tm = @{term "w*(x + y*z)::real"};
neuper@37906
    98
neuper@37906
    99
val SOME (r,_) = (rewrite_ thy dummy_ord e_rls false thm tm)
neuper@38022
   100
  handle _ => error "rewrite.sml diff.behav. in rew_sub";
neuper@37906
   101
neuper@37906
   102
"----- ordered rewriting";
neuper@38022
   103
fun tord (_:subst) pp = Term_Ord.termless pp;
neuper@37906
   104
if tord [] (@{term "x + y*z::real"}, @{term "y*z + x::real"}) then ()
neuper@38022
   105
else error "rewrite.sml diff.behav. in ord.rewr.";
neuper@37906
   106
neuper@37906
   107
val NONE = (rewrite_ thy tord e_rls false thm tm)
neuper@38022
   108
  handle _ => error "rewrite.sml diff.behav. in rewriting";
neuper@37906
   109
(*is displayed on _TOP_ of <response> buffer...*)
neuper@37906
   110
Pretty.writeln (ProofContext.pretty_term_abbrev @{context} r);
neuper@37906
   111
neuper@37906
   112
val tm = @{term "x*y + z::real"};
neuper@37906
   113
val SOME (r,_) = (rewrite_ thy tord e_rls false thm tm)
neuper@38022
   114
  handle _ => error "rewrite.sml diff.behav. in rewriting";
neuper@37906
   115
neuper@37906
   116
neuper@38022
   117
"----------- conditional rewriting without Isac's thys --";
neuper@38022
   118
"----------- conditional rewriting without Isac's thys --";
neuper@38022
   119
"----------- conditional rewriting without Isac's thys --";
neuper@37906
   120
(*ML {*)
neuper@37906
   121
"===== prepr cond.rew. with Pattern.match";
neuper@37906
   122
val thy = @{theory Complex_Main};
neuper@37906
   123
val ctxt = @{context};
neuper@37906
   124
val thm =  @{thm nonzero_mult_divide_cancel_right};
neuper@37906
   125
val rule = Thm.prop_of thm;
neuper@37906
   126
val tm = @{term "x*2 / 2::real"};
neuper@37906
   127
neuper@37906
   128
val prem = Logic.strip_imp_prems rule;
neuper@37906
   129
val nps = Logic.count_prems rule;
neuper@37906
   130
val prems = Logic.strip_prems (nps, [], rule);
neuper@37906
   131
neuper@37906
   132
val eq = Logic.strip_imp_concl rule;
neuper@41942
   133
val (LHS, RHS) = (HOLogic.dest_eq o HOLogic.dest_Trueprop) eq;
neuper@37906
   134
neuper@41942
   135
val mtcs = Pattern.match thy (LHS, tm) (Vartab.empty, Vartab.empty);
neuper@37906
   136
val rule' = Envir.subst_term mtcs rule;
neuper@37906
   137
neuper@37906
   138
val prems' = (fst o Logic.strip_prems) 
neuper@37906
   139
              (Logic.count_prems rule', [], rule');
neuper@41942
   140
val RHS' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop 
neuper@37906
   141
            o Logic.strip_imp_concl) rule';
neuper@37906
   142
neuper@37906
   143
"----- conditional rewriting creating an assumption";
neuper@37906
   144
"----- conditional rewriting creating an assumption";
neuper@37906
   145
val tm = @{term "x*y / y::real"};
neuper@38022
   146
val SOME (rew, asm) = (rewrite_ thy dummy_ord e_rls false thm tm)
neuper@38022
   147
  handle _ => error "rewrite.sml diff.behav. in cond.rew.";
neuper@37906
   148
neuper@38022
   149
if rew = @{term "x::real"} then () (* the rewrite is _NO_ Trueprop *)
neuper@38022
   150
else error "rewrite.sml diff.result in cond.rew.";
neuper@37906
   151
neuper@38022
   152
if hd asm = @{term "~ y = (0::real)"} (* dropped Trueprop $ ...*)
neuper@38022
   153
then () else error "rewrite.sml diff.asm in cond.rew.";
neuper@38022
   154
"----- conditional rewriting immediately: can only be done with ";
neuper@38022
   155
"------Isabelle numerals, because erls cannot handle them yet.";
neuper@37906
   156
neuper@37906
   157
neuper@38022
   158
"----------- step through 'and rew_sub': ----------------";
neuper@38022
   159
"----------- step through 'and rew_sub': ----------------";
neuper@38022
   160
"----------- step through 'and rew_sub': ----------------";
neuper@38022
   161
(*and make asms without Trueprop, beginning with the result:*)
neuper@38025
   162
val tm = @{term "x*y / y::real"};
neuper@38022
   163
val (t', asm, _, _) = rew_sub thy 0 [] dummy_ord e_rls true [] (prop_of thm) tm;
neuper@41924
   164
(*show_types := false;*)
neuper@38022
   165
"----- evaluate arguments";
neuper@38022
   166
val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) = 
neuper@38022
   167
    (thy, 0, [], dummy_ord, e_rls, true, [], (prop_of thm), tm);
neuper@41942
   168
"----- step 1: LHS, RHS of rule";
neuper@41942
   169
     val (LHS, RHS) = (HOLogic.dest_eq o HOLogic.dest_Trueprop
neuper@38022
   170
                       o Logic.strip_imp_concl) r;
neuper@38025
   171
term2str r = "?b ~= (0::?'a) ==> ?a * ?b / ?b = ?a";
neuper@41942
   172
term2str LHS = "?a * ?b / ?b"; term2str RHS = "?a";
neuper@38022
   173
"----- step 2: the rule instantiated";
neuper@38025
   174
     val r' = Envir.subst_term 
neuper@41942
   175
                  (Pattern.match thy (LHS, t) (Vartab.empty, Vartab.empty)) r;
neuper@38022
   176
term2str r' = "y ~= 0 ==> x * y / y = x";
neuper@38022
   177
"----- step 3: get the (instantiated) assumption(s)";
neuper@38022
   178
     val p' = (fst o Logic.strip_prems) (Logic.count_prems r', [], r');
neuper@38022
   179
term2str (hd p') = "y ~= 0";
neuper@38022
   180
"=====vvv make asms without Trueprop ---vvv";
neuper@38022
   181
     val p' = map HOLogic.dest_Trueprop ((fst o Logic.strip_prems) 
neuper@38022
   182
                                             (Logic.count_prems r', [], r'));
neuper@38022
   183
case p' of
neuper@41928
   184
    [Const ("HOL.Not", _) $ (Const ("HOL.eq", _) $ Free ("y", _) $
neuper@38022
   185
                               Const ("Groups.zero_class.zero", _))] => ()
neuper@38022
   186
  | _ => error "rewrite.sml assumption changed";
neuper@38022
   187
"=====^^^ make asms without Trueprop ---^^^";
neuper@41942
   188
"----- step 4: get the (instantiated) RHS";
neuper@38022
   189
     val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop 
neuper@38022
   190
               o Logic.strip_imp_concl) r';
neuper@38022
   191
term2str t' = "x";
neuper@37906
   192
neuper@38025
   193
"----------- step through 'fun rewrite_terms_'  ---------";
neuper@38025
   194
"----------- step through 'fun rewrite_terms_'  ---------";
neuper@38025
   195
"----------- step through 'fun rewrite_terms_'  ---------";
neuper@38025
   196
"----- step 0: args for rewrite_terms_, local fun";
neuper@38025
   197
val (thy, ord, erls, equs, t) =
neuper@41928
   198
    (@{theory "Biegelinie"}, dummy_ord, Erls, [str2term "x = 0"],
neuper@38025
   199
     str2term "M_b x = -1 * q_0 * x ^^^ 2 / 2 + x * c + c_2");
neuper@38025
   200
"----- step 1: args for rew_";
neuper@38025
   201
val ((t', asm'), (rules as r::rs), t) = ((e_term, []), equs, t);
neuper@38025
   202
"----- step 2: rew_sub";
neuper@38025
   203
rew_sub thy 1 [] ord erls false [] (Trueprop $ r) t;
neuper@38025
   204
"----- step 3: step through rew_sub -- inefficient: goes into subterms";
neuper@38025
   205
neuper@38025
   206
neuper@38025
   207
val SOME (t', _) = rewrite_terms_ thy dummy_ord Erls equs t;
neuper@38025
   208
writeln "----------- rewrite_terms_  1---------------------------";
neuper@37906
   209
if term2str t' = "M_b 0 = -1 * q_0 * 0 ^^^ 2 / 2 + 0 * c + c_2" then ()
neuper@38031
   210
else error "rewrite.sml rewrite_terms_ [x = 0]";
neuper@37906
   211
neuper@38025
   212
val equs = [str2term "M_b 0 = 0"];
neuper@38025
   213
val t = str2term "M_b 0 = -1 * q_0 * 0 ^^^ 2 / 2 + 0 * c + c_2";
neuper@38025
   214
val SOME (t', _) = rewrite_terms_ thy dummy_ord Erls equs t;
neuper@38025
   215
writeln "----------- rewrite_terms_  2---------------------------";
neuper@37906
   216
if term2str t' = "0 = -1 * q_0 * 0 ^^^ 2 / 2 + 0 * c + c_2" then ()
neuper@38031
   217
else error "rewrite.sml rewrite_terms_ [M_b 0 = 0]";
neuper@37906
   218
neuper@38025
   219
val equs = [str2term "x = 0", str2term"M_b 0 = 0"];
neuper@38025
   220
val t = str2term "M_b x = -1 * q_0 * x ^^^ 2 / 2 + x * c + c_2";
neuper@38025
   221
val SOME (t', _) = rewrite_terms_ thy dummy_ord Erls equs t;
neuper@38025
   222
writeln "----------- rewrite_terms_  3---------------------------";
neuper@37906
   223
if term2str t' = "0 = -1 * q_0 * 0 ^^^ 2 / 2 + 0 * c + c_2" then ()
neuper@38031
   224
else error "rewrite.sml rewrite_terms_ [x = 0, M_b 0 = 0]";
neuper@37906
   225
neuper@37906
   226
neuper@38022
   227
"----------- rewrite_inst_ bdvs -------------------------";
neuper@38022
   228
"----------- rewrite_inst_ bdvs -------------------------";
neuper@38022
   229
"----------- rewrite_inst_ bdvs -------------------------";
neuper@37906
   230
(*see smltest/Scripts/term_G.sml: inst_bdv 2*)
neuper@37906
   231
val t = str2term"-1 * (q_0 * L ^^^ 2) / 2 + (L * c_3 + c_4) = 0";
neuper@37906
   232
val bdvs = [(str2term"bdv_1",str2term"c"),
neuper@37906
   233
	    (str2term"bdv_2",str2term"c_2"),
neuper@37906
   234
	    (str2term"bdv_3",str2term"c_3"),
neuper@37906
   235
	    (str2term"bdv_4",str2term"c_4")];
neuper@37906
   236
(*------------ outcommented WN071210, after inclusion into ROOT.ML 
neuper@37926
   237
val SOME (t,_) = 
neuper@37906
   238
    rewrite_inst_ thy e_rew_ord 
neuper@37906
   239
		  (append_rls "erls_isolate_bdvs" e_rls 
neuper@37906
   240
			      [(Calc ("EqSystem.occur'_exactly'_in", 
neuper@37906
   241
				      eval_occur_exactly_in 
neuper@37906
   242
					  "#eval_occur_exactly_in_"))
neuper@37906
   243
			       ]) 
neuper@37967
   244
		  false bdvs (num_str @{separate_bdvs_add) t;
neuper@37906
   245
(writeln o term2str) t;
neuper@37906
   246
if term2str t = "L * c_3 + c_4 = 0 + -1 * (-1 * (q_0 * L ^^^ 2) / 2)"
neuper@38031
   247
then () else error "rewrite.sml rewrite_inst_ bdvs";
neuper@37906
   248
trace_rewrite:=true;
neuper@37906
   249
trace_rewrite:=false;--------------------------------------------*)
neuper@37906
   250
neuper@38025
   251
neuper@38022
   252
"----------- check diff 2002--2009-3 --------------------";
neuper@38022
   253
"----------- check diff 2002--2009-3 --------------------";
neuper@38022
   254
"----------- check diff 2002--2009-3 --------------------";
neuper@38022
   255
(*----- 2002 -------------------------------------------------------------------
neuper@38022
   256
#  rls: norm_Rational_noadd_fractions on: 1 / EI * (L * q_0 * x / 2 + -1 *
neuper@38022
   257
q_0 * x ^^^ 2 / 2)
neuper@38022
   258
##  rls: discard_minus_ on: 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2
neuper@38022
   259
/ 2)
neuper@38022
   260
###  try thm: real_diff_minus
neuper@38022
   261
###  try thm: sym_real_mult_minus1
neuper@38022
   262
##  rls: rat_mult_poly on: 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2
neuper@38022
   263
/ 2)
neuper@38022
   264
###  try thm: rat_mult_poly_l
neuper@38022
   265
###  try thm: rat_mult_poly_r
neuper@38022
   266
####  eval asms: L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2 is_polyexp
neuper@38022
   267
==> 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2) =
neuper@38022
   268
    1 * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2) / EI
neuper@38022
   269
#####  rls: e_rls-is_polyexp on: L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2
neuper@38022
   270
is_polyexp
neuper@38022
   271
######  try calc: Poly.is'_polyexp'
neuper@38022
   272
======  calc. to: False
neuper@38022
   273
######  try calc: Poly.is'_polyexp'
neuper@38022
   274
######  try calc: Poly.is'_polyexp'
neuper@38022
   275
####  asms false: ["L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2 is_polyexp"]
neuper@38022
   276
----- 2002 NONE rewrite --------------------------------------------------------
neuper@38022
   277
----- 2009 should maintain this behaviour, but: --------------------------------
neuper@38022
   278
#  rls: norm_Rational_noadd_fractions on: 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2)
neuper@38022
   279
##  rls: discard_minus on: 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2)
neuper@38022
   280
###  try thm: real_diff_minus
neuper@38022
   281
###  try thm: sym_real_mult_minus1
neuper@38022
   282
##  rls: rat_mult_poly on: 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2)
neuper@38022
   283
###  try thm: rat_mult_poly_l
neuper@38022
   284
###  try thm: rat_mult_poly_r
neuper@38022
   285
####  eval asms: L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2 is_polyexp
neuper@38022
   286
==> 1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2) =
neuper@38022
   287
    1 * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2) / EI
neuper@38022
   288
#####  rls: e_rls-is_polyexp on: L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2 is_polyexp
neuper@38022
   289
######  try calc: Poly.is'_polyexp'
neuper@38022
   290
======  calc. to: False
neuper@38022
   291
######  try calc: Poly.is'_polyexp'
neuper@38022
   292
######  try calc: Poly.is'_polyexp'
neuper@38022
   293
####  asms accepted: ["L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2 is_polyexp"]   stored: ["False"]
neuper@38022
   294
===  rewrites to: 1 * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2) / EI
neuper@38022
   295
----- 2009 -------------------------------------------------------------------*)
neuper@38022
   296
neuper@38022
   297
(*the situation as was before repair (asm without Trueprop) is outcommented*)
neuper@41928
   298
val thy = @{theory "Isac"};
neuper@38022
   299
"===== example which raised the problem =================";
neuper@38022
   300
val t = @{term "1 / EI * (L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2)"};
neuper@38022
   301
"----- rewrite_set_inst_ norm_Rational_noadd_fractions--";
neuper@38022
   302
val subs = [(str2term "bdv", str2term "x")];
neuper@38022
   303
val rls = norm_Rational_noadd_fractions;
neuper@38022
   304
val NONE (*SOME (t', _)*) = rewrite_set_inst_ thy true subs rls t;
neuper@38022
   305
"----- rewrite_ rat_mult_poly_r--------------------------";
neuper@38022
   306
val thm = @{thm rat_mult_poly_r};
neuper@38022
   307
         "?c::real is_polyexp ==> (?a::real) / (?b::real) * ?c = ?a * ?c / ?b";
neuper@38022
   308
val erls = append_rls "e_rls-is_polyexp" e_rls 
neuper@38022
   309
                      [Calc ("Poly.is'_polyexp", eval_is_polyexp "")];
neuper@38022
   310
val NONE (*SOME (t'', _)*) = rewrite_ thy dummy_ord erls true thm t;
neuper@38022
   311
(*t' = t''; (*false because of further rewrites in t'*)*)
neuper@38022
   312
"----- rew_sub  --------------------------------";
neuper@38022
   313
val (t''', _, _, _) = rew_sub thy 0 [] dummy_ord erls true [] (prop_of thm) t;
neuper@38022
   314
(*t'' = t'''; (*true*)*)
neuper@38022
   315
"----- rewrite_set_ erls --------------------------------";
neuper@38022
   316
val cond = @{term "(L * q_0 * x / 2 + -1 * q_0 * x ^^^ 2 / 2)"};
neuper@38022
   317
val NONE = rewrite_set_ thy true erls cond; 
neuper@38022
   318
(* ^^^^^ goes with '======  calc. to: False' above from beginning*)
neuper@38022
   319
neuper@38022
   320
writeln "===== maximally simplified example =====================";
neuper@38022
   321
val t = @{term "a / b * (x / x ^^^ 2)"};
neuper@38022
   322
         "?c::real is_polyexp ==> (?a::real) / (?b::real) * ?c = ?a * ?c / ?b";
neuper@38022
   323
writeln "----- rewrite_set_inst_ norm_Rational_noadd_fractions--";
neuper@38022
   324
val (*NONE*) SOME (t', asm) = rewrite_set_inst_ thy true subs rls t;
neuper@38022
   325
term2str t' = "a * x / (b * x ^^^ 2)"; (*rew. by thm outside test case*)
neuper@38022
   326
(*checked visually: trace_rewrite looks like above for 2009*)
neuper@38022
   327
neuper@38022
   328
writeln "----- rewrite_ rat_mult_poly_r--------------------------";
neuper@38022
   329
val NONE (*SOME (t'', _)*) = rewrite_ thy dummy_ord erls true thm t;
neuper@38022
   330
(*t' = t''; (*false because of further rewrites in t'*)*)
neuper@38022
   331
writeln "----- rew_sub  --------------------------------";
neuper@38022
   332
val (t''', _, _, _) = rew_sub thy 0 [] dummy_ord erls true [] (prop_of thm) t;
neuper@38022
   333
(*t'' = t'''; (*true*)*)
neuper@38022
   334
writeln "----- rewrite_set_ erls --------------------------------";
neuper@38022
   335
val cond = @{term "(x / x ^^^ 2)"};
neuper@38022
   336
val NONE = rewrite_set_ thy true erls cond; 
neuper@38022
   337
(* ^^^^^ goes with '======  calc. to: False' above from beginning*)
neuper@42201
   338
neuper@38025
   339
neuper@38039
   340
"----------- compare all prepat's existing 2010 ---------";
neuper@38039
   341
"----------- compare all prepat's existing 2010 ---------";
neuper@38039
   342
"----------- compare all prepat's existing 2010 ---------";
neuper@41928
   343
val thy = @{theory "Isac"};
neuper@38036
   344
val t = @{term "a + b * x = (0 ::real)"};
neuper@38036
   345
val pat = parse_patt thy "?l = (?r ::real)";
neuper@38036
   346
val precond = parse_patt thy "is_polynomial (?l::real)";(*no infix def*)
neuper@38039
   347
val precond = parse_patt thy "(?l::real) is_expanded"; 
neuper@38036
   348
neuper@38036
   349
val inst = Pattern.match thy (pat, t) (Vartab.empty, Vartab.empty);
neuper@38036
   350
val preinst = Envir.subst_term inst precond;
neuper@38036
   351
term2str preinst;
neuper@38036
   352
neuper@38036
   353
"===== Rational.thy: cancel ===";
neuper@38036
   354
(* pat matched with the current term gives an environment 
neuper@38036
   355
   (or not: hen the Rrls not applied);
neuper@38036
   356
   if pre1 and pre2 evaluate to HOLogic.true_const in this environment,
neuper@38036
   357
   then the Rrls is applied. *)
neuper@38036
   358
val t = str2term "(a + b) / c ::real";
neuper@38036
   359
val pat = parse_patt thy "?r / ?s ::real";
neuper@38036
   360
val pres = [parse_patt thy "?r is_expanded", parse_patt thy "?s is_expanded"];
neuper@38036
   361
val prepat = [(pres, pat)];
neuper@38036
   362
val erls = rational_erls;
neuper@38036
   363
(* erls got from Rrls {erls, prepat, scr = Rfuns {normal_form, ...}, ...} *)
neuper@38036
   364
neuper@38036
   365
val subst = Pattern.match thy (pat, t) (Vartab.empty, Vartab.empty);
neuper@38036
   366
val asms = map (Envir.subst_term subst) pres;
neuper@38036
   367
if terms2str asms = "[\"a + b is_expanded\",\"c is_expanded\"]"
neuper@38036
   368
then () else error "rewrite.sml: prepat cancel subst";
neuper@38036
   369
if ([], true) = eval__true thy 0 asms [] erls
neuper@38036
   370
then () else error "rewrite.sml: prepat cancel eval__true";
neuper@38036
   371
neuper@38036
   372
"===== Rational.thy: common_nominator_p ===";
neuper@38036
   373
(* if each pat* matches with the current term, the Rrls is applied
neuper@38036
   374
   (there are no preconditions to be checked, they are HOLogic.true_const) *)
neuper@38036
   375
val t = str2term "a / b + 1 / 2";
neuper@38036
   376
val pat = parse_patt thy "?r / ?s + ?u / ?v";
neuper@38036
   377
val pres = [HOLogic.true_const];
neuper@38036
   378
val prepat = [(pres, pat)];
neuper@38036
   379
val erls = rational_erls;
neuper@38036
   380
(* erls got from Rrls {erls, prepat, scr = Rfuns {normal_form, ...}, ...} *)
neuper@38036
   381
neuper@38036
   382
val subst = Pattern.match thy (pat, t) (Vartab.empty, Vartab.empty);
neuper@38036
   383
if ([], true) = eval__true thy 0 (map (Envir.subst_term subst) pres) [] erls
neuper@38036
   384
then () else error "rewrite.sml: prepat common_nominator_p";
neuper@38036
   385
neuper@38036
   386
"===== Poly.thy: order_mult_ ===";
neuper@38036
   387
          (* ?p matched with the current term gives an environment,
neuper@38036
   388
             which evaluates (the instantiated) "p is_multUnordered" to true*)
neuper@38036
   389
val t = str2term "x^^^2 * x";
neuper@38036
   390
val pat = parse_patt thy "?p :: real"
neuper@38036
   391
val pres = [parse_patt thy "?p is_multUnordered"];
neuper@38036
   392
val prepat = [(pres, pat)];
neuper@38036
   393
val erls = append_rls "e_rls-is_multUnordered" e_rls
neuper@38036
   394
		      [Calc ("Poly.is'_multUnordered", 
neuper@38036
   395
                             eval_is_multUnordered "")];
neuper@38036
   396
neuper@38036
   397
val subst = Pattern.match thy (pat, t) (Vartab.empty, Vartab.empty);
neuper@38036
   398
val asms = map (Envir.subst_term subst) pres;
neuper@38036
   399
if terms2str asms = "[\"x ^^^ 2 * x is_multUnordered\"]"
neuper@38036
   400
then () else error "rewrite.sml: prepat order_mult_ subst";
neuper@38036
   401
if ([], true) = eval__true thy 0 asms [] erls
neuper@38036
   402
then () else error "rewrite.sml: prepat order_mult_ eval__true";
neuper@38036
   403
neuper@38036
   404
neuper@38039
   405
"----------- fun app_rev, Rrls, -------------------------";
neuper@38039
   406
"----------- fun app_rev, Rrls, -------------------------";
neuper@38039
   407
"----------- fun app_rev, Rrls, -------------------------";
neuper@38039
   408
val t = str2term "x^^^2 * x";
neuper@41928
   409
neuper@38039
   410
if is_multUnordered t then () else error "rewrite.sml diff. is_multUnordered 2";
neuper@38039
   411
val tm = str2term "(x^^^2 * x) is_multUnordered";
neuper@41928
   412
eval_is_multUnordered "testid" "" tm thy;
neuper@41928
   413
neuper@38039
   414
case eval_is_multUnordered "testid" "" tm thy of
neuper@41924
   415
    SOME (_, Const ("HOL.Trueprop", _) $ 
neuper@41922
   416
                   (Const ("HOL.eq", _) $
neuper@38039
   417
                          (Const ("Poly.is'_multUnordered", _) $ _) $ 
neuper@41928
   418
                          Const ("HOL.True", _))) => ()
neuper@41928
   419
  | _ => error "rewrite.sml diff. eval_is_multUnordered 2b";
neuper@38039
   420
neuper@38039
   421
tracing "----- begin rewrite x^^^2 * x ---"; trace_rewrite := true;
neuper@38039
   422
val SOME (t', _) = rewrite_set_ thy true order_mult_ t;
neuper@38039
   423
tracing "----- end rewrite x^^^2 * x ---"; trace_rewrite := false;
neuper@38039
   424
if term2str t' = "x * x ^^^ 2" then ()
neuper@38039
   425
else error "rewrite.sml Poly.is'_multUnordered doesn't work";
neuper@38039
   426
neuper@38039
   427
(* for achieving the previous result, the following code was taken apart *)
neuper@38039
   428
"----- rewrite__set_ ---";
neuper@38039
   429
val (thy, i, _, _, (rrls as Rrls _), t) = (thy, 0, true, [], order_mult_, tm);
neuper@38039
   430
	val (t', asm, rew) = app_rev thy (i+1) rrls t;
neuper@38039
   431
"----- app_rev ---";
neuper@38039
   432
val (thy, i, rrls, t) = (thy, (i+1), rrls, t);
neuper@38039
   433
	fun chk_prepat thy erls [] t = true
neuper@38039
   434
	  | chk_prepat thy erls prepat t =
neuper@38039
   435
	    let fun chk (pres, pat) =
neuper@38039
   436
		    (let val subst: Type.tyenv * Envir.tenv = 
neuper@38039
   437
			     Pattern.match thy (pat, t)
neuper@38039
   438
					    (Vartab.empty, Vartab.empty)
neuper@38039
   439
		     in snd (eval__true thy (i+1) 
neuper@38039
   440
					(map (Envir.subst_term subst) pres)
neuper@38039
   441
					[] erls)
neuper@38039
   442
		     end)
neuper@38039
   443
		    handle _ => false
neuper@38039
   444
		fun scan_ f [] = false (*scan_ NEVER called by []*)
neuper@38039
   445
		  | scan_ f (pp::pps) = if f pp then true
neuper@38039
   446
					else scan_ f pps;
neuper@38039
   447
	    in scan_ chk prepat end;
neuper@38039
   448
neuper@38039
   449
	(*.apply the normal_form of a rev-set.*)
neuper@38039
   450
	fun app_rev' thy (Rrls{erls,prepat,scr=Rfuns{normal_form,...},...}) t =
neuper@38039
   451
	    if chk_prepat thy erls prepat t
neuper@38039
   452
	    then ((*tracing("### app_rev': t = "^(term2str t));*)
neuper@38039
   453
                  normal_form t)
neuper@38039
   454
	    else NONE;
neuper@38039
   455
(*fixme val NONE = app_rev' thy rrls t;*)
neuper@38039
   456
"----- app_rev' ---";
neuper@38039
   457
val (thy, Rrls{erls,prepat,scr=Rfuns{normal_form,...},...}, t) = (thy, rrls, t);
neuper@38039
   458
(*fixme false*)   chk_prepat thy erls prepat t;
neuper@38039
   459
"----- chk_prepat ---";
neuper@38039
   460
val (thy, erls, prepat, t) = (thy, erls, prepat, t);
neuper@38039
   461
                fun chk (pres, pat) =
neuper@38039
   462
		    (let val subst: Type.tyenv * Envir.tenv = 
neuper@38039
   463
			     Pattern.match thy (pat, t)
neuper@38039
   464
					    (Vartab.empty, Vartab.empty)
neuper@38039
   465
		     in snd (eval__true thy (i+1) 
neuper@38039
   466
					(map (Envir.subst_term subst) pres)
neuper@38039
   467
					[] erls)
neuper@38039
   468
		     end)
neuper@38039
   469
		    handle _ => false;
neuper@38039
   470
		fun scan_ f [] = false (*scan_ NEVER called by []*)
neuper@38039
   471
		  | scan_ f (pp::pps) = if f pp then true
neuper@38039
   472
					else scan_ f pps;
neuper@38039
   473
tracing "=== poly.sml: scan_ chk prepat begin";
neuper@38039
   474
scan_ chk prepat;
neuper@38039
   475
tracing "=== poly.sml: scan_ chk prepat end";
neuper@38039
   476
neuper@38039
   477
"----- chk ---";
neuper@38039
   478
(*reestablish...*) val t = str2term "x ^^^ 2 * x";
neuper@38039
   479
val [(pres, pat)] = prepat;
neuper@38039
   480
                         val subst: Type.tyenv * Envir.tenv = 
neuper@38039
   481
			     Pattern.match thy (pat, t)
neuper@38039
   482
					    (Vartab.empty, Vartab.empty);
neuper@38039
   483
neuper@38039
   484
(*fixme: asms = ["p is_multUnordered"]...instantiate*)
neuper@38039
   485
"----- eval__true ---";
neuper@38039
   486
val asms = (map (Envir.subst_term subst) pres);
neuper@38039
   487
if terms2str asms = "[\"x ^^^ 2 * x is_multUnordered\"]" then ()
neuper@38039
   488
else error "rewrite.sml: diff. is_multUnordered, asms";
neuper@38039
   489
val (thy, i, asms, bdv, rls) = 
neuper@38039
   490
    (thy, (i+1), [str2term "(x^^^2 * x) is_multUnordered"], 
neuper@38039
   491
     [] : (term * term) list, erls);
neuper@38039
   492
case eval__true thy i asms bdv rls of 
neuper@38039
   493
    ([], true) => ()
neuper@38039
   494
  | _ => error "rewrite.sml: diff. is_multUnordered, eval__true";
neuper@42223
   495
neuper@42223
   496
"----------- 2011 thms with axclasses -------------------";
neuper@42223
   497
"----------- 2011 thms with axclasses -------------------";
neuper@42223
   498
"----------- 2011 thms with axclasses -------------------";
neuper@42223
   499
val thm = num_str @{thm divide_1};
neuper@42223
   500
val prop = prop_of thm;
neuper@42223
   501
atomty prop;                                     (*Type 'a*)
neuper@42223
   502
val t = str2term "(2*x)/1";                      (*Type real*)
neuper@42223
   503
neuper@42223
   504
val (thy, ro, er, inst) = 
neuper@42223
   505
    (@{theory "Isac"}, tless_true, eval_rls, [(@{term "bdv::real"}, @{term "x::real"})]);
neuper@42223
   506
val SOME (t, _) = rewrite_ thy ro er true thm t; (*real matches 'a ?via ring? etc*)
neuper@42223
   507