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