src/Tools/isac/Knowledge/Test.thy
author Mathias Lehnfeld <s1210629013@students.fh-hagenberg.at>
Wed, 16 Oct 2013 23:59:43 +0100
changeset 52145 d13173b915e0
parent 52142 e7febad0c988
child 52148 aabc6c8e930a
permissions -rw-r--r--
add functions accessing Theory_Data in parallel to those accessing "calclist' = Unsynchronized.ref
neuper@37954
     1
(* some tests are based on specficially simple scripts etc.
neuper@37954
     2
   Author: Walther Neuper 2003
neuper@37954
     3
   (c) due to copyright terms
neuper@37954
     4
*) 
neuper@37906
     5
neuper@38007
     6
theory Test imports Atools Poly Rational Root Diff begin
neuper@37906
     7
 
neuper@37906
     8
consts
neuper@37906
     9
neuper@37906
    10
(*"cancel":: [real, real] => real    (infixl "'/'/'/" 70) ...divide 2002*)
neuper@37906
    11
neuper@37906
    12
  Expand'_binomtest
neuper@37954
    13
             :: "['y,  
neuper@37954
    14
		    'y] => 'y"
neuper@37954
    15
               ("((Script Expand'_binomtest (_ =))//  
neuper@37954
    16
                   (_))" 9)
neuper@37906
    17
neuper@37906
    18
  Solve'_univar'_err
neuper@37954
    19
             :: "[bool,real,bool,  
neuper@37954
    20
		    bool list] => bool list"
neuper@37954
    21
               ("((Script Solve'_univar'_err (_ _ _ =))//  
neuper@37954
    22
                   (_))" 9)
neuper@37906
    23
  
neuper@37906
    24
  Solve'_linear
neuper@37954
    25
             :: "[bool,real,  
neuper@37954
    26
		    bool list] => bool list"
neuper@37954
    27
               ("((Script Solve'_linear (_ _ =))//  
neuper@37954
    28
                   (_))" 9)
neuper@37906
    29
neuper@37906
    30
(*17.9.02 aus SqRoot.thy------------------------------vvv---*)
neuper@37906
    31
neuper@42008
    32
  "is'_root'_free"   :: "'a => bool"      ("is'_root'_free _" 10)
neuper@42008
    33
  "contains'_root"   :: "'a => bool"      ("contains'_root _" 10)
neuper@42008
    34
neuper@42008
    35
  "precond'_rootmet" :: "'a => bool"      ("precond'_rootmet _" 10)
neuper@42008
    36
  "precond'_rootpbl" :: "'a => bool"      ("precond'_rootpbl _" 10)
neuper@42008
    37
  "precond'_submet"  :: "'a => bool"      ("precond'_submet _" 10)
neuper@42008
    38
  "precond'_subpbl"  :: "'a => bool"      ("precond'_subpbl _" 10)
neuper@37906
    39
neuper@37906
    40
  Solve'_root'_equation 
neuper@37954
    41
             :: "[bool,real,  
neuper@37954
    42
		    bool list] => bool list"
neuper@37954
    43
               ("((Script Solve'_root'_equation (_ _ =))//  
neuper@37954
    44
                   (_))" 9)
neuper@37906
    45
neuper@37906
    46
  Solve'_plain'_square 
neuper@37954
    47
             :: "[bool,real,  
neuper@37954
    48
		    bool list] => bool list"
neuper@37954
    49
               ("((Script Solve'_plain'_square (_ _ =))//  
neuper@37954
    50
                   (_))" 9)
neuper@37906
    51
neuper@37906
    52
  Norm'_univar'_equation 
neuper@37954
    53
             :: "[bool,real,  
neuper@37954
    54
		    bool] => bool"
neuper@37954
    55
               ("((Script Norm'_univar'_equation (_ _ =))//  
neuper@37954
    56
                   (_))" 9)
neuper@37906
    57
neuper@37906
    58
  STest'_simplify
neuper@37954
    59
             :: "['z,  
neuper@37954
    60
		    'z] => 'z"
neuper@37954
    61
               ("((Script STest'_simplify (_ =))//  
neuper@37954
    62
                   (_))" 9)
neuper@37906
    63
neuper@37906
    64
(*17.9.02 aus SqRoot.thy------------------------------^^^---*)  
neuper@37906
    65
t@42211
    66
axioms(*axiomatization where*) (*TODO: prove as theorems*)
neuper@37906
    67
t@42211
    68
  radd_mult_distrib2:      "(k::real) * (m + n) = k * m + k * n" (*and*)
t@42211
    69
  rdistr_right_assoc:      "(k::real) + l * n + m * n = k + (l + m) * n" (*and*)
t@42211
    70
  rdistr_right_assoc_p:    "l * n + (m * n + (k::real)) = (l + m) * n + k" (*and*)
t@42211
    71
  rdistr_div_right:        "((k::real) + l) / n = k / n + l / n" (*and*)
neuper@37983
    72
  rcollect_right:
t@42211
    73
          "[| l is_const; m is_const |] ==> (l::real)*n + m*n = (l + m) * n" (*and*)
neuper@37983
    74
  rcollect_one_left:
t@42211
    75
          "m is_const ==> (n::real) + m * n = (1 + m) * n" (*and*)
neuper@37983
    76
  rcollect_one_left_assoc:
t@42211
    77
          "m is_const ==> (k::real) + n + m * n = k + (1 + m) * n" (*and*)
neuper@37983
    78
  rcollect_one_left_assoc_p:
t@42211
    79
          "m is_const ==> n + (m * n + (k::real)) = (1 + m) * n + k" (*and*)
neuper@37906
    80
t@42211
    81
  rtwo_of_the_same:        "a + a = 2 * a" (*and*)
t@42211
    82
  rtwo_of_the_same_assoc:  "(x + a) + a = x + 2 * a" (*and*)
t@42211
    83
  rtwo_of_the_same_assoc_p:"a + (a + x) = 2 * a + x" (*and*)
neuper@37906
    84
t@42211
    85
  rcancel_den:             "not(a=0) ==> a * (b / a) = b" (*and*)
t@42211
    86
  rcancel_const:           "[| a is_const; b is_const |] ==> a*(x/b) = a/b*x" (*and*)
t@42211
    87
  rshift_nominator:        "(a::real) * b / c = a / c * b" (*and*)
neuper@37906
    88
t@42211
    89
  exp_pow:                 "(a ^^^ b) ^^^ c = a ^^^ (b * c)" (*and*)
t@42211
    90
  rsqare:                  "(a::real) * a = a ^^^ 2" (*and*)
t@42211
    91
  power_1:                 "(a::real) ^^^ 1 = a" (*and*)
t@42211
    92
  rbinom_power_2:          "((a::real) + b)^^^ 2 = a^^^ 2 + 2*a*b + b^^^ 2" (*and*)
neuper@37906
    93
t@42211
    94
  rmult_1:                 "1 * k = (k::real)" (*and*)
t@42211
    95
  rmult_1_right:           "k * 1 = (k::real)" (*and*)
t@42211
    96
  rmult_0:                 "0 * k = (0::real)" (*and*)
t@42211
    97
  rmult_0_right:           "k * 0 = (0::real)" (*and*)
t@42211
    98
  radd_0:                  "0 + k = (k::real)" (*and*)
t@42211
    99
  radd_0_right:            "k + 0 = (k::real)" (*and*)
neuper@37906
   100
neuper@37983
   101
  radd_real_const_eq:
t@42211
   102
          "[| a is_const; c is_const; d is_const |] ==> a/d + c/d = (a+c)/(d::real)" (*and*)
neuper@37983
   103
  radd_real_const:
neuper@37906
   104
          "[| a is_const; b is_const; c is_const; d is_const |] ==> a/b + c/d = (a*d + b*c)/(b*(d::real))"  
t@42211
   105
   (*and*)
neuper@37906
   106
(*for AC-operators*)
t@42211
   107
  radd_commute:            "(m::real) + (n::real) = n + m" (*and*)
t@42211
   108
  radd_left_commute:       "(x::real) + (y + z) = y + (x + z)" (*and*)
t@42211
   109
  radd_assoc:              "(m::real) + n + k = m + (n + k)" (*and*)
t@42211
   110
  rmult_commute:           "(m::real) * n = n * m" (*and*)
t@42211
   111
  rmult_left_commute:      "(x::real) * (y * z) = y * (x * z)" (*and*)
t@42211
   112
  rmult_assoc:             "(m::real) * n * k = m * (n * k)" (*and*)
neuper@37906
   113
neuper@37906
   114
(*for equations: 'bdv' is a meta-constant*)
t@42211
   115
  risolate_bdv_add:       "((k::real) + bdv = m) = (bdv = m + (-1)*k)" (*and*)
t@42211
   116
  risolate_bdv_mult_add:  "((k::real) + n*bdv = m) = (n*bdv = m + (-1)*k)" (*and*)
t@42211
   117
  risolate_bdv_mult:      "((n::real) * bdv = m) = (bdv = m / n)" (*and*)
neuper@37906
   118
neuper@37983
   119
  rnorm_equation_add:
t@42211
   120
      "~(b =!= 0) ==> (a = b) = (a + (-1)*b = 0)" (*and*)
neuper@37906
   121
neuper@37906
   122
(*17.9.02 aus SqRoot.thy------------------------------vvv---*) 
t@42211
   123
  root_ge0:            "0 <= a ==> 0 <= sqrt a" (*and*)
neuper@37906
   124
  (*should be dropped with better simplification in eval_rls ...*)
neuper@37983
   125
  root_add_ge0:
t@42211
   126
	"[| 0 <= a; 0 <= b |] ==> (0 <= sqrt a + sqrt b) = True" (*and*)
neuper@37983
   127
  root_ge0_1:
t@42211
   128
	"[| 0<=a; 0<=b; 0<=c |] ==> (0 <= a * sqrt b + sqrt c) = True" (*and*)
neuper@37983
   129
  root_ge0_2:
t@42211
   130
	"[| 0<=a; 0<=b; 0<=c |] ==> (0 <= sqrt a + b * sqrt c) = True" (*and*)
neuper@37906
   131
neuper@37906
   132
t@42211
   133
  rroot_square_inv:         "(sqrt a)^^^ 2 = a" (*and*)
t@42211
   134
  rroot_times_root:         "sqrt a * sqrt b = sqrt(a*b)" (*and*)
t@42211
   135
  rroot_times_root_assoc:   "(a * sqrt b) * sqrt c = a * sqrt(b*c)" (*and*)
t@42211
   136
  rroot_times_root_assoc_p: "sqrt b * (sqrt c * a)= sqrt(b*c) * a" (*and*)
neuper@37906
   137
neuper@37906
   138
neuper@37906
   139
(*for root-equations*)
neuper@37983
   140
  square_equation_left:
t@42211
   141
          "[| 0 <= a; 0 <= b |] ==> (((sqrt a)=b)=(a=(b^^^ 2)))" (*and*)
neuper@37983
   142
  square_equation_right:
t@42211
   143
          "[| 0 <= a; 0 <= b |] ==> ((a=(sqrt b))=((a^^^ 2)=b))" (*and*)
neuper@37906
   144
  (*causes frequently non-termination:*)
neuper@37983
   145
  square_equation:  
t@42211
   146
          "[| 0 <= a; 0 <= b |] ==> ((a=b)=((a^^^ 2)=b^^^ 2))" (*and*)
neuper@37906
   147
  
t@42211
   148
  risolate_root_add:        "(a+  sqrt c = d) = (  sqrt c = d + (-1)*a)" (*and*)
t@42211
   149
  risolate_root_mult:       "(a+b*sqrt c = d) = (b*sqrt c = d + (-1)*a)" (*and*)
t@42211
   150
  risolate_root_div:        "(a * sqrt c = d) = (  sqrt c = d / a)" (*and*)
neuper@37906
   151
neuper@37906
   152
(*for polynomial equations of degree 2; linear case in RatArith*)
t@42211
   153
  mult_square:		"(a*bdv^^^2 = b) = (bdv^^^2 = b / a)" (*and*)
t@42211
   154
  constant_square:       "(a + bdv^^^2 = b) = (bdv^^^2 = b + -1*a)" (*and*)
t@42211
   155
  constant_mult_square:  "(a + b*bdv^^^2 = c) = (b*bdv^^^2 = c + -1*a)" (*and*)
neuper@37906
   156
neuper@37983
   157
  square_equality: 
t@42211
   158
	     "0 <= a ==> (x^^^2 = a) = ((x=sqrt a) | (x=-1*sqrt a))" (*and*)
neuper@37983
   159
  square_equality_0:
t@42211
   160
	     "(x^^^2 = 0) = (x = 0)" (*and*)
neuper@37906
   161
neuper@37906
   162
(*isolate root on the LEFT hand side of the equation
neuper@37906
   163
  otherwise shuffling from left to right would not terminate*)  
neuper@37906
   164
neuper@37983
   165
  rroot_to_lhs:
t@42211
   166
          "is_root_free a ==> (a = sqrt b) = (a + (-1)*sqrt b = 0)" (*and*)
neuper@37983
   167
  rroot_to_lhs_mult:
t@42211
   168
          "is_root_free a ==> (a = c*sqrt b) = (a + (-1)*c*sqrt b = 0)" (*and*)
neuper@37983
   169
  rroot_to_lhs_add_mult:
neuper@37906
   170
          "is_root_free a ==> (a = d+c*sqrt b) = (a + (-1)*c*sqrt b = d)"
neuper@37906
   171
(*17.9.02 aus SqRoot.thy------------------------------^^^---*)  
neuper@37906
   172
neuper@37954
   173
ML {*
neuper@37972
   174
val thy = @{theory};
neuper@37972
   175
neuper@37954
   176
(** evaluation of numerals and predicates **)
neuper@37954
   177
neuper@42008
   178
(*does a term contain a root ? WN110518 seems incorrect, compare contains_root*)
neuper@52070
   179
fun eval_root_free (thmid:string) _ (t as (Const (op0, t0) $ arg)) thy = 
neuper@37954
   180
  if strip_thy op0 <> "is'_root'_free" 
neuper@52070
   181
    then error ("eval_root_free: wrong " ^ op0)
neuper@37954
   182
  else if const_in (strip_thy op0) arg
neuper@52070
   183
  then SOME (mk_thmid thmid "" (term_to_string''' thy arg)"",
neuper@52070
   184
	       Trueprop $ (mk_equality (t, @{term False})))
neuper@52070
   185
  else SOME (mk_thmid thmid "" (term_to_string''' thy arg)"",
neuper@52070
   186
	       Trueprop $ (mk_equality (t, @{term True})))
neuper@38053
   187
| eval_root_free _ _ _ _ = NONE; 
neuper@37954
   188
neuper@37954
   189
(*does a term contain a root ?*)
neuper@37954
   190
fun eval_contains_root (thmid:string) _ 
neuper@37954
   191
		       (t as (Const("Test.contains'_root",t0) $ arg)) thy = 
neuper@38053
   192
  if member op = (ids_of arg) "sqrt"
neuper@52070
   193
  then SOME (mk_thmid thmid "" (term_to_string''' thy arg)"",
neuper@52070
   194
	       Trueprop $ (mk_equality (t, @{term True})))
neuper@52070
   195
  else SOME (mk_thmid thmid "" (term_to_string''' thy arg)"",
neuper@52070
   196
	       Trueprop $ (mk_equality (t, @{term False})))
neuper@38053
   197
| eval_contains_root _ _ _ _ = NONE; 
neuper@42008
   198
neuper@42008
   199
(*dummy precondition for root-met of x+1=2*)
neuper@42008
   200
fun eval_precond_rootmet (thmid:string) _ (t as (Const ("Test.precond'_rootmet", _) $ arg)) thy = 
neuper@52070
   201
    SOME (mk_thmid thmid "" (term_to_string''' thy arg)"",
neuper@52070
   202
      Trueprop $ (mk_equality (t, @{term True})))
neuper@52070
   203
  | eval_precond_rootmet _ _ _ _ = NONE; 
neuper@42008
   204
neuper@42008
   205
(*dummy precondition for root-pbl of x+1=2*)
neuper@42008
   206
fun eval_precond_rootpbl (thmid:string) _ (t as (Const ("Test.precond'_rootpbl", _) $ arg)) thy = 
neuper@52070
   207
    SOME (mk_thmid thmid "" (term_to_string''' thy arg) "",
neuper@52070
   208
	    Trueprop $ (mk_equality (t, @{term True})))
neuper@52070
   209
	| eval_precond_rootpbl _ _ _ _ = NONE; 
neuper@42008
   210
neuper@37954
   211
calclist':= overwritel (!calclist', 
neuper@37954
   212
   [("is_root_free", ("Test.is'_root'_free", 
neuper@37981
   213
		      eval_root_free"#is_root_free_e")),
neuper@37954
   214
    ("contains_root", ("Test.contains'_root",
neuper@42008
   215
		       eval_contains_root"#contains_root_")),
neuper@42008
   216
    ("Test.precond'_rootmet", ("Test.precond'_rootmet",
neuper@42008
   217
		       eval_precond_rootmet"#Test.precond_rootmet_")),
neuper@42008
   218
    ("Test.precond'_rootpbl", ("Test.precond'_rootpbl",
neuper@42024
   219
		       eval_precond_rootpbl"#Test.precond_rootpbl_"))
neuper@37954
   220
    ]);
s1210629013@52145
   221
*}
s1210629013@52145
   222
setup {* KEStore_Elems.add_calcs
s1210629013@52145
   223
  [("is_root_free", ("Test.is'_root'_free", eval_root_free"#is_root_free_e")),
s1210629013@52145
   224
    ("contains_root", ("Test.contains'_root", eval_contains_root"#contains_root_")),
s1210629013@52145
   225
    ("Test.precond'_rootmet", ("Test.precond'_rootmet", eval_precond_rootmet"#Test.precond_rootmet_")),
s1210629013@52145
   226
    ("Test.precond'_rootpbl", ("Test.precond'_rootpbl",
s1210629013@52145
   227
        eval_precond_rootpbl"#Test.precond_rootpbl_"))] *}
s1210629013@52145
   228
ML {*
neuper@37954
   229
(** term order **)
neuper@38001
   230
fun term_order (_:subst) tu = (term_ordI [] tu = LESS);
s1210629013@52145
   231
neuper@38001
   232
(** rule sets **)
neuper@37954
   233
neuper@37954
   234
val testerls = 
neuper@37954
   235
  Rls {id = "testerls", preconds = [], rew_ord = ("termlessI",termlessI), 
neuper@37954
   236
      erls = e_rls, srls = Erls, 
neuper@42451
   237
      calc = [], errpatts = [], 
neuper@37969
   238
      rules = [Thm ("refl",num_str @{thm refl}),
neuper@48764
   239
	       Thm ("order_refl",num_str @{thm order_refl}),
neuper@37969
   240
	       Thm ("radd_left_cancel_le",num_str @{thm radd_left_cancel_le}),
neuper@37969
   241
	       Thm ("not_true",num_str @{thm not_true}),
neuper@37969
   242
	       Thm ("not_false",num_str @{thm not_false}),
neuper@37969
   243
	       Thm ("and_true",num_str @{thm and_true}),
neuper@37969
   244
	       Thm ("and_false",num_str @{thm and_false}),
neuper@37969
   245
	       Thm ("or_true",num_str @{thm or_true}),
neuper@37969
   246
	       Thm ("or_false",num_str @{thm or_false}),
neuper@37969
   247
	       Thm ("and_commute",num_str @{thm and_commute}),
neuper@37969
   248
	       Thm ("or_commute",num_str @{thm or_commute}),
neuper@37954
   249
neuper@37954
   250
	       Calc ("Atools.is'_const",eval_const "#is_const_"),
neuper@37954
   251
	       Calc ("Tools.matches",eval_matches ""),
neuper@37954
   252
    
neuper@38014
   253
	       Calc ("Groups.plus_class.plus",eval_binop "#add_"),
neuper@38034
   254
	       Calc ("Groups.times_class.times",eval_binop "#mult_"),
neuper@37954
   255
	       Calc ("Atools.pow" ,eval_binop "#power_"),
neuper@37954
   256
		    
neuper@38045
   257
	       Calc ("Orderings.ord_class.less",eval_equ "#less_"),
neuper@38045
   258
	       Calc ("Orderings.ord_class.less_eq",eval_equ "#less_equal_"),
neuper@37954
   259
	     	    
neuper@37954
   260
	       Calc ("Atools.ident",eval_ident "#ident_")],
neuper@48763
   261
      scr = Prog ((term_of o the o (parse thy)) "empty_script")
neuper@37954
   262
      }:rls;      
neuper@38001
   263
*}
neuper@38001
   264
ML {*
neuper@37954
   265
(*.for evaluation of conditions in rewrite rules.*)
neuper@37954
   266
(*FIXXXXXXME 10.8.02: handle like _simplify*)
neuper@37954
   267
val tval_rls =  
neuper@37954
   268
  Rls{id = "tval_rls", preconds = [], 
neuper@52140
   269
      rew_ord = ("sqrt_right",sqrt_right false @{theory "Pure"}), 
neuper@37954
   270
      erls=testerls,srls = e_rls, 
neuper@42451
   271
      calc=[], errpatts = [],
neuper@37969
   272
      rules = [Thm ("refl",num_str @{thm refl}),
neuper@48764
   273
	       Thm ("order_refl",num_str @{thm order_refl}),
neuper@37969
   274
	       Thm ("radd_left_cancel_le",num_str @{thm radd_left_cancel_le}),
neuper@37969
   275
	       Thm ("not_true",num_str @{thm not_true}),
neuper@37969
   276
	       Thm ("not_false",num_str @{thm not_false}),
neuper@37969
   277
	       Thm ("and_true",num_str @{thm and_true}),
neuper@37969
   278
	       Thm ("and_false",num_str @{thm and_false}),
neuper@37969
   279
	       Thm ("or_true",num_str @{thm or_true}),
neuper@37969
   280
	       Thm ("or_false",num_str @{thm or_false}),
neuper@37969
   281
	       Thm ("and_commute",num_str @{thm and_commute}),
neuper@38001
   282
	       Thm ("or_commute",num_str @{thm or_commute}),
neuper@37954
   283
neuper@37969
   284
	       Thm ("real_diff_minus",num_str @{thm real_diff_minus}),
neuper@37954
   285
neuper@37969
   286
	       Thm ("root_ge0",num_str @{thm root_ge0}),
neuper@37969
   287
	       Thm ("root_add_ge0",num_str @{thm root_add_ge0}),
neuper@37969
   288
	       Thm ("root_ge0_1",num_str @{thm root_ge0_1}),
neuper@37969
   289
	       Thm ("root_ge0_2",num_str @{thm root_ge0_2}),
neuper@37954
   290
neuper@37954
   291
	       Calc ("Atools.is'_const",eval_const "#is_const_"),
neuper@37981
   292
	       Calc ("Test.is'_root'_free",eval_root_free "#is_root_free_e"),
neuper@37954
   293
	       Calc ("Tools.matches",eval_matches ""),
neuper@37954
   294
	       Calc ("Test.contains'_root",
neuper@37954
   295
		     eval_contains_root"#contains_root_"),
neuper@37954
   296
    
neuper@38014
   297
	       Calc ("Groups.plus_class.plus",eval_binop "#add_"),
neuper@38034
   298
	       Calc ("Groups.times_class.times",eval_binop "#mult_"),
neuper@37982
   299
	       Calc ("NthRoot.sqrt",eval_sqrt "#sqrt_"),
neuper@37954
   300
	       Calc ("Atools.pow" ,eval_binop "#power_"),
neuper@37954
   301
		    
neuper@38045
   302
	       Calc ("Orderings.ord_class.less",eval_equ "#less_"),
neuper@38045
   303
	       Calc ("Orderings.ord_class.less_eq",eval_equ "#less_equal_"),
neuper@37954
   304
	     	    
neuper@37954
   305
	       Calc ("Atools.ident",eval_ident "#ident_")],
neuper@48763
   306
      scr = Prog ((term_of o the o (parse thy)) "empty_script")
neuper@37954
   307
      }:rls;      
neuper@38001
   308
*}
neuper@38001
   309
ML {*
neuper@37954
   310
neuper@37967
   311
ruleset' := overwritelthy @{theory} (!ruleset',
neuper@37954
   312
  [("testerls", prep_rls testerls)
neuper@37954
   313
   ]);
neuper@52125
   314
*}
neuper@52125
   315
setup {* KEStore_Elems.add_rlss [("testerls", (Context.theory_name @{theory}, prep_rls testerls))] *}
neuper@52125
   316
ML {*
neuper@37954
   317
neuper@37954
   318
neuper@37954
   319
(*make () dissappear*)   
neuper@37954
   320
val rearrange_assoc =
neuper@37954
   321
  Rls{id = "rearrange_assoc", preconds = [], 
neuper@37954
   322
      rew_ord = ("e_rew_ord",e_rew_ord), 
neuper@42451
   323
      erls = e_rls, srls = e_rls, calc = [], errpatts = [],
neuper@37954
   324
      rules = 
neuper@37974
   325
      [Thm ("sym_add_assoc",num_str (@{thm add_assoc} RS @{thm sym})),
neuper@37969
   326
       Thm ("sym_rmult_assoc",num_str (@{thm rmult_assoc} RS @{thm sym}))],
neuper@48763
   327
      scr = Prog ((term_of o the o (parse thy)) "empty_script")
neuper@37954
   328
      }:rls;      
neuper@37954
   329
neuper@37954
   330
val ac_plus_times =
neuper@37954
   331
  Rls{id = "ac_plus_times", preconds = [], rew_ord = ("term_order",term_order),
neuper@42451
   332
      erls = e_rls, srls = e_rls, calc = [], errpatts = [],
neuper@37954
   333
      rules = 
neuper@37969
   334
      [Thm ("radd_commute",num_str @{thm radd_commute}),
neuper@37969
   335
       Thm ("radd_left_commute",num_str @{thm radd_left_commute}),
neuper@37974
   336
       Thm ("add_assoc",num_str @{thm add_assoc}),
neuper@37969
   337
       Thm ("rmult_commute",num_str @{thm rmult_commute}),
neuper@37969
   338
       Thm ("rmult_left_commute",num_str @{thm rmult_left_commute}),
neuper@37969
   339
       Thm ("rmult_assoc",num_str @{thm rmult_assoc})],
neuper@48763
   340
      scr = Prog ((term_of o the o (parse thy)) "empty_script")
neuper@37954
   341
      }:rls;      
neuper@37954
   342
neuper@37969
   343
(*todo: replace by Rewrite("rnorm_equation_add",num_str @{thm rnorm_equation_add)*)
neuper@37954
   344
val norm_equation =
neuper@37954
   345
  Rls{id = "norm_equation", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
neuper@42451
   346
      erls = tval_rls, srls = e_rls, calc = [], errpatts = [],
neuper@38001
   347
      rules = [Thm ("rnorm_equation_add",num_str @{thm rnorm_equation_add})
neuper@37954
   348
	       ],
neuper@48763
   349
      scr = Prog ((term_of o the o (parse thy)) "empty_script")
neuper@37954
   350
      }:rls;      
neuper@38001
   351
*}
neuper@38001
   352
ML {*
neuper@37954
   353
(** rule sets **)
neuper@37954
   354
neuper@37954
   355
val STest_simplify =     (*   vv--- not changed to real by parse*)
neuper@38001
   356
  "Script STest_simplify (t_t::'z) =                           " ^
neuper@37954
   357
  "(Repeat" ^
neuper@37954
   358
  "    ((Try (Repeat (Rewrite real_diff_minus False))) @@        " ^
neuper@37954
   359
  "     (Try (Repeat (Rewrite radd_mult_distrib2 False))) @@  " ^
neuper@37954
   360
  "     (Try (Repeat (Rewrite rdistr_right_assoc False))) @@  " ^
neuper@37954
   361
  "     (Try (Repeat (Rewrite rdistr_right_assoc_p False))) @@" ^
neuper@37954
   362
  "     (Try (Repeat (Rewrite rdistr_div_right False))) @@    " ^
neuper@37954
   363
  "     (Try (Repeat (Rewrite rbinom_power_2 False))) @@      " ^
neuper@37954
   364
	
neuper@37954
   365
  "     (Try (Repeat (Rewrite radd_commute False))) @@        " ^
neuper@37954
   366
  "     (Try (Repeat (Rewrite radd_left_commute False))) @@   " ^
neuper@37974
   367
  "     (Try (Repeat (Rewrite add_assoc False))) @@          " ^
neuper@37954
   368
  "     (Try (Repeat (Rewrite rmult_commute False))) @@       " ^
neuper@37954
   369
  "     (Try (Repeat (Rewrite rmult_left_commute False))) @@  " ^
neuper@37954
   370
  "     (Try (Repeat (Rewrite rmult_assoc False))) @@         " ^
neuper@37954
   371
	
neuper@37954
   372
  "     (Try (Repeat (Rewrite radd_real_const_eq False))) @@   " ^
neuper@37954
   373
  "     (Try (Repeat (Rewrite radd_real_const False))) @@   " ^
neuper@37975
   374
  "     (Try (Repeat (Calculate PLUS))) @@   " ^
neuper@37975
   375
  "     (Try (Repeat (Calculate TIMES))) @@   " ^
neuper@37954
   376
  "     (Try (Repeat (Calculate divide_))) @@" ^
neuper@37975
   377
  "     (Try (Repeat (Calculate POWER))) @@  " ^
neuper@37954
   378
	
neuper@37954
   379
  "     (Try (Repeat (Rewrite rcollect_right False))) @@   " ^
neuper@37954
   380
  "     (Try (Repeat (Rewrite rcollect_one_left False))) @@   " ^
neuper@37954
   381
  "     (Try (Repeat (Rewrite rcollect_one_left_assoc False))) @@   " ^
neuper@37954
   382
  "     (Try (Repeat (Rewrite rcollect_one_left_assoc_p False))) @@   " ^
neuper@37954
   383
	
neuper@37954
   384
  "     (Try (Repeat (Rewrite rshift_nominator False))) @@   " ^
neuper@37954
   385
  "     (Try (Repeat (Rewrite rcancel_den False))) @@   " ^
neuper@37954
   386
  "     (Try (Repeat (Rewrite rroot_square_inv False))) @@   " ^
neuper@37954
   387
  "     (Try (Repeat (Rewrite rroot_times_root False))) @@   " ^
neuper@37954
   388
  "     (Try (Repeat (Rewrite rroot_times_root_assoc_p False))) @@   " ^
neuper@37954
   389
  "     (Try (Repeat (Rewrite rsqare False))) @@   " ^
neuper@37954
   390
  "     (Try (Repeat (Rewrite power_1 False))) @@   " ^
neuper@37954
   391
  "     (Try (Repeat (Rewrite rtwo_of_the_same False))) @@   " ^
neuper@37954
   392
  "     (Try (Repeat (Rewrite rtwo_of_the_same_assoc_p False))) @@   " ^
neuper@37954
   393
	
neuper@37954
   394
  "     (Try (Repeat (Rewrite rmult_1 False))) @@   " ^
neuper@37954
   395
  "     (Try (Repeat (Rewrite rmult_1_right False))) @@   " ^
neuper@37954
   396
  "     (Try (Repeat (Rewrite rmult_0 False))) @@   " ^
neuper@37954
   397
  "     (Try (Repeat (Rewrite rmult_0_right False))) @@   " ^
neuper@37954
   398
  "     (Try (Repeat (Rewrite radd_0 False))) @@   " ^
neuper@37954
   399
  "     (Try (Repeat (Rewrite radd_0_right False)))) " ^
neuper@38001
   400
  " t_t)";
neuper@37954
   401
neuper@38001
   402
*}
neuper@38001
   403
ML {*
neuper@37954
   404
(* expects * distributed over + *)
neuper@37954
   405
val Test_simplify =
neuper@37954
   406
  Rls{id = "Test_simplify", preconds = [], 
neuper@52140
   407
      rew_ord = ("sqrt_right",sqrt_right false @{theory "Pure"}),
neuper@37954
   408
      erls = tval_rls, srls = e_rls, 
neuper@42451
   409
      calc=[(*since 040209 filled by prep_rls*)], errpatts = [],
neuper@37954
   410
      rules = [
neuper@37969
   411
	       Thm ("real_diff_minus",num_str @{thm real_diff_minus}),
neuper@37969
   412
	       Thm ("radd_mult_distrib2",num_str @{thm radd_mult_distrib2}),
neuper@37969
   413
	       Thm ("rdistr_right_assoc",num_str @{thm rdistr_right_assoc}),
neuper@37969
   414
	       Thm ("rdistr_right_assoc_p",num_str @{thm rdistr_right_assoc_p}),
neuper@37969
   415
	       Thm ("rdistr_div_right",num_str @{thm rdistr_div_right}),
neuper@37969
   416
	       Thm ("rbinom_power_2",num_str @{thm rbinom_power_2}),	       
neuper@37954
   417
neuper@37969
   418
               Thm ("radd_commute",num_str @{thm radd_commute}), 
neuper@37969
   419
	       Thm ("radd_left_commute",num_str @{thm radd_left_commute}),
neuper@37974
   420
	       Thm ("add_assoc",num_str @{thm add_assoc}),
neuper@37969
   421
	       Thm ("rmult_commute",num_str @{thm rmult_commute}),
neuper@37969
   422
	       Thm ("rmult_left_commute",num_str @{thm rmult_left_commute}),
neuper@37969
   423
	       Thm ("rmult_assoc",num_str @{thm rmult_assoc}),
neuper@37954
   424
neuper@37969
   425
	       Thm ("radd_real_const_eq",num_str @{thm radd_real_const_eq}),
neuper@37969
   426
	       Thm ("radd_real_const",num_str @{thm radd_real_const}),
neuper@37954
   427
	       (* these 2 rules are invers to distr_div_right wrt. termination.
neuper@37954
   428
		  thus they MUST be done IMMEDIATELY before calc *)
neuper@38014
   429
	       Calc ("Groups.plus_class.plus", eval_binop "#add_"), 
neuper@38034
   430
	       Calc ("Groups.times_class.times", eval_binop "#mult_"),
neuper@48789
   431
	       Calc ("Fields.inverse_class.divide", eval_cancel "#divide_e"),
neuper@37954
   432
	       Calc ("Atools.pow", eval_binop "#power_"),
neuper@37954
   433
neuper@37969
   434
	       Thm ("rcollect_right",num_str @{thm rcollect_right}),
neuper@37969
   435
	       Thm ("rcollect_one_left",num_str @{thm rcollect_one_left}),
neuper@37969
   436
	       Thm ("rcollect_one_left_assoc",num_str @{thm rcollect_one_left_assoc}),
neuper@37969
   437
	       Thm ("rcollect_one_left_assoc_p",num_str @{thm rcollect_one_left_assoc_p}),
neuper@37954
   438
neuper@37969
   439
	       Thm ("rshift_nominator",num_str @{thm rshift_nominator}),
neuper@37969
   440
	       Thm ("rcancel_den",num_str @{thm rcancel_den}),
neuper@37969
   441
	       Thm ("rroot_square_inv",num_str @{thm rroot_square_inv}),
neuper@37969
   442
	       Thm ("rroot_times_root",num_str @{thm rroot_times_root}),
neuper@37969
   443
	       Thm ("rroot_times_root_assoc_p",num_str @{thm rroot_times_root_assoc_p}),
neuper@37969
   444
	       Thm ("rsqare",num_str @{thm rsqare}),
neuper@38001
   445
	       Thm ("power_1",num_str @{thm power_1}),
neuper@37969
   446
	       Thm ("rtwo_of_the_same",num_str @{thm rtwo_of_the_same}),
neuper@37969
   447
	       Thm ("rtwo_of_the_same_assoc_p",num_str @{thm rtwo_of_the_same_assoc_p}),
neuper@37954
   448
neuper@37969
   449
	       Thm ("rmult_1",num_str @{thm rmult_1}),
neuper@37969
   450
	       Thm ("rmult_1_right",num_str @{thm rmult_1_right}),
neuper@37969
   451
	       Thm ("rmult_0",num_str @{thm rmult_0}),
neuper@37969
   452
	       Thm ("rmult_0_right",num_str @{thm rmult_0_right}),
neuper@37969
   453
	       Thm ("radd_0",num_str @{thm radd_0}),
neuper@37969
   454
	       Thm ("radd_0_right",num_str @{thm radd_0_right})
neuper@37954
   455
	       ],
neuper@48763
   456
      scr = Prog ((term_of o the o (parse thy)) "empty_script")
neuper@37954
   457
		    (*since 040209 filled by prep_rls: STest_simplify*)
neuper@37954
   458
      }:rls;      
neuper@38001
   459
*}
neuper@38001
   460
ML {*
neuper@37954
   461
neuper@37954
   462
(** rule sets **)
neuper@37954
   463
neuper@37954
   464
neuper@37954
   465
neuper@37954
   466
(*isolate the root in a root-equation*)
neuper@37954
   467
val isolate_root =
neuper@37954
   468
  Rls{id = "isolate_root", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), 
neuper@42451
   469
      erls=tval_rls,srls = e_rls, calc=[], errpatts = [],
neuper@37969
   470
      rules = [Thm ("rroot_to_lhs",num_str @{thm rroot_to_lhs}),
neuper@37969
   471
	       Thm ("rroot_to_lhs_mult",num_str @{thm rroot_to_lhs_mult}),
neuper@37969
   472
	       Thm ("rroot_to_lhs_add_mult",num_str @{thm rroot_to_lhs_add_mult}),
neuper@37969
   473
	       Thm ("risolate_root_add",num_str @{thm risolate_root_add}),
neuper@37969
   474
	       Thm ("risolate_root_mult",num_str @{thm risolate_root_mult}),
neuper@37969
   475
	       Thm ("risolate_root_div",num_str @{thm risolate_root_div})       ],
neuper@48763
   476
      scr = Prog ((term_of o the o (parse thy)) 
neuper@37954
   477
      "empty_script")
neuper@37954
   478
      }:rls;
neuper@37954
   479
neuper@37954
   480
(*isolate the bound variable in an equation; 'bdv' is a meta-constant*)
neuper@37954
   481
val isolate_bdv =
neuper@37954
   482
    Rls{id = "isolate_bdv", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
neuper@42451
   483
	erls=tval_rls,srls = e_rls, calc= [], errpatts = [],
neuper@37954
   484
	rules = 
neuper@37969
   485
	[Thm ("risolate_bdv_add",num_str @{thm risolate_bdv_add}),
neuper@37969
   486
	 Thm ("risolate_bdv_mult_add",num_str @{thm risolate_bdv_mult_add}),
neuper@37969
   487
	 Thm ("risolate_bdv_mult",num_str @{thm risolate_bdv_mult}),
neuper@38001
   488
	 Thm ("mult_square",num_str @{thm mult_square}),
neuper@38001
   489
	 Thm ("constant_square",num_str @{thm constant_square}),
neuper@38001
   490
	 Thm ("constant_mult_square",num_str @{thm constant_mult_square})
neuper@37954
   491
	 ],
neuper@48763
   492
	scr = Prog ((term_of o the o (parse thy)) 
neuper@37954
   493
			  "empty_script")
neuper@37954
   494
	}:rls;      
neuper@38001
   495
*}
neuper@38001
   496
ML {*
neuper@37954
   497
neuper@37954
   498
(* association list for calculate_, calculate
neuper@38014
   499
   "Groups.plus_class.plus" etc. not usable in scripts *)
neuper@37954
   500
val calclist = 
neuper@37954
   501
    [
neuper@37954
   502
     (*as Tools.ML*)
neuper@37954
   503
     ("Vars"    ,("Tools.Vars"    ,eval_var "#Vars_")),
neuper@37954
   504
     ("matches",("Tools.matches",eval_matches "#matches_")),
neuper@37954
   505
     ("lhs"    ,("Tools.lhs"    ,eval_lhs "")),
neuper@37954
   506
     (*aus Atools.ML*)
neuper@38014
   507
     ("PLUS"    ,("Groups.plus_class.plus"        ,eval_binop "#add_")),
neuper@38034
   508
     ("TIMES"   ,("Groups.times_class.times"        ,eval_binop "#mult_")),
neuper@48789
   509
     ("DIVIDE" ,("Fields.inverse_class.divide"  ,eval_cancel "#divide_e")),
neuper@37954
   510
     ("POWER"  ,("Atools.pow"  ,eval_binop "#power_")),
neuper@37954
   511
     ("is_const",("Atools.is'_const",eval_const "#is_const_")),
neuper@38045
   512
     ("le"      ,("Orderings.ord_class.less"        ,eval_equ "#less_")),
neuper@38045
   513
     ("leq"     ,("Orderings.ord_class.less_eq"       ,eval_equ "#less_equal_")),
neuper@37954
   514
     ("ident"   ,("Atools.ident",eval_ident "#ident_")),
neuper@37954
   515
     (*von hier (ehem.SqRoot*)
neuper@37982
   516
     ("sqrt"    ,("NthRoot.sqrt"   ,eval_sqrt "#sqrt_")),
neuper@37981
   517
     ("Test.is_root_free",("is'_root'_free", eval_root_free"#is_root_free_e")),
neuper@37954
   518
     ("Test.contains_root",("contains'_root",
neuper@37954
   519
			    eval_contains_root"#contains_root_"))
neuper@37954
   520
     ];
neuper@37954
   521
neuper@37967
   522
ruleset' := overwritelthy @{theory} (!ruleset',
neuper@37954
   523
  [("Test_simplify", prep_rls Test_simplify),
neuper@37954
   524
   ("tval_rls", prep_rls tval_rls),
neuper@37954
   525
   ("isolate_root", prep_rls isolate_root),
neuper@37954
   526
   ("isolate_bdv", prep_rls isolate_bdv),
neuper@37954
   527
   ("matches", 
neuper@37954
   528
    prep_rls (append_rls "matches" testerls 
neuper@37954
   529
			 [Calc ("Tools.matches",eval_matches "#matches_")]))
neuper@37954
   530
   ]);
neuper@52125
   531
*}
neuper@52125
   532
setup {* KEStore_Elems.add_rlss 
neuper@52125
   533
  [("Test_simplify", (Context.theory_name @{theory}, prep_rls Test_simplify)), 
neuper@52125
   534
  ("tval_rls", (Context.theory_name @{theory}, prep_rls tval_rls)), 
neuper@52125
   535
  ("isolate_root", (Context.theory_name @{theory}, prep_rls isolate_root)), 
neuper@52125
   536
  ("isolate_bdv", (Context.theory_name @{theory}, prep_rls isolate_bdv)), 
neuper@52125
   537
  ("matches", (Context.theory_name @{theory}, prep_rls
neuper@52125
   538
    (append_rls "matches" testerls [Calc ("Tools.matches",eval_matches "#matches_")])))] *}
neuper@37954
   539
neuper@38001
   540
ML {*
neuper@37954
   541
(** problem types **)
neuper@37954
   542
store_pbt
neuper@37972
   543
 (prep_pbt thy "pbl_test" [] e_pblID
neuper@37954
   544
 (["test"],
neuper@37954
   545
  [],
neuper@37954
   546
  e_rls, NONE, []));
neuper@37954
   547
store_pbt
neuper@37972
   548
 (prep_pbt thy "pbl_test_equ" [] e_pblID
neuper@37954
   549
 (["equation","test"],
neuper@37981
   550
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@37981
   551
   ("#Where" ,["matches (?a = ?b) e_e"]),
neuper@38012
   552
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   553
  ],
neuper@52142
   554
  assoc_rls' @{theory} "matches",
neuper@37981
   555
  SOME "solve (e_e::bool, v_v)", []));
neuper@37954
   556
neuper@37954
   557
store_pbt
neuper@37972
   558
 (prep_pbt thy "pbl_test_uni" [] e_pblID
neuper@37954
   559
 (["univariate","equation","test"],
neuper@37981
   560
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@37981
   561
   ("#Where" ,["matches (?a = ?b) e_e"]),
neuper@38011
   562
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   563
  ],
neuper@52142
   564
  assoc_rls' @{theory} "matches",
neuper@37981
   565
  SOME "solve (e_e::bool, v_v)", []));
neuper@37954
   566
neuper@37954
   567
store_pbt
neuper@37972
   568
 (prep_pbt thy "pbl_test_uni_lin" [] e_pblID
neuper@37954
   569
 (["linear","univariate","equation","test"],
neuper@37981
   570
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38001
   571
   ("#Where" ,["(matches (   v_v = 0) e_e) | (matches (   ?b*v_v = 0) e_e) |" ^
neuper@38001
   572
	       "(matches (?a+v_v = 0) e_e) | (matches (?a+?b*v_v = 0) e_e)  "]),
neuper@38012
   573
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   574
  ],
neuper@52142
   575
  assoc_rls' @{theory} "matches", 
neuper@37981
   576
  SOME "solve (e_e::bool, v_v)", [["Test","solve_linear"]]));
neuper@37954
   577
neuper@37954
   578
(*25.8.01 ------
neuper@37954
   579
store_pbt
neuper@37972
   580
 (prep_pbt thy
neuper@37972
   581
 (["thy"],
neuper@38001
   582
  [("#Given" ,"boolTestGiven g_g"),
neuper@37994
   583
   ("#Find"  ,"boolTestFind f_f")
neuper@37954
   584
  ],
neuper@37954
   585
  []));
neuper@37954
   586
neuper@37954
   587
store_pbt
neuper@37972
   588
 (prep_pbt thy
neuper@37972
   589
 (["testeq","thy"],
neuper@38001
   590
  [("#Given" ,"boolTestGiven g_g"),
neuper@37994
   591
   ("#Find"  ,"boolTestFind f_f")
neuper@37954
   592
  ],
neuper@37954
   593
  []));
neuper@37954
   594
neuper@37954
   595
neuper@40836
   596
val ttt = (term_of o the o (parse (Thy_Info.get_theory "Isac"))) "(matches (   v_v = 0) e_e)";
neuper@37954
   597
neuper@37954
   598
 ------ 25.8.01*)
neuper@37954
   599
neuper@38001
   600
*}
neuper@38001
   601
ML {*
neuper@37954
   602
(** methods **)
neuper@37954
   603
store_met
neuper@52105
   604
 (prep_met @{theory "Diff"} "met_test" [] e_metID
neuper@37954
   605
 (["Test"],
neuper@37954
   606
   [],
neuper@37954
   607
   {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
neuper@42425
   608
    crls=Atools_erls, errpats = [], nrls = e_rls}, "empty_script"));
neuper@38001
   609
*}
neuper@38001
   610
ML {*
neuper@37954
   611
store_met
neuper@37972
   612
 (prep_met thy "met_test_solvelin" [] e_metID
neuper@37954
   613
 (["Test","solve_linear"]:metID,
neuper@37981
   614
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@37981
   615
    ("#Where" ,["matches (?a = ?b) e_e"]),
neuper@38012
   616
    ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   617
    ],
neuper@38001
   618
   {rew_ord' = "e_rew_ord", rls' = tval_rls, srls = e_rls,
neuper@52142
   619
    prls = assoc_rls' @{theory} "matches", calc = [], crls = tval_rls,
neuper@42425
   620
    errpats = [], nrls = Test_simplify},
neuper@38001
   621
 "Script Solve_linear (e_e::bool) (v_v::real)=                     " ^
neuper@38001
   622
 "(let e_e =                                                       " ^
neuper@38001
   623
 "  Repeat                                                         " ^
neuper@38001
   624
 "    (((Rewrite_Set_Inst [(bdv,v_v::real)] isolate_bdv False) @@  " ^
neuper@37981
   625
 "      (Rewrite_Set Test_simplify False))) e_e" ^
neuper@38001
   626
 " in [e_e::bool])"
neuper@37954
   627
 )
neuper@37972
   628
(*, prep_met thy (*test for equations*)
neuper@37954
   629
 (["Test","testeq"]:metID,
neuper@38001
   630
  [("#Given" ,["boolTestGiven g_g"]),
neuper@37994
   631
   ("#Find"  ,["boolTestFind f_f"])
neuper@37954
   632
    ],
neuper@37954
   633
  {rew_ord'="e_rew_ord",rls'="tval_rls",asm_rls=[],
neuper@37954
   634
   asm_thm=[("square_equation_left","")]},
neuper@38001
   635
 "Script Testeq (e_q::bool) =                                         " ^
neuper@37954
   636
   "Repeat                                                            " ^
neuper@38001
   637
   " (let e_e = Try (Repeat (Rewrite rroot_square_inv False e_q));      " ^
neuper@37981
   638
   "      e_e = Try (Repeat (Rewrite square_equation_left True e_e)); " ^
neuper@37981
   639
   "      e_e = Try (Repeat (Rewrite rmult_0 False e_e))                " ^
neuper@37981
   640
   "   in e_e) Until (is_root_free e_e)" (*deleted*)
neuper@37954
   641
 )
neuper@37954
   642
, ---------27.4.02*)
neuper@37954
   643
);
neuper@37954
   644
neuper@38001
   645
*}
neuper@38001
   646
ML {*
neuper@37967
   647
ruleset' := overwritelthy @{theory} (!ruleset',
neuper@37954
   648
  [("norm_equation", prep_rls norm_equation),
neuper@37954
   649
   ("ac_plus_times", prep_rls ac_plus_times),
neuper@37954
   650
   ("rearrange_assoc", prep_rls rearrange_assoc)
neuper@37954
   651
   ]);
neuper@52125
   652
*}
neuper@52125
   653
setup {* KEStore_Elems.add_rlss 
neuper@52125
   654
  [("norm_equation", (Context.theory_name @{theory}, prep_rls norm_equation)), 
neuper@52125
   655
  ("ac_plus_times", (Context.theory_name @{theory}, prep_rls ac_plus_times)), 
neuper@52125
   656
  ("rearrange_assoc", (Context.theory_name @{theory}, prep_rls rearrange_assoc))] *}
neuper@52125
   657
ML {*
neuper@37954
   658
neuper@37954
   659
neuper@37954
   660
fun bin_o (Const (op_,(Type ("fun",
neuper@37954
   661
	   [Type (s2,[]),Type ("fun",
neuper@37954
   662
	    [Type (s4,tl4),Type (s5,tl5)])])))) = 
neuper@37954
   663
    if (s2=s4)andalso(s4=s5)then[op_]else[]
neuper@37954
   664
    | bin_o _                                   = [];
neuper@37954
   665
neuper@37954
   666
fun bin_op (t1 $ t2) = union op = (bin_op t1) (bin_op t2)
neuper@37954
   667
  | bin_op t         =  bin_o t;
neuper@37954
   668
fun is_bin_op t = ((bin_op t)<>[]);
neuper@37954
   669
neuper@37954
   670
fun bin_op_arg1 ((Const (op_,(Type ("fun",
neuper@37954
   671
	   [Type (s2,[]),Type ("fun",
neuper@37954
   672
	    [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) = 
neuper@37954
   673
    arg1;
neuper@37954
   674
fun bin_op_arg2 ((Const (op_,(Type ("fun",
neuper@37954
   675
	   [Type (s2,[]),Type ("fun",
neuper@37954
   676
	    [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) = 
neuper@37954
   677
    arg2;
neuper@37954
   678
neuper@37954
   679
neuper@37954
   680
exception NO_EQUATION_TERM;
neuper@41922
   681
fun is_equation ((Const ("HOL.eq",(Type ("fun",
neuper@37954
   682
		 [Type (_,[]),Type ("fun",
neuper@37954
   683
		  [Type (_,[]),Type ("bool",[])])])))) $ _ $ _) 
neuper@37954
   684
                  = true
neuper@37954
   685
  | is_equation _ = false;
neuper@41922
   686
fun equ_lhs ((Const ("HOL.eq",(Type ("fun",
neuper@37954
   687
		 [Type (_,[]),Type ("fun",
neuper@37954
   688
		  [Type (_,[]),Type ("bool",[])])])))) $ l $ r) 
neuper@37954
   689
              = l
neuper@37954
   690
  | equ_lhs _ = raise NO_EQUATION_TERM;
neuper@41922
   691
fun equ_rhs ((Const ("HOL.eq",(Type ("fun",
neuper@37954
   692
		 [Type (_,[]),Type ("fun",
neuper@37954
   693
		  [Type (_,[]),Type ("bool",[])])])))) $ l $ r) 
neuper@37954
   694
              = r
neuper@37954
   695
  | equ_rhs _ = raise NO_EQUATION_TERM;
neuper@37954
   696
neuper@37954
   697
neuper@37954
   698
fun atom (Const (_,Type (_,[])))           = true
neuper@37954
   699
  | atom (Free  (_,Type (_,[])))           = true
neuper@37954
   700
  | atom (Var   (_,Type (_,[])))           = true
neuper@37954
   701
(*| atom (_     (_,"?DUMMY"   ))           = true ..ML-error *)
neuper@37954
   702
  | atom((Const ("Bin.integ_of_bin",_)) $ _) = true
neuper@37954
   703
  | atom _                                 = false;
neuper@37954
   704
neuper@37954
   705
fun varids (Const  (s,Type (_,[])))         = [strip_thy s]
neuper@37954
   706
  | varids (Free   (s,Type (_,[])))         = if is_no s then []
neuper@37954
   707
					      else [strip_thy s]
neuper@37954
   708
  | varids (Var((s,_),Type (_,[])))         = [strip_thy s]
neuper@37954
   709
(*| varids (_      (s,"?DUMMY"   ))         =   ..ML-error *)
neuper@37954
   710
  | varids((Const ("Bin.integ_of_bin",_)) $ _)= [](*8.01: superfluous?*)
neuper@37954
   711
  | varids (Abs(a,T,t)) = union op = [a] (varids t)
neuper@37954
   712
  | varids (t1 $ t2) = union op = (varids t1) (varids t2)
neuper@37954
   713
  | varids _         = [];
neuper@37954
   714
(*> val t = term_of (hd (parse Diophant.thy "x"));
neuper@37954
   715
val t = Free ("x","?DUMMY") : term
neuper@37954
   716
> varids t;
neuper@37954
   717
val it = [] : string list          [] !!! *)
neuper@37954
   718
neuper@37954
   719
neuper@37954
   720
fun bin_ops_only ((Const op_) $ t1 $ t2) = 
neuper@37954
   721
    if(is_bin_op (Const op_))
neuper@37954
   722
    then(bin_ops_only t1)andalso(bin_ops_only t2)
neuper@37954
   723
    else false
neuper@37954
   724
  | bin_ops_only t =
neuper@37954
   725
    if atom t then true else bin_ops_only t;
neuper@37954
   726
neuper@37954
   727
fun polynomial opl t bdVar = (* bdVar TODO *)
neuper@37954
   728
    subset op = (bin_op t, opl) andalso (bin_ops_only t);
neuper@37954
   729
neuper@37954
   730
fun poly_equ opl bdVar t = is_equation t (* bdVar TODO *) 
neuper@37954
   731
    andalso polynomial opl (equ_lhs t) bdVar 
neuper@37954
   732
    andalso polynomial opl (equ_rhs t) bdVar
neuper@37954
   733
    andalso (subset op = (varids bdVar, varids (equ_lhs t)) orelse
neuper@37954
   734
             subset op = (varids bdVar, varids (equ_lhs t)));
neuper@37954
   735
neuper@37954
   736
(*fun max is =
neuper@37954
   737
    let fun max_ m [] = m 
neuper@37954
   738
	  | max_ m (i::is) = if m<i then max_ i is else max_ m is;
neuper@37954
   739
    in max_ (hd is) is end;
neuper@37954
   740
> max [1,5,3,7,4,2];
neuper@37954
   741
val it = 7 : int  *)
neuper@37954
   742
neuper@37954
   743
fun max (a,b) = if a < b then b else a;
neuper@37954
   744
neuper@37954
   745
fun degree addl mul bdVar t =
neuper@37954
   746
let
neuper@37954
   747
fun deg _ _ v (Const  (s,Type (_,[])))         = if v=strip_thy s then 1 else 0
neuper@37954
   748
  | deg _ _ v (Free   (s,Type (_,[])))         = if v=strip_thy s then 1 else 0
neuper@37954
   749
  | deg _ _ v (Var((s,_),Type (_,[])))         = if v=strip_thy s then 1 else 0
neuper@37954
   750
(*| deg _ _ v (_     (s,"?DUMMY"   ))          =   ..ML-error *) 
neuper@37954
   751
  | deg _ _ v((Const ("Bin.integ_of_bin",_)) $ _ )= 0 
neuper@37954
   752
  | deg addl mul v (h $ t1 $ t2) =
neuper@37954
   753
    if subset op = (bin_op h, addl)
neuper@37954
   754
    then max (deg addl mul v t1  ,deg addl mul v t2)
neuper@37954
   755
    else (*mul!*)(deg addl mul v t1)+(deg addl mul v t2)
neuper@37954
   756
in if polynomial (addl @ [mul]) t bdVar
neuper@37954
   757
   then SOME (deg addl mul (id_of bdVar) t) else (NONE:int option)
neuper@37954
   758
end;
neuper@37954
   759
fun degree_ addl mul bdVar t = (* do not export *)
neuper@37954
   760
    let fun opt (SOME i)= i
neuper@37954
   761
	  | opt  NONE   = 0
neuper@37954
   762
in opt (degree addl mul bdVar t) end;
neuper@37954
   763
neuper@37954
   764
neuper@37954
   765
fun linear addl mul t bdVar = (degree_ addl mul bdVar t)<2;
neuper@37954
   766
neuper@37954
   767
fun linear_equ addl mul bdVar t =
neuper@37954
   768
    if is_equation t 
neuper@37954
   769
    then let val degl = degree_ addl mul bdVar (equ_lhs t);
neuper@37954
   770
	     val degr = degree_ addl mul bdVar (equ_rhs t)
neuper@37954
   771
	 in if (degl>0 orelse degr>0)andalso max(degl,degr)<2
neuper@37954
   772
		then true else false
neuper@37954
   773
	 end
neuper@37954
   774
    else false;
neuper@37954
   775
(* strip_thy op_  before *)
neuper@37954
   776
fun is_div_op (dv,(Const (op_,(Type ("fun",
neuper@37954
   777
	   [Type (s2,[]),Type ("fun",
neuper@37954
   778
	    [Type (s4,tl4),Type (s5,tl5)])])))) )= (dv = strip_thy op_)
neuper@37954
   779
  | is_div_op _ = false;
neuper@37954
   780
neuper@37954
   781
fun is_denom bdVar div_op t =
neuper@37954
   782
    let fun is bool[v]dv (Const  (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
neuper@37954
   783
	  | is bool[v]dv (Free   (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false) 
neuper@37954
   784
	  | is bool[v]dv (Var((s,_),Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
neuper@37954
   785
	  | is bool[v]dv((Const ("Bin.integ_of_bin",_)) $ _) = false
neuper@37954
   786
	  | is bool[v]dv (h$n$d) = 
neuper@37954
   787
	      if is_div_op(dv,h) 
neuper@37954
   788
	      then (is false[v]dv n)orelse(is true[v]dv d)
neuper@37954
   789
	      else (is bool [v]dv n)orelse(is bool[v]dv d)
neuper@37954
   790
in is false (varids bdVar) (strip_thy div_op) t end;
neuper@37954
   791
neuper@37954
   792
neuper@37954
   793
fun rational t div_op bdVar = 
neuper@37954
   794
    is_denom bdVar div_op t andalso bin_ops_only t;
neuper@37954
   795
neuper@38001
   796
*}
neuper@38001
   797
ML {*
neuper@37954
   798
neuper@37954
   799
(** problem types **)
neuper@37954
   800
neuper@37954
   801
store_pbt
neuper@37972
   802
 (prep_pbt thy "pbl_test_uni_plain2" [] e_pblID
neuper@37954
   803
 (["plain_square","univariate","equation","test"],
neuper@37981
   804
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38001
   805
   ("#Where" ,["(matches (?a + ?b*v_v ^^^2 = 0) e_e) |" ^
neuper@38001
   806
	       "(matches (     ?b*v_v ^^^2 = 0) e_e) |" ^
neuper@37981
   807
	       "(matches (?a +    v_v ^^^2 = 0) e_e) |" ^
neuper@37981
   808
	       "(matches (        v_v ^^^2 = 0) e_e)"]),
neuper@38012
   809
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   810
  ],
neuper@52142
   811
  assoc_rls' @{theory} "matches", 
neuper@37981
   812
  SOME "solve (e_e::bool, v_v)", [["Test","solve_plain_square"]]));
neuper@37954
   813
(*
neuper@38001
   814
 val e_e = (term_of o the o (parse thy)) "e_e::bool";
neuper@37954
   815
 val ve = (term_of o the o (parse thy)) "4 + 3*x^^^2 = 0";
neuper@37954
   816
 val env = [(e_,ve)];
neuper@37954
   817
neuper@37954
   818
 val pre = (term_of o the o (parse thy))
neuper@38001
   819
	      "(matches (a + b*v_v ^^^2 = 0, e_e::bool)) |" ^
neuper@38001
   820
	      "(matches (    b*v_v ^^^2 = 0, e_e::bool)) |" ^
neuper@37981
   821
	      "(matches (a +   v_v ^^^2 = 0, e_e::bool)) |" ^
neuper@37981
   822
	      "(matches (      v_v ^^^2 = 0, e_e::bool))";
neuper@37954
   823
 val prei = subst_atomic env pre;
neuper@37954
   824
 val cpre = (cterm_of thy) prei;
neuper@37954
   825
neuper@37954
   826
 val SOME (ct,_) = rewrite_set_ thy false tval_rls cpre;
neuper@37954
   827
val ct = "True | False | False | False" : cterm 
neuper@37954
   828
neuper@37954
   829
> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
neuper@37954
   830
> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
neuper@37954
   831
> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
neuper@41928
   832
val ct = "HOL.True" : cterm
neuper@37954
   833
neuper@37954
   834
*)
neuper@37954
   835
neuper@38001
   836
*}
neuper@38001
   837
ML {*
neuper@37954
   838
store_pbt
neuper@37972
   839
 (prep_pbt thy "pbl_test_uni_poly" [] e_pblID
neuper@37954
   840
 (["polynomial","univariate","equation","test"],
neuper@38001
   841
  [("#Given" ,["equality (v_v ^^^2 + p_p * v_v + q__q = 0)","solveFor v_v"]),
neuper@41928
   842
   ("#Where" ,["HOL.False"]),
neuper@38012
   843
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   844
  ],
neuper@37981
   845
  e_rls, SOME "solve (e_e::bool, v_v)", []));
neuper@37954
   846
neuper@37954
   847
store_pbt
neuper@37972
   848
 (prep_pbt thy "pbl_test_uni_poly_deg2" [] e_pblID
neuper@37954
   849
 (["degree_two","polynomial","univariate","equation","test"],
neuper@38001
   850
  [("#Given" ,["equality (v_v ^^^2 + p_p * v_v + q__q = 0)","solveFor v_v"]),
neuper@38012
   851
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   852
  ],
neuper@38001
   853
  e_rls, SOME "solve (v_v ^^^2 + p_p * v_v + q__q = 0, v_v)", []));
neuper@37954
   854
neuper@37954
   855
store_pbt
neuper@37972
   856
 (prep_pbt thy "pbl_test_uni_poly_deg2_pq" [] e_pblID
neuper@37954
   857
 (["pq_formula","degree_two","polynomial","univariate","equation","test"],
neuper@38001
   858
  [("#Given" ,["equality (v_v ^^^2 + p_p * v_v + q__q = 0)","solveFor v_v"]),
neuper@38012
   859
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   860
  ],
neuper@38001
   861
  e_rls, SOME "solve (v_v ^^^2 + p_p * v_v + q__q = 0, v_v)", []));
neuper@37954
   862
neuper@37954
   863
store_pbt
neuper@37972
   864
 (prep_pbt thy "pbl_test_uni_poly_deg2_abc" [] e_pblID
neuper@37954
   865
 (["abc_formula","degree_two","polynomial","univariate","equation","test"],
neuper@38001
   866
  [("#Given" ,["equality (a_a * x ^^^2 + b_b * x + c_c = 0)","solveFor v_v"]),
neuper@38012
   867
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   868
  ],
neuper@38001
   869
  e_rls, SOME "solve (a_a * x ^^^2 + b_b * x + c_c = 0, v_v)", []));
neuper@37954
   870
neuper@38001
   871
*}
neuper@38001
   872
ML {*
neuper@37954
   873
store_pbt
neuper@37972
   874
 (prep_pbt thy "pbl_test_uni_root" [] e_pblID
neuper@37954
   875
 (["squareroot","univariate","equation","test"],
neuper@37981
   876
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@42008
   877
   ("#Where" ,["precond_rootpbl v_v"]),
neuper@38012
   878
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   879
  ],
neuper@37954
   880
  append_rls "contains_root" e_rls [Calc ("Test.contains'_root",
neuper@37954
   881
			  eval_contains_root "#contains_root_")], 
neuper@37981
   882
  SOME "solve (e_e::bool, v_v)", [["Test","square_equation"]]));
neuper@37954
   883
neuper@37954
   884
store_pbt
neuper@37972
   885
 (prep_pbt thy "pbl_test_uni_norm" [] e_pblID
neuper@37954
   886
 (["normalize","univariate","equation","test"],
neuper@37981
   887
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@37954
   888
   ("#Where" ,[]),
neuper@38012
   889
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   890
  ],
neuper@37981
   891
  e_rls, SOME "solve (e_e::bool, v_v)", [["Test","norm_univar_equation"]]));
neuper@37954
   892
neuper@37954
   893
store_pbt
neuper@37972
   894
 (prep_pbt thy "pbl_test_uni_roottest" [] e_pblID
neuper@37954
   895
 (["sqroot-test","univariate","equation","test"],
neuper@37981
   896
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@42008
   897
   ("#Where" ,["precond_rootpbl v_v"]),
neuper@38012
   898
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
   899
  ],
neuper@37981
   900
  e_rls, SOME "solve (e_e::bool, v_v)", []));
neuper@37954
   901
neuper@41934
   902
store_pbt
neuper@41934
   903
 (prep_pbt thy "pbl_test_intsimp" [] e_pblID
neuper@41934
   904
 (["inttype","test"],
neuper@41934
   905
  [("#Given" ,["intTestGiven t_t"]),
neuper@41934
   906
   ("#Where" ,[]),
neuper@41934
   907
   ("#Find"  ,["intTestFind s_s"]) 
neuper@41934
   908
  ],
neuper@41935
   909
  e_rls, NONE, [["Test","intsimp"]])); 
neuper@41934
   910
(*
neuper@41934
   911
show_ptyps();
neuper@41934
   912
get_pbt ["inttype","test"];
neuper@41934
   913
*)
neuper@41934
   914
neuper@38001
   915
*}
neuper@41934
   916
neuper@38001
   917
ML {*
neuper@37954
   918
store_met
neuper@37972
   919
 (prep_met thy  "met_test_sqrt" [] e_metID
neuper@37954
   920
(*root-equation, version for tests before 8.01.01*)
neuper@37954
   921
 (["Test","sqrt-equ-test"]:metID,
neuper@37981
   922
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@37981
   923
   ("#Where" ,["contains_root (e_e::bool)"]),
neuper@38012
   924
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   925
   ],
neuper@37954
   926
  {rew_ord'="e_rew_ord",rls'=tval_rls,
neuper@37954
   927
   srls =append_rls "srls_contains_root" e_rls 
neuper@37954
   928
		    [Calc ("Test.contains'_root",eval_contains_root "")],
neuper@37954
   929
   prls =append_rls "prls_contains_root" e_rls 
neuper@37954
   930
		    [Calc ("Test.contains'_root",eval_contains_root "")],
neuper@37954
   931
   calc=[],
neuper@42425
   932
   crls=tval_rls, errpats = [], nrls = e_rls(*,asm_rls=[],
neuper@37954
   933
   asm_thm=[("square_equation_left",""),
neuper@37954
   934
	    ("square_equation_right","")]*)},
neuper@37982
   935
 "Script Solve_root_equation (e_e::bool) (v_v::real) =  " ^
neuper@37981
   936
 "(let e_e = " ^
neuper@37981
   937
 "   ((While (contains_root e_e) Do" ^
neuper@37954
   938
 "      ((Rewrite square_equation_left True) @@" ^
neuper@37954
   939
 "       (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37954
   940
 "       (Try (Rewrite_Set rearrange_assoc False)) @@" ^
neuper@37954
   941
 "       (Try (Rewrite_Set isolate_root False)) @@" ^
neuper@37954
   942
 "       (Try (Rewrite_Set Test_simplify False)))) @@" ^
neuper@37954
   943
 "    (Try (Rewrite_Set norm_equation False)) @@" ^
neuper@37954
   944
 "    (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37991
   945
 "    (Rewrite_Set_Inst [(bdv,v_v::real)] isolate_bdv False) @@" ^
neuper@37954
   946
 "    (Try (Rewrite_Set Test_simplify False)))" ^
neuper@37981
   947
 "   e_e" ^
neuper@38001
   948
 " in [e_e::bool])"
neuper@37954
   949
  ));
neuper@37954
   950
neuper@38001
   951
*}
neuper@38001
   952
ML {*
neuper@37954
   953
store_met
neuper@37972
   954
 (prep_met thy  "met_test_sqrt2" [] e_metID
neuper@37954
   955
(*root-equation ... for test-*.sml until 8.01*)
neuper@37954
   956
 (["Test","squ-equ-test2"]:metID,
neuper@37981
   957
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38012
   958
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   959
   ],
neuper@37954
   960
  {rew_ord'="e_rew_ord",rls'=tval_rls,
neuper@37954
   961
   srls = append_rls "srls_contains_root" e_rls 
neuper@37954
   962
		     [Calc ("Test.contains'_root",eval_contains_root"")],
neuper@37954
   963
   prls=e_rls,calc=[],
neuper@42425
   964
   crls=tval_rls, errpats = [], nrls = e_rls(*,asm_rls=[],
neuper@37954
   965
   asm_thm=[("square_equation_left",""),
neuper@37954
   966
	    ("square_equation_right","")]*)},
neuper@37982
   967
 "Script Solve_root_equation (e_e::bool) (v_v::real) =  " ^
neuper@37981
   968
 "(let e_e = " ^
neuper@37981
   969
 "   ((While (contains_root e_e) Do" ^
neuper@37954
   970
 "      ((Rewrite square_equation_left True) @@" ^
neuper@37954
   971
 "       (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37954
   972
 "       (Try (Rewrite_Set rearrange_assoc False)) @@" ^
neuper@37954
   973
 "       (Try (Rewrite_Set isolate_root False)) @@" ^
neuper@37954
   974
 "       (Try (Rewrite_Set Test_simplify False)))) @@" ^
neuper@37954
   975
 "    (Try (Rewrite_Set norm_equation False)) @@" ^
neuper@37954
   976
 "    (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37991
   977
 "    (Rewrite_Set_Inst [(bdv,v_v::real)] isolate_bdv False) @@" ^
neuper@37954
   978
 "    (Try (Rewrite_Set Test_simplify False)))" ^
neuper@37991
   979
 "   e_e;" ^
neuper@38001
   980
 "  (L_L::bool list) = Tac subproblem_equation_dummy;          " ^
neuper@37991
   981
 "  L_L = Tac solve_equation_dummy                             " ^
neuper@37991
   982
 "  in Check_elementwise L_L {(v_v::real). Assumptions})"
neuper@37954
   983
  ));
neuper@37954
   984
neuper@38001
   985
*}
neuper@38001
   986
ML {*
neuper@37954
   987
store_met
neuper@37972
   988
 (prep_met thy "met_test_squ_sub" [] e_metID
neuper@37954
   989
(*tests subproblem fixed linear*)
neuper@37954
   990
 (["Test","squ-equ-test-subpbl1"]:metID,
neuper@37981
   991
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@42008
   992
   ("#Where" ,["precond_rootmet v_v"]),
neuper@38012
   993
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
   994
   ],
neuper@42008
   995
  {rew_ord' = "e_rew_ord", rls' = tval_rls, srls = e_rls,
neuper@42008
   996
   prls = append_rls "prls_met_test_squ_sub" e_rls
neuper@42010
   997
     [Calc ("Test.precond'_rootmet", eval_precond_rootmet "")],
neuper@42425
   998
   calc=[], crls=tval_rls, errpats = [], nrls = Test_simplify},
neuper@42025
   999
  "Script Solve_root_equation (e_e::bool) (v_v::real) =       " ^
neuper@42025
  1000
  " (let e_e = ((Try (Rewrite_Set norm_equation False)) @@    " ^
neuper@42025
  1001
  "            (Try (Rewrite_Set Test_simplify False))) e_e;  " ^
neuper@42025
  1002
  "     (L_L::bool list) =                                    " ^
neuper@42025
  1003
  "            (SubProblem (Test',                            " ^
neuper@42025
  1004
  "                         [linear,univariate,equation,test]," ^
neuper@42025
  1005
  "                         [Test,solve_linear])              " ^
neuper@42025
  1006
  "                        [BOOL e_e, REAL v_v])              " ^
neuper@42025
  1007
  "  in Check_elementwise L_L {(v_v::real). Assumptions})     "
neuper@37954
  1008
  ));
neuper@37954
  1009
neuper@38001
  1010
*}
neuper@38001
  1011
ML {*
neuper@37954
  1012
store_met
neuper@37972
  1013
 (prep_met thy "met_test_squ_sub2" [] e_metID
neuper@37954
  1014
 (*tests subproblem fixed degree 2*)
neuper@37954
  1015
 (["Test","squ-equ-test-subpbl2"]:metID,
neuper@37981
  1016
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38012
  1017
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
  1018
   ],
neuper@37954
  1019
  {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
neuper@42425
  1020
    crls=tval_rls, errpats = [], nrls = e_rls(*,
neuper@37954
  1021
   asm_rls=[],asm_thm=[("square_equation_left",""),
neuper@37954
  1022
	    ("square_equation_right","")]*)},
neuper@37982
  1023
   "Script Solve_root_equation (e_e::bool) (v_v::real) =  " ^
neuper@37991
  1024
   " (let e_e = Try (Rewrite_Set norm_equation False) e_e;              " ^
neuper@38001
  1025
   "(L_L::bool list) = (SubProblem (Test',[linear,univariate,equation,test]," ^
neuper@38001
  1026
   "                    [Test,solve_by_pq_formula]) [BOOL e_e, REAL v_v])" ^
neuper@37991
  1027
   "in Check_elementwise L_L {(v_v::real). Assumptions})"
neuper@37954
  1028
   )); 
neuper@37954
  1029
neuper@38001
  1030
*}
neuper@38001
  1031
ML {*
neuper@37954
  1032
store_met
neuper@37972
  1033
 (prep_met thy "met_test_squ_nonterm" [] e_metID
neuper@37954
  1034
 (*root-equation: see foils..., but notTerminating*)
neuper@37954
  1035
 (["Test","square_equation...notTerminating"]:metID,
neuper@37981
  1036
  [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38012
  1037
   ("#Find"  ,["solutions v_v'i'"])
neuper@37954
  1038
   ],
neuper@37954
  1039
  {rew_ord'="e_rew_ord",rls'=tval_rls,
neuper@37954
  1040
   srls = append_rls "srls_contains_root" e_rls 
neuper@37954
  1041
		     [Calc ("Test.contains'_root",eval_contains_root"")],
neuper@37954
  1042
   prls=e_rls,calc=[],
neuper@42425
  1043
    crls=tval_rls, errpats = [], nrls = e_rls(*,asm_rls=[],
neuper@37954
  1044
   asm_thm=[("square_equation_left",""),
neuper@37954
  1045
	    ("square_equation_right","")]*)},
neuper@37982
  1046
 "Script Solve_root_equation (e_e::bool) (v_v::real) =  " ^
neuper@37981
  1047
 "(let e_e = " ^
neuper@37981
  1048
 "   ((While (contains_root e_e) Do" ^
neuper@37954
  1049
 "      ((Rewrite square_equation_left True) @@" ^
neuper@37954
  1050
 "       (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37954
  1051
 "       (Try (Rewrite_Set rearrange_assoc False)) @@" ^
neuper@37954
  1052
 "       (Try (Rewrite_Set isolate_root False)) @@" ^
neuper@37954
  1053
 "       (Try (Rewrite_Set Test_simplify False)))) @@" ^
neuper@37954
  1054
 "    (Try (Rewrite_Set norm_equation False)) @@" ^
neuper@37954
  1055
 "    (Try (Rewrite_Set Test_simplify False)))" ^
neuper@37991
  1056
 "   e_e;" ^
neuper@38001
  1057
 "  (L_L::bool list) =                                        " ^
neuper@38001
  1058
 "    (SubProblem (Test',[linear,univariate,equation,test]," ^
neuper@38001
  1059
 "                 [Test,solve_linear]) [BOOL e_e, REAL v_v])" ^
neuper@37991
  1060
 "in Check_elementwise L_L {(v_v::real). Assumptions})"
neuper@37954
  1061
  ));
neuper@37954
  1062
neuper@38001
  1063
*}
neuper@38001
  1064
ML {*
neuper@37954
  1065
store_met
neuper@37972
  1066
 (prep_met thy  "met_test_eq1" [] e_metID
neuper@37954
  1067
(*root-equation1:*)
neuper@37954
  1068
 (["Test","square_equation1"]:metID,
neuper@37981
  1069
   [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38012
  1070
    ("#Find"  ,["solutions v_v'i'"])
neuper@37954
  1071
    ],
neuper@37954
  1072
   {rew_ord'="e_rew_ord",rls'=tval_rls,
neuper@37954
  1073
   srls = append_rls "srls_contains_root" e_rls 
neuper@37954
  1074
		     [Calc ("Test.contains'_root",eval_contains_root"")],
neuper@37954
  1075
   prls=e_rls,calc=[],
neuper@42425
  1076
    crls=tval_rls, errpats = [], nrls = e_rls(*,asm_rls=[],
neuper@37954
  1077
   asm_thm=[("square_equation_left",""),
neuper@37954
  1078
	    ("square_equation_right","")]*)},
neuper@37982
  1079
 "Script Solve_root_equation (e_e::bool) (v_v::real) =  " ^
neuper@37981
  1080
 "(let e_e = " ^
neuper@37981
  1081
 "   ((While (contains_root e_e) Do" ^
neuper@37954
  1082
 "      ((Rewrite square_equation_left True) @@" ^
neuper@37954
  1083
 "       (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37954
  1084
 "       (Try (Rewrite_Set rearrange_assoc False)) @@" ^
neuper@37954
  1085
 "       (Try (Rewrite_Set isolate_root False)) @@" ^
neuper@37954
  1086
 "       (Try (Rewrite_Set Test_simplify False)))) @@" ^
neuper@37954
  1087
 "    (Try (Rewrite_Set norm_equation False)) @@" ^
neuper@37954
  1088
 "    (Try (Rewrite_Set Test_simplify False)))" ^
neuper@37991
  1089
 "   e_e;" ^
neuper@38001
  1090
 "  (L_L::bool list) = (SubProblem (Test',[linear,univariate,equation,test]," ^
neuper@38001
  1091
 "                    [Test,solve_linear]) [BOOL e_e, REAL v_v])" ^
neuper@37991
  1092
 "  in Check_elementwise L_L {(v_v::real). Assumptions})"
neuper@37954
  1093
  ));
neuper@37954
  1094
neuper@38001
  1095
*}
neuper@38001
  1096
ML {*
neuper@37954
  1097
store_met
neuper@37972
  1098
 (prep_met thy "met_test_squ2" [] e_metID
neuper@37954
  1099
 (*root-equation2*)
neuper@37954
  1100
 (["Test","square_equation2"]:metID,
neuper@37981
  1101
   [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38012
  1102
    ("#Find"  ,["solutions v_v'i'"])
neuper@37954
  1103
    ],
neuper@37954
  1104
   {rew_ord'="e_rew_ord",rls'=tval_rls,
neuper@37954
  1105
   srls = append_rls "srls_contains_root" e_rls 
neuper@37954
  1106
		     [Calc ("Test.contains'_root",eval_contains_root"")],
neuper@37954
  1107
   prls=e_rls,calc=[],
neuper@42425
  1108
    crls=tval_rls, errpats = [], nrls = e_rls(*,asm_rls=[],
neuper@37954
  1109
   asm_thm=[("square_equation_left",""),
neuper@37954
  1110
	    ("square_equation_right","")]*)},
neuper@37982
  1111
 "Script Solve_root_equation (e_e::bool) (v_v::real)  =  " ^
neuper@37981
  1112
 "(let e_e = " ^
neuper@37981
  1113
 "   ((While (contains_root e_e) Do" ^
neuper@37954
  1114
 "      (((Rewrite square_equation_left True) Or " ^
neuper@37954
  1115
 "        (Rewrite square_equation_right True)) @@" ^
neuper@37954
  1116
 "       (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37954
  1117
 "       (Try (Rewrite_Set rearrange_assoc False)) @@" ^
neuper@37954
  1118
 "       (Try (Rewrite_Set isolate_root False)) @@" ^
neuper@37954
  1119
 "       (Try (Rewrite_Set Test_simplify False)))) @@" ^
neuper@37954
  1120
 "    (Try (Rewrite_Set norm_equation False)) @@" ^
neuper@37954
  1121
 "    (Try (Rewrite_Set Test_simplify False)))" ^
neuper@37991
  1122
 "   e_e;" ^
neuper@38001
  1123
 "  (L_L::bool list) = (SubProblem (Test',[plain_square,univariate,equation,test]," ^
neuper@38001
  1124
 "                    [Test,solve_plain_square]) [BOOL e_e, REAL v_v])" ^
neuper@37991
  1125
 "  in Check_elementwise L_L {(v_v::real). Assumptions})"
neuper@37954
  1126
  ));
neuper@37954
  1127
neuper@38001
  1128
*}
neuper@38001
  1129
ML {*
neuper@37954
  1130
store_met
neuper@37972
  1131
 (prep_met thy "met_test_squeq" [] e_metID
neuper@37954
  1132
 (*root-equation*)
neuper@37954
  1133
 (["Test","square_equation"]:metID,
neuper@37981
  1134
   [("#Given" ,["equality e_e","solveFor v_v"]),
neuper@38012
  1135
    ("#Find"  ,["solutions v_v'i'"])
neuper@37954
  1136
    ],
neuper@37954
  1137
   {rew_ord'="e_rew_ord",rls'=tval_rls,
neuper@37954
  1138
   srls = append_rls "srls_contains_root" e_rls 
neuper@37954
  1139
		     [Calc ("Test.contains'_root",eval_contains_root"")],
neuper@37954
  1140
   prls=e_rls,calc=[],
neuper@42425
  1141
    crls=tval_rls, errpats = [], nrls = e_rls(*,asm_rls=[],
neuper@37954
  1142
   asm_thm=[("square_equation_left",""),
neuper@37954
  1143
	    ("square_equation_right","")]*)},
neuper@37982
  1144
 "Script Solve_root_equation (e_e::bool) (v_v::real) =  " ^
neuper@37981
  1145
 "(let e_e = " ^
neuper@37981
  1146
 "   ((While (contains_root e_e) Do" ^
neuper@37954
  1147
 "      (((Rewrite square_equation_left True) Or" ^
neuper@37954
  1148
 "        (Rewrite square_equation_right True)) @@" ^
neuper@37954
  1149
 "       (Try (Rewrite_Set Test_simplify False)) @@" ^
neuper@37954
  1150
 "       (Try (Rewrite_Set rearrange_assoc False)) @@" ^
neuper@37954
  1151
 "       (Try (Rewrite_Set isolate_root False)) @@" ^
neuper@37954
  1152
 "       (Try (Rewrite_Set Test_simplify False)))) @@" ^
neuper@37954
  1153
 "    (Try (Rewrite_Set norm_equation False)) @@" ^
neuper@37954
  1154
 "    (Try (Rewrite_Set Test_simplify False)))" ^
neuper@37991
  1155
 "   e_e;" ^
neuper@38001
  1156
 "  (L_L::bool list) = (SubProblem (Test',[univariate,equation,test]," ^
neuper@38001
  1157
 "                    [no_met]) [BOOL e_e, REAL v_v])" ^
neuper@37991
  1158
 "  in Check_elementwise L_L {(v_v::real). Assumptions})"
neuper@37954
  1159
  ) ); (*#######*)
neuper@37954
  1160
neuper@38001
  1161
*}
neuper@38001
  1162
ML {*
neuper@37954
  1163
store_met
neuper@37972
  1164
 (prep_met thy "met_test_eq_plain" [] e_metID
neuper@37954
  1165
 (*solve_plain_square*)
neuper@37954
  1166
 (["Test","solve_plain_square"]:metID,
neuper@37981
  1167
   [("#Given",["equality e_e","solveFor v_v"]),
neuper@38001
  1168
   ("#Where" ,["(matches (?a + ?b*v_v ^^^2 = 0) e_e) |" ^
neuper@38001
  1169
	       "(matches (     ?b*v_v ^^^2 = 0) e_e) |" ^
neuper@37981
  1170
	       "(matches (?a +    v_v ^^^2 = 0) e_e) |" ^
neuper@37981
  1171
	       "(matches (        v_v ^^^2 = 0) e_e)"]), 
neuper@38012
  1172
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
  1173
   ],
neuper@37954
  1174
   {rew_ord'="e_rew_ord",rls'=tval_rls,calc=[],srls=e_rls,
neuper@52142
  1175
    prls = assoc_rls' @{theory} "matches",
neuper@42425
  1176
    crls=tval_rls, errpats = [], nrls = e_rls(*,
neuper@37954
  1177
    asm_rls=[],asm_thm=[]*)},
neuper@37982
  1178
  "Script Solve_plain_square (e_e::bool) (v_v::real) =           " ^
neuper@37981
  1179
   " (let e_e = ((Try (Rewrite_Set isolate_bdv False)) @@         " ^
neuper@37954
  1180
   "            (Try (Rewrite_Set Test_simplify False)) @@     " ^
neuper@37954
  1181
   "            ((Rewrite square_equality_0 False) Or        " ^
neuper@37954
  1182
   "             (Rewrite square_equality True)) @@            " ^
neuper@37981
  1183
   "            (Try (Rewrite_Set tval_rls False))) e_e             " ^
neuper@37981
  1184
   "  in ((Or_to_List e_e)::bool list))"
neuper@37954
  1185
 ));
neuper@37954
  1186
neuper@38001
  1187
*}
neuper@41935
  1188
neuper@38001
  1189
ML {*
neuper@37954
  1190
store_met
neuper@37972
  1191
 (prep_met thy "met_test_norm_univ" [] e_metID
neuper@37954
  1192
 (["Test","norm_univar_equation"]:metID,
neuper@37981
  1193
   [("#Given",["equality e_e","solveFor v_v"]),
neuper@37954
  1194
   ("#Where" ,[]), 
neuper@38012
  1195
   ("#Find"  ,["solutions v_v'i'"]) 
neuper@37954
  1196
   ],
neuper@37954
  1197
   {rew_ord'="e_rew_ord",rls'=tval_rls,srls = e_rls,prls=e_rls,
neuper@37954
  1198
   calc=[],
neuper@42425
  1199
    crls=tval_rls, errpats = [], nrls = e_rls},
neuper@37982
  1200
  "Script Norm_univar_equation (e_e::bool) (v_v::real) =      " ^
neuper@37981
  1201
   " (let e_e = ((Try (Rewrite rnorm_equation_add False)) @@   " ^
neuper@37981
  1202
   "            (Try (Rewrite_Set Test_simplify False))) e_e   " ^
neuper@38001
  1203
   "  in (SubProblem (Test',[univariate,equation,test],         " ^
neuper@38001
  1204
   "                    [no_met]) [BOOL e_e, REAL v_v]))"
neuper@37954
  1205
 ));
neuper@37954
  1206
neuper@41934
  1207
(*17.9.02 aus SqRoot.ML------------------------------^^^---*)  
neuper@37954
  1208
neuper@41934
  1209
store_met
neuper@41934
  1210
(prep_met thy "met_test_intsimp" [] e_metID
neuper@41934
  1211
 (["Test","intsimp"]:metID,
neuper@41934
  1212
  [("#Given" ,["intTestGiven t_t"]),
neuper@41934
  1213
   ("#Where" ,[]),
neuper@41934
  1214
   ("#Find"  ,["intTestFind s_s"]) 
neuper@41934
  1215
  ],
neuper@41934
  1216
   {rew_ord' = "e_rew_ord", rls' = tval_rls, srls = e_rls,
neuper@42425
  1217
    prls = e_rls, calc = [], crls = tval_rls, errpats = [], nrls = Test_simplify},
neuper@41934
  1218
 "Script STest_simplify (t_t::int) =                  " ^
neuper@41934
  1219
 "(Repeat                                                          " ^
neuper@41934
  1220
 "    ((Try (Calculate PLUS)) @@  " ^
neuper@41935
  1221
 "     (Try (Calculate TIMES))) t_t::int)"
neuper@41934
  1222
 ));
neuper@37954
  1223
neuper@38001
  1224
*}
neuper@41934
  1225
neuper@38001
  1226
ML {*
neuper@37954
  1227
(*8.4.03  aus Poly.ML--------------------------------vvv---
neuper@37954
  1228
  make_polynomial  ---> make_poly
neuper@37954
  1229
  ^-- for user          ^-- for systest _ONLY_*)  
neuper@37954
  1230
neuper@37954
  1231
local (*. for make_polytest .*)
neuper@37954
  1232
neuper@37954
  1233
open Term;  (* for type order = EQUAL | LESS | GREATER *)
neuper@37954
  1234
neuper@37954
  1235
fun pr_ord EQUAL = "EQUAL"
neuper@37954
  1236
  | pr_ord LESS  = "LESS"
neuper@37954
  1237
  | pr_ord GREATER = "GREATER";
neuper@37954
  1238
neuper@37954
  1239
fun dest_hd' (Const (a, T)) =                          (* ~ term.ML *)
neuper@37954
  1240
  (case a of
neuper@37954
  1241
     "Atools.pow" => ((("|||||||||||||", 0), T), 0)           (*WN greatest *)
neuper@37954
  1242
   | _ => (((a, 0), T), 0))
neuper@37954
  1243
  | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
neuper@37954
  1244
  | dest_hd' (Var v) = (v, 2)
neuper@37954
  1245
  | dest_hd' (Bound i) = ((("", i), dummyT), 3)
neuper@37954
  1246
  | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
neuper@37954
  1247
(* RL *)
neuper@37954
  1248
fun get_order_pow (t $ (Free(order,_))) = 
neuper@37954
  1249
    	(case int_of_str (order) of
neuper@37954
  1250
	             SOME d => d
neuper@37954
  1251
		   | NONE   => 0)
neuper@37954
  1252
  | get_order_pow _ = 0;
neuper@37954
  1253
neuper@37954
  1254
fun size_of_term' (Const(str,_) $ t) =
neuper@37954
  1255
  if "Atools.pow"=str then 1000 + size_of_term' t else 1 + size_of_term' t(*WN*)
neuper@37954
  1256
  | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
neuper@37954
  1257
  | size_of_term' (f$t) = size_of_term' f  +  size_of_term' t
neuper@37954
  1258
  | size_of_term' _ = 1;
neuper@38001
  1259
fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) =       (* ~ term.ML *)
neuper@38053
  1260
    (case term_ord' pr thy (t, u) of EQUAL => Term_Ord.typ_ord (T, U) 
neuper@38053
  1261
                                   | ord => ord)
neuper@38001
  1262
  | term_ord' pr thy (t, u) =
neuper@38053
  1263
    (if pr then 
neuper@38053
  1264
	 let val (f, ts) = strip_comb t and (g, us) = strip_comb u;
neuper@38053
  1265
	     val _ = tracing ("t= f@ts= \"" ^ term2str f ^ "\" @ \"[" ^
neuper@38053
  1266
	                      commas(map term2str ts) ^ "]\"")
neuper@38053
  1267
	     val _ = tracing ("u= g@us= \"" ^ term2str g ^"\" @ \"[" ^
neuper@38053
  1268
	                      commas(map term2str us) ^"]\"")
neuper@38053
  1269
	     val _ = tracing ("size_of_term(t,u)= (" ^
neuper@38053
  1270
	                      string_of_int (size_of_term' t) ^ ", " ^
neuper@38053
  1271
	                      string_of_int (size_of_term' u) ^ ")")
neuper@38053
  1272
	     val _ = tracing ("hd_ord(f,g)      = " ^ (pr_ord o hd_ord) (f,g))
neuper@38053
  1273
	     val _ = tracing ("terms_ord(ts,us) = " ^
neuper@38053
  1274
			      (pr_ord o terms_ord str false) (ts,us));
neuper@38053
  1275
	     val _ = tracing "-------"
neuper@37954
  1276
	 in () end
neuper@37954
  1277
       else ();
neuper@37954
  1278
	 case int_ord (size_of_term' t, size_of_term' u) of
neuper@37954
  1279
	   EQUAL =>
neuper@37954
  1280
	     let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
neuper@37954
  1281
	       (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) 
neuper@37954
  1282
	     | ord => ord)
neuper@37954
  1283
	     end
neuper@37954
  1284
	 | ord => ord)
neuper@37954
  1285
and hd_ord (f, g) =                                        (* ~ term.ML *)
neuper@37991
  1286
  prod_ord (prod_ord Term_Ord.indexname_ord Term_Ord.typ_ord) int_ord (dest_hd' f, dest_hd' g)
neuper@37954
  1287
and terms_ord str pr (ts, us) = 
neuper@37991
  1288
    list_ord (term_ord' pr (assoc_thy "Isac"))(ts, us);
neuper@37954
  1289
in
neuper@37954
  1290
neuper@37954
  1291
fun ord_make_polytest (pr:bool) thy (_:subst) tu = 
neuper@37954
  1292
    (term_ord' pr thy(***) tu = LESS );
neuper@37954
  1293
neuper@37954
  1294
end;(*local*)
neuper@38001
  1295
*}
neuper@38001
  1296
ML {*
neuper@37954
  1297
neuper@37954
  1298
rew_ord' := overwritel (!rew_ord',
neuper@37954
  1299
[("termlessI", termlessI),
neuper@37954
  1300
 ("ord_make_polytest", ord_make_polytest false thy)
neuper@37954
  1301
 ]);
neuper@37954
  1302
neuper@37954
  1303
(*WN060510 this was a preparation for prep_rls ...
neuper@37954
  1304
val scr_make_polytest = 
neuper@38001
  1305
"Script Expand_binomtest t_t =" ^
neuper@37954
  1306
"(Repeat                       " ^
neuper@37954
  1307
"((Try (Repeat (Rewrite real_diff_minus         False))) @@ " ^ 
neuper@37954
  1308
neuper@52062
  1309
" (Try (Repeat (Rewrite distrib_right   False))) @@ " ^	 
neuper@52062
  1310
" (Try (Repeat (Rewrite distrib_left  False))) @@ " ^	
neuper@37971
  1311
" (Try (Repeat (Rewrite left_diff_distrib  False))) @@ " ^	
neuper@37971
  1312
" (Try (Repeat (Rewrite right_diff_distrib False))) @@ " ^	
neuper@37954
  1313
neuper@37971
  1314
" (Try (Repeat (Rewrite mult_1_left             False))) @@ " ^		   
neuper@37971
  1315
" (Try (Repeat (Rewrite mult_zero_left             False))) @@ " ^		   
neuper@37971
  1316
" (Try (Repeat (Rewrite add_0_left      False))) @@ " ^	 
neuper@37954
  1317
neuper@48763
  1318
" (Try (Repeat (Rewrite mult_commute       False))) @@ " ^		
neuper@37954
  1319
" (Try (Repeat (Rewrite real_mult_left_commute  False))) @@ " ^	
neuper@48763
  1320
" (Try (Repeat (Rewrite mult_assoc         False))) @@ " ^		
neuper@37971
  1321
" (Try (Repeat (Rewrite add_commute        False))) @@ " ^		
neuper@37971
  1322
" (Try (Repeat (Rewrite add_left_commute   False))) @@ " ^	 
neuper@37971
  1323
" (Try (Repeat (Rewrite add_assoc          False))) @@ " ^	 
neuper@37954
  1324
neuper@37954
  1325
" (Try (Repeat (Rewrite sym_realpow_twoI        False))) @@ " ^	 
neuper@37954
  1326
" (Try (Repeat (Rewrite realpow_plus_1          False))) @@ " ^	 
neuper@37954
  1327
" (Try (Repeat (Rewrite sym_real_mult_2         False))) @@ " ^		
neuper@37954
  1328
" (Try (Repeat (Rewrite real_mult_2_assoc       False))) @@ " ^		
neuper@37954
  1329
neuper@37954
  1330
" (Try (Repeat (Rewrite real_num_collect        False))) @@ " ^		
neuper@37954
  1331
" (Try (Repeat (Rewrite real_num_collect_assoc  False))) @@ " ^	
neuper@37954
  1332
neuper@37954
  1333
" (Try (Repeat (Rewrite real_one_collect        False))) @@ " ^		
neuper@37954
  1334
" (Try (Repeat (Rewrite real_one_collect_assoc  False))) @@ " ^   
neuper@37954
  1335
neuper@37975
  1336
" (Try (Repeat (Calculate PLUS  ))) @@ " ^
neuper@37975
  1337
" (Try (Repeat (Calculate TIMES ))) @@ " ^
neuper@37975
  1338
" (Try (Repeat (Calculate POWER)))) " ^  
neuper@38001
  1339
" t_t)";
neuper@37954
  1340
-----------------------------------------------------*)
neuper@37954
  1341
neuper@37954
  1342
val make_polytest =
neuper@37954
  1343
  Rls{id = "make_polytest", preconds = []:term list, 
neuper@52105
  1344
      rew_ord = ("ord_make_polytest", ord_make_polytest false @{theory "Poly"}),
neuper@37954
  1345
      erls = testerls, srls = Erls,
neuper@38014
  1346
      calc = [("PLUS"  , ("Groups.plus_class.plus", eval_binop "#add_")), 
neuper@38034
  1347
	      ("TIMES" , ("Groups.times_class.times", eval_binop "#mult_")),
neuper@37954
  1348
	      ("POWER", ("Atools.pow", eval_binop "#power_"))
neuper@42451
  1349
	      ], errpatts = [],
neuper@37969
  1350
      rules = [Thm ("real_diff_minus",num_str @{thm real_diff_minus}),
neuper@37954
  1351
	       (*"a - b = a + (-1) * b"*)
neuper@52062
  1352
	       Thm ("distrib_right" ,num_str @{thm distrib_right}),
neuper@37954
  1353
	       (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
neuper@52062
  1354
	       Thm ("distrib_left",num_str @{thm distrib_left}),
neuper@37954
  1355
	       (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
neuper@37965
  1356
	       Thm ("left_diff_distrib" ,num_str @{thm left_diff_distrib}),
neuper@37954
  1357
	       (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
neuper@37982
  1358
	       Thm ("right_diff_distrib",num_str @{thm right_diff_distrib}),
neuper@37954
  1359
	       (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
neuper@37965
  1360
	       Thm ("mult_1_left",num_str @{thm mult_1_left}),                 
neuper@37954
  1361
	       (*"1 * z = z"*)
neuper@37965
  1362
	       Thm ("mult_zero_left",num_str @{thm mult_zero_left}),        
neuper@37954
  1363
	       (*"0 * z = 0"*)
neuper@37965
  1364
	       Thm ("add_0_left",num_str @{thm add_0_left}),
neuper@37954
  1365
	       (*"0 + z = z"*)
neuper@37954
  1366
neuper@37954
  1367
	       (*AC-rewriting*)
neuper@48763
  1368
	       Thm ("mult_commute",num_str @{thm mult_commute}),
neuper@37954
  1369
	       (* z * w = w * z *)
neuper@37969
  1370
	       Thm ("real_mult_left_commute",num_str @{thm real_mult_left_commute}),
neuper@37954
  1371
	       (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
neuper@48763
  1372
	       Thm ("mult_assoc",num_str @{thm mult_assoc}),		
neuper@37954
  1373
	       (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
neuper@37965
  1374
	       Thm ("add_commute",num_str @{thm add_commute}),	
neuper@37954
  1375
	       (*z + w = w + z*)
neuper@37965
  1376
	       Thm ("add_left_commute",num_str @{thm add_left_commute}),
neuper@37954
  1377
	       (*x + (y + z) = y + (x + z)*)
neuper@37965
  1378
	       Thm ("add_assoc",num_str @{thm add_assoc}),	               
neuper@37954
  1379
	       (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
neuper@37954
  1380
neuper@37969
  1381
	       Thm ("sym_realpow_twoI",
neuper@37969
  1382
                     num_str (@{thm realpow_twoI} RS @{thm sym})),	
neuper@37954
  1383
	       (*"r1 * r1 = r1 ^^^ 2"*)
neuper@37969
  1384
	       Thm ("realpow_plus_1",num_str @{thm realpow_plus_1}),		
neuper@37954
  1385
	       (*"r * r ^^^ n = r ^^^ (n + 1)"*)
neuper@37969
  1386
	       Thm ("sym_real_mult_2",
neuper@37969
  1387
                     num_str (@{thm real_mult_2} RS @{thm sym})),	
neuper@37954
  1388
	       (*"z1 + z1 = 2 * z1"*)
neuper@37969
  1389
	       Thm ("real_mult_2_assoc",num_str @{thm real_mult_2_assoc}),	
neuper@37954
  1390
	       (*"z1 + (z1 + k) = 2 * z1 + k"*)
neuper@37954
  1391
neuper@37969
  1392
	       Thm ("real_num_collect",num_str @{thm real_num_collect}), 
neuper@37954
  1393
	       (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
neuper@37969
  1394
	       Thm ("real_num_collect_assoc",num_str @{thm real_num_collect_assoc}),
neuper@37954
  1395
	       (*"[| l is_const; m is_const |] ==>  
neuper@37954
  1396
				l * n + (m * n + k) =  (l + m) * n + k"*)
neuper@37969
  1397
	       Thm ("real_one_collect",num_str @{thm real_one_collect}),	
neuper@37954
  1398
	       (*"m is_const ==> n + m * n = (1 + m) * n"*)
neuper@37969
  1399
	       Thm ("real_one_collect_assoc",num_str @{thm real_one_collect_assoc}), 
neuper@37954
  1400
	       (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
neuper@37954
  1401
neuper@38014
  1402
	       Calc ("Groups.plus_class.plus", eval_binop "#add_"), 
neuper@38034
  1403
	       Calc ("Groups.times_class.times", eval_binop "#mult_"),
neuper@37954
  1404
	       Calc ("Atools.pow", eval_binop "#power_")
neuper@37954
  1405
	       ],
neuper@48763
  1406
      scr = EmptyScr(*Prog ((term_of o the o (parse thy)) 
neuper@37954
  1407
      scr_make_polytest)*)
neuper@38001
  1408
      }:rls; 
neuper@38001
  1409
*}
neuper@38001
  1410
ML {*     
neuper@38001
  1411
(*WN060510 this was done before 'fun prep_rls' ...------------------------
neuper@37954
  1412
val scr_expand_binomtest =
neuper@38001
  1413
"Script Expand_binomtest t_t =" ^
neuper@37954
  1414
"(Repeat                       " ^
neuper@37954
  1415
"((Try (Repeat (Rewrite real_plus_binom_pow2    False))) @@ " ^
neuper@37954
  1416
" (Try (Repeat (Rewrite real_plus_binom_times   False))) @@ " ^
neuper@37954
  1417
" (Try (Repeat (Rewrite real_minus_binom_pow2   False))) @@ " ^
neuper@37954
  1418
" (Try (Repeat (Rewrite real_minus_binom_times  False))) @@ " ^
neuper@37954
  1419
" (Try (Repeat (Rewrite real_plus_minus_binom1  False))) @@ " ^
neuper@37954
  1420
" (Try (Repeat (Rewrite real_plus_minus_binom2  False))) @@ " ^
neuper@37954
  1421
neuper@37971
  1422
" (Try (Repeat (Rewrite mult_1_left             False))) @@ " ^
neuper@37971
  1423
" (Try (Repeat (Rewrite mult_zero_left             False))) @@ " ^
neuper@37971
  1424
" (Try (Repeat (Rewrite add_0_left      False))) @@ " ^
neuper@37954
  1425
neuper@37975
  1426
" (Try (Repeat (Calculate PLUS  ))) @@ " ^
neuper@37975
  1427
" (Try (Repeat (Calculate TIMES ))) @@ " ^
neuper@37975
  1428
" (Try (Repeat (Calculate POWER))) @@ " ^
neuper@37954
  1429
neuper@37954
  1430
" (Try (Repeat (Rewrite sym_realpow_twoI        False))) @@ " ^
neuper@37954
  1431
" (Try (Repeat (Rewrite realpow_plus_1          False))) @@ " ^
neuper@37954
  1432
" (Try (Repeat (Rewrite sym_real_mult_2         False))) @@ " ^
neuper@37954
  1433
" (Try (Repeat (Rewrite real_mult_2_assoc       False))) @@ " ^
neuper@37954
  1434
neuper@37954
  1435
" (Try (Repeat (Rewrite real_num_collect        False))) @@ " ^
neuper@37954
  1436
" (Try (Repeat (Rewrite real_num_collect_assoc  False))) @@ " ^
neuper@37954
  1437
neuper@37954
  1438
" (Try (Repeat (Rewrite real_one_collect        False))) @@ " ^
neuper@37954
  1439
" (Try (Repeat (Rewrite real_one_collect_assoc  False))) @@ " ^ 
neuper@37954
  1440
neuper@37975
  1441
" (Try (Repeat (Calculate PLUS  ))) @@ " ^
neuper@37975
  1442
" (Try (Repeat (Calculate TIMES ))) @@ " ^
neuper@37975
  1443
" (Try (Repeat (Calculate POWER)))) " ^  
neuper@38001
  1444
" t_t)";
neuper@38001
  1445
--------------------------------------------------------------------------*)
neuper@37954
  1446
neuper@37954
  1447
val expand_binomtest =
neuper@37954
  1448
  Rls{id = "expand_binomtest", preconds = [], 
neuper@37954
  1449
      rew_ord = ("termlessI",termlessI),
neuper@37954
  1450
      erls = testerls, srls = Erls,
neuper@38014
  1451
      calc = [("PLUS"  , ("Groups.plus_class.plus", eval_binop "#add_")), 
neuper@38034
  1452
	      ("TIMES" , ("Groups.times_class.times", eval_binop "#mult_")),
neuper@37954
  1453
	      ("POWER", ("Atools.pow", eval_binop "#power_"))
neuper@42451
  1454
	      ], errpatts = [],
neuper@38001
  1455
      rules = 
neuper@38001
  1456
      [Thm ("real_plus_binom_pow2"  ,num_str @{thm real_plus_binom_pow2}),     
neuper@37954
  1457
	       (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
neuper@38001
  1458
       Thm ("real_plus_binom_times" ,num_str @{thm real_plus_binom_times}),    
neuper@37954
  1459
	      (*"(a + b)*(a + b) = ...*)
neuper@38001
  1460
       Thm ("real_minus_binom_pow2" ,num_str @{thm real_minus_binom_pow2}),   
neuper@38001
  1461
       (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
neuper@38001
  1462
       Thm ("real_minus_binom_times",num_str @{thm real_minus_binom_times}),   
neuper@38001
  1463
       (*"(a - b)*(a - b) = ...*)
neuper@38001
  1464
       Thm ("real_plus_minus_binom1",num_str @{thm real_plus_minus_binom1}),   
neuper@38001
  1465
        (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
neuper@38001
  1466
       Thm ("real_plus_minus_binom2",num_str @{thm real_plus_minus_binom2}),   
neuper@38001
  1467
        (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
neuper@38001
  1468
       (*RL 020915*)
neuper@38001
  1469
       Thm ("real_pp_binom_times",num_str @{thm real_pp_binom_times}), 
neuper@38001
  1470
        (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
neuper@38001
  1471
       Thm ("real_pm_binom_times",num_str @{thm real_pm_binom_times}), 
neuper@38001
  1472
        (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
neuper@38001
  1473
       Thm ("real_mp_binom_times",num_str @{thm real_mp_binom_times}), 
neuper@38001
  1474
        (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
neuper@38001
  1475
       Thm ("real_mm_binom_times",num_str @{thm real_mm_binom_times}), 
neuper@38001
  1476
        (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
neuper@38001
  1477
       Thm ("realpow_multI",num_str @{thm realpow_multI}),                
neuper@38001
  1478
        (*(a*b)^^^n = a^^^n * b^^^n*)
neuper@38001
  1479
       Thm ("real_plus_binom_pow3",num_str @{thm real_plus_binom_pow3}),
neuper@38001
  1480
        (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *)
neuper@38001
  1481
       Thm ("real_minus_binom_pow3",num_str @{thm real_minus_binom_pow3}),
neuper@38001
  1482
        (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *)
neuper@37954
  1483
neuper@37954
  1484
neuper@52062
  1485
     (*  Thm ("distrib_right" ,num_str @{thm distrib_right}),	
neuper@38001
  1486
	 (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
neuper@52062
  1487
	Thm ("distrib_left",num_str @{thm distrib_left}),	
neuper@38001
  1488
	(*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
neuper@38001
  1489
	Thm ("left_diff_distrib" ,num_str @{thm left_diff_distrib}),	
neuper@38001
  1490
	(*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
neuper@38001
  1491
	Thm ("right_diff_distrib",num_str @{thm right_diff_distrib}),	
neuper@38001
  1492
	(*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
neuper@38001
  1493
	*)
neuper@38001
  1494
	
neuper@38001
  1495
	Thm ("mult_1_left",num_str @{thm mult_1_left}),              
neuper@38001
  1496
         (*"1 * z = z"*)
neuper@38001
  1497
	Thm ("mult_zero_left",num_str @{thm mult_zero_left}),              
neuper@38001
  1498
         (*"0 * z = 0"*)
neuper@38001
  1499
	Thm ("add_0_left",num_str @{thm add_0_left}),
neuper@38001
  1500
         (*"0 + z = z"*)
neuper@37954
  1501
neuper@38014
  1502
	Calc ("Groups.plus_class.plus", eval_binop "#add_"), 
neuper@38034
  1503
	Calc ("Groups.times_class.times", eval_binop "#mult_"),
neuper@38001
  1504
	Calc ("Atools.pow", eval_binop "#power_"),
neuper@38001
  1505
        (*	       
neuper@48763
  1506
	 Thm ("mult_commute",num_str @{thm mult_commute}),		
neuper@38001
  1507
        (*AC-rewriting*)
neuper@38001
  1508
	Thm ("real_mult_left_commute",num_str @{thm real_mult_left_commute}),
neuper@48763
  1509
	Thm ("mult_assoc",num_str @{thm mult_assoc}),
neuper@38001
  1510
	Thm ("add_commute",num_str @{thm add_commute}),	
neuper@38001
  1511
	Thm ("add_left_commute",num_str @{thm add_left_commute}),
neuper@38001
  1512
	Thm ("add_assoc",num_str @{thm add_assoc}),
neuper@38001
  1513
	*)
neuper@38001
  1514
	
neuper@38001
  1515
	Thm ("sym_realpow_twoI",
neuper@38001
  1516
              num_str (@{thm realpow_twoI} RS @{thm sym})),
neuper@38001
  1517
	(*"r1 * r1 = r1 ^^^ 2"*)
neuper@38001
  1518
	Thm ("realpow_plus_1",num_str @{thm realpow_plus_1}),			
neuper@38001
  1519
	(*"r * r ^^^ n = r ^^^ (n + 1)"*)
neuper@38001
  1520
	(*Thm ("sym_real_mult_2",
neuper@38001
  1521
                num_str (@{thm real_mult_2} RS @{thm sym})),
neuper@38001
  1522
	(*"z1 + z1 = 2 * z1"*)*)
neuper@38001
  1523
	Thm ("real_mult_2_assoc",num_str @{thm real_mult_2_assoc}),		
neuper@38001
  1524
	(*"z1 + (z1 + k) = 2 * z1 + k"*)
neuper@37954
  1525
neuper@38001
  1526
	Thm ("real_num_collect",num_str @{thm real_num_collect}), 
neuper@38001
  1527
	(*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
neuper@38001
  1528
	Thm ("real_num_collect_assoc",num_str @{thm real_num_collect_assoc}),	
neuper@38001
  1529
	(*"[| l is_const; m is_const |] ==>  l * n + (m * n + k) =  (l + m) * n + k"*)
neuper@38001
  1530
	Thm ("real_one_collect",num_str @{thm real_one_collect}),		
neuper@38001
  1531
	(*"m is_const ==> n + m * n = (1 + m) * n"*)
neuper@38001
  1532
	Thm ("real_one_collect_assoc",num_str @{thm real_one_collect_assoc}), 
neuper@38001
  1533
	(*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
neuper@37954
  1534
neuper@38014
  1535
	Calc ("Groups.plus_class.plus", eval_binop "#add_"), 
neuper@38034
  1536
	Calc ("Groups.times_class.times", eval_binop "#mult_"),
neuper@38001
  1537
	Calc ("Atools.pow", eval_binop "#power_")
neuper@38001
  1538
	],
neuper@37954
  1539
      scr = EmptyScr
neuper@37954
  1540
(*Script ((term_of o the o (parse thy)) scr_expand_binomtest)*)
neuper@37954
  1541
      }:rls;      
neuper@37954
  1542
neuper@37954
  1543
neuper@37967
  1544
ruleset' := overwritelthy @{theory} (!ruleset',
neuper@37954
  1545
   [("make_polytest", prep_rls make_polytest),
neuper@37954
  1546
    ("expand_binomtest", prep_rls expand_binomtest)
neuper@37954
  1547
    ]);
neuper@37954
  1548
*}
neuper@52125
  1549
setup {* KEStore_Elems.add_rlss 
neuper@52125
  1550
  [("make_polytest", (Context.theory_name @{theory}, prep_rls make_polytest)), 
neuper@52125
  1551
  ("expand_binomtest", (Context.theory_name @{theory}, prep_rls expand_binomtest))] *}
neuper@37906
  1552
neuper@37906
  1553
end