1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/sml/IsacKnowledge/Rational.ML Thu Apr 17 18:01:03 2003 +0200
1.3 @@ -0,0 +1,3481 @@
1.4 +(* use"../knowledge/Rational.ML";
1.5 + use"knowledge/Rational.ML";
1.6 + use"Rational.ML";
1.7 + *)
1.8 +
1.9 +(*. calculate in rationals: gcd, lcm, etc.
1.10 + (c) Stefan Karnel
1.11 + Institute for Mathematics D and Institute for Software Technology,
1.12 + TU-Graz SS 2002
1.13 +
1.14 +Remark on notions in the documentation below:
1.15 + referring to the remark on 'polynomials' in Poly.sml we use
1.16 + (2) 'polynomial' normalform (Polynom)
1.17 + (3) 'expanded_term' normalform (Ausmultiplizierter Term),
1.18 + where normalform (2) is a special case of (3), i.e. (3) implies (2).
1.19 + Instead of
1.20 + 'fraction with numerator and nominator both in normalform (2)'
1.21 + 'fraction with numerator and nominator both in normalform (3)'
1.22 + we say:
1.23 + 'fraction in normalform (2)'
1.24 + 'fraction in normalform (3)'
1.25 + or
1.26 + 'fraction (2)'
1.27 + 'fraction (3)'.
1.28 + a 'simple fraction' is a term with '/' as outmost operator and
1.29 + numerator and nominator in normalform (2) or (3).
1.30 +.*)
1.31 +
1.32 +signature RATIONALI =
1.33 +sig
1.34 + type mv_monom (*.internal representation.*)
1.35 + type mv_poly (*.internal reprecsentation.*)
1.36 + val add_fraction_ : (*.add 2 or more fractions.*)
1.37 + theory -> (*.10.02 unused.*)
1.38 + term -> (*.2 or more fractions with normalform (3).*)
1.39 + (term * (*.one fraction in normalform (3) ?????????WN???*)
1.40 + term list) (*.eventual asumptions in normalform (3) ??????WN???.*)
1.41 + option (*.None: the function is not applicable.*)
1.42 + val add_fraction_p_ :(*.add 2 or more fractions.*)
1.43 + theory -> (*.10.02 unused.*)
1.44 + term -> (*.2 or more fractions with normalform (2).*)
1.45 + (term * (*.one fraction with normalform (2).*)
1.46 + term list) (*.eventual asumptions in normalform (2) ??????WN???.*)
1.47 + option (*.None: the function is not applicable.*)
1.48 + val calculate_Rational :
1.49 + rls (*.simplifies expressions with numerals.*)
1.50 + val calc_rat_erls:rls(*for calculate_Rational:make local with
1.51 + FIXX@ME result:term * term list*)
1.52 + val cancel : rls (*.cancels a single fraction in normalform (3).
1.53 + resulting in a canceled fraction (3).*)
1.54 + val cancel_ : (*.cancels a single fraction.*)
1.55 + theory -> (*.10.02 unused.*)
1.56 + term -> (*.fraction in normalform (3).*)
1.57 + (term * (*.fraction in normalform (3).*)
1.58 + term list) (*.eventual asumptions in normalform (3).*)
1.59 + option (*.None: the function is not applicable.*)
1.60 + val cancel_p : rls (*.cancels a single fraction with normalform (2)
1.61 + resulting in a canceled fraction (2).*)
1.62 + val cancel_p_ :
1.63 + theory ->
1.64 + term ->
1.65 + (term *
1.66 + term list)
1.67 + option
1.68 + val common_nominator :
1.69 + rls (*.transforms sums of at least 2 fractions (3) to
1.70 + sums with the least common multiple as nominator.*)
1.71 + val common_nominator_ : theory -> term -> (term * term list) option
1.72 + val common_nominator_p :
1.73 + rls (*.transforms sums of at least 2 fractions (2) to
1.74 + sums with the least common multiple as nominator.*)
1.75 + val common_nominator_p_ : theory -> term -> (term * term list) option
1.76 + val eval_is_expanded : string -> 'a -> term -> theory ->
1.77 + (string * term) option
1.78 + val expanded2polynomial : term -> term option
1.79 + val factout_ : theory -> term -> (term * term list) option
1.80 + val factout_p_ : theory -> term -> (term * term list) option
1.81 + val is_expanded : term -> bool
1.82 + val is_polynomial : term -> bool
1.83 +
1.84 + val mv_gcd : (int * int list) list -> mv_poly -> mv_poly
1.85 + val mv_lcm : mv_poly -> mv_poly -> mv_poly
1.86 +
1.87 + val norm_expanded_rat_ : theory -> term -> (term * term list) option
1.88 +(*val norm_Rational : rls(*.normalizes an arbitrary rational term without
1.89 + roots into a simple and canceled fraction
1.90 + with normalform (2).*)
1.91 +-------nur fuer Arbeit 18.3.03---*)
1.92 +(*val norm_rational_p : 19.10.02 missing FIXXXXXXXXXXXXME
1.93 + rls (*.normalizes an rational term (2) without
1.94 + roots into a simple and canceled fraction
1.95 + with normalform (2).*)
1.96 +*)
1.97 + val norm_rational_ : theory -> term -> (term * term list) option
1.98 + val polynomial2expanded : term -> term option
1.99 + val rational_erls :
1.100 + rls (*.evaluates an arbitrary rational term with numerals.*)
1.101 +
1.102 +(*????????WN? fehlen Funktionen, die exportiert werden sollen ? *)
1.103 +end
1.104 +
1.105 +(*.survey on the functions
1.106 + ~~~~~~~~~~~~~~~~~~~~~~~
1.107 + (2) 'polynomial' :rls | (3)'expanded_term':rls
1.108 +--------------------:------------------+-------------------:-----------------
1.109 + factout_p_ : | factout_ :
1.110 + cancel_p_ : | cancel_ :
1.111 + :cancel_p | :cancel
1.112 +--------------------:------------------+-------------------:-----------------
1.113 + common_nominator_p_: | common_nominator_ :
1.114 + :common_nominator_p| :common_nominator
1.115 + add_fraction_p_ : | add_fraction_ :
1.116 +--------------------:------------------+-------------------:-----------------
1.117 +??? :norm_rational_p | :norm_rational
1.118 +
1.119 +This survey shows only the principal functions for reuse, and the identifiers
1.120 +of the rls exported. The list below shows some more useful functions.
1.121 +
1.122 +
1.123 +conversion from Isabelle-term to internal representation
1.124 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.125 +
1.126 +... BITTE FORTSETZEN ...
1.127 +
1.128 +polynomial2expanded = ...
1.129 +expanded2polynomial = ...
1.130 +
1.131 +remark: polynomial2expanded o expanded2polynomial = I,
1.132 + where 'o' is function chaining, and 'I' is identity ??????WN?????????
1.133 +
1.134 +functions for greatest common divisor and canceling
1.135 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.136 +mv_gcd
1.137 +factout_
1.138 +factout_p_
1.139 +cancel_
1.140 +cancel_p_
1.141 +
1.142 +functions for least common multiple and addition of fractions
1.143 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.144 +mv_lcm
1.145 +common_nominator_
1.146 +common_nominator_p_
1.147 +add_fraction_ (*.add 2 or more fractions.*)
1.148 +add_fraction_p_ (*.add 2 or more fractions.*)
1.149 +
1.150 +functions for normalform of rationals
1.151 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.152 +??? interne Funktionen f"ur norm_rational:
1.153 + schaffen diese SML-Funktionen wirklich ganz allgemeine Terme???
1.154 +
1.155 +norm_rational_
1.156 +norm_expanded_rat_
1.157 +
1.158 +.*)
1.159 +
1.160 +
1.161 +(*##*)
1.162 +structure RationalI : RATIONALI =
1.163 +struct
1.164 +(*##*)
1.165 +
1.166 +(*. gcd of integers .*)
1.167 +(* die gcd Funktion von Isabelle funktioniert nicht richtig !!! *)
1.168 +fun gcd_int a b = if b=0 then a
1.169 + else gcd_int b (a mod b);
1.170 +
1.171 +
1.172 +(*. univariate polynomials (uv) .*)
1.173 +(*. univariate polynomials are represented as a list of the coefficent in reverse maximum degree order .*)
1.174 +(*. 5 * x^5 + 4 * x^3 + 2 * x^2 + x + 19 => [19,1,2,4,0,5] .*)
1.175 +type uv_poly = int list;
1.176 +
1.177 +
1.178 +(*. adds two uv polynomials .*)
1.179 +fun uv_mod_add_poly ([]:uv_poly,p2:uv_poly) = p2:uv_poly
1.180 + | uv_mod_add_poly (p1,[]) = p1
1.181 + | uv_mod_add_poly (x::p1,y::p2) = (x+y)::(uv_mod_add_poly(p1,p2));
1.182 +
1.183 +(*. multiplies a uv polynomial with a skalar s .*)
1.184 +fun uv_mod_smul_poly ([]:uv_poly,s:int) = []:uv_poly
1.185 + | uv_mod_smul_poly (x::p,s) = (x*s)::(uv_mod_smul_poly(p,s));
1.186 +
1.187 +(*. calculates the remainder of a polynomial divided by a skalar s .*)
1.188 +fun uv_mod_rem_poly ([]:uv_poly,s) = []:uv_poly
1.189 + | uv_mod_rem_poly (x::p,s) = (x mod s)::(uv_mod_smul_poly(p,s));
1.190 +
1.191 +(*. calculates the degree of a uv polynomial .*)
1.192 +fun uv_mod_deg ([]:uv_poly) = 0
1.193 + | uv_mod_deg p = length(p)-1;
1.194 +
1.195 +(*. calculates the remainder of x/p and represents it as value between -p/2 and p/2 .*)
1.196 +fun uv_mod_mod2(x,p)=
1.197 + let
1.198 + val y=(x mod p);
1.199 + in
1.200 + if (y)>(p div 2) then (y)-p else
1.201 + (
1.202 + if (y)<(~p div 2) then p+(y) else (y)
1.203 + )
1.204 + end;
1.205 +
1.206 +(*. calculates the remainder for each element of a integer list divided by p .*)
1.207 +fun uv_mod_list_modp [] p = []
1.208 + | uv_mod_list_modp (x::xs) p = (uv_mod_mod2(x,p))::(uv_mod_list_modp xs p);
1.209 +
1.210 +(*. appends an integer at the end of a integer list .*)
1.211 +fun uv_mod_null (p1:int list,0) = p1
1.212 + | uv_mod_null (p1:int list,n1:int) = uv_mod_null(p1,n1-1) @ [0];
1.213 +
1.214 +(*. uv polynomial division, result is (quotient, remainder) .*)
1.215 +(*. only for uv_mod_divides .*)
1.216 +(* FIXME: Division von x^9+x^5+1 durch x-1000 funktioniert nicht integer zu klein *)
1.217 +fun uv_mod_pdiv (p1:uv_poly) ([]:uv_poly) = raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero")
1.218 + | uv_mod_pdiv p1 [x] =
1.219 + let
1.220 + val xs=ref [];
1.221 + in
1.222 + if x<>0 then
1.223 + (
1.224 + xs:=(uv_mod_rem_poly(p1,x));
1.225 + while length(!xs)>0 andalso hd(!xs)=0 do xs:=tl(!xs)
1.226 + )
1.227 + else raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero");
1.228 + ([]:uv_poly,!xs:uv_poly)
1.229 + end
1.230 + | uv_mod_pdiv p1 p2 =
1.231 + let
1.232 + val n= uv_mod_deg(p2);
1.233 + val m= ref (uv_mod_deg(p1));
1.234 + val p1'=ref (rev(p1));
1.235 + val p2'=(rev(p2));
1.236 + val lc2=hd(p2');
1.237 + val q=ref [];
1.238 + val c=ref 0;
1.239 + val output=ref ([],[]);
1.240 + in
1.241 + (
1.242 + if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: Division by zero")
1.243 + else
1.244 + (
1.245 + if (!m)<n then
1.246 + (
1.247 + output:=([0],p1)
1.248 + )
1.249 + else
1.250 + (
1.251 + while (!m)>=n do
1.252 + (
1.253 + c:=hd(!p1') div hd(p2');
1.254 + if !c<>0 then
1.255 + (
1.256 + p1':=uv_mod_add_poly(!p1',uv_mod_null(uv_mod_smul_poly(p2',~(!c)),!m-n));
1.257 + while length(!p1')>0 andalso hd(!p1')=0 do p1':= tl(!p1');
1.258 + m:=uv_mod_deg(!p1')
1.259 + )
1.260 + else m:=0
1.261 + );
1.262 + output:=(rev(!q),rev(!p1'))
1.263 + )
1.264 + );
1.265 + !output
1.266 + )
1.267 + end;
1.268 +
1.269 +(*. divides p1 by p2 in Zp .*)
1.270 +fun uv_mod_pdivp (p1:uv_poly) (p2:uv_poly) p =
1.271 + let
1.272 + val n=uv_mod_deg(p2);
1.273 + val m=ref (uv_mod_deg(uv_mod_list_modp p1 p));
1.274 + val p1'=ref (rev(p1));
1.275 + val p2'=(rev(uv_mod_list_modp p2 p));
1.276 + val lc2=hd(p2');
1.277 + val q=ref [];
1.278 + val c=ref 0;
1.279 + val output=ref ([],[]);
1.280 + in
1.281 + (
1.282 + if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIVP_EXCEPTION: Division by zero")
1.283 + else
1.284 + (
1.285 + if (!m)<n then
1.286 + (
1.287 + output:=([0],p1)
1.288 + )
1.289 + else
1.290 + (
1.291 + while (!m)>=n do
1.292 + (
1.293 + c:=uv_mod_mod2(hd(!p1')*(power lc2 1), p);
1.294 + q:=(!c)::(!q);
1.295 + p1':=uv_mod_list_modp(tl(uv_mod_add_poly(uv_mod_smul_poly(!p1',lc2),
1.296 + uv_mod_smul_poly(uv_mod_smul_poly(p2',hd(!p1')),~1)))) p;
1.297 + m:=(!m)-1
1.298 + );
1.299 +
1.300 + while !p1'<>[] andalso hd(!p1')=0 do
1.301 + (
1.302 + p1':=tl(!p1')
1.303 + );
1.304 +
1.305 + output:=(rev(uv_mod_list_modp (!q) (p)),rev(!p1'))
1.306 + )
1.307 + );
1.308 + !output:uv_poly * uv_poly
1.309 + )
1.310 + end;
1.311 +
1.312 +(*. calculates the remainder of p1/p2 .*)
1.313 +fun uv_mod_prest (p1:uv_poly) ([]:uv_poly) = raise error("UV_MOD_PREST_EXCEPTION: Division by zero")
1.314 + | uv_mod_prest [] p2 = []:uv_poly
1.315 + | uv_mod_prest p1 p2 = (#2(uv_mod_pdiv p1 p2));
1.316 +
1.317 +(*. calculates the remainder of p1/p2 in Zp .*)
1.318 +fun uv_mod_prestp (p1:uv_poly) ([]:uv_poly) p= raise error("UV_MOD_PRESTP_EXCEPTION: Division by zero")
1.319 + | uv_mod_prestp [] p2 p= []:uv_poly
1.320 + | uv_mod_prestp p1 p2 p = #2(uv_mod_pdivp p1 p2 p);
1.321 +
1.322 +(*. calculates the content of a uv polynomial .*)
1.323 +fun uv_mod_cont ([]:uv_poly) = 0
1.324 + | uv_mod_cont (x::p)= gcd_int x (uv_mod_cont(p));
1.325 +
1.326 +(*. divides each coefficient of a uv polynomial by y .*)
1.327 +fun uv_mod_div_list (p:uv_poly,0) = raise error("UV_MOD_DIV_LIST_EXCEPTION: Division by zero")
1.328 + | uv_mod_div_list ([],y) = []:uv_poly
1.329 + | uv_mod_div_list (x::p,y) = (x div y)::uv_mod_div_list(p,y);
1.330 +
1.331 +(*. calculates the primitiv part of a uv polynomial .*)
1.332 +fun uv_mod_pp ([]:uv_poly) = []:uv_poly
1.333 + | uv_mod_pp p =
1.334 + let
1.335 + val c=ref 0;
1.336 + in
1.337 + (
1.338 + c:=uv_mod_cont(p);
1.339 +
1.340 + if !c=0 then raise error ("RATIONALS_UV_MOD_PP_EXCEPTION: content is 0")
1.341 + else uv_mod_div_list(p,!c)
1.342 + )
1.343 + end;
1.344 +
1.345 +(*. gets the leading coefficient of a uv polynomial .*)
1.346 +fun uv_mod_lc ([]:uv_poly) = 0
1.347 + | uv_mod_lc p = hd(rev(p));
1.348 +
1.349 +(*. calculates the euklidean polynomial remainder sequence in Zp .*)
1.350 +fun uv_mod_prs_euklid_p(p1:uv_poly,p2:uv_poly,p)=
1.351 + let
1.352 + val f =ref [];
1.353 + val f'=ref p2;
1.354 + val fi=ref [];
1.355 + in
1.356 + (
1.357 + f:=p2::p1::[];
1.358 + while uv_mod_deg(!f')>0 do
1.359 + (
1.360 + f':=uv_mod_prestp (hd(tl(!f))) (hd(!f)) p;
1.361 + if (!f')<>[] then
1.362 + (
1.363 + fi:=(!f');
1.364 + f:=(!fi)::(!f)
1.365 + )
1.366 + else ()
1.367 + );
1.368 + (!f)
1.369 +
1.370 + )
1.371 + end;
1.372 +
1.373 +(*. calculates the gcd of p1 and p2 in Zp .*)
1.374 +fun uv_mod_gcd_modp ([]:uv_poly) (p2:uv_poly) p = p2:uv_poly
1.375 + | uv_mod_gcd_modp p1 [] p= p1
1.376 + | uv_mod_gcd_modp p1 p2 p=
1.377 + let
1.378 + val p1'=ref[];
1.379 + val p2'=ref[];
1.380 + val pc=ref[];
1.381 + val g=ref [];
1.382 + val d=ref 0;
1.383 + val prs=ref [];
1.384 + in
1.385 + (
1.386 + if uv_mod_deg(p1)>=uv_mod_deg(p2) then
1.387 + (
1.388 + p1':=uv_mod_list_modp (uv_mod_pp(p1)) p;
1.389 + p2':=uv_mod_list_modp (uv_mod_pp(p2)) p
1.390 + )
1.391 + else
1.392 + (
1.393 + p1':=uv_mod_list_modp (uv_mod_pp(p2)) p;
1.394 + p2':=uv_mod_list_modp (uv_mod_pp(p1)) p
1.395 + );
1.396 + d:=uv_mod_mod2((gcd_int (uv_mod_cont(p1))) (uv_mod_cont(p2)), p) ;
1.397 + if !d>(p div 2) then d:=(!d)-p else ();
1.398 +
1.399 + prs:=uv_mod_prs_euklid_p(!p1',!p2',p);
1.400 +
1.401 + if hd(!prs)=[] then pc:=hd(tl(!prs))
1.402 + else pc:=hd(!prs);
1.403 +
1.404 + g:=uv_mod_smul_poly(uv_mod_pp(!pc),!d);
1.405 + !g
1.406 + )
1.407 + end;
1.408 +
1.409 +(*. calculates the minimum of two real values x and y .*)
1.410 +fun uv_mod_r_min(x,y):BasisLibrary.Real.real = if x>y then y else x;
1.411 +
1.412 +(*. calculates the minimum of two integer values x and y .*)
1.413 +fun uv_mod_min(x,y) = if x>y then y else x;
1.414 +
1.415 +(*. adds the squared values of a integer list .*)
1.416 +fun uv_mod_add_qu [] = 0.0
1.417 + | uv_mod_add_qu (x::p) = BasisLibrary.Real.fromInt(x)*BasisLibrary.Real.fromInt(x) + uv_mod_add_qu p;
1.418 +
1.419 +(*. calculates the euklidean norm .*)
1.420 +fun uv_mod_norm ([]:uv_poly) = 0.0
1.421 + | uv_mod_norm p = Math.sqrt(uv_mod_add_qu(p));
1.422 +
1.423 +(*. multipies two values a and b .*)
1.424 +fun uv_mod_multi a b = a * b;
1.425 +
1.426 +(*. decides if x is a prim, the list contains all primes which are lower then x .*)
1.427 +fun uv_mod_prim(x,[])= false
1.428 + | uv_mod_prim(x,[y])=if ((x mod y) <> 0) then true
1.429 + else false
1.430 + | uv_mod_prim(x,y::ys) = if uv_mod_prim(x,[y])
1.431 + then
1.432 + if uv_mod_prim(x,ys) then true
1.433 + else false
1.434 + else false;
1.435 +
1.436 +(*. gets the first prime, which is greater than p and does not divide g .*)
1.437 +fun uv_mod_nextprime(g,p)=
1.438 + let
1.439 + val list=ref [2];
1.440 + val exit=ref 0;
1.441 + val i = ref 2
1.442 + in
1.443 + while (!i<p) do (* calculates the primes lower then p *)
1.444 + (
1.445 + if uv_mod_prim(!i,!list) then
1.446 + (
1.447 + if (p mod !i <> 0)
1.448 + then
1.449 + (
1.450 + list:= (!i)::(!list);
1.451 + i:= (!i)+1
1.452 + )
1.453 + else i:=(!i)+1
1.454 + )
1.455 + else i:= (!i)+1
1.456 + );
1.457 + i:=(p+1);
1.458 + while (!exit=0) do (* calculate next prime which does not divide g *)
1.459 + (
1.460 + if uv_mod_prim(!i,!list) then
1.461 + (
1.462 + if (g mod !i <> 0)
1.463 + then
1.464 + (
1.465 + list:= (!i)::(!list);
1.466 + exit:= (!i)
1.467 + )
1.468 + else i:=(!i)+1
1.469 + )
1.470 + else i:= (!i)+1
1.471 + );
1.472 + !exit
1.473 + end;
1.474 +
1.475 +(*. decides if p1 is a factor of p2 in Zp .*)
1.476 +fun uv_mod_dividesp ([]:uv_poly) (p2:uv_poly) p= raise error("UV_MOD_DIVIDESP: Division by zero")
1.477 + | uv_mod_dividesp p1 p2 p= if uv_mod_prestp p2 p1 p = [] then true else false;
1.478 +
1.479 +(*. decides if p1 is a factor of p2 .*)
1.480 +fun uv_mod_divides ([]:uv_poly) (p2:uv_poly) = raise error("UV_MOD_DIVIDES: Division by zero")
1.481 + | uv_mod_divides p1 p2 = if uv_mod_prest p2 p1 = [] then true else false;
1.482 +
1.483 +(*. chinese remainder algorithm .*)
1.484 +fun uv_mod_cra2(r1,r2,m1,m2)=
1.485 + let
1.486 + val c=ref 0;
1.487 + val r1'=ref 0;
1.488 + val d=ref 0;
1.489 + val a=ref 0;
1.490 + in
1.491 + (
1.492 + while (uv_mod_mod2((!c)*m1,m2))<>1 do
1.493 + (
1.494 + c:=(!c)+1
1.495 + );
1.496 + r1':= uv_mod_mod2(r1,m1);
1.497 + d:=uv_mod_mod2(((r2-(!r1'))*(!c)),m2);
1.498 + !r1'+(!d)*m1
1.499 + )
1.500 + end;
1.501 +
1.502 +(*. applies the chinese remainder algorithmen to the coefficients of x1 and x2 .*)
1.503 +fun uv_mod_cra_2 ([],[],m1,m2) = []
1.504 + | uv_mod_cra_2 ([],x2,m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x1")
1.505 + | uv_mod_cra_2 (x1,[],m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x2")
1.506 + | uv_mod_cra_2 (x1::x1s,x2::x2s,m1,m2) = (uv_mod_cra2(x1,x2,m1,m2))::(uv_mod_cra_2(x1s,x2s,m1,m2));
1.507 +
1.508 +(*. calculates the gcd of two uv polynomials p1' and p2' with the modular algorithm .*)
1.509 +fun uv_mod_gcd (p1':uv_poly) (p2':uv_poly) =
1.510 + let
1.511 + val p1=ref (uv_mod_pp(p1'));
1.512 + val p2=ref (uv_mod_pp(p2'));
1.513 + val c=gcd_int (uv_mod_cont(p1')) (uv_mod_cont(p2'));
1.514 + val temp=ref [];
1.515 + val cp=ref [];
1.516 + val qp=ref [];
1.517 + val q=ref[];
1.518 + val pn=ref 0;
1.519 + val d=ref 0;
1.520 + val g1=ref 0;
1.521 + val p=ref 0;
1.522 + val m=ref 0;
1.523 + val exit=ref 0;
1.524 + val i=ref 1;
1.525 + in
1.526 + if length(!p1)>length(!p2) then ()
1.527 + else
1.528 + (
1.529 + temp:= !p1;
1.530 + p1:= !p2;
1.531 + p2:= !temp
1.532 + );
1.533 +
1.534 +
1.535 + d:=gcd_int (uv_mod_lc(!p1)) (uv_mod_lc(!p2));
1.536 + g1:=uv_mod_lc(!p1)*uv_mod_lc(!p2);
1.537 + p:=4;
1.538 +
1.539 + m:=BasisLibrary.Real.ceil(2.0 *
1.540 + BasisLibrary.Real.fromInt(!d) *
1.541 + BasisLibrary.Real.fromInt(power 2 (uv_mod_min(uv_mod_deg(!p2),uv_mod_deg(!p1)))) *
1.542 + BasisLibrary.Real.fromInt(!d) *
1.543 + uv_mod_r_min(uv_mod_norm(!p1) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p1))),
1.544 + uv_mod_norm(!p2) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p2)))));
1.545 +
1.546 + while (!exit=0) do
1.547 + (
1.548 + p:=uv_mod_nextprime(!d,!p);
1.549 + cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)) ;
1.550 + if abs(uv_mod_lc(!cp))<>1 then (* leading coefficient = 1 ? *)
1.551 + (
1.552 + i:=1;
1.553 + while (!i)<(!p) andalso (abs(uv_mod_mod2((uv_mod_lc(!cp)*(!i)),(!p)))<>1) do
1.554 + (
1.555 + i:=(!i)+1
1.556 + );
1.557 + cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p)
1.558 + )
1.559 + else ();
1.560 +
1.561 + qp:= ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp));
1.562 +
1.563 + if uv_mod_deg(!qp)=0 then (q:=[1]; exit:=1) else ();
1.564 +
1.565 + pn:=(!p);
1.566 + q:=(!qp);
1.567 +
1.568 + while !pn<= !m andalso !m>(!p) andalso !exit=0 do
1.569 + (
1.570 + p:=uv_mod_nextprime(!d,!p);
1.571 + cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p));
1.572 + if uv_mod_lc(!cp)<>1 then (* leading coefficient = 1 ? *)
1.573 + (
1.574 + i:=1;
1.575 + while (!i)<(!p) andalso ((uv_mod_mod2((uv_mod_lc(!q)*(!i)),(!p)))<>1) do
1.576 + (
1.577 + i:=(!i)+1
1.578 + );
1.579 + cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p)
1.580 + )
1.581 + else ();
1.582 +
1.583 + qp:=uv_mod_list_modp ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp) ) (!p);
1.584 + if uv_mod_deg(!qp)>uv_mod_deg(!q) then
1.585 + (
1.586 + (*print("degree to high!!!\n")*)
1.587 + )
1.588 + else
1.589 + (
1.590 + if uv_mod_deg(!qp)=uv_mod_deg(!q) then
1.591 + (
1.592 + q:=uv_mod_cra_2(!q,!qp,!pn,!p);
1.593 + pn:=(!pn) * !p;
1.594 + q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn)); (* found already gcd ? *)
1.595 + if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then (exit:=1) else ()
1.596 + )
1.597 + else
1.598 + (
1.599 + if uv_mod_deg(!qp)<uv_mod_deg(!q) then
1.600 + (
1.601 + pn:= !p;
1.602 + q:= !qp
1.603 + )
1.604 + else ()
1.605 + )
1.606 + )
1.607 + );
1.608 + q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn));
1.609 + if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then exit:=1 else ()
1.610 + );
1.611 + uv_mod_smul_poly(!q,c):uv_poly
1.612 + end;
1.613 +
1.614 +(*. multivariate polynomials .*)
1.615 +(*. multivariate polynomials are represented as a list of the pairs,
1.616 + first is the coefficent and the second is a list of the exponents .*)
1.617 +(*. 5 * x^5 * y^3 + 4 * x^3 * z^2 + 2 * x^2 * y * z^3 - z - 19
1.618 + => [(5,[5,3,0]),(4,[3,0,2]),(2,[2,1,3]),(~1,[0,0,1]),(~19,[0,0,0])] .*)
1.619 +
1.620 +(*. global variables .*)
1.621 +(*. order indicators .*)
1.622 +val LEX_=0; (* lexicographical term order *)
1.623 +val GGO_=1; (* greatest degree order *)
1.624 +
1.625 +(*. datatypes .*)
1.626 +type mv_monom = (int * int list); (* (coefficient,list of exponents) *)
1.627 +type mv_poly = mv_monom list;
1.628 +
1.629 +(*. help function for monom_greater and geq .*)
1.630 +fun mv_mg_hlp([]) = EQUAL
1.631 + | mv_mg_hlp(x::list)=if x<0 then LESS
1.632 + else if x>0 then GREATER
1.633 + else mv_mg_hlp(list);
1.634 +
1.635 +(*. adds a list of values .*)
1.636 +fun mv_addlist([]) = 0
1.637 + | mv_addlist(p1) = hd(p1)+mv_addlist(tl(p1));
1.638 +
1.639 +(*. tests if the monomial M1 is greater as the monomial M2 and returns a boolean value .*)
1.640 +(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*)
1.641 +fun mv_monom_greater((M1x,M1l):mv_monom,(M2x,M2l):mv_monom,order)=
1.642 + if order=LEX_ then
1.643 + (
1.644 + if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error")
1.645 + else if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true
1.646 + )
1.647 + else
1.648 + if order=GGO_ then
1.649 + (
1.650 + if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error")
1.651 + else
1.652 + if mv_addlist(M1l)=mv_addlist(M2l) then if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true
1.653 + else if mv_addlist(M1l)>mv_addlist(M2l) then true else false
1.654 + )
1.655 + else raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Wrong Order");
1.656 +
1.657 +(*. tests if the monomial X is greater as the monomial Y and returns a order value (GREATER,EQUAL,LESS) .*)
1.658 +(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*)
1.659 +fun mv_geq order ((x1,x):mv_monom,(x2,y):mv_monom) =
1.660 +let
1.661 + val temp=ref EQUAL;
1.662 +in
1.663 + if order=LEX_ then
1.664 + (
1.665 + if length(x)<>length(y) then
1.666 + raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error")
1.667 + else
1.668 + (
1.669 + temp:=mv_mg_hlp((map op- (x~~y)));
1.670 + if !temp=EQUAL then
1.671 + ( if x1=x2 then EQUAL
1.672 + else if x1>x2 then GREATER
1.673 + else LESS
1.674 + )
1.675 + else (!temp)
1.676 + )
1.677 + )
1.678 + else
1.679 + if order=GGO_ then
1.680 + (
1.681 + if length(x)<>length(y) then
1.682 + raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error")
1.683 + else
1.684 + if mv_addlist(x)=mv_addlist(y) then
1.685 + (mv_mg_hlp((map op- (x~~y))))
1.686 + else if mv_addlist(x)>mv_addlist(y) then GREATER else LESS
1.687 + )
1.688 + else raise error ("RATIONALS_MV_GEQ_EXCEPTION: Wrong Order")
1.689 +end;
1.690 +
1.691 +(*. cuts the first variable from a polynomial .*)
1.692 +fun mv_cut([]:mv_poly)=[]:mv_poly
1.693 + | mv_cut((x,[])::list) = raise error ("RATIONALS_MV_CUT_EXCEPTION: Invalid list ")
1.694 + | mv_cut((x,y::ys)::list)=(x,ys)::mv_cut(list);
1.695 +
1.696 +(*. leading power product .*)
1.697 +fun mv_lpp([]:mv_poly,order) = []
1.698 + | mv_lpp([(x,y)],order) = y
1.699 + | mv_lpp(p1,order) = #2(hd(rev(sort (mv_geq order) p1)));
1.700 +
1.701 +(*. leading monomial .*)
1.702 +fun mv_lm([]:mv_poly,order) = (0,[]):mv_monom
1.703 + | mv_lm([x],order) = x
1.704 + | mv_lm(p1,order) = hd(rev(sort (mv_geq order) p1));
1.705 +
1.706 +(*. leading coefficient in term order .*)
1.707 +fun mv_lc2([]:mv_poly,order) = 0
1.708 + | mv_lc2([(x,y)],order) = x
1.709 + | mv_lc2(p1,order) = #1(hd(rev(sort (mv_geq order) p1)));
1.710 +
1.711 +
1.712 +(*. reverse the coefficients in mv polynomial .*)
1.713 +fun mv_rev_to([]:mv_poly) = []:mv_poly
1.714 + | mv_rev_to((c,e)::xs) = (c,rev(e))::mv_rev_to(xs);
1.715 +
1.716 +(*. leading coefficient in reverse term order .*)
1.717 +fun mv_lc([]:mv_poly,order) = []:mv_poly
1.718 + | mv_lc([(x,y)],order) = mv_rev_to(mv_cut(mv_rev_to([(x,y)])))
1.719 + | mv_lc(p1,order) =
1.720 + let
1.721 + val p1o=ref (rev(sort (mv_geq order) (mv_rev_to(p1))));
1.722 + val lp=hd(#2(hd(!p1o)));
1.723 + val lc=ref [];
1.724 + in
1.725 + (
1.726 + while (length(!p1o)>0 andalso hd(#2(hd(!p1o)))=lp) do
1.727 + (
1.728 + lc:=hd(mv_cut([hd(!p1o)]))::(!lc);
1.729 + p1o:=tl(!p1o)
1.730 + );
1.731 + if !lc=[] then raise error ("RATIONALS_MV_LC_EXCEPTION: lc is empty") else ();
1.732 + mv_rev_to(!lc)
1.733 + )
1.734 + end;
1.735 +
1.736 +(*. compares two powerproducts .*)
1.737 +fun mv_monom_equal((_,xlist):mv_monom,(_,ylist):mv_monom) = (foldr and_) (((map op=) (xlist~~ylist)),true);
1.738 +
1.739 +(*. help function for mv_add .*)
1.740 +fun mv_madd([]:mv_poly,[]:mv_poly,order) = []:mv_poly
1.741 + | mv_madd([(0,_)],p2,order) = p2
1.742 + | mv_madd(p1,[(0,_)],order) = p1
1.743 + | mv_madd([],p2,order) = p2
1.744 + | mv_madd(p1,[],order) = p1
1.745 + | mv_madd(p1,p2,order) =
1.746 + (
1.747 + if mv_monom_greater(hd(p1),hd(p2),order)
1.748 + then hd(p1)::mv_madd(tl(p1),p2,order)
1.749 + else if mv_monom_equal(hd(p1),hd(p2))
1.750 + then if mv_lc2(p1,order)+mv_lc2(p2,order)<>0
1.751 + then (mv_lc2(p1,order)+mv_lc2(p2,order),mv_lpp(p1,order))::mv_madd(tl(p1),tl(p2),order)
1.752 + else mv_madd(tl(p1),tl(p2),order)
1.753 + else hd(p2)::mv_madd(p1,tl(p2),order)
1.754 + )
1.755 +
1.756 +(*. adds two multivariate polynomials .*)
1.757 +fun mv_add([]:mv_poly,p2:mv_poly,order) = p2
1.758 + | mv_add(p1,[],order) = p1
1.759 + | mv_add(p1,p2,order) = mv_madd(rev(sort (mv_geq order) p1),rev(sort (mv_geq order) p2), order);
1.760 +
1.761 +(*. monom multiplication .*)
1.762 +fun mv_mmul((x1,y1):mv_monom,(x2,y2):mv_monom)=(x1*x2,(map op+) (y1~~y2)):mv_monom;
1.763 +
1.764 +(*. deletes all monomials with coefficient 0 .*)
1.765 +fun mv_shorten([]:mv_poly,order) = []:mv_poly
1.766 + | mv_shorten(x::xs,order)=mv_madd([x],mv_shorten(xs,order),order);
1.767 +
1.768 +(*. zeros a list .*)
1.769 +fun mv_null2([])=[]
1.770 + | mv_null2(x::l)=0::mv_null2(l);
1.771 +
1.772 +(*. multiplies two multivariate polynomials .*)
1.773 +fun mv_mul([]:mv_poly,[]:mv_poly,_) = []:mv_poly
1.774 + | mv_mul([],y::p2,_) = [(0,mv_null2(#2(y)))]
1.775 + | mv_mul(x::p1,[],_) = [(0,mv_null2(#2(x)))]
1.776 + | mv_mul(x::p1,y::p2,order) = mv_shorten(rev(sort (mv_geq order) (mv_mmul(x,y) :: (mv_mul(p1,y::p2,order) @
1.777 + mv_mul([x],p2,order)))),order);
1.778 +
1.779 +(*. gets the maximum value of a list .*)
1.780 +fun mv_getmax([])=0
1.781 + | mv_getmax(x::p1)= let
1.782 + val m=mv_getmax(p1);
1.783 + in
1.784 + if m>x then m
1.785 + else x
1.786 + end;
1.787 +(*. calculates the maximum degree of an multivariate polynomial .*)
1.788 +fun mv_grad([]:mv_poly) = 0
1.789 + | mv_grad(p1:mv_poly)= mv_getmax((map mv_addlist) ((map #2) p1));
1.790 +
1.791 +(*. converts the sign of a value .*)
1.792 +fun mv_minus(x)=(~1) * x;
1.793 +
1.794 +(*. converts the sign of all coefficients of a polynomial .*)
1.795 +fun mv_minus2([]:mv_poly)=[]:mv_poly
1.796 + | mv_minus2(p1)=(mv_minus(#1(hd(p1))),#2(hd(p1)))::(mv_minus2(tl(p1)));
1.797 +
1.798 +(*. searches for a negativ value in a list .*)
1.799 +fun mv_is_negativ([])=false
1.800 + | mv_is_negativ(x::xs)=if x<0 then true else mv_is_negativ(xs);
1.801 +
1.802 +(*. division of monomials .*)
1.803 +fun mv_mdiv((0,[]):mv_monom,_:mv_monom)=(0,[]):mv_monom
1.804 + | mv_mdiv(_,(0,[]))= raise error ("RATIONALS_MV_MDIV_EXCEPTION Division by 0 ")
1.805 + | mv_mdiv(p1:mv_monom,p2:mv_monom)=
1.806 + let
1.807 + val c=ref (#1(p2));
1.808 + val pp=ref [];
1.809 + in
1.810 + (
1.811 + if !c=0 then raise error("MV_MDIV_EXCEPTION Dividing by zero")
1.812 + else c:=(#1(p1) div #1(p2));
1.813 + if #1(p2)<>0 then
1.814 + (
1.815 + pp:=(#2(mv_mmul((1,#2(p1)),(1,(map mv_minus) (#2(p2))))));
1.816 + if mv_is_negativ(!pp) then (0,!pp)
1.817 + else (!c,!pp)
1.818 + )
1.819 + else raise error("MV_MDIV_EXCEPTION Dividing by empty Polynom")
1.820 + )
1.821 + end;
1.822 +
1.823 +(*. prints a polynom for (internal use only) .*)
1.824 +fun mv_print_poly([]:mv_poly)=print("[]\n")
1.825 + | mv_print_poly((x,y)::[])= print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^")\n")
1.826 + | mv_print_poly((x,y)::p1) = (print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^"),");mv_print_poly(p1));
1.827 +
1.828 +
1.829 +(*. division of two multivariate polynomials .*)
1.830 +fun mv_division([]:mv_poly,g:mv_poly,order)=([]:mv_poly,[]:mv_poly)
1.831 + | mv_division(f,[],order)= raise error ("RATIONALS_MV_DIVISION_EXCEPTION Division by zero")
1.832 + | mv_division(f,g,order)=
1.833 + let
1.834 + val r=ref [];
1.835 + val q=ref [];
1.836 + val g'=ref [];
1.837 + val k=ref 0;
1.838 + val m=ref (0,[0]);
1.839 + val exit=ref 0;
1.840 + in
1.841 + r := rev(sort (mv_geq order) (mv_shorten(f,order)));
1.842 + g':= rev(sort (mv_geq order) (mv_shorten(g,order)));
1.843 + if #1(hd(!g'))=0 then raise error("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero") else ();
1.844 + if (mv_monom_greater (hd(!g'),hd(!r),order)) then ([(0,mv_null2(#2(hd(f))))],(!r))
1.845 + else
1.846 + (
1.847 + exit:=0;
1.848 + while (if (!exit)=0 then not(mv_monom_greater (hd(!g'),hd(!r),order)) else false) do
1.849 + (
1.850 + if (#1(mv_lm(!g',order)))<>0 then m:=mv_mdiv(mv_lm(!r,order),mv_lm(!g',order))
1.851 + else raise error ("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero");
1.852 + if #1(!m)<>0 then
1.853 + (
1.854 + q:=(!m)::(!q);
1.855 + r:=mv_add((!r),mv_minus2(mv_mul(!g',[!m],order)),order)
1.856 + )
1.857 + else exit:=1;
1.858 + if (if length(!r)<>0 then length(!g')<>0 else false) then ()
1.859 + else (exit:=1)
1.860 + );
1.861 + (rev(!q),!r)
1.862 + )
1.863 + end;
1.864 +
1.865 +(*. multiplies a polynomial with an integer .*)
1.866 +fun mv_skalar_mul([]:mv_poly,c) = []:mv_poly
1.867 + | mv_skalar_mul((x,y)::p1,c) = ((x * c),y)::mv_skalar_mul(p1,c);
1.868 +
1.869 +(*. inserts the a first variable into an polynomial with exponent v .*)
1.870 +fun mv_correct([]:mv_poly,v:int)=[]:mv_poly
1.871 + | mv_correct((x,y)::list,v:int)=(x,v::y)::mv_correct(list,v);
1.872 +
1.873 +(*. multivariate case .*)
1.874 +
1.875 +(*. decides if x is a factor of y .*)
1.876 +fun mv_divides([]:mv_poly,[]:mv_poly)= raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero")
1.877 + | mv_divides(x,[]) = raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero")
1.878 + | mv_divides(x:mv_poly,y:mv_poly) = #2(mv_division(y,x,LEX_))=[];
1.879 +
1.880 +(*. gets the maximum of a and b .*)
1.881 +fun mv_max(a,b) = if a>b then a else b;
1.882 +
1.883 +(*. gets the maximum exponent of a mv polynomial in the lexicographic term order .*)
1.884 +fun mv_deg([]:mv_poly) = 0
1.885 + | mv_deg(p1)=
1.886 + let
1.887 + val p1'=mv_shorten(p1,LEX_);
1.888 + in
1.889 + if length(p1')=0 then 0
1.890 + else mv_max(hd(#2(hd(p1'))),mv_deg(tl(p1')))
1.891 + end;
1.892 +
1.893 +(*. gets the maximum exponent of a mv polynomial in the reverse lexicographic term order .*)
1.894 +fun mv_deg2([]:mv_poly) = 0
1.895 + | mv_deg2(p1)=
1.896 + let
1.897 + val p1'=mv_shorten(p1,LEX_);
1.898 + in
1.899 + if length(p1')=0 then 0
1.900 + else mv_max(hd(rev(#2(hd(p1')))),mv_deg2(tl(p1')))
1.901 + end;
1.902 +
1.903 +(*. evaluates the mv polynomial at the value v of the main variable .*)
1.904 +fun mv_subs([]:mv_poly,v) = []:mv_poly
1.905 + | mv_subs((c,e)::p1:mv_poly,v) = mv_skalar_mul(mv_cut([(c,e)]),power v (hd(e))) @ mv_subs(p1,v);
1.906 +
1.907 +(*. calculates the content of a uv-polynomial in mv-representation .*)
1.908 +fun uv_content2([]:mv_poly) = 0
1.909 + | uv_content2((c,e)::p1) = (gcd_int c (uv_content2(p1)));
1.910 +
1.911 +(*. converts a uv-polynomial from mv-representation to uv-representation .*)
1.912 +fun uv_to_list ([]:mv_poly)=[]:uv_poly
1.913 + | uv_to_list ((c1,e1)::others) =
1.914 + let
1.915 + val count=ref 0;
1.916 + val max=mv_grad((c1,e1)::others);
1.917 + val help=ref ((c1,e1)::others);
1.918 + val list=ref [];
1.919 + in
1.920 + if length(e1)>1 then raise error ("RATIONALS_TO_LIST_EXCEPTION: not univariate")
1.921 + else if length(e1)=0 then [c1]
1.922 + else
1.923 + (
1.924 + count:=0;
1.925 + while (!count)<=max do
1.926 + (
1.927 + if length(!help)>0 andalso hd(#2(hd(!help)))=max-(!count) then
1.928 + (
1.929 + list:=(#1(hd(!help)))::(!list);
1.930 + help:=tl(!help)
1.931 + )
1.932 + else
1.933 + (
1.934 + list:= 0::(!list)
1.935 + );
1.936 + count := (!count) + 1
1.937 + );
1.938 + (!list)
1.939 + )
1.940 + end;
1.941 +
1.942 +(*. converts a uv-polynomial from uv-representation to mv-representation .*)
1.943 +fun uv_to_poly ([]:uv_poly) = []:mv_poly
1.944 + | uv_to_poly p1 =
1.945 + let
1.946 + val count=ref 0;
1.947 + val help=ref p1;
1.948 + val list=ref [];
1.949 + in
1.950 + while length(!help)>0 do
1.951 + (
1.952 + if hd(!help)=0 then ()
1.953 + else list:=(hd(!help),[!count])::(!list);
1.954 + count:=(!count)+1;
1.955 + help:=tl(!help)
1.956 + );
1.957 + (!list)
1.958 + end;
1.959 +
1.960 +(*. univariate gcd calculation from polynomials in multivariate representation .*)
1.961 +fun uv_gcd ([]:mv_poly) p2 = p2
1.962 + | uv_gcd p1 ([]:mv_poly) = p1
1.963 + | uv_gcd p1 [(c,[e])] =
1.964 + let
1.965 + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_))));
1.966 + val min=uv_mod_min(e,(hd(#2(hd(rev(!list))))));
1.967 + in
1.968 + [(gcd_int (uv_content2(p1)) c,[min])]
1.969 + end
1.970 + | uv_gcd [(c,[e])] p2 =
1.971 + let
1.972 + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p2,LEX_))));
1.973 + val min=uv_mod_min(e,(hd(#2(hd(rev(!list))))));
1.974 + in
1.975 + [(gcd_int (uv_content2(p2)) c,[min])]
1.976 + end
1.977 + | uv_gcd p11 p22 = uv_to_poly(uv_mod_gcd (uv_to_list(mv_shorten(p11,LEX_))) (uv_to_list(mv_shorten(p22,LEX_))));
1.978 +
1.979 +(*. help function for the newton interpolation .*)
1.980 +fun mv_newton_help ([]:mv_poly list,k:int) = []:mv_poly list
1.981 + | mv_newton_help (pl:mv_poly list,k) =
1.982 + let
1.983 + val x=ref (rev(pl));
1.984 + val t=ref [];
1.985 + val y=ref [];
1.986 + val n=ref 1;
1.987 + val n1=ref[];
1.988 + in
1.989 + (
1.990 + while length(!x)>1 do
1.991 + (
1.992 + if length(hd(!x))>0 then n1:=mv_null2(#2(hd(hd(!x))))
1.993 + else if length(hd(tl(!x)))>0 then n1:=mv_null2(#2(hd(hd(tl(!x)))))
1.994 + else n1:=[];
1.995 + t:= #1(mv_division(mv_add(hd(!x),mv_skalar_mul(hd(tl(!x)),~1),LEX_),[(k,!n1)],LEX_));
1.996 + y:=(!t)::(!y);
1.997 + x:=tl(!x)
1.998 + );
1.999 + (!y)
1.1000 + )
1.1001 + end;
1.1002 +
1.1003 +(*. help function for the newton interpolation .*)
1.1004 +fun mv_newton_add ([]:mv_poly list) t = []:mv_poly
1.1005 + | mv_newton_add [x:mv_poly] t = x
1.1006 + | mv_newton_add (pl:mv_poly list) t =
1.1007 + let
1.1008 + val expos=ref [];
1.1009 + val pll=ref pl;
1.1010 + in
1.1011 + (
1.1012 +
1.1013 + while length(!pll)>0 andalso hd(!pll)=[] do
1.1014 + (
1.1015 + pll:=tl(!pll)
1.1016 + );
1.1017 + if length(!pll)>0 then expos:= #2(hd(hd(!pll))) else expos:=[];
1.1018 + mv_add(hd(pl),
1.1019 + mv_mul(
1.1020 + mv_add(mv_correct(mv_cut([(1,mv_null2(!expos))]),1),[(~t,mv_null2(!expos))],LEX_),
1.1021 + mv_newton_add (tl(pl)) (t+1),
1.1022 + LEX_
1.1023 + ),
1.1024 + LEX_)
1.1025 + )
1.1026 + end;
1.1027 +
1.1028 +(*. calculates the newton interpolation with polynomial coefficients .*)
1.1029 +(*. step-depth is 1 and if the result is not an integerpolynomial .*)
1.1030 +(*. this function returns [] .*)
1.1031 +fun mv_newton ([]:(mv_poly) list) = []:mv_poly
1.1032 + | mv_newton pl =
1.1033 + let
1.1034 + val c=ref pl;
1.1035 + val c1=ref [];
1.1036 + val n=length(pl);
1.1037 + val k=ref 1;
1.1038 + val i=ref n;
1.1039 + val ppl=ref [];
1.1040 + in
1.1041 + c1:=hd(pl)::[];
1.1042 + c:=mv_newton_help(!c,!k);
1.1043 + c1:=(hd(!c))::(!c1);
1.1044 + while(length(!c)>1 andalso !k<n) do
1.1045 + (
1.1046 + k:=(!k)+1;
1.1047 + while length(!c)>0 andalso hd(!c)=[] do c:=tl(!c);
1.1048 + if !c=[] then () else c:=mv_newton_help(!c,!k);
1.1049 + ppl:= !c;
1.1050 + if !c=[] then () else c1:=(hd(!c))::(!c1)
1.1051 + );
1.1052 + while hd(!c1)=[] do c1:=tl(!c1);
1.1053 + c1:=rev(!c1);
1.1054 + ppl:= !c1;
1.1055 +
1.1056 + mv_newton_add (!c1) 1
1.1057 + end;
1.1058 +
1.1059 +(*. sets the exponents of the first variable to zero .*)
1.1060 +fun mv_null3([]:mv_poly) = []:mv_poly
1.1061 + | mv_null3((x,y)::xs) = (x,0::tl(y))::mv_null3(xs);
1.1062 +
1.1063 +(*. calculates the minimum exponents of a multivariate polynomial .*)
1.1064 +fun mv_min_pp([]:mv_poly)=[]
1.1065 + | mv_min_pp((c,e)::xs)=
1.1066 + let
1.1067 + val y=ref xs;
1.1068 + val x=ref [];
1.1069 + in
1.1070 + (
1.1071 + x:=e;
1.1072 + while length(!y)>0 do
1.1073 + (
1.1074 + x:=(map uv_mod_min) ((!x) ~~ (#2(hd(!y))));
1.1075 + y:=tl(!y)
1.1076 + );
1.1077 + !x
1.1078 + )
1.1079 + end;
1.1080 +
1.1081 +(*. calculates the content of an polynomial .*)
1.1082 +fun mv_content([]:mv_poly) = []:mv_poly
1.1083 + | mv_content(p1) =
1.1084 + let
1.1085 + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_))));
1.1086 + val test=ref (hd(#2(hd(!list))));
1.1087 + val result=ref [];
1.1088 + val min=(hd(#2(hd(rev(!list)))));
1.1089 + in
1.1090 + (
1.1091 + if length(!list)>1 then
1.1092 + (
1.1093 + while (if length(!list)>0 then (hd(#2(hd(!list)))=(!test)) else false) do
1.1094 + (
1.1095 + result:=(#1(hd(!list)),tl(#2(hd(!list))))::(!result);
1.1096 +
1.1097 + if length(!list)<1 then list:=[]
1.1098 + else list:=tl(!list)
1.1099 +
1.1100 + );
1.1101 + if length(!list)>0 then
1.1102 + (
1.1103 + list:=mv_gcd (!result) (mv_cut(mv_content(!list)))
1.1104 + )
1.1105 + else list:=(!result);
1.1106 + list:=mv_correct(!list,0);
1.1107 + (!list)
1.1108 + )
1.1109 + else
1.1110 + (
1.1111 + mv_null3(!list)
1.1112 + )
1.1113 + )
1.1114 + end
1.1115 +
1.1116 +(*. calculates the primitiv part of a polynomial .*)
1.1117 +and mv_pp([]:mv_poly) = []:mv_poly
1.1118 + | mv_pp(p1) = let
1.1119 + val cont=ref [];
1.1120 + val pp=ref[];
1.1121 + in
1.1122 + cont:=mv_content(p1);
1.1123 + pp:=(#1(mv_division(p1,!cont,LEX_)));
1.1124 + if !pp=[]
1.1125 + then raise error("RATIONALS_MV_PP_EXCEPTION: Invalid Content ")
1.1126 + else (!pp)
1.1127 + end
1.1128 +
1.1129 +(*. calculates the gcd of two multivariate polynomials with a modular approach .*)
1.1130 +and mv_gcd ([]:mv_poly) ([]:mv_poly) :mv_poly= []:mv_poly
1.1131 + | mv_gcd ([]:mv_poly) (p2) :mv_poly= p2:mv_poly
1.1132 + | mv_gcd (p1:mv_poly) ([]) :mv_poly= p1:mv_poly
1.1133 + | mv_gcd ([(x,xs)]:mv_poly) ([(y,ys)]):mv_poly = if xs=ys then [((gcd_int x y),xs)]
1.1134 + else
1.1135 + (
1.1136 + [((gcd_int x y),(map uv_mod_min)(xs~~ys))]:mv_poly
1.1137 + )
1.1138 + | mv_gcd (p1:mv_poly) ([(y,ys)]) :mv_poly= [(gcd_int (uv_content2(p1)) (y),(map uv_mod_min)(mv_min_pp(p1)~~ys))]:mv_poly
1.1139 + | mv_gcd ([(y,ys)]:mv_poly) (p2):mv_poly = [(gcd_int (uv_content2(p2)) (y),(map uv_mod_min)(mv_min_pp(p2)~~ys))]:mv_poly
1.1140 + | mv_gcd (p1':mv_poly) (p2':mv_poly):mv_poly=
1.1141 + let
1.1142 + val vc=length(#2(hd(p1')));
1.1143 + val cont=mv_gcd (mv_content(p1')) (mv_content(p2'));
1.1144 + val p1= #1(mv_division(p1',cont,LEX_));
1.1145 + val p2= #1(mv_division(p2',cont,LEX_));
1.1146 + val gcd=ref [];
1.1147 + val candidate=ref [];
1.1148 + val interpolation_list=ref [];
1.1149 + val delta=ref [];
1.1150 + val factor=ref [];
1.1151 + val r=ref 0;
1.1152 + val gcd_r=ref [];
1.1153 + val d=ref 0;
1.1154 + val exit=ref 0;
1.1155 + val current_degree=ref 99999; (*. FIXME: unlimited ! .*)
1.1156 + in
1.1157 + (
1.1158 + if vc<2 then (* areUnivariate(p1',p2') *)
1.1159 + (
1.1160 + gcd:=uv_gcd (mv_shorten(p1',LEX_)) (mv_shorten(p2',LEX_))
1.1161 + )
1.1162 + else
1.1163 + (
1.1164 + while !exit=0 do
1.1165 + (
1.1166 + r:=(!r)+1;
1.1167 + delta:=mv_gcd (mv_lc(p1,LEX_)) (mv_lc(p2,LEX_));
1.1168 + if mv_shorten(mv_subs(mv_lc(p1,LEX_),!r),LEX_)=[] andalso
1.1169 + mv_shorten(mv_subs(mv_lc(p2,LEX_),!r),LEX_)=[]
1.1170 + then ()
1.1171 + else
1.1172 + (
1.1173 + gcd_r:=mv_shorten(mv_gcd (mv_shorten(mv_subs(p1,!r),LEX_))
1.1174 + (mv_shorten(mv_subs(p2,!r),LEX_)) ,LEX_);
1.1175 + gcd_r:= #1(mv_division(mv_mul(mv_correct(mv_subs(!delta,!r),0),!gcd_r,LEX_),
1.1176 + mv_correct(mv_lc(!gcd_r,LEX_),0),LEX_));
1.1177 + d:=mv_deg2(!gcd_r); (* deg(gcd_r,z) *)
1.1178 + if (!d < !current_degree) then
1.1179 + (
1.1180 + current_degree:= !d;
1.1181 + interpolation_list:=[mv_correct(!gcd_r,0)]
1.1182 + )
1.1183 + else
1.1184 + (
1.1185 + if (!d = !current_degree) then
1.1186 + (
1.1187 + interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list)
1.1188 + )
1.1189 + else ()
1.1190 + )
1.1191 + );
1.1192 +
1.1193 + if length(!interpolation_list)> uv_mod_min(mv_deg(p1),mv_deg(p2)) then
1.1194 + (
1.1195 + candidate:=mv_newton(rev(!interpolation_list));
1.1196 + if !candidate=[] then ()
1.1197 + else
1.1198 + (
1.1199 + candidate:=mv_pp(!candidate);
1.1200 + if mv_divides(!candidate,p1) andalso mv_divides(!candidate,p2) then
1.1201 + (
1.1202 + gcd:= mv_mul(!candidate,cont,LEX_);
1.1203 + exit:=1
1.1204 + )
1.1205 + else ()
1.1206 + );
1.1207 + interpolation_list:=[mv_correct(!gcd_r,0)]
1.1208 + )
1.1209 + else ()
1.1210 + )
1.1211 + );
1.1212 + (!gcd):mv_poly
1.1213 + )
1.1214 + end;
1.1215 +
1.1216 +
1.1217 +(*. calculates the least common divisor of two polynomials .*)
1.1218 +fun mv_lcm (p1:mv_poly) (p2:mv_poly) :mv_poly =
1.1219 + (
1.1220 + #1(mv_division(mv_mul(p1,p2,LEX_),mv_gcd p1 p2,LEX_))
1.1221 + );
1.1222 +
1.1223 +(*. gets the variables (strings) of a term .*)
1.1224 +fun get_vars(term1) = (map free2str) (vars term1); (*["a","b","c"]; *)
1.1225 +
1.1226 +(*. counts the negative coefficents in a polynomial .*)
1.1227 +fun count_neg ([]:mv_poly) = 0
1.1228 + | count_neg ((c,e)::xs) = if c<0 then 1+count_neg xs
1.1229 + else count_neg xs;
1.1230 +
1.1231 +(*. help function for is_polynomial
1.1232 + checks the order of the operators .*)
1.1233 +fun test_polynomial (Const ("uminus",_) $ Free (str,_)) _ = true (*WN.13.3.03*)
1.1234 + | test_polynomial (t as Free(str,_)) v = true
1.1235 + | test_polynomial (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false
1.1236 + else (test_polynomial t1 "*") andalso (test_polynomial t2 "*")
1.1237 + | test_polynomial (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
1.1238 + else (test_polynomial t1 " ") andalso (test_polynomial t2 " ")
1.1239 + | test_polynomial (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_polynomial t1 "^") andalso (test_polynomial t2 "^")
1.1240 + | test_polynomial _ v = false;
1.1241 +
1.1242 +(*. tests if a term is a polynomial .*)
1.1243 +fun is_polynomial t = test_polynomial t " ";
1.1244 +
1.1245 +(*. help function for is_expanded
1.1246 + checks the order of the operators .*)
1.1247 +fun test_exp (t as Free(str,_)) v = true
1.1248 + | test_exp (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false
1.1249 + else (test_exp t1 "*") andalso (test_exp t2 "*")
1.1250 + | test_exp (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
1.1251 + else (test_exp t1 " ") andalso (test_exp t2 " ")
1.1252 + | test_exp (t as Const ("op -",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
1.1253 + else (test_exp t1 " ") andalso (test_exp t2 " ")
1.1254 + | test_exp (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_exp t1 "^") andalso (test_exp t2 "^")
1.1255 + | test_exp _ v = false;
1.1256 +
1.1257 +
1.1258 +(*. help function for check_coeff:
1.1259 + converts the term to a list of coefficients .*)
1.1260 +fun term2coef' (t as Free(str,_(*typ*))) v :mv_poly option =
1.1261 + let
1.1262 + val x=ref None;
1.1263 + val len=ref 0;
1.1264 + val vl=ref [];
1.1265 + val vh=ref [];
1.1266 + val i=ref 0;
1.1267 + in
1.1268 + if is_numeral str then
1.1269 + (
1.1270 + Some [(((the o int_of_str) str),mv_null2(v))] handle _ => None
1.1271 + )
1.1272 + else (* variable *)
1.1273 + (
1.1274 + len:=length(v);
1.1275 + vh:=v;
1.1276 + while ((!len)>(!i)) do
1.1277 + (
1.1278 + if str=hd((!vh)) then
1.1279 + (
1.1280 + vl:=1::(!vl)
1.1281 + )
1.1282 + else
1.1283 + (
1.1284 + vl:=0::(!vl)
1.1285 + );
1.1286 + vh:=tl(!vh);
1.1287 + i:=(!i)+1
1.1288 + );
1.1289 + Some [(1,rev(!vl))] handle _ => None
1.1290 + )
1.1291 + end
1.1292 + | term2coef' (Const ("op *",_) $ t1 $ t2) v :mv_poly option=
1.1293 + let
1.1294 + val t1pp=ref [];
1.1295 + val t2pp=ref [];
1.1296 + val t1c=ref 0;
1.1297 + val t2c=ref 0;
1.1298 + in
1.1299 + (
1.1300 + t1pp:=(#2(hd(the(term2coef' t1 v))));
1.1301 + t2pp:=(#2(hd(the(term2coef' t2 v))));
1.1302 + t1c:=(#1(hd(the(term2coef' t1 v))));
1.1303 + t2c:=(#1(hd(the(term2coef' t2 v))));
1.1304 +
1.1305 + Some [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] handle _ => None
1.1306 +
1.1307 + )
1.1308 + end
1.1309 + | term2coef' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ (t2 as Free (str2,_))) v :mv_poly option=
1.1310 + let
1.1311 + val x=ref None;
1.1312 + val len=ref 0;
1.1313 + val vl=ref [];
1.1314 + val vh=ref [];
1.1315 + val vtemp=ref [];
1.1316 + val i=ref 0;
1.1317 + in
1.1318 + (
1.1319 + if (not o is_numeral) str1 andalso is_numeral str2 then
1.1320 + (
1.1321 + len:=length(v);
1.1322 + vh:=v;
1.1323 +
1.1324 + while ((!len)>(!i)) do
1.1325 + (
1.1326 + if str1=hd((!vh)) then
1.1327 + (
1.1328 + vl:=((the o int_of_str) str2)::(!vl)
1.1329 + )
1.1330 + else
1.1331 + (
1.1332 + vl:=0::(!vl)
1.1333 + );
1.1334 + vh:=tl(!vh);
1.1335 + i:=(!i)+1
1.1336 + );
1.1337 + Some [(1,rev(!vl))] handle _ => None
1.1338 + )
1.1339 + else raise error ("RATIONALS_TERM2COEF_EXCEPTION 1: Invalid term")
1.1340 + )
1.1341 + end
1.1342 + | term2coef' (Const ("op +",_) $ t1 $ t2) v :mv_poly option=
1.1343 + (
1.1344 + Some ((the(term2coef' t1 v)) @ (the(term2coef' t2 v))) handle _ => None
1.1345 + )
1.1346 + | term2coef' (Const ("op -",_) $ t1 $ t2) v :mv_poly option=
1.1347 + (
1.1348 + Some ((the(term2coef' t1 v)) @ mv_skalar_mul((the(term2coef' t2 v)),1)) handle _ => None
1.1349 + )
1.1350 + | term2coef' (term) v = raise error ("RATIONALS_TERM2COEF_EXCEPTION 2: Invalid term");
1.1351 +
1.1352 +(*. checks if all coefficients of a polynomial are positiv (except the first) .*)
1.1353 +fun check_coeff t = (* erste Koeffizient kann <0 sein !!! *)
1.1354 + if count_neg(tl(the(term2coef' t (get_vars(t)))))=0 then true
1.1355 + else false;
1.1356 +
1.1357 +(*. checks for expanded term (3) .*)
1.1358 +fun is_expanded t = test_exp t " " andalso check_coeff(t);
1.1359 +
1.1360 +(*WN.7.3.03 Hilfsfunktion f"ur term2poly'*)
1.1361 +fun mk_monom v' p vs =
1.1362 + let fun conv p (v: string) = if v'= v then p else 0
1.1363 + in map (conv p) vs end;
1.1364 +(* mk_monom "y" 5 ["a","b","x","y","z"];
1.1365 +val it = [0,0,0,5,0] : int list*)
1.1366 +
1.1367 +(*. this function converts the term representation into the internal representation mv_poly .*)
1.1368 +fun term2poly' (Const ("uminus",_) $ Free (str,_)) v = (*WN.7.3.03*)
1.1369 + if is_numeral str
1.1370 + then Some [((the o int_of_str) ("-"^str), mk_monom "#" 0 v)]
1.1371 + else Some [(~1, mk_monom str 1 v)]
1.1372 +
1.1373 + | term2poly' (Free(str,_)) v :mv_poly option =
1.1374 + let
1.1375 + val x=ref None;
1.1376 + val len=ref 0;
1.1377 + val vl=ref [];
1.1378 + val vh=ref [];
1.1379 + val i=ref 0;
1.1380 + in
1.1381 + if is_numeral str then
1.1382 + (
1.1383 + Some [(((the o int_of_str) str),mv_null2 v)] handle _ => None
1.1384 + )
1.1385 + else (* variable *)
1.1386 + (
1.1387 + len:=length v;
1.1388 + vh:= v;
1.1389 + while ((!len)>(!i)) do
1.1390 + (
1.1391 + if str=hd((!vh)) then
1.1392 + (
1.1393 + vl:=1::(!vl)
1.1394 + )
1.1395 + else
1.1396 + (
1.1397 + vl:=0::(!vl)
1.1398 + );
1.1399 + vh:=tl(!vh);
1.1400 + i:=(!i)+1
1.1401 + );
1.1402 + Some [(1,rev(!vl))] handle _ => None
1.1403 + )
1.1404 + end
1.1405 + | term2poly' (Const ("op *",_) $ t1 $ t2) v :mv_poly option=
1.1406 + let
1.1407 + val t1pp=ref [];
1.1408 + val t2pp=ref [];
1.1409 + val t1c=ref 0;
1.1410 + val t2c=ref 0;
1.1411 + in
1.1412 + (
1.1413 + t1pp:=(#2(hd(the(term2poly' t1 v))));
1.1414 + t2pp:=(#2(hd(the(term2poly' t2 v))));
1.1415 + t1c:=(#1(hd(the(term2poly' t1 v))));
1.1416 + t2c:=(#1(hd(the(term2poly' t2 v))));
1.1417 +
1.1418 + Some [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )]
1.1419 + handle _ => None
1.1420 +
1.1421 + )
1.1422 + end
1.1423 + | term2poly' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $
1.1424 + (t2 as Free (str2,_))) v :mv_poly option=
1.1425 + let
1.1426 + val x=ref None;
1.1427 + val len=ref 0;
1.1428 + val vl=ref [];
1.1429 + val vh=ref [];
1.1430 + val vtemp=ref [];
1.1431 + val i=ref 0;
1.1432 + in
1.1433 + (
1.1434 + if (not o is_numeral) str1 andalso is_numeral str2 then
1.1435 + (
1.1436 + len:=length(v);
1.1437 + vh:=v;
1.1438 +
1.1439 + while ((!len)>(!i)) do
1.1440 + (
1.1441 + if str1=hd((!vh)) then
1.1442 + (
1.1443 + vl:=((the o int_of_str) str2)::(!vl)
1.1444 + )
1.1445 + else
1.1446 + (
1.1447 + vl:=0::(!vl)
1.1448 + );
1.1449 + vh:=tl(!vh);
1.1450 + i:=(!i)+1
1.1451 + );
1.1452 + Some [(1,rev(!vl))] handle _ => None
1.1453 + )
1.1454 + else raise error ("RATIONALS_TERM2POLY_EXCEPTION 1: Invalid term")
1.1455 + )
1.1456 + end
1.1457 + | term2poly' (Const ("op +",_) $ t1 $ t2) v :mv_poly option =
1.1458 + (
1.1459 + Some ((the(term2poly' t1 v)) @ (the(term2poly' t2 v))) handle _ => None
1.1460 + )
1.1461 + | term2poly' (Const ("op -",_) $ t1 $ t2) v :mv_poly option =
1.1462 + (
1.1463 + Some ((the(term2poly' t1 v)) @ mv_skalar_mul((the(term2poly' t2 v)),~1)) handle _ => None
1.1464 + )
1.1465 + | term2poly' (term) v = raise error ("RATIONALS_TERM2POLY_EXCEPTION 2: Invalid term");
1.1466 +
1.1467 +(*. translates an Isabelle term into internal representation.
1.1468 + term2poly
1.1469 + fn : term -> (*normalform (2) *)
1.1470 + string list -> (*for ...!!! BITTE DIE ERKLÄRUNG,
1.1471 + DIE DU MIR LETZTES MAL GEGEBEN HAST*)
1.1472 + mv_monom list (*internal representation *)
1.1473 + option (*the translation may fail with None*)
1.1474 +.*)
1.1475 +fun term2poly (t:term) v =
1.1476 + if is_polynomial t then term2poly' t v
1.1477 + else raise error ("term2poly: invalid = "^(term2str t));
1.1478 +
1.1479 +(*. same as term2poly with automatic detection of the variables .*)
1.1480 +fun term2polyx t = term2poly t (((map free2str) o vars) t);
1.1481 +
1.1482 +(*. checks if the term is in expanded polynomial form and converts it into the internal representation .*)
1.1483 +fun expanded2poly (t:term) v =
1.1484 + (*if is_expanded t then*) term2poly' t v
1.1485 + (*else raise error ("RATIONALS_EXPANDED2POLY_EXCEPTION: Invalid Polynomial")*);
1.1486 +
1.1487 +(*. same as expanded2poly with automatic detection of the variables .*)
1.1488 +fun expanded2polyx t = expanded2poly t (((map free2str) o vars) t);
1.1489 +
1.1490 +(*. checks if all elements of the list have value zero .*)
1.1491 +fun list_is_null [] = true
1.1492 + | list_is_null (x::xs) = (x=0 andalso list_is_null(xs));
1.1493 +
1.1494 +(*. converts a powerproduct into term representation .*)
1.1495 +fun powerproduct2term(xs,v) =
1.1496 + let
1.1497 + val xss=ref xs;
1.1498 + val vv=ref v;
1.1499 + in
1.1500 + (
1.1501 + while hd(!xss)=0 do
1.1502 + (
1.1503 + xss:=tl(!xss);
1.1504 + vv:=tl(!vv)
1.1505 + );
1.1506 +
1.1507 + if list_is_null(tl(!xss)) then
1.1508 + (
1.1509 + if hd(!xss)=1 then Free(hd(!vv), HOLogic.realT)
1.1510 + else
1.1511 + (
1.1512 + Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1513 + Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT)
1.1514 + )
1.1515 + )
1.1516 + else
1.1517 + (
1.1518 + if hd(!xss)=1 then
1.1519 + (
1.1520 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1521 + Free(hd(!vv), HOLogic.realT) $
1.1522 + powerproduct2term(tl(!xss),tl(!vv))
1.1523 + )
1.1524 + else
1.1525 + (
1.1526 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1527 + (
1.1528 + Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1529 + Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT)
1.1530 + ) $
1.1531 + powerproduct2term(tl(!xss),tl(!vv))
1.1532 + )
1.1533 + )
1.1534 + )
1.1535 + end;
1.1536 +
1.1537 +(*. converts a monom into term representation .*)
1.1538 +(*fun monom2term ((c,e):mv_monom, v:string list) =
1.1539 + if c=0 then Free(str_of_int 0,HOLogic.realT)
1.1540 + else
1.1541 + (
1.1542 + if list_is_null(e) then
1.1543 + (
1.1544 + Free(str_of_int c,HOLogic.realT)
1.1545 + )
1.1546 + else
1.1547 + (
1.1548 + if c=1 then
1.1549 + (
1.1550 + powerproduct2term(e,v)
1.1551 + )
1.1552 + else
1.1553 + (
1.1554 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1555 + Free(str_of_int c,HOLogic.realT) $
1.1556 + powerproduct2term(e,v)
1.1557 + )
1.1558 + )
1.1559 + );*)
1.1560 +(*WN.10.3.03*)
1.1561 +fun allzeros [] = true
1.1562 + | allzeros (i::is) = if i = 0 then allzeros is else false;
1.1563 +(*allzeros [0,0,0,0];
1.1564 +val it = true
1.1565 + allzeros [0,0,1,0];
1.1566 +val it = false
1.1567 + allzeros [];
1.1568 +val it = true*)
1.1569 +(*fun monom2term ((i, is):mv_monom, v) =
1.1570 + if allzeros is
1.1571 + then
1.1572 + if i >= 0
1.1573 + then Free (str_of_int i, HOLogic.realT)
1.1574 + else Const ("uminus", HOLogic.realT --> HOLogic.realT) $
1.1575 + Free ((str_of_int o abs) i, HOLogic.realT)
1.1576 + else
1.1577 + if i > 0
1.1578 + then Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
1.1579 + (Free (str_of_int i, HOLogic.realT)) $
1.1580 + powerproduct2term(is, v)
1.1581 + else Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
1.1582 + (Const ("uminus", HOLogic.realT --> HOLogic.realT) $
1.1583 + Free ((str_of_int o abs) i, HOLogic.realT)) $
1.1584 + powerproduct2term(is, v);---------------------------*)
1.1585 +fun monom2term ((i, is):mv_monom, v) =
1.1586 + if allzeros is
1.1587 + then Free (str_of_int i, HOLogic.realT)
1.1588 + else Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
1.1589 + (Free (str_of_int i, HOLogic.realT)) $
1.1590 + powerproduct2term(is, v);
1.1591 +
1.1592 +
1.1593 +(*. converts the polynomial representation into the term representation .*)
1.1594 +fun poly2term' ([]:mv_poly,vs) = Free(str_of_int 0,HOLogic.realT)
1.1595 + | poly2term' ([(c,e)],vs) = monom2term((c,e),vs)
1.1596 + | poly2term' ((c,e)::others,vs) = Const("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1597 + poly2term(others,vs) $
1.1598 + (
1.1599 + monom2term((c,e),vs)
1.1600 + )
1.1601 +(*. translates the internal representation into an Isabelle term
1.1602 + poly2term =
1.1603 + fn : (int * (**)
1.1604 + int list) list * (**)
1.1605 + string list -> (**)
1.1606 + term (**)
1.1607 +.*)
1.1608 +and poly2term (xs,vs) = poly2term'(rev(sort (mv_geq LEX_) (xs)),vs);
1.1609 +
1.1610 +
1.1611 +(*. converts a monom into term representation .*)
1.1612 +(*. ignores the sign of the coefficients => use only for exp-poly functions .*)
1.1613 +fun monom2term2((c,e):mv_monom, v:string list) =
1.1614 + if c=0 then Free(str_of_int 0,HOLogic.realT)
1.1615 + else
1.1616 + (
1.1617 + if list_is_null(e) then
1.1618 + (
1.1619 + Free(str_of_int (abs(c)),HOLogic.realT)
1.1620 + )
1.1621 + else
1.1622 + (
1.1623 + if abs(c)=1 then
1.1624 + (
1.1625 + powerproduct2term(e,v)
1.1626 + )
1.1627 + else
1.1628 + (
1.1629 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1630 + Free(str_of_int (abs(c)),HOLogic.realT) $
1.1631 + powerproduct2term(e,v)
1.1632 + )
1.1633 + )
1.1634 + );
1.1635 +
1.1636 +(*. converts the expanded polynomial representation into the term representation .*)
1.1637 +fun exp2term' ([]:mv_poly,vars) = Free(str_of_int 0,HOLogic.realT)
1.1638 + | exp2term' ([(c,e)],vars) = monom2term((c,e),vars)
1.1639 + | exp2term' ((c1,e1)::others,vars) =
1.1640 + if c1<0 then
1.1641 + Const("op -",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1642 + exp2term'(others,vars) $
1.1643 + (
1.1644 + monom2term2((c1,e1),vars)
1.1645 + )
1.1646 + else
1.1647 + Const("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1648 + exp2term'(others,vars) $
1.1649 + (
1.1650 + monom2term2((c1,e1),vars)
1.1651 + );
1.1652 +
1.1653 +(*. sorts the powerproduct by lexicographic termorder and converts them into
1.1654 + a term in polynomial representation .*)
1.1655 +fun poly2expanded (xs,vars) = exp2term'(rev(sort (mv_geq LEX_) (xs)),vars);
1.1656 +
1.1657 +(*. converts a polynomial into expanded form .*)
1.1658 +fun polynomial2expanded t =
1.1659 + (let
1.1660 + val vars=(((map free2str) o vars) t);
1.1661 + in
1.1662 + Some (poly2expanded (the (term2poly t vars), vars))
1.1663 + end) handle _ => None;
1.1664 +
1.1665 +(*. converts a polynomial into polynomial form .*)
1.1666 +fun expanded2polynomial t =
1.1667 + (let
1.1668 + val vars=(((map free2str) o vars) t);
1.1669 + in
1.1670 + Some (poly2term (the (expanded2poly t vars), vars))
1.1671 + end) handle _ => None;
1.1672 +
1.1673 +
1.1674 +(*. calculates the greatest common divisor of numerator and denominator and seperates it from each .*)
1.1675 +fun step_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) =
1.1676 + let
1.1677 + val p1' = ref [];
1.1678 + val p2' = ref [];
1.1679 + val p3 = ref []
1.1680 + val vars = rev(get_vars(p1) union get_vars(p2));
1.1681 + in
1.1682 + (
1.1683 + p1':= sort (mv_geq LEX_) (the (term2poly p1 vars ));
1.1684 + p2':= sort (mv_geq LEX_) (the (term2poly p2 vars ));
1.1685 + p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
1.1686 + if (!p3)=[(1,mv_null2(vars))] then
1.1687 + (
1.1688 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2
1.1689 + )
1.1690 + else
1.1691 + (
1.1692 +
1.1693 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
1.1694 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
1.1695 +
1.1696 + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
1.1697 + (
1.1698 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1699 + $
1.1700 + (
1.1701 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1702 + poly2term(!p1',vars) $
1.1703 + poly2term(!p3,vars)
1.1704 + )
1.1705 + $
1.1706 + (
1.1707 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1708 + poly2term(!p2',vars) $
1.1709 + poly2term(!p3,vars)
1.1710 + )
1.1711 + )
1.1712 + else
1.1713 + (
1.1714 + p1':=mv_skalar_mul(!p1',~1);
1.1715 + p2':=mv_skalar_mul(!p2',~1);
1.1716 + p3:=mv_skalar_mul(!p3,~1);
1.1717 + (
1.1718 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1719 + $
1.1720 + (
1.1721 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1722 + poly2term(!p1',vars) $
1.1723 + poly2term(!p3,vars)
1.1724 + )
1.1725 + $
1.1726 + (
1.1727 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1728 + poly2term(!p2',vars) $
1.1729 + poly2term(!p3,vars)
1.1730 + )
1.1731 + )
1.1732 + )
1.1733 + )
1.1734 + )
1.1735 + end
1.1736 +| step_cancel _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction");
1.1737 +
1.1738 +
1.1739 +(*. same as step_cancel, this time for expanded forms (input+output) .*)
1.1740 +fun step_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) =
1.1741 + let
1.1742 + val p1' = ref [];
1.1743 + val p2' = ref [];
1.1744 + val p3 = ref []
1.1745 + val vars = rev(get_vars(p1) union get_vars(p2));
1.1746 + in
1.1747 + (
1.1748 + p1':= sort (mv_geq LEX_) (the (expanded2poly p1 vars ));
1.1749 + p2':= sort (mv_geq LEX_) (the (expanded2poly p2 vars ));
1.1750 + p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
1.1751 + if (!p3)=[(1,mv_null2(vars))] then
1.1752 + (
1.1753 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2
1.1754 + )
1.1755 + else
1.1756 + (
1.1757 +
1.1758 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
1.1759 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
1.1760 +
1.1761 + if #1(hd(sort (mv_geq LEX_) (!p2')))(* mv_lc2(!p2',LEX_)*)>0 then
1.1762 + (
1.1763 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1764 + $
1.1765 + (
1.1766 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1767 + poly2expanded(!p1',vars) $
1.1768 + poly2expanded(!p3,vars)
1.1769 + )
1.1770 + $
1.1771 + (
1.1772 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1773 + poly2expanded(!p2',vars) $
1.1774 + poly2expanded(!p3,vars)
1.1775 + )
1.1776 + )
1.1777 + else
1.1778 + (
1.1779 + p1':=mv_skalar_mul(!p1',~1);
1.1780 + p2':=mv_skalar_mul(!p2',~1);
1.1781 + p3:=mv_skalar_mul(!p3,~1);
1.1782 + (
1.1783 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1784 + $
1.1785 + (
1.1786 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1787 + poly2expanded(!p1',vars) $
1.1788 + poly2expanded(!p3,vars)
1.1789 + )
1.1790 + $
1.1791 + (
1.1792 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.1793 + poly2expanded(!p2',vars) $
1.1794 + poly2expanded(!p3,vars)
1.1795 + )
1.1796 + )
1.1797 + )
1.1798 + )
1.1799 + )
1.1800 + end
1.1801 +| step_cancel_expanded _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction");
1.1802 +
1.1803 +(*. calculates the greatest common divisor of numerator and denominator and divides each through it .*)
1.1804 +fun direct_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) =
1.1805 + let
1.1806 + val p1' = ref [];
1.1807 + val p2' = ref [];
1.1808 + val p3 = ref []
1.1809 + val vars = rev(get_vars(p1) union get_vars(p2));
1.1810 + in
1.1811 + (
1.1812 + p1':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p1 vars )),LEX_));
1.1813 + p2':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p2 vars )),LEX_));
1.1814 + p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
1.1815 +
1.1816 + if (!p3)=[(1,mv_null2(vars))] then
1.1817 + (
1.1818 + (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[])
1.1819 + )
1.1820 + else
1.1821 + (
1.1822 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
1.1823 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
1.1824 + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
1.1825 + (
1.1826 + (
1.1827 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1828 + $
1.1829 + (
1.1830 + poly2term((!p1'),vars)
1.1831 + )
1.1832 + $
1.1833 + (
1.1834 + poly2term((!p2'),vars)
1.1835 + )
1.1836 + )
1.1837 + ,
1.1838 + if mv_grad(!p3)>0 then
1.1839 + [
1.1840 + (
1.1841 + Const ("Not",[bool]--->bool) $
1.1842 + (
1.1843 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
1.1844 + poly2term((!p3),vars) $
1.1845 + Free("0",HOLogic.realT)
1.1846 + )
1.1847 + )
1.1848 + ]
1.1849 + else
1.1850 + []
1.1851 + )
1.1852 + else
1.1853 + (
1.1854 + p1':=mv_skalar_mul(!p1',~1);
1.1855 + p2':=mv_skalar_mul(!p2',~1);
1.1856 + if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1);
1.1857 + (
1.1858 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1859 + $
1.1860 + (
1.1861 + poly2term((!p1'),vars)
1.1862 + )
1.1863 + $
1.1864 + (
1.1865 + poly2term((!p2'),vars)
1.1866 + )
1.1867 + ,
1.1868 + if mv_grad(!p3)>0 then
1.1869 + [
1.1870 + (
1.1871 + Const ("Not",[bool]--->bool) $
1.1872 + (
1.1873 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
1.1874 + poly2term((!p3),vars) $
1.1875 + Free("0",HOLogic.realT)
1.1876 + )
1.1877 + )
1.1878 + ]
1.1879 + else
1.1880 + []
1.1881 + )
1.1882 + )
1.1883 + )
1.1884 + )
1.1885 + end
1.1886 + | direct_cancel _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction");
1.1887 +
1.1888 +(*. same es direct_cancel, this time for expanded forms (input+output).*)
1.1889 +fun direct_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) =
1.1890 + let
1.1891 + val p1' = ref [];
1.1892 + val p2' = ref [];
1.1893 + val p3 = ref []
1.1894 + val vars = rev(get_vars(p1) union get_vars(p2));
1.1895 + in
1.1896 + (
1.1897 + p1':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p1 vars )),LEX_));
1.1898 + p2':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p2 vars )),LEX_));
1.1899 + p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
1.1900 +
1.1901 + if (!p3)=[(1,mv_null2(vars))] then
1.1902 + (
1.1903 + (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[])
1.1904 + )
1.1905 + else
1.1906 + (
1.1907 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
1.1908 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
1.1909 + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
1.1910 + (
1.1911 + (
1.1912 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1913 + $
1.1914 + (
1.1915 + poly2expanded((!p1'),vars)
1.1916 + )
1.1917 + $
1.1918 + (
1.1919 + poly2expanded((!p2'),vars)
1.1920 + )
1.1921 + )
1.1922 + ,
1.1923 + if mv_grad(!p3)>0 then
1.1924 + [
1.1925 + (
1.1926 + Const ("Not",[bool]--->bool) $
1.1927 + (
1.1928 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
1.1929 + poly2expanded((!p3),vars) $
1.1930 + Free("0",HOLogic.realT)
1.1931 + )
1.1932 + )
1.1933 + ]
1.1934 + else
1.1935 + []
1.1936 + )
1.1937 + else
1.1938 + (
1.1939 + p1':=mv_skalar_mul(!p1',~1);
1.1940 + p2':=mv_skalar_mul(!p2',~1);
1.1941 + if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1);
1.1942 + (
1.1943 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1944 + $
1.1945 + (
1.1946 + poly2expanded((!p1'),vars)
1.1947 + )
1.1948 + $
1.1949 + (
1.1950 + poly2expanded((!p2'),vars)
1.1951 + )
1.1952 + ,
1.1953 + if mv_grad(!p3)>0 then
1.1954 + [
1.1955 + (
1.1956 + Const ("Not",[bool]--->bool) $
1.1957 + (
1.1958 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
1.1959 + poly2expanded((!p3),vars) $
1.1960 + Free("0",HOLogic.realT)
1.1961 + )
1.1962 + )
1.1963 + ]
1.1964 + else
1.1965 + []
1.1966 + )
1.1967 + )
1.1968 + )
1.1969 + )
1.1970 + end
1.1971 + | direct_cancel_expanded _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction");
1.1972 +
1.1973 +
1.1974 +(*. adds two fractions .*)
1.1975 +fun add_fract ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) =
1.1976 + let
1.1977 + val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22);
1.1978 + val t11'=ref (the(term2poly t11 vars));
1.1979 + val t12'=ref (the(term2poly t12 vars));
1.1980 + val t21'=ref (the(term2poly t21 vars));
1.1981 + val t22'=ref (the(term2poly t22 vars));
1.1982 + val den=ref [];
1.1983 + val nom=ref [];
1.1984 + val m1=ref [];
1.1985 + val m2=ref [];
1.1986 + in
1.1987 +
1.1988 + (
1.1989 + den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22'));
1.1990 + m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_)));
1.1991 + m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_)));
1.1992 + nom :=sort (mv_geq LEX_) (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),mv_mul(!t21',!m2,LEX_),LEX_),LEX_));
1.1993 + (
1.1994 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.1995 + $
1.1996 + (
1.1997 + poly2term((!nom),vars)
1.1998 + )
1.1999 + $
1.2000 + (
1.2001 + poly2term((!den),vars)
1.2002 + )
1.2003 + )
1.2004 + )
1.2005 + end
1.2006 + | add_fract (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: Invalid add_fraction call");
1.2007 +
1.2008 +(*. adds two expanded fractions .*)
1.2009 +fun add_fract_exp ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) =
1.2010 + let
1.2011 + val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22);
1.2012 + val t11'=ref (the(expanded2poly t11 vars));
1.2013 + val t12'=ref (the(expanded2poly t12 vars));
1.2014 + val t21'=ref (the(expanded2poly t21 vars));
1.2015 + val t22'=ref (the(expanded2poly t22 vars));
1.2016 + val den=ref [];
1.2017 + val nom=ref [];
1.2018 + val m1=ref [];
1.2019 + val m2=ref [];
1.2020 + in
1.2021 +
1.2022 + (
1.2023 + den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22'));
1.2024 + m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_)));
1.2025 + m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_)));
1.2026 + nom :=sort (mv_geq LEX_) (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),mv_mul(!t21',!m2,LEX_),LEX_),LEX_));
1.2027 + (
1.2028 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2029 + $
1.2030 + (
1.2031 + poly2expanded((!nom),vars)
1.2032 + )
1.2033 + $
1.2034 + (
1.2035 + poly2expanded((!den),vars)
1.2036 + )
1.2037 + )
1.2038 + )
1.2039 + end
1.2040 + | add_fract_exp (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXP_EXCEPTION: Invalid add_fraction call");
1.2041 +
1.2042 +(*. adds a list of terms .*)
1.2043 +fun add_list_of_fractions []= (Free("0",HOLogic.realT),[])
1.2044 + | add_list_of_fractions [x]= direct_cancel x
1.2045 + | add_list_of_fractions (x::y::xs) =
1.2046 + let
1.2047 + val (t1a,rest1)=direct_cancel(x);
1.2048 + val (t2a,rest2)=direct_cancel(y);
1.2049 + val (t3a,rest3)=(add_list_of_fractions (add_fract(t1a,t2a)::xs));
1.2050 + val (t4a,rest4)=direct_cancel(t3a);
1.2051 + val rest=rest1 union rest2 union rest3 union rest4;
1.2052 + in
1.2053 + (
1.2054 + (t4a,rest)
1.2055 + )
1.2056 + end;
1.2057 +
1.2058 +(*. adds a list of expanded terms .*)
1.2059 +fun add_list_of_fractions_exp []= (Free("0",HOLogic.realT),[])
1.2060 + | add_list_of_fractions_exp [x]= direct_cancel_expanded x
1.2061 + | add_list_of_fractions_exp (x::y::xs) =
1.2062 + let
1.2063 + val (t1a,rest1)=direct_cancel_expanded(x);
1.2064 + val (t2a,rest2)=direct_cancel_expanded(y);
1.2065 + val (t3a,rest3)=(add_list_of_fractions_exp (add_fract_exp(t1a,t2a)::xs));
1.2066 + val (t4a,rest4)=direct_cancel_expanded(t3a);
1.2067 + val rest=rest1 union rest2 union rest3 union rest4;
1.2068 + in
1.2069 + (
1.2070 + (t4a,rest)
1.2071 + )
1.2072 + end;
1.2073 +
1.2074 +(*. calculates the lcm of a list of mv_poly .*)
1.2075 +fun calc_lcm ([x],var)= (x,var)
1.2076 + | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var);
1.2077 +
1.2078 +(*. converts a list of terms to a list of mv_poly .*)
1.2079 +fun t2d([],_)=[]
1.2080 + | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars);
1.2081 +
1.2082 +(*. same as t2d, this time for expanded forms .*)
1.2083 +fun t2d_exp([],_)=[]
1.2084 + | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars);
1.2085 +
1.2086 +(*. converts a list of fract terms to a list of their denominators .*)
1.2087 +fun termlist2denominators [] = ([],[])
1.2088 + | termlist2denominators xs =
1.2089 + let
1.2090 + val xxs=ref xs;
1.2091 + val var=ref [];
1.2092 + in
1.2093 + var:=[];
1.2094 + while length(!xxs)>0 do
1.2095 + (
1.2096 + let
1.2097 + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
1.2098 + in
1.2099 + (
1.2100 + xxs:=tl(!xxs);
1.2101 + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
1.2102 + )
1.2103 + end
1.2104 + );
1.2105 + (t2d(xs,!var),!var)
1.2106 + end;
1.2107 +
1.2108 +(*. calculates the lcm of a list of mv_poly .*)
1.2109 +fun calc_lcm ([x],var)= (x,var)
1.2110 + | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var);
1.2111 +
1.2112 +(*. converts a list of terms to a list of mv_poly .*)
1.2113 +fun t2d([],_)=[]
1.2114 + | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars);
1.2115 +
1.2116 +(*. same as t2d, this time for expanded forms .*)
1.2117 +fun t2d_exp([],_)=[]
1.2118 + | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars);
1.2119 +
1.2120 +(*. converts a list of fract terms to a list of their denominators .*)
1.2121 +fun termlist2denominators [] = ([],[])
1.2122 + | termlist2denominators xs =
1.2123 + let
1.2124 + val xxs=ref xs;
1.2125 + val var=ref [];
1.2126 + in
1.2127 + var:=[];
1.2128 + while length(!xxs)>0 do
1.2129 + (
1.2130 + let
1.2131 + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
1.2132 + in
1.2133 + (
1.2134 + xxs:=tl(!xxs);
1.2135 + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
1.2136 + )
1.2137 + end
1.2138 + );
1.2139 + (t2d(xs,!var),!var)
1.2140 + end;
1.2141 +
1.2142 +(*. same as termlist2denminators, this time for expanded forms .*)
1.2143 +fun termlist2denominators_exp [] = ([],[])
1.2144 + | termlist2denominators_exp xs =
1.2145 + let
1.2146 + val xxs=ref xs;
1.2147 + val var=ref [];
1.2148 + in
1.2149 + var:=[];
1.2150 + while length(!xxs)>0 do
1.2151 + (
1.2152 + let
1.2153 + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
1.2154 + in
1.2155 + (
1.2156 + xxs:=tl(!xxs);
1.2157 + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
1.2158 + )
1.2159 + end
1.2160 + );
1.2161 + (t2d_exp(xs,!var),!var)
1.2162 + end;
1.2163 +
1.2164 +(*. reduces all fractions to the least common denominator .*)
1.2165 +fun com_den(x::xs,denom,den,var)=
1.2166 + let
1.2167 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
1.2168 + val p2= sort (mv_geq LEX_) (the(term2poly p2' var));
1.2169 + val p3= #1(mv_division(denom,p2,LEX_));
1.2170 + val p1var=get_vars(p1');
1.2171 + in
1.2172 + if length(xs)>0 then
1.2173 + if p3=[(1,mv_null2(var))] then
1.2174 + (
1.2175 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2176 + $
1.2177 + (
1.2178 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2179 + $
1.2180 + poly2term(the (term2poly p1' p1var),p1var)
1.2181 + $
1.2182 + den
1.2183 + )
1.2184 + $
1.2185 + #1(com_den(xs,denom,den,var))
1.2186 + ,
1.2187 + []
1.2188 + )
1.2189 + else
1.2190 + (
1.2191 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2192 + $
1.2193 + (
1.2194 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2195 + $
1.2196 + (
1.2197 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2198 + poly2term(the (term2poly p1' p1var),p1var) $
1.2199 + poly2term(p3,var)
1.2200 + )
1.2201 + $
1.2202 + (
1.2203 + den
1.2204 + )
1.2205 + )
1.2206 + $
1.2207 + #1(com_den(xs,denom,den,var))
1.2208 + ,
1.2209 + []
1.2210 + )
1.2211 + else
1.2212 + if p3=[(1,mv_null2(var))] then
1.2213 + (
1.2214 + (
1.2215 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2216 + $
1.2217 + poly2term(the (term2poly p1' p1var),p1var)
1.2218 + $
1.2219 + den
1.2220 + )
1.2221 + ,
1.2222 + []
1.2223 + )
1.2224 + else
1.2225 + (
1.2226 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2227 + $
1.2228 + (
1.2229 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2230 + poly2term(the (term2poly p1' p1var),p1var) $
1.2231 + poly2term(p3,var)
1.2232 + )
1.2233 + $
1.2234 + den
1.2235 + ,
1.2236 + []
1.2237 + )
1.2238 + end;
1.2239 +
1.2240 +(*. same as com_den, this time for expanded forms .*)
1.2241 +fun com_den_exp(x::xs,denom,den,var)=
1.2242 + let
1.2243 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
1.2244 + val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var));
1.2245 + val p3= #1(mv_division(denom,p2,LEX_));
1.2246 + val p1var=get_vars(p1');
1.2247 + in
1.2248 + if length(xs)>0 then
1.2249 + if p3=[(1,mv_null2(var))] then
1.2250 + (
1.2251 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2252 + $
1.2253 + (
1.2254 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2255 + $
1.2256 + poly2expanded(the(expanded2poly p1' p1var),p1var)
1.2257 + $
1.2258 + den
1.2259 + )
1.2260 + $
1.2261 + #1(com_den_exp(xs,denom,den,var))
1.2262 + ,
1.2263 + []
1.2264 + )
1.2265 + else
1.2266 + (
1.2267 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2268 + $
1.2269 + (
1.2270 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2271 + $
1.2272 + (
1.2273 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2274 + poly2expanded(the(expanded2poly p1' p1var),p1var) $
1.2275 + poly2expanded(p3,var)
1.2276 + )
1.2277 + $
1.2278 + (
1.2279 + den
1.2280 + )
1.2281 + )
1.2282 + $
1.2283 + #1(com_den_exp(xs,denom,den,var))
1.2284 + ,
1.2285 + []
1.2286 + )
1.2287 + else
1.2288 + if p3=[(1,mv_null2(var))] then
1.2289 + (
1.2290 + (
1.2291 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2292 + $
1.2293 + poly2expanded(the(expanded2poly p1' p1var),p1var)
1.2294 + $
1.2295 + den
1.2296 + )
1.2297 + ,
1.2298 + []
1.2299 + )
1.2300 + else
1.2301 + (
1.2302 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
1.2303 + $
1.2304 + (
1.2305 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2306 + poly2expanded(the(expanded2poly p1' p1var),p1var) $
1.2307 + poly2expanded(p3,var)
1.2308 + )
1.2309 + $
1.2310 + den
1.2311 + ,
1.2312 + []
1.2313 + )
1.2314 + end;
1.2315 +
1.2316 +(* wird aktuell nicht mehr gebraucht, bei rückänderung schon
1.2317 +-------------------------------------------------------------
1.2318 +(* FIXME brauch ma des überhaupt??? *)
1.2319 +fun com_den2(x::xs,denom,den,var)=
1.2320 + let
1.2321 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
1.2322 + val p2= sort (mv_geq LEX_) (the(term2poly p2' var));
1.2323 + val p3= #1(mv_division(denom,p2,LEX_));
1.2324 + val p1var=get_vars(p1');
1.2325 + in
1.2326 + if length(xs)>0 then
1.2327 + if p3=[(1,mv_null2(var))] then
1.2328 + (
1.2329 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2330 + poly2term(the(term2poly p1' p1var),p1var) $
1.2331 + com_den2(xs,denom,den,var)
1.2332 + )
1.2333 + else
1.2334 + (
1.2335 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2336 + (
1.2337 + let
1.2338 + val p3'=poly2term(p3,var);
1.2339 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
1.2340 + in
1.2341 + poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars)
1.2342 + end
1.2343 + ) $
1.2344 + com_den2(xs,denom,den,var)
1.2345 + )
1.2346 + else
1.2347 + if p3=[(1,mv_null2(var))] then
1.2348 + (
1.2349 + poly2term(the(term2poly p1' p1var),p1var)
1.2350 + )
1.2351 + else
1.2352 + (
1.2353 + let
1.2354 + val p3'=poly2term(p3,var);
1.2355 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
1.2356 + in
1.2357 + poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars)
1.2358 + end
1.2359 + )
1.2360 + end;
1.2361 +
1.2362 +(* FIXME brauch ma des überhaupt??? *)
1.2363 +fun com_den_exp2(x::xs,denom,den,var)=
1.2364 + let
1.2365 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
1.2366 + val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var));
1.2367 + val p3= #1(mv_division(denom,p2,LEX_));
1.2368 + val p1var=get_vars p1';
1.2369 + in
1.2370 + if length(xs)>0 then
1.2371 + if p3=[(1,mv_null2(var))] then
1.2372 + (
1.2373 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2374 + poly2expanded(the (expanded2poly p1' p1var),p1var) $
1.2375 + com_den_exp2(xs,denom,den,var)
1.2376 + )
1.2377 + else
1.2378 + (
1.2379 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2380 + (
1.2381 + let
1.2382 + val p3'=poly2expanded(p3,var);
1.2383 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
1.2384 + in
1.2385 + poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars)
1.2386 + end
1.2387 + ) $
1.2388 + com_den_exp2(xs,denom,den,var)
1.2389 + )
1.2390 + else
1.2391 + if p3=[(1,mv_null2(var))] then
1.2392 + (
1.2393 + poly2expanded(the (expanded2poly p1' p1var),p1var)
1.2394 + )
1.2395 + else
1.2396 + (
1.2397 + let
1.2398 + val p3'=poly2expanded(p3,var);
1.2399 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
1.2400 + in
1.2401 + poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars)
1.2402 + end
1.2403 + )
1.2404 + end;
1.2405 +---------------------------------------------------------*)
1.2406 +
1.2407 +
1.2408 +(*. searches for an element y of a list ys, which has an gcd not 1 with x .*)
1.2409 +fun exists_gcd (x,[]) = false
1.2410 + | exists_gcd (x,y::ys) = if mv_gcd x y = [(1,mv_null2(#2(hd(x))))] then exists_gcd (x,ys)
1.2411 + else true;
1.2412 +
1.2413 +(*. divides each element of the list xs with y .*)
1.2414 +fun list_div ([],y) = []
1.2415 + | list_div (x::xs,y) =
1.2416 + let
1.2417 + val (d,r)=mv_division(x,y,LEX_);
1.2418 + in
1.2419 + if r=[] then
1.2420 + d::list_div(xs,y)
1.2421 + else x::list_div(xs,y)
1.2422 + end;
1.2423 +
1.2424 +(*. checks if x is in the list ys .*)
1.2425 +fun in_list (x,[]) = false
1.2426 + | in_list (x,y::ys) = if x=y then true
1.2427 + else in_list(x,ys);
1.2428 +
1.2429 +(*. deletes all equal elements of the list xs .*)
1.2430 +fun kill_equal [] = []
1.2431 + | kill_equal (x::xs) = if in_list(x,xs) orelse x=[(1,mv_null2(#2(hd(x))))] then kill_equal(xs)
1.2432 + else x::kill_equal(xs);
1.2433 +
1.2434 +(*. searches for new factors .*)
1.2435 +fun new_factors [] = []
1.2436 + | new_factors (list:mv_poly list):mv_poly list =
1.2437 + let
1.2438 + val l = kill_equal list;
1.2439 + val len = length(l);
1.2440 + in
1.2441 + if len>=2 then
1.2442 + (
1.2443 + let
1.2444 + val x::y::xs=l;
1.2445 + val gcd=mv_gcd x y;
1.2446 + in
1.2447 + if gcd=[(1,mv_null2(#2(hd(x))))] then
1.2448 + (
1.2449 + if exists_gcd(x,xs) then new_factors (y::xs @ [x])
1.2450 + else x::new_factors(y::xs)
1.2451 + )
1.2452 + else gcd::new_factors(kill_equal(list_div(x::y::xs,gcd)))
1.2453 + end
1.2454 + )
1.2455 + else
1.2456 + if len=1 then [hd(l)]
1.2457 + else []
1.2458 + end;
1.2459 +
1.2460 +(*. gets the factors of a list .*)
1.2461 +fun get_factors x = new_factors x;
1.2462 +
1.2463 +(*. multiplies the elements of the list .*)
1.2464 +fun multi_list [] = []
1.2465 + | multi_list (x::xs) = if xs=[] then x
1.2466 + else mv_mul(x,multi_list xs,LEX_);
1.2467 +
1.2468 +(*. makes a term out of the elements of the list (polynomial representation) .*)
1.2469 +fun make_term ([],vars) = Free(str_of_int 0,HOLogic.realT)
1.2470 + | make_term ((x::xs),vars) = if length(xs)=0 then poly2term(sort (mv_geq LEX_) (x),vars)
1.2471 + else
1.2472 + (
1.2473 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2474 + poly2term(sort (mv_geq LEX_) (x),vars) $
1.2475 + make_term(xs,vars)
1.2476 + );
1.2477 +
1.2478 +(*. factorizes the denominator (polynomial representation) .*)
1.2479 +fun factorize_den (l,den,vars) =
1.2480 + let
1.2481 + val factor_list=kill_equal( (get_factors l));
1.2482 + val mlist=multi_list(factor_list);
1.2483 + val (last,rest)=mv_division(den,multi_list(factor_list),LEX_);
1.2484 + in
1.2485 + if rest=[] then
1.2486 + (
1.2487 + if last=[(1,mv_null2(vars))] then make_term(factor_list,vars)
1.2488 + else make_term(last::factor_list,vars)
1.2489 + )
1.2490 + else raise error ("RATIONALS_FACTORIZE_DEN_EXCEPTION: Invalid factor by division")
1.2491 + end;
1.2492 +
1.2493 +(*. makes a term out of the elements of the list (expanded polynomial representation) .*)
1.2494 +fun make_exp ([],vars) = Free(str_of_int 0,HOLogic.realT)
1.2495 + | make_exp ((x::xs),vars) = if length(xs)=0 then poly2expanded(sort (mv_geq LEX_) (x),vars)
1.2496 + else
1.2497 + (
1.2498 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2499 + poly2expanded(sort (mv_geq LEX_) (x),vars) $
1.2500 + make_exp(xs,vars)
1.2501 + );
1.2502 +
1.2503 +(*. factorizes the denominator (expanded polynomial representation) .*)
1.2504 +fun factorize_den_exp (l,den,vars) =
1.2505 + let
1.2506 + val factor_list=kill_equal( (get_factors l));
1.2507 + val mlist=multi_list(factor_list);
1.2508 + val (last,rest)=mv_division(den,multi_list(factor_list),LEX_);
1.2509 + in
1.2510 + if rest=[] then
1.2511 + (
1.2512 + if last=[(1,mv_null2(vars))] then make_exp(factor_list,vars)
1.2513 + else make_exp(last::factor_list,vars)
1.2514 + )
1.2515 + else raise error ("RATIONALS_FACTORIZE_DEN_EXP_EXCEPTION: Invalid factor by division")
1.2516 + end;
1.2517 +
1.2518 +(*. calculates the common denominator of all elements of the list and multiplies .*)
1.2519 +(*. the nominators and denominators with the correct factor .*)
1.2520 +(*. (polynomial representation) .*)
1.2521 +fun step_add_list_of_fractions []=(Free("0",HOLogic.realT),[]:term list)
1.2522 + | step_add_list_of_fractions [x]= raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXCEPTION: Nothing to add")
1.2523 + | step_add_list_of_fractions (xs) =
1.2524 + let
1.2525 + val den_list=termlist2denominators (xs); (* list of denominators *)
1.2526 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
1.2527 + val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
1.2528 + in
1.2529 + com_den(xs,denom,den,var)
1.2530 + end;
1.2531 +
1.2532 +(*. calculates the common denominator of all elements of the list and multiplies .*)
1.2533 +(*. the nominators and denominators with the correct factor .*)
1.2534 +(*. (expanded polynomial representation) .*)
1.2535 +fun step_add_list_of_fractions_exp [] = (Free("0",HOLogic.realT),[]:term list)
1.2536 + | step_add_list_of_fractions_exp [x] = raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXP_EXCEPTION: Nothing to add")
1.2537 + | step_add_list_of_fractions_exp (xs)=
1.2538 + let
1.2539 + val den_list=termlist2denominators_exp (xs); (* list of denominators *)
1.2540 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
1.2541 + val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
1.2542 + in
1.2543 + com_den_exp(xs,denom,den,var)
1.2544 + end;
1.2545 +
1.2546 +(* wird aktuell nicht mehr gebraucht, bei rückänderung schon
1.2547 +-------------------------------------------------------------
1.2548 +(* FIXME brauch ma des überhaupt??? *)
1.2549 +fun step_add_list_of_fractions2 []=(Free("0",HOLogic.realT),[]:term list)
1.2550 + | step_add_list_of_fractions2 [x]=(x,[])
1.2551 + | step_add_list_of_fractions2 (xs) =
1.2552 + let
1.2553 + val den_list=termlist2denominators (xs); (* list of denominators *)
1.2554 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
1.2555 + val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
1.2556 + in
1.2557 + (
1.2558 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2559 + com_den2(xs,denom, poly2term(denom,var)(*den*),var) $
1.2560 + poly2term(denom,var)
1.2561 + ,
1.2562 + []
1.2563 + )
1.2564 + end;
1.2565 +
1.2566 +(* FIXME brauch ma des überhaupt??? *)
1.2567 +fun step_add_list_of_fractions2_exp []=(Free("0",HOLogic.realT),[]:term list)
1.2568 + | step_add_list_of_fractions2_exp [x]=(x,[])
1.2569 + | step_add_list_of_fractions2_exp (xs) =
1.2570 + let
1.2571 + val den_list=termlist2denominators_exp (xs); (* list of denominators *)
1.2572 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
1.2573 + val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
1.2574 + in
1.2575 + (
1.2576 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2577 + com_den_exp2(xs,denom, poly2term(denom,var)(*den*),var) $
1.2578 + poly2expanded(denom,var)
1.2579 + ,
1.2580 + []
1.2581 + )
1.2582 + end;
1.2583 +---------------------------------------------- *)
1.2584 +
1.2585 +
1.2586 +(*. converts a term, which contains severel terms seperated by +, into a list of these terms .*)
1.2587 +fun term2list (t as (Const("HOL.divide",_) $ _ $ _)) = [t]
1.2588 + | term2list (t as (Const("Atools.pow",_) $ _ $ _)) =
1.2589 + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2590 + t $ Free("1",HOLogic.realT)
1.2591 + ]
1.2592 + | term2list (t as (Free(_,_))) =
1.2593 + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2594 + t $ Free("1",HOLogic.realT)
1.2595 + ]
1.2596 + | term2list (t as (Const("op *",_) $ _ $ _)) =
1.2597 + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
1.2598 + t $ Free("1",HOLogic.realT)
1.2599 + ]
1.2600 + | term2list (Const("op +",_) $ t1 $ t2) = term2list(t1) @ term2list(t2)
1.2601 + | term2list (Const("op -",_) $ t1 $ t2) =
1.2602 + raise error ("RATIONALS_TERM2LIST_EXCEPTION: - not implemented yet")
1.2603 + | term2list _ = raise error ("RATIONALS_TERM2LIST_EXCEPTION: invalid term");
1.2604 +
1.2605 +(*. cancels a single fraction .*)
1.2606 +fun factout_p_ (thy:theory) t = Some (step_cancel t,[]:term list);
1.2607 +fun factout_ (thy:theory) t = Some (step_cancel_expanded t,[]:term list);
1.2608 +fun cancel_p_ (thy:theory) t = Some (direct_cancel t) handle _ => None;
1.2609 +fun cancel_ (thy:theory) t = Some (direct_cancel_expanded t) handle _ => None;
1.2610 +
1.2611 +(*. calculates the common nominator.*)
1.2612 +fun common_nominator_p_ (thy:theory) t =
1.2613 + Some (step_add_list_of_fractions(term2list(t))) handle _ => None;
1.2614 +fun common_nominator_ (thy:theory) t =
1.2615 + Some (step_add_list_of_fractions_exp(term2list(t))) handle _ => None;
1.2616 +fun add_fraction_p_ (thy:theory) t =
1.2617 + if length(term2list(t))>1
1.2618 + then Some (add_list_of_fractions(term2list(t))) handle _ => None
1.2619 + else (*raise error ("RATIONALS_ADD_EXCEPTION: nothing to add")*) None;
1.2620 +
1.2621 +(*Some (step_add_list_of_fractions2(term2list(t))); *)
1.2622 +fun add_fraction_ (thy:theory) t =
1.2623 + if length(term2list(t))>1
1.2624 + then Some (add_list_of_fractions_exp(term2list(t))) handle _ => None
1.2625 + else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*)
1.2626 + None;
1.2627 +
1.2628 +(*Some (step_add_list_of_fractions2_exp(term2list(t))); *)
1.2629 +
1.2630 +(*. brings the term into a normal form .*)
1.2631 +fun norm_rational_ (thy:theory) t =
1.2632 + Some (add_list_of_fractions(term2list(t))) handle _ => None;
1.2633 +fun norm_expanded_rat_ (thy:theory) t =
1.2634 + Some (add_list_of_fractions_exp(term2list(t))) handle _ => None;
1.2635 +
1.2636 +
1.2637 +(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*)
1.2638 +val calc_rat_erls =
1.2639 + Rls {id = "calc_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.2640 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
1.2641 + rules =
1.2642 + [Calc ("op =",eval_equal "#equal_"),
1.2643 + Calc ("Atools.is'_const",eval_const "#is_const_"),
1.2644 + Thm ("not_true",num_str not_true),
1.2645 + Thm ("not_false",num_str not_false)
1.2646 + ],
1.2647 + scr = EmptyScr};
1.2648 +
1.2649 +
1.2650 +(*.does NOT rearrange the term by AC-rewriting; thus terms with variables
1.2651 + need to have constants to be commuted together respectively.*)
1.2652 +val calculate_Rational =
1.2653 + merge_rls "calculate_Rational"
1.2654 + (Rls {id = "divide", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.2655 + erls = calc_rat_erls, srls = Erls, asm_thm = [],
1.2656 + calc = [],
1.2657 + rules =
1.2658 + [Calc ("HOL.divide" ,eval_cancel "#divide_"),
1.2659 +
1.2660 + Thm ("sym_real_minus_divide_eq",
1.2661 + num_str (real_minus_divide_eq RS sym)),
1.2662 + (*SYM - ?x / ?y = - (?x / ?y) may come from subst*)
1.2663 +
1.2664 + Thm ("rat_add",num_str rat_add),
1.2665 + (*"[| a is_const; b is_const; c is_const; d is_const |] ==> \
1.2666 + \"a / c + b / d = (a * d) / (c * d) + (b * c ) / (d * c)"*)
1.2667 + Thm ("rat_add1",num_str rat_add1),
1.2668 + (*"[| a is_const; b is_const; c is_const |] ==> \
1.2669 + \"a / c + b / c = (a + b) / c"*)
1.2670 + Thm ("rat_add2",num_str rat_add2),
1.2671 + (*"[| ?a is_const; ?b is_const; ?c is_const |] ==> \
1.2672 + \?a / ?c + ?b = (?a + ?b * ?c) / ?c"*)
1.2673 + Thm ("rat_add3",num_str rat_add3),
1.2674 + (*"[| a is_const; b is_const; c is_const |] ==> \
1.2675 + \"a + b / c = (a * c) / c + b / c"\
1.2676 + \.... is_const to be omitted here FIXME*)
1.2677 +
1.2678 + Thm ("rat_mult",num_str rat_mult),
1.2679 + (*a / b * (c / d) = a * c / (b * d)*)
1.2680 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
1.2681 + (*?x * (?y / ?z) = ?x * ?y / ?z*)
1.2682 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
1.2683 + (*?y / ?z * ?x = ?y * ?x / ?z*)
1.2684 +
1.2685 + Thm ("real_divide_divide1",num_str real_divide_divide1),
1.2686 + (*"?y ~= 0 ==> ?u / ?v / (?y / ?z) = ?u / ?v * (?z / ?y)"*)
1.2687 + Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq),
1.2688 + (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
1.2689 +
1.2690 + Thm ("rat_power", num_str rat_power),
1.2691 + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
1.2692 +
1.2693 + Thm ("mult_cross",num_str mult_cross),
1.2694 + (*"[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)*)
1.2695 + Thm ("mult_cross1",num_str mult_cross1),
1.2696 + (*" b ~= 0 ==> (a / b = c ) = (a = b * c)*)
1.2697 + Thm ("mult_cross2",num_str mult_cross2)
1.2698 + (*" d ~= 0 ==> (a = c / d) = (a * d = c)*)
1.2699 + ], scr = EmptyScr})
1.2700 + calculate_Poly;
1.2701 +
1.2702 +
1.2703 +(*("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))*)
1.2704 +fun eval_is_expanded (thmid:string) _
1.2705 + (t as (Const("Rational.is'_expanded", _) $ arg)) thy =
1.2706 + if is_expanded arg
1.2707 + then Some (mk_thmid thmid ""
1.2708 + ((string_of_cterm o cterm_of (sign_of thy)) arg) "",
1.2709 + Trueprop $ (mk_equality (t, HOLogic.true_const)))
1.2710 + else Some (mk_thmid thmid ""
1.2711 + ((string_of_cterm o cterm_of (sign_of thy)) arg) "",
1.2712 + Trueprop $ (mk_equality (t, HOLogic.false_const)))
1.2713 + | eval_is_expanded _ _ _ _ = None;
1.2714 +
1.2715 +val rational_erls =
1.2716 + merge_rls "rational_erls" calculate_Rational
1.2717 + (append_rls "is_expanded" atools_erls
1.2718 + [Calc ("Rational.is'_expanded", eval_is_expanded "")
1.2719 + ]);
1.2720 +
1.2721 +
1.2722 +
1.2723 +(*.3 'reverse-rewrite-sets' for symbolic computation on rationals:
1.2724 + =================================================================
1.2725 + (A2) 'cancel_p': .
1.2726 + (A3) 'cancel': .
1.2727 + (B2) 'common_nominator_p': transforms summands in a term (2)
1.2728 + to fractions with the (least) common multiple as nominator.
1.2729 + (3) 'norm_rational': normalizes arbitrary algebraic terms (without
1.2730 + radicals and transzendental functions) to one canceled fraction,
1.2731 + nominator and denominator in polynomial form.
1.2732 +
1.2733 +In order to meet isac's requirements for interactive and stepwise calculation,
1.2734 +each 'reverse-rewerite-set' consists of an initialization for the interpreter
1.2735 +state and of 4 functions, each of which employs rewriting as much as possible.
1.2736 +The signature of these functions are the same in each 'reverse-rewrite-set'
1.2737 +respectively.*)
1.2738 +
1.2739 +(* **************************************************************************************************** *)
1.2740 +
1.2741 +
1.2742 +local(*. cancel_p
1.2743 +------------------------.
1.2744 +cancel transforms a fraction consisting of two (uni- or multivariate)
1.2745 +polynomials into another such fraction; examples:
1.2746 +
1.2747 + a^2 + (-1)*b^2 a + b
1.2748 + -------------------- = ---------
1.2749 + a^2 + (-2)*a*b + b^2 a + (-1)*b
1.2750 +
1.2751 + a^2 a
1.2752 + --- = ---
1.2753 + a 1
1.2754 +
1.2755 +Remark: the reverse ruleset does _NOT_ work properly with other input !.*)
1.2756 +(*WN 24.8.02: wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*)
1.2757 +
1.2758 +
1.2759 +
1.2760 +val {rules=rules,rew_ord=(_,ro),...} =
1.2761 + rep_rls (the (assoc'(!ruleset',"make_polynomial")));
1.2762 +val thy = Rational.thy;
1.2763 +
1.2764 +
1.2765 +(*.cancel_p_ = fn : theory -> term -> (term * term list) option
1.2766 + as defined above*)
1.2767 +
1.2768 +(*.init_state = fn : term -> istate
1.2769 +initialzies the state of the interactive interpreter. The state is:
1.2770 +
1.2771 +type rrlsstate = (*state for reverse rewriting*)
1.2772 + (term * (*the current formula*)
1.2773 + term * (*the final term*)
1.2774 + rule list (*'reverse rule list' (#)*)
1.2775 + list * (*may be serveral, eg. in norm_rational*)
1.2776 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
1.2777 + (term * (*... rewrite with ...*)
1.2778 + term list)) (*... assumptions*)
1.2779 + list); (*derivation from given term to normalform
1.2780 + in reverse order with sym_thm;
1.2781 + (#) could be extracted from here by (map #1)*).*)
1.2782 +fun init_state thy eval_rls ro t =
1.2783 + let val Some (t',_) = factout_p_ thy t;
1.2784 + val Some (t'',asm) = cancel_p_ thy t;
1.2785 + val der = reverse_deriv thy eval_rls rules ro None t';
1.2786 + val der = der @ [(Thm ("real_mult_div_cancel2",
1.2787 + num_str real_mult_div_cancel2),
1.2788 + (t'',asm))]
1.2789 + val rs = (distinct_Thm o (map #1)) der;
1.2790 + val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
1.2791 + "sym_real_mult_0",
1.2792 + "sym_real_mult_1"]) rs;
1.2793 + in (t,t'',[rs(*here only _ONE_*)],der) end;
1.2794 +
1.2795 +(*.locate_rule = fn : rule list -> term -> rule
1.2796 + -> (rule * (term * term list) option) list.
1.2797 + checks a rule R for being a cancel-rule, and if it is,
1.2798 + then return the list of rules (+ the terms they are rewriting to)
1.2799 + which need to be applied before R should be applied.
1.2800 + precondition: the rule is applicable to the argument-term.
1.2801 +arguments:
1.2802 + rule list: the reverse rule list
1.2803 + -> term : ... to which the rule shall be applied
1.2804 + -> rule : ... to be applied to term
1.2805 +value:
1.2806 + -> (rule : a rule rewriting to ...
1.2807 + * (term : ... the resulting term ...
1.2808 + * term list): ... with the assumptions ( //#0).
1.2809 + ) list : there may be several such rules;
1.2810 + the list is empty, if the rule has nothing to do
1.2811 + with cancelation.*)
1.2812 +(* val () = ();
1.2813 + *)
1.2814 +fun locate_rule thy eval_rls ro [rs] t r =
1.2815 + if (id_of_thm r) mem (map (id_of_thm)) rs
1.2816 + then let val ropt =
1.2817 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
1.2818 + in case ropt of
1.2819 + Some ta => [(r, ta)]
1.2820 + | None => (writeln("### locate_rule: rewrite "^
1.2821 + (id_of_thm r)^" "^(term2str t)^" = None");
1.2822 + []) end
1.2823 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
1.2824 + | locate_rule _ _ _ _ _ _ =
1.2825 + raise error ("locate_rule: doesnt match rev-sets in istate");
1.2826 +
1.2827 +(*.next_rule = fn : rule list -> term -> rule option
1.2828 + for a given term return the next rules to be done for cancelling.
1.2829 +arguments:
1.2830 + rule list : the reverse rule list
1.2831 + term : the term for which ...
1.2832 +value:
1.2833 + -> rule option: ... this rule is appropriate for cancellation;
1.2834 + there may be no such rule (if the term is canceled already.*)
1.2835 +(* val thy = Rational.thy;
1.2836 + val Rrls {rew_ord=(_,ro),...} = cancel;
1.2837 + val ([rs],t) = (rss,f);
1.2838 + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
1.2839 +
1.2840 + val (thy, [rs]) = (Rational.thy, revsets);
1.2841 + val Rrls {rew_ord=(_,ro),...} = cancel;
1.2842 + nex [rs] t;
1.2843 + *)
1.2844 +fun next_rule thy eval_rls ro [rs] t =
1.2845 + let val der = make_deriv thy eval_rls rs ro None t;
1.2846 + in case der of
1.2847 +(* val (_,r,_)::_ = der;
1.2848 + *)
1.2849 + (_,r,_)::_ => Some r
1.2850 + | _ => None
1.2851 + end
1.2852 + | next_rule _ _ _ _ _ =
1.2853 + raise error ("next_rule: doesnt match rev-sets in istate");
1.2854 +
1.2855 +(*.val attach_form = f : rule list -> term -> term
1.2856 + -> (rule * (term * term list)) list
1.2857 + checks an input term TI, if it may belong to a current cancellation, by
1.2858 + trying to derive it from the given term TG.
1.2859 +arguments:
1.2860 + term : TG, the last one in the cancellation agreed upon by user + math-eng
1.2861 + -> term: TI, the next one input by the user
1.2862 +value:
1.2863 + -> (rule : the rule to be applied in order to reach TI
1.2864 + * (term : ... obtained by applying the rule ...
1.2865 + * term list): ... and the respective assumptions.
1.2866 + ) list : there may be several such rules;
1.2867 + the list is empty, if the users term does not belong
1.2868 + to a cancellation of the term last agreed upon.*)
1.2869 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
1.2870 + []:(rule * (term * term list)) list;
1.2871 +
1.2872 +in
1.2873 +
1.2874 +val cancel_p =
1.2875 + Rrls {id = "cancel_p", prepat=[],
1.2876 + rew_ord=("ord_make_polynomial",
1.2877 + ord_make_polynomial false Rational.thy),
1.2878 + erls = rational_erls,
1.2879 + calc = [("plus" ,("op +" ,eval_binop "#add_")),
1.2880 + ("times" ,("op *" ,eval_binop "#mult_")),
1.2881 + ("divide_" ,("HOL.divide" ,eval_cancel "#divide_")),
1.2882 + ("power_" ,("Atools.pow" ,eval_binop "#power_"))],
1.2883 + asm_thm=[("real_mult_div_cancel2","")],
1.2884 + scr=Rfuns {init_state = init_state thy atools_erls ro,
1.2885 + normal_form = cancel_p_ thy,
1.2886 + locate_rule = locate_rule thy atools_erls ro,
1.2887 + next_rule = next_rule thy atools_erls ro,
1.2888 + attach_form = attach_form}}
1.2889 +end;(*local*)
1.2890 +
1.2891 +
1.2892 +local(*.ad (1) 'cancel'
1.2893 +------------------------------
1.2894 +cancel transforms a fraction consisting of two binoms (binary - !)
1.2895 +into another such fraction; examples:
1.2896 +
1.2897 + a^2 - b^2 a + b
1.2898 + -------------------- = ---------
1.2899 + a^2 - 2*a*b + b^2 a - *b
1.2900 +
1.2901 +Remark: the reverse ruleset does _NOT_ work properly with other input !.*)
1.2902 +(*WN 24.8.02: wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*)
1.2903 +
1.2904 +val Some (Rls {rules=rules,rew_ord=(_,ro),...}) =
1.2905 + assoc'(!ruleset',"expand_binoms");
1.2906 +val thy = Rational.thy;
1.2907 +
1.2908 +fun init_state thy eval_rls ro t =
1.2909 + let val Some (t',_) = factout_ thy t;
1.2910 + val Some (t'',asm) = cancel_ thy t;
1.2911 + val der = reverse_deriv thy eval_rls rules ro None t';
1.2912 + val der = der @ [(Thm ("real_mult_div_cancel2",
1.2913 + num_str real_mult_div_cancel2),
1.2914 + (t'',asm))]
1.2915 + val rs = map #1 der;
1.2916 + in (t,t'',[rs],der) end;
1.2917 +
1.2918 +fun locate_rule thy eval_rls ro [rs] t r =
1.2919 + if (id_of_thm r) mem (map (id_of_thm)) rs
1.2920 + then let val ropt =
1.2921 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
1.2922 + in case ropt of
1.2923 + Some ta => [(r, ta)]
1.2924 + | None => (writeln("### locate_rule: rewrite "^
1.2925 + (id_of_thm r)^" "^(term2str t)^" = None");
1.2926 + []) end
1.2927 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
1.2928 + | locate_rule _ _ _ _ _ _ =
1.2929 + raise error ("locate_rule: doesnt match rev-sets in istate");
1.2930 +
1.2931 +fun next_rule thy eval_rls ro [rs] t =
1.2932 + let val der = make_deriv thy eval_rls rs ro None t;
1.2933 + in case der of
1.2934 +(* val (_,r,_)::_ = der;
1.2935 + *)
1.2936 + (_,r,_)::_ => Some r
1.2937 + | _ => None
1.2938 + end
1.2939 + | next_rule _ _ _ _ _ =
1.2940 + raise error ("next_rule: doesnt match rev-sets in istate");
1.2941 +
1.2942 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
1.2943 + []:(rule * (term * term list)) list;
1.2944 +
1.2945 +val pat = (term_of o the o (parse thy)) "?r/?s";
1.2946 +val pre1 = (term_of o the o (parse thy)) "r is_expanded";
1.2947 +val pre2 = (term_of o the o (parse thy)) "s is_expanded";
1.2948 +val prepat = [([pre1, pre2], pat)];
1.2949 +
1.2950 +in
1.2951 +
1.2952 +
1.2953 +val cancel =
1.2954 + Rrls {id = "cancel", prepat=prepat,
1.2955 + rew_ord=("ord_make_polynomial",
1.2956 + ord_make_polynomial false Rational.thy),
1.2957 + erls = rational_erls,
1.2958 + calc = [("plus" ,("op +" ,eval_binop "#add_")),
1.2959 + ("times" ,("op *" ,eval_binop "#mult_")),
1.2960 + ("divide_" ,("HOL.divide" ,eval_cancel "#divide_")),
1.2961 + ("power_" ,("Atools.pow" ,eval_binop "#power_"))],
1.2962 + asm_thm=[("real_mult_div_cancel2","")],
1.2963 + scr=Rfuns {init_state = init_state thy atools_erls ro,
1.2964 + normal_form = cancel_ thy,
1.2965 + locate_rule = locate_rule thy atools_erls ro,
1.2966 + next_rule = next_rule thy atools_erls ro,
1.2967 + attach_form = attach_form}}
1.2968 +end;(*local*)
1.2969 +
1.2970 +
1.2971 +
1.2972 +local(*.ad (2) 'common_nominator_p'
1.2973 +---------------------------------
1.2974 +FIXME Beschreibung .*)
1.2975 +
1.2976 +
1.2977 +val {rules=rules,rew_ord=(_,ro),...} =
1.2978 + rep_rls (the (assoc'(!ruleset',"make_polynomial")));
1.2979 +val thy = Rational.thy;
1.2980 +
1.2981 +
1.2982 +(*.common_nominator_p_ = fn : theory -> term -> (term * term list) option
1.2983 + as defined above*)
1.2984 +
1.2985 +(*.init_state = fn : term -> istate
1.2986 +initialzies the state of the interactive interpreter. The state is:
1.2987 +
1.2988 +type rrlsstate = (*state for reverse rewriting*)
1.2989 + (term * (*the current formula*)
1.2990 + term * (*the final term*)
1.2991 + rule list (*'reverse rule list' (#)*)
1.2992 + list * (*may be serveral, eg. in norm_rational*)
1.2993 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
1.2994 + (term * (*... rewrite with ...*)
1.2995 + term list)) (*... assumptions*)
1.2996 + list); (*derivation from given term to normalform
1.2997 + in reverse order with sym_thm;
1.2998 + (#) could be extracted from here by (map #1)*).*)
1.2999 +fun init_state thy eval_rls ro t =
1.3000 + let val Some (t',_) = common_nominator_p_ thy t;
1.3001 + val Some (t'',asm) = add_fraction_p_ thy t;
1.3002 + val der = reverse_deriv thy eval_rls rules ro None t';
1.3003 + val der = der @ [(Thm ("real_mult_div_cancel2",
1.3004 + num_str real_mult_div_cancel2),
1.3005 + (t'',asm))]
1.3006 + val rs = (distinct_Thm o (map #1)) der;
1.3007 + val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
1.3008 + "sym_real_mult_0",
1.3009 + "sym_real_mult_1"]) rs;
1.3010 + in (t,t'',[rs(*here only _ONE_*)],der) end;
1.3011 +
1.3012 +(* use"knowledge/Rational.ML";
1.3013 + *)
1.3014 +
1.3015 +(*.locate_rule = fn : rule list -> term -> rule
1.3016 + -> (rule * (term * term list) option) list.
1.3017 + checks a rule R for being a cancel-rule, and if it is,
1.3018 + then return the list of rules (+ the terms they are rewriting to)
1.3019 + which need to be applied before R should be applied.
1.3020 + precondition: the rule is applicable to the argument-term.
1.3021 +arguments:
1.3022 + rule list: the reverse rule list
1.3023 + -> term : ... to which the rule shall be applied
1.3024 + -> rule : ... to be applied to term
1.3025 +value:
1.3026 + -> (rule : a rule rewriting to ...
1.3027 + * (term : ... the resulting term ...
1.3028 + * term list): ... with the assumptions ( //#0).
1.3029 + ) list : there may be several such rules;
1.3030 + the list is empty, if the rule has nothing to do
1.3031 + with cancelation.*)
1.3032 +(* val () = ();
1.3033 + *)
1.3034 +fun locate_rule thy eval_rls ro [rs] t r =
1.3035 + if (id_of_thm r) mem (map (id_of_thm)) rs
1.3036 + then let val ropt =
1.3037 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
1.3038 + in case ropt of
1.3039 + Some ta => [(r, ta)]
1.3040 + | None => (writeln("### locate_rule: rewrite "^
1.3041 + (id_of_thm r)^" "^(term2str t)^" = None");
1.3042 + []) end
1.3043 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
1.3044 + | locate_rule _ _ _ _ _ _ =
1.3045 + raise error ("locate_rule: doesnt match rev-sets in istate");
1.3046 +
1.3047 +(*.next_rule = fn : rule list -> term -> rule option
1.3048 + for a given term return the next rules to be done for cancelling.
1.3049 +arguments:
1.3050 + rule list : the reverse rule list
1.3051 + term : the term for which ...
1.3052 +value:
1.3053 + -> rule option: ... this rule is appropriate for cancellation;
1.3054 + there may be no such rule (if the term is canceled already.*)
1.3055 +(* val thy = Rational.thy;
1.3056 + val Rrls {rew_ord=(_,ro),...} = cancel;
1.3057 + val ([rs],t) = (rss,f);
1.3058 + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
1.3059 +
1.3060 + val (thy, [rs]) = (Rational.thy, revsets);
1.3061 + val Rrls {rew_ord=(_,ro),...} = cancel;
1.3062 + nex [rs] t;
1.3063 + *)
1.3064 +fun next_rule thy eval_rls ro [rs] t =
1.3065 + let val der = make_deriv thy eval_rls rs ro None t;
1.3066 + in case der of
1.3067 +(* val (_,r,_)::_ = der;
1.3068 + *)
1.3069 + (_,r,_)::_ => Some r
1.3070 + | _ => None
1.3071 + end
1.3072 + | next_rule _ _ _ _ _ =
1.3073 + raise error ("next_rule: doesnt match rev-sets in istate");
1.3074 +
1.3075 +(*.val attach_form = f : rule list -> term -> term
1.3076 + -> (rule * (term * term list)) list
1.3077 + checks an input term TI, if it may belong to a current cancellation, by
1.3078 + trying to derive it from the given term TG.
1.3079 +arguments:
1.3080 + term : TG, the last one in the cancellation agreed upon by user + math-eng
1.3081 + -> term: TI, the next one input by the user
1.3082 +value:
1.3083 + -> (rule : the rule to be applied in order to reach TI
1.3084 + * (term : ... obtained by applying the rule ...
1.3085 + * term list): ... and the respective assumptions.
1.3086 + ) list : there may be several such rules;
1.3087 + the list is empty, if the users term does not belong
1.3088 + to a cancellation of the term last agreed upon.*)
1.3089 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
1.3090 + []:(rule * (term * term list)) list;
1.3091 +
1.3092 +val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v";
1.3093 +val pat1 = (term_of o the o (parse thy)) "?r/?s+?u ";
1.3094 +val pat2 = (term_of o the o (parse thy)) "?r +?u/?v";
1.3095 +val prepat = [([HOLogic.true_const], pat0),
1.3096 + ([HOLogic.true_const], pat1),
1.3097 + ([HOLogic.true_const], pat2)];
1.3098 +
1.3099 +in
1.3100 +
1.3101 +(*11.02 schnelle L"osung f"ur RL: Bruch auch gek"urzt;
1.3102 + besser w"are: auf 1 gemeinsamen Bruchstrich, Nenner und Z"ahler unvereinfacht
1.3103 + dh. wie common_nominator_p_, aber auf 1 Bruchstrich*)
1.3104 +val common_nominator_p =
1.3105 + Rrls {id = "common_nominator_p", prepat=prepat,
1.3106 + rew_ord=("ord_make_polynomial",
1.3107 + ord_make_polynomial false Rational.thy),
1.3108 + erls = rational_erls,
1.3109 + calc = [("plus" ,("op +" ,eval_binop "#add_")),
1.3110 + ("times" ,("op *" ,eval_binop "#mult_")),
1.3111 + ("divide_" ,("HOL.divide" ,eval_cancel "#divide_")),
1.3112 + ("power_" ,("Atools.pow" ,eval_binop "#power_"))],
1.3113 + asm_thm=[("real_mult_div_cancel2","")],
1.3114 + scr=Rfuns {init_state = init_state thy atools_erls ro,
1.3115 + normal_form = add_fraction_p_ thy,
1.3116 + locate_rule = locate_rule thy atools_erls ro,
1.3117 + next_rule = next_rule thy atools_erls ro,
1.3118 + attach_form = attach_form}}
1.3119 +end;(*local*)
1.3120 +
1.3121 +
1.3122 +local(*.ad (2) 'common_nominator'
1.3123 +---------------------------------
1.3124 +FIXME Beschreibung .*)
1.3125 +
1.3126 +
1.3127 +val {rules=rules,rew_ord=(_,ro),...} =
1.3128 + rep_rls (the (assoc'(!ruleset',"make_polynomial")));
1.3129 +val thy = Rational.thy;
1.3130 +
1.3131 +
1.3132 +(*.common_nominator_ = fn : theory -> term -> (term * term list) option
1.3133 + as defined above*)
1.3134 +
1.3135 +(*.init_state = fn : term -> istate
1.3136 +initialzies the state of the interactive interpreter. The state is:
1.3137 +
1.3138 +type rrlsstate = (*state for reverse rewriting*)
1.3139 + (term * (*the current formula*)
1.3140 + term * (*the final term*)
1.3141 + rule list (*'reverse rule list' (#)*)
1.3142 + list * (*may be serveral, eg. in norm_rational*)
1.3143 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
1.3144 + (term * (*... rewrite with ...*)
1.3145 + term list)) (*... assumptions*)
1.3146 + list); (*derivation from given term to normalform
1.3147 + in reverse order with sym_thm;
1.3148 + (#) could be extracted from here by (map #1)*).*)
1.3149 +fun init_state thy eval_rls ro t =
1.3150 + let val Some (t',_) = common_nominator_ thy t;
1.3151 + val Some (t'',asm) = add_fraction_ thy t;
1.3152 + val der = reverse_deriv thy eval_rls rules ro None t';
1.3153 + val der = der @ [(Thm ("real_mult_div_cancel2",
1.3154 + num_str real_mult_div_cancel2),
1.3155 + (t'',asm))]
1.3156 + val rs = (distinct_Thm o (map #1)) der;
1.3157 + val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
1.3158 + "sym_real_mult_0",
1.3159 + "sym_real_mult_1"]) rs;
1.3160 + in (t,t'',[rs(*here only _ONE_*)],der) end;
1.3161 +
1.3162 +(* use"knowledge/Rational.ML";
1.3163 + *)
1.3164 +
1.3165 +(*.locate_rule = fn : rule list -> term -> rule
1.3166 + -> (rule * (term * term list) option) list.
1.3167 + checks a rule R for being a cancel-rule, and if it is,
1.3168 + then return the list of rules (+ the terms they are rewriting to)
1.3169 + which need to be applied before R should be applied.
1.3170 + precondition: the rule is applicable to the argument-term.
1.3171 +arguments:
1.3172 + rule list: the reverse rule list
1.3173 + -> term : ... to which the rule shall be applied
1.3174 + -> rule : ... to be applied to term
1.3175 +value:
1.3176 + -> (rule : a rule rewriting to ...
1.3177 + * (term : ... the resulting term ...
1.3178 + * term list): ... with the assumptions ( //#0).
1.3179 + ) list : there may be several such rules;
1.3180 + the list is empty, if the rule has nothing to do
1.3181 + with cancelation.*)
1.3182 +(* val () = ();
1.3183 + *)
1.3184 +fun locate_rule thy eval_rls ro [rs] t r =
1.3185 + if (id_of_thm r) mem (map (id_of_thm)) rs
1.3186 + then let val ropt =
1.3187 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
1.3188 + in case ropt of
1.3189 + Some ta => [(r, ta)]
1.3190 + | None => (writeln("### locate_rule: rewrite "^
1.3191 + (id_of_thm r)^" "^(term2str t)^" = None");
1.3192 + []) end
1.3193 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
1.3194 + | locate_rule _ _ _ _ _ _ =
1.3195 + raise error ("locate_rule: doesnt match rev-sets in istate");
1.3196 +
1.3197 +(*.next_rule = fn : rule list -> term -> rule option
1.3198 + for a given term return the next rules to be done for cancelling.
1.3199 +arguments:
1.3200 + rule list : the reverse rule list
1.3201 + term : the term for which ...
1.3202 +value:
1.3203 + -> rule option: ... this rule is appropriate for cancellation;
1.3204 + there may be no such rule (if the term is canceled already.*)
1.3205 +(* val thy = Rational.thy;
1.3206 + val Rrls {rew_ord=(_,ro),...} = cancel;
1.3207 + val ([rs],t) = (rss,f);
1.3208 + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
1.3209 +
1.3210 + val (thy, [rs]) = (Rational.thy, revsets);
1.3211 + val Rrls {rew_ord=(_,ro),...} = cancel_p;
1.3212 + nex [rs] t;
1.3213 + *)
1.3214 +fun next_rule thy eval_rls ro [rs] t =
1.3215 + let val der = make_deriv thy eval_rls rs ro None t;
1.3216 + in case der of
1.3217 +(* val (_,r,_)::_ = der;
1.3218 + *)
1.3219 + (_,r,_)::_ => Some r
1.3220 + | _ => None
1.3221 + end
1.3222 + | next_rule _ _ _ _ _ =
1.3223 + raise error ("next_rule: doesnt match rev-sets in istate");
1.3224 +
1.3225 +(*.val attach_form = f : rule list -> term -> term
1.3226 + -> (rule * (term * term list)) list
1.3227 + checks an input term TI, if it may belong to a current cancellation, by
1.3228 + trying to derive it from the given term TG.
1.3229 +arguments:
1.3230 + term : TG, the last one in the cancellation agreed upon by user + math-eng
1.3231 + -> term: TI, the next one input by the user
1.3232 +value:
1.3233 + -> (rule : the rule to be applied in order to reach TI
1.3234 + * (term : ... obtained by applying the rule ...
1.3235 + * term list): ... and the respective assumptions.
1.3236 + ) list : there may be several such rules;
1.3237 + the list is empty, if the users term does not belong
1.3238 + to a cancellation of the term last agreed upon.*)
1.3239 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
1.3240 + []:(rule * (term * term list)) list;
1.3241 +
1.3242 +val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v";
1.3243 +val pat01 = (term_of o the o (parse thy)) "?r/?s-?u/?v";
1.3244 +val pat1 = (term_of o the o (parse thy)) "?r/?s+?u ";
1.3245 +val pat11 = (term_of o the o (parse thy)) "?r/?s-?u ";
1.3246 +val pat2 = (term_of o the o (parse thy)) "?r +?u/?v";
1.3247 +val pat21 = (term_of o the o (parse thy)) "?r -?u/?v";
1.3248 +val prepat = [([HOLogic.true_const], pat0),
1.3249 + ([HOLogic.true_const], pat01),
1.3250 + ([HOLogic.true_const], pat1),
1.3251 + ([HOLogic.true_const], pat11),
1.3252 + ([HOLogic.true_const], pat2),
1.3253 + ([HOLogic.true_const], pat21)];
1.3254 +
1.3255 +
1.3256 +in
1.3257 +
1.3258 +val common_nominator =
1.3259 + Rrls {id = "common_nominator", prepat=prepat,
1.3260 + rew_ord=("ord_make_polynomial",
1.3261 + ord_make_polynomial false Rational.thy),
1.3262 + erls = rational_erls,
1.3263 + calc = [("plus" ,("op +" ,eval_binop "#add_")),
1.3264 + ("times" ,("op *" ,eval_binop "#mult_")),
1.3265 + ("divide_" ,("HOL.divide" ,eval_cancel "#divide_")),
1.3266 + ("power_" ,("Atools.pow" ,eval_binop "#power_"))],
1.3267 + asm_thm=[("real_mult_div_cancel2","")],
1.3268 + scr=Rfuns {init_state = init_state thy atools_erls ro,
1.3269 + normal_form = add_fraction_ (*NOT common_nominator_*) thy,
1.3270 + locate_rule = locate_rule thy atools_erls ro,
1.3271 + next_rule = next_rule thy atools_erls ro,
1.3272 + attach_form = attach_form}}
1.3273 +
1.3274 +end;(*local*)
1.3275 +
1.3276 +
1.3277 +(*##*)
1.3278 +end;(*struct*)
1.3279 +
1.3280 +open RationalI;
1.3281 +(*##*)
1.3282 +
1.3283 +(*-------------------18.3.03 --> struct <-----------vvv--*)
1.3284 +val add_fractions_p = common_nominator_p; (*FIXXXME:eilig f"ur norm_Rational*)
1.3285 +
1.3286 +(*.discard binary minus, shift unary minus into -1*;
1.3287 + unary minus before numerals are put into the numeral by parsing;
1.3288 + contains absolute minimum of thms for context in norm_Rational .*)
1.3289 +val discard_minus =
1.3290 + Rls {id = "discard_minus", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.3291 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
1.3292 + rules = [Thm ("real_diff_minus", num_str real_diff_minus),
1.3293 + (*"a - b = a + -1 * b"*)
1.3294 + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
1.3295 + (*- ?z = "-1 * ?z"*)
1.3296 + ],
1.3297 + scr = Script ((term_of o the o (parse thy))
1.3298 + "empty_script")
1.3299 + }:rls;
1.3300 +(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*)
1.3301 +val powers_erls =
1.3302 + Rls {id = "powers_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.3303 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
1.3304 + rules = [Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"),
1.3305 + Calc ("Atools.is'_even",eval_is_even "#is_even_"),
1.3306 + Calc ("op <",eval_equ "#less_"),
1.3307 + Thm ("not_false", not_false)
1.3308 + ],
1.3309 + scr = Script ((term_of o the o (parse thy))
1.3310 + "empty_script")
1.3311 + }:rls;
1.3312 +(*.all powers over + distributed; atoms over * collected, other distributed
1.3313 + contains absolute minimum of thms for context in norm_Rational .*)
1.3314 +val powers =
1.3315 + Rls {id = "powers", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.3316 + erls = powers_erls, srls = Erls, calc = [], asm_thm = [],
1.3317 + rules = [Thm ("realpow_multI", num_str realpow_multI),
1.3318 + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
1.3319 + Thm ("realpow_pow",num_str realpow_pow),
1.3320 + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
1.3321 + Thm ("realpow_oneI",num_str realpow_oneI),
1.3322 + (*"r ^^^ 1 = r"*)
1.3323 + Thm ("realpow_minus_even",num_str realpow_minus_even),
1.3324 + (*"n is_even ==> (- r) ^^^ n = r ^^^ n" ?-->discard_minus?*)
1.3325 + Thm ("realpow_minus_odd",num_str realpow_minus_odd),
1.3326 + (*"Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"*)
1.3327 +
1.3328 + (*----- collect atoms over * -----*)
1.3329 + Thm ("realpow_two_atom",num_str realpow_two_atom),
1.3330 + (*"r is_atom ==> r * r = r ^^^ 2"*)
1.3331 + Thm ("realpow_plus_1",num_str realpow_plus_1),
1.3332 + (*"r is_atom ==> r * r ^^^ n = r ^^^ (n + 1)"*)
1.3333 + Thm ("realpow_addI_atom",num_str realpow_addI_atom),
1.3334 + (*"r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
1.3335 +
1.3336 + (*----- distribute none-atoms -----*)
1.3337 + Thm ("realpow_def_atom",num_str realpow_def_atom),
1.3338 + (*"[| 1 < n; not(r is_atom) |]==>r ^^^ n = r * r ^^^ (n + -1)"*)
1.3339 + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI),
1.3340 + (*"1 ^^^ n = 1"*)
1.3341 + Calc ("op +",eval_binop "#add_")
1.3342 + ],
1.3343 + scr = Script ((term_of o the o (parse thy))
1.3344 + "empty_script")
1.3345 + }:rls;
1.3346 +(*.contains absolute minimum of thms for context in norm_Rational.*)
1.3347 +val rat_mult_divide =
1.3348 + Rls {id = "rat_mult_divide", preconds = [],
1.3349 + rew_ord = ("dummy_ord",dummy_ord),
1.3350 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
1.3351 + rules = [Thm ("rat_mult",num_str rat_mult),
1.3352 + (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
1.3353 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
1.3354 + (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be (2),
1.3355 + otherwise inv.to a / b / c = ...*)
1.3356 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
1.3357 + (*"?a / ?b * ?c = ?a * ?c / ?b" order weights x^^^n too much
1.3358 + and does not commute a / b * c ^^^ 2 !*)
1.3359 +
1.3360 + Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
1.3361 + (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
1.3362 + Thm ("real_divide_divide2_eq", real_divide_divide2_eq)
1.3363 + (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
1.3364 + ],
1.3365 + scr = Script ((term_of o the o (parse thy)) "empty_script")
1.3366 + }:rls;
1.3367 +(*.contains absolute minimum of thms for context in norm_Rational.*)
1.3368 +val reduce_0_1_2 =
1.3369 + Rls{id = "reduce_0_1_2", preconds = [], rew_ord = ("dummy_ord", dummy_ord),
1.3370 + erls = e_rls,srls = Erls,calc = [],asm_thm = [],
1.3371 + rules = [(*Thm ("real_divide_1",num_str real_divide_1),
1.3372 + "?x / 1 = ?x" unnecess.for normalform*)
1.3373 + Thm ("real_mult_1",num_str real_mult_1),
1.3374 + (*"1 * z = z"*)
1.3375 + (*Thm ("real_mult_minus1",num_str real_mult_minus1),
1.3376 + "-1 * z = - z"*)
1.3377 + (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel),
1.3378 + "- ?x * - ?y = ?x * ?y"*)
1.3379 +
1.3380 + Thm ("real_mult_0",num_str real_mult_0),
1.3381 + (*"0 * z = 0"*)
1.3382 + Thm ("real_add_zero_left",num_str real_add_zero_left),
1.3383 + (*"0 + z = z"*)
1.3384 + (*Thm ("real_add_minus",num_str real_add_minus),
1.3385 + "?z + - ?z = 0"*)
1.3386 +
1.3387 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
1.3388 + (*"z1 + z1 = 2 * z1"*)
1.3389 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc)
1.3390 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
1.3391 + ], scr = EmptyScr}:rls;
1.3392 +
1.3393 +(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*)
1.3394 +val norm_rat_erls =
1.3395 + Rls {id = "norm_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.3396 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
1.3397 + rules = [Calc ("Atools.is'_const",eval_const "#is_const_")
1.3398 + ],
1.3399 + scr = Script ((term_of o the o (parse thy))
1.3400 + "empty_script")
1.3401 + }:rls;
1.3402 +(*.consists of rls containing the absolute minimum of thms.*)
1.3403 +val norm_Rational =
1.3404 + Rls {id = "norm_Rational", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
1.3405 + erls = norm_rat_erls, srls = Erls, calc = [], asm_thm = [],
1.3406 + rules = [(*sequence given by operator precedence*)
1.3407 + Rls_ discard_minus,
1.3408 + Rls_ powers,
1.3409 + Rls_ rat_mult_divide,
1.3410 + Rls_ expand,
1.3411 + Rls_ reduce_0_1_2,
1.3412 + Rls_ order_add_mult,
1.3413 + Rls_ collect_numerals,
1.3414 + Rls_ add_fractions_p
1.3415 + ],
1.3416 + scr = Script ((term_of o the o (parse thy))
1.3417 + "empty_script")
1.3418 + }:rls;
1.3419 +(*-------------------18.3.03 --> struct <-----------^^^--*)
1.3420 +
1.3421 +
1.3422 +
1.3423 +
1.3424 +
1.3425 +
1.3426 +theory' := overwritel (!theory', [("Rational.thy",Rational.thy)]);
1.3427 +
1.3428 +ruleset' := overwritel (!ruleset',
1.3429 + [("calculate_Rational", calculate_Rational),
1.3430 + ("calc_rat_erls",calc_rat_erls),
1.3431 + ("rational_erls", rational_erls),
1.3432 + ("cancel_p", cancel_p),
1.3433 + ("cancel", cancel),
1.3434 + ("common_nominator_p", common_nominator_p),
1.3435 + ("common_nominator" , common_nominator),
1.3436 + ("discard_minus", discard_minus),
1.3437 + ("powers_erls", powers_erls),
1.3438 + ("powers", powers),
1.3439 + ("rat_mult_divide", rat_mult_divide),
1.3440 + ("reduce_0_1_2", reduce_0_1_2),
1.3441 + ("norm_rat_erls", norm_rat_erls),
1.3442 + ("norm_Rational", norm_Rational)
1.3443 + ]);
1.3444 +
1.3445 +
1.3446 +(*WN.18.3.03 ???: simplifies all but cancel and common_nominator*)
1.3447 +val simplify_rational =
1.3448 + merge_rls "simplify_rational" expand_binoms
1.3449 + (append_rls "divide" calculate_Rational
1.3450 + [Thm ("real_divide_1",num_str real_divide_1),
1.3451 + (*"?x / 1 = ?x"*)
1.3452 + Thm ("rat_mult",num_str rat_mult),
1.3453 + (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
1.3454 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
1.3455 + (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be (2),
1.3456 + otherwise inv.to a / b / c = ...*)
1.3457 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
1.3458 + (*"?a / ?b * ?c = ?a * ?c / ?b"*)
1.3459 + Thm ("add_minus",num_str add_minus),
1.3460 + (*"?a + ?b - ?b = ?a"*)
1.3461 + Thm ("add_minus1",num_str add_minus1),
1.3462 + (*"?a - ?b + ?b = ?a"*)
1.3463 + Thm ("real_divide_minus1",num_str real_divide_minus1)
1.3464 + (*"?x / -1 = - ?x"*)
1.3465 +(*
1.3466 +,
1.3467 + Thm ("",num_str )
1.3468 +*)
1.3469 + ]);
1.3470 +
1.3471 +
1.3472 +
1.3473 +
1.3474 +
1.3475 +
1.3476 +
1.3477 +
1.3478 +
1.3479 +
1.3480 +
1.3481 +
1.3482 +
1.3483 +
1.3484 +
2.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2 +++ b/src/sml/IsacKnowledge/Rational.thy Thu Apr 17 18:01:03 2003 +0200
2.3 @@ -0,0 +1,73 @@
2.4 +(* rationals, i.e. frcations of multivariate polynomials over the real field
2.5 +
2.6 + depends on Poly (and not on Atools), because
2.7 + fractions with _normalized_ polynomials are canceled, added, etc.
2.8 +
2.9 + use_thy_only"knowledge/Rational";
2.10 + use_thy"../knowledge/Rational";
2.11 + use_thy"knowledge/Rational";
2.12 +
2.13 + remove_thy"Rational";
2.14 + use_thy"knowledge/Isac";
2.15 + use_thy_only"knowledge/Rational";
2.16 +
2.17 +*)
2.18 +
2.19 +Rational = Poly +
2.20 +
2.21 +consts
2.22 +
2.23 + is'_expanded:: "real => bool" ("_ is'_expanded")(*RL->Poly.thy*)
2.24 +
2.25 +rules (*.not contained in Isabelle2002,
2.26 + stated as axioms, TODO: prove as theorems*)
2.27 +
2.28 + mult_cross "[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)"
2.29 + mult_cross1 " b ~= 0 ==> (a / b = c ) = (a = b * c)"
2.30 + mult_cross2 " d ~= 0 ==> (a = c / d) = (a * d = c)"
2.31 +
2.32 + add_minus "a + b - b = a"(*RL->Poly.thy*)
2.33 + add_minus1 "a - b + b = a"(*RL->Poly.thy*)
2.34 +
2.35 + rat_mult "a / b * (c / d) = a * c / (b * d)"(*?Isa02*)
2.36 + rat_mult2 "a / b * c = a * c / b "(*?Isa02*)
2.37 +(*real_times_divide1_eq .. Isa02*)
2.38 + real_times_divide_1_eq "-1 * (c / d) =-1 * c / d "
2.39 + real_times_divide_num "a is_const ==> \
2.40 + \a * (c / d) = a * c / d "
2.41 +
2.42 + real_mult_div_cancel2 "k ~= 0 ==> m * k / (n * k) = m / n"
2.43 +(*real_mult_div_cancel1 "k ~= 0 ==> k * m / (k * n) = m / n"..Isa02*)
2.44 +
2.45 + real_divide_divide1 "y ~= 0 ==> (u / v) / (y / z) = (u / v) * (z / y)"
2.46 +(*real_divide_divide2_eq "x / y / z = x / (y * z)"..Isa02*)
2.47 +
2.48 + rat_leq1 "[| b ~= 0; d ~= 0 |] ==> \
2.49 + \((a / b) <= (c / d)) = ((a*d) <= (b*c))"(*Isa?*)
2.50 + rat_leq2 "d ~= 0 ==> \
2.51 + \( a <= (c / d)) = ((a*d) <= c )"(*Isa?*)
2.52 + rat_leq3 "b ~= 0 ==> \
2.53 + \((a / b) <= c ) = ( a <= (b*c))"(*Isa?*)
2.54 + rat_power "(a / b)^^^n = (a^^^n) / (b^^^n)"
2.55 +
2.56 +
2.57 + rat_add "[| a is_const; b is_const; c is_const; d is_const |] ==> \
2.58 + \a / c + b / d = (a * d + b * c) / (c * d)"
2.59 + rat_add_assoc "[| a is_const; b is_const; c is_const; d is_const |] ==> \
2.60 + \a / c +(b / d + e) = (a * d + b * c)/(d * c) + e"
2.61 + rat_add1 "[| a is_const; b is_const; c is_const |] ==> \
2.62 + \a / c + b / c = (a + b) / c"
2.63 + rat_add1_assoc "[| a is_const; b is_const; c is_const |] ==> \
2.64 + \a / c + (b / c + e) = (a + b) / c + e"
2.65 + rat_add2 "[| a is_const; b is_const; c is_const |] ==> \
2.66 + \a / c + b = (a + b * c) / c"
2.67 + rat_add2_assoc "[| a is_const; b is_const; c is_const |] ==> \
2.68 + \a / c + (b + e) = (a + b * c) / c + e"
2.69 + rat_add3 "[| a is_const; b is_const; c is_const |] ==> \
2.70 + \a + b / c = (a * c + b) / c"
2.71 + rat_add3_assoc "[| a is_const; b is_const; c is_const |] ==> \
2.72 + \a + (b / c + e) = (a * c + b) / c + e"
2.73 +
2.74 +
2.75 +
2.76 +end
3.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/src/sml/IsacKnowledge/Root.ML Thu Apr 17 18:01:03 2003 +0200
3.3 @@ -0,0 +1,271 @@
3.4 +(* collecting all knowledge for Root
3.5 + created by:
3.6 + date:
3.7 + changed by: rlang
3.8 + last change by: rlang
3.9 + date: 02.10.24
3.10 +*)
3.11 +
3.12 +(* use"../knowledge/Root.ML";
3.13 + use"knowledge/Root.ML";
3.14 + use"Root.ML";
3.15 +
3.16 + remove_thy"Root";
3.17 + use_thy"Isac";
3.18 +
3.19 + use"ROOT.ML";
3.20 + cd"knowledge";
3.21 + *)
3.22 +"******* Root.ML begin *******";
3.23 +theory' := overwritel (!theory', [("Root.thy",Root.thy)]);
3.24 +(*-------------------------functions---------------------*)
3.25 +(*evaluation square-root over the integers*)
3.26 +fun eval_sqrt (thmid:string) (op_:string) (t as
3.27 + (Const(op0,t0) $ arg)) thy =
3.28 + (case arg of
3.29 + Free(n1,t1) =>
3.30 + (case (int_of_str o strip_thy) n1 of
3.31 + Some ni =>
3.32 + let val fact = squfact ni;
3.33 + in if fact*fact = ni
3.34 + then Some ("#sqrt #"^(string_of_int ni)^" = #"
3.35 + ^(string_of_int (ni div fact)),
3.36 + Trueprop $ mk_equality (t, term_of_num t1 fact))
3.37 + else if fact = 1 then None
3.38 + else Some ("#sqrt #"^(string_of_int ni)^" = sqrt (#"
3.39 + ^(string_of_int fact)^" * #"
3.40 + ^(string_of_int fact)^" * #"
3.41 + ^(string_of_int (ni div (fact*fact))^")"),
3.42 + Trueprop $
3.43 + (mk_equality
3.44 + (t,
3.45 + (mk_factroot op0 t1 fact
3.46 + (ni div (fact*fact))))))
3.47 + end
3.48 + | None => None)
3.49 + | _ => None)
3.50 +
3.51 + | eval_sqrt _ _ _ _ = None;
3.52 +(*val ttt = (term_of o the o (parse thy)) "sqrt 1";
3.53 + val Some (_,rrr) = eval_sqrt "" "" ttt "";
3.54 + term2str rrr;
3.55 + "sqrt 1 = 1" *)
3.56 +
3.57 +local (* Vers. 7.10.99.A *)
3.58 +
3.59 +open Term; (* for type order = EQUAL | LESS | GREATER *)
3.60 +
3.61 +fun pr_ord EQUAL = "EQUAL"
3.62 + | pr_ord LESS = "LESS"
3.63 + | pr_ord GREATER = "GREATER";
3.64 +
3.65 +fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
3.66 + (case a of "Root.sqrt" => ((("|||", 0), T), 0) (*WN greatest *)
3.67 + | _ => (((a, 0), T), 0))
3.68 + | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
3.69 + | dest_hd' (Var v) = (v, 2)
3.70 + | dest_hd' (Bound i) = ((("", i), dummyT), 3)
3.71 + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
3.72 +fun size_of_term' (Const(str,_) $ t) =
3.73 + (case str of "Root.sqrt" => (1000 + size_of_term' t)
3.74 + | _ => 1 + size_of_term' t)
3.75 + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
3.76 + | size_of_term' (f $ t) = size_of_term' f + size_of_term' t
3.77 + | size_of_term' _ = 1;
3.78 +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
3.79 + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
3.80 + | term_ord' pr thy (t, u) =
3.81 + (if pr then
3.82 + let
3.83 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
3.84 + val _=writeln("t= f@ts= \""^
3.85 + ((string_of_cterm o cterm_of (sign_of thy)) f)^"\" @ \"["^
3.86 + (commas(map(string_of_cterm o cterm_of (sign_of thy)) ts))^"]\"");
3.87 + val _=writeln("u= g@us= \""^
3.88 + ((string_of_cterm o cterm_of (sign_of thy)) g)^"\" @ \"["^
3.89 + (commas(map(string_of_cterm o cterm_of (sign_of thy)) us))^"]\"");
3.90 + val _=writeln("size_of_term(t,u)= ("^
3.91 + (string_of_int(size_of_term' t))^", "^
3.92 + (string_of_int(size_of_term' u))^")");
3.93 + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
3.94 + val _=writeln("terms_ord(ts,us) = "^
3.95 + ((pr_ord o terms_ord str false)(ts,us)));
3.96 + val _=writeln("-------");
3.97 + in () end
3.98 + else ();
3.99 + case int_ord (size_of_term' t, size_of_term' u) of
3.100 + EQUAL =>
3.101 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
3.102 + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
3.103 + | ord => ord)
3.104 + end
3.105 + | ord => ord)
3.106 +and hd_ord (f, g) = (* ~ term.ML *)
3.107 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
3.108 +and terms_ord str pr (ts, us) =
3.109 + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
3.110 +
3.111 +in
3.112 +(* associates a+(b+c) => (a+b)+c = a+b+c ... avoiding parentheses
3.113 + by (1) size_of_term: less(!) to right, size_of 'sqrt (...)' = 1
3.114 + (2) hd_ord: greater to right, 'sqrt' < numerals < variables
3.115 + (3) terms_ord: recurs. on args, greater to right
3.116 +*)
3.117 +(* FIXME same funktion ord_make_rooteq and sqrt_right*)
3.118 +fun sqrt_right (pr:bool) thy (_:subst) tu =
3.119 + (term_ord' pr thy(***) tu = LESS );
3.120 +end;
3.121 +
3.122 +rew_ord' := overwritel (!rew_ord',
3.123 +[("termlessI", termlessI),
3.124 + ("sqrt_right", sqrt_right false ProtoPure.thy)
3.125 + ]);
3.126 +
3.127 +(*-------------------------rulse-------------------------*)
3.128 +val root_erls =
3.129 + merge_rls "root_erls" atools_erls
3.130 + (append_rls "ops" e_rls
3.131 + [Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"),
3.132 + Calc ("HOL.divide",eval_cancel "#divide_"),
3.133 + Calc ("Atools.pow" ,eval_binop "#power_"),
3.134 + Calc ("op +", eval_binop "#add_"),
3.135 + Calc ("op -", eval_binop "#sub_"),
3.136 + Calc ("op *", eval_binop "#mult_")
3.137 + ]);
3.138 +
3.139 +ruleset' := overwritel (!ruleset',
3.140 + [("root_erls",root_erls) (*FIXXXME:del with rls.rls'*)
3.141 + ]);
3.142 +
3.143 +val make_rooteq =
3.144 + Rls{id = "make_rooteq", preconds = []:term list,
3.145 + rew_ord = ("sqrt_right", sqrt_right false Root.thy),
3.146 + erls = atools_erls, srls = Erls,
3.147 + calc = [],
3.148 + asm_thm = [],
3.149 + rules = [Thm ("real_diff_minus",num_str real_diff_minus),
3.150 + (*"a - b = a + (-1) * b"*)
3.151 +
3.152 + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
3.153 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
3.154 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
3.155 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
3.156 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
3.157 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
3.158 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
3.159 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
3.160 +
3.161 + Thm ("real_mult_1",num_str real_mult_1),
3.162 + (*"1 * z = z"*)
3.163 + Thm ("real_mult_0",num_str real_mult_0),
3.164 + (*"0 * z = 0"*)
3.165 + Thm ("real_add_zero_left",num_str real_add_zero_left),
3.166 + (*"0 + z = z"*)
3.167 +
3.168 + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
3.169 + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
3.170 + Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
3.171 + Thm ("real_add_commute",num_str real_add_commute), (**)
3.172 + Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
3.173 + Thm ("real_add_assoc",num_str real_add_assoc), (**)
3.174 +
3.175 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
3.176 + (*"r1 * r1 = r1 ^^^ 2"*)
3.177 + Thm ("realpow_plus_1",num_str realpow_plus_1),
3.178 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
3.179 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
3.180 + (*"z1 + z1 = 2 * z1"*)
3.181 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
3.182 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
3.183 +
3.184 + Thm ("real_num_collect",num_str real_num_collect),
3.185 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
3.186 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
3.187 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
3.188 + Thm ("real_one_collect",num_str real_one_collect),
3.189 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
3.190 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
3.191 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
3.192 +
3.193 + Calc ("op +", eval_binop "#add_"),
3.194 + Calc ("op *", eval_binop "#mult_"),
3.195 + Calc ("Atools.pow", eval_binop "#power_")
3.196 + ],
3.197 + scr = Script ((term_of o the o (parse thy)) "empty_script")
3.198 + }:rls;
3.199 +ruleset' := overwritel (!ruleset',
3.200 + [("make_rooteq", make_rooteq)
3.201 + ]);
3.202 +
3.203 +val expand_rootbinoms =
3.204 + Rls{id = "expand_rootbinoms", preconds = [],
3.205 + rew_ord = ("termlessI",termlessI),
3.206 + erls = atools_erls, srls = Erls,
3.207 + calc = [],
3.208 + asm_thm = [],
3.209 + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
3.210 + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
3.211 + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
3.212 + (*"(a + b)*(a + b) = ...*)
3.213 + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
3.214 + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
3.215 + Thm ("real_minus_binom_times",num_str real_minus_binom_times),
3.216 + (*"(a - b)*(a - b) = ...*)
3.217 + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
3.218 + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
3.219 + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
3.220 + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
3.221 + (*RL 020915*)
3.222 + Thm ("real_pp_binom_times",num_str real_pp_binom_times),
3.223 + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
3.224 + Thm ("real_pm_binom_times",num_str real_pm_binom_times),
3.225 + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
3.226 + Thm ("real_mp_binom_times",num_str real_mp_binom_times),
3.227 + (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
3.228 + Thm ("real_mm_binom_times",num_str real_mm_binom_times),
3.229 + (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
3.230 + Thm ("realpow_mul",num_str realpow_mul),
3.231 + (*(a*b)^^^n = a^^^n * b^^^n*)
3.232 +
3.233 + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
3.234 + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
3.235 + Thm ("real_add_zero_left",num_str real_add_zero_left), (*"0 + z = z"*)
3.236 +
3.237 + Calc ("op +", eval_binop "#add_"),
3.238 + Calc ("op -", eval_binop "#sub_"),
3.239 + Calc ("op *", eval_binop "#mult_"),
3.240 + Calc ("HOL.divide" ,eval_cancel "#divide_"),
3.241 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
3.242 + Calc ("Atools.pow", eval_binop "#power_"),
3.243 +
3.244 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
3.245 + (*"r1 * r1 = r1 ^^^ 2"*)
3.246 + Thm ("realpow_plus_1",num_str realpow_plus_1),
3.247 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
3.248 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
3.249 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
3.250 +
3.251 + Thm ("real_num_collect",num_str real_num_collect),
3.252 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
3.253 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
3.254 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
3.255 + Thm ("real_one_collect",num_str real_one_collect),
3.256 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
3.257 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
3.258 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
3.259 +
3.260 + Calc ("op +", eval_binop "#add_"),
3.261 + Calc ("op -", eval_binop "#sub_"),
3.262 + Calc ("op *", eval_binop "#mult_"),
3.263 + Calc ("HOL.divide" ,eval_cancel "#divide_"),
3.264 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
3.265 + Calc ("Atools.pow", eval_binop "#power_")
3.266 + ],
3.267 + scr = Script ((term_of o the o (parse thy)) "empty_script")
3.268 + }:rls;
3.269 +
3.270 +
3.271 +ruleset' := overwritel (!ruleset',
3.272 + [("expand_rootbinoms", expand_rootbinoms)
3.273 + ]);
3.274 +"******* Root.ML end *******";
4.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2 +++ b/src/sml/IsacKnowledge/Root.thy Thu Apr 17 18:01:03 2003 +0200
4.3 @@ -0,0 +1,49 @@
4.4 +(* theory collecting all knowledge for Root
4.5 + created by:
4.6 + date:
4.7 + changed by: rlang
4.8 + last change by: rlang
4.9 + date: 02.10.21
4.10 +*)
4.11 +
4.12 +(*
4.13 + remove_thy"Root";
4.14 + use_thy"Isac";
4.15 +*)
4.16 +Root = Atools +
4.17 +
4.18 +(*-------------------- consts------------------------------------------------*)
4.19 +consts
4.20 +
4.21 + sqrt :: "real => real" (*"(sqrt _ )" [80] 80*)
4.22 + nroot :: "[real, real] => real"
4.23 +
4.24 +(*----------------------scripts-----------------------*)
4.25 +
4.26 +(*-------------------- rules------------------------------------------------*)
4.27 +rules (*.not contained in Isabelle2002,
4.28 + stated as axioms, TODO: prove as theorems;
4.29 + theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*)
4.30 +
4.31 + root_plus_minus "0 <= b ==> \
4.32 + \(a^^^2 = b) = ((a = sqrt b) | (a = -sqrt b))"
4.33 + root_false "b < 0 ==> (a^^^2 = b) = False"
4.34 +
4.35 + (* for expand_rootbinom *)
4.36 + real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d"
4.37 + real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d"
4.38 + real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d"
4.39 + real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d"
4.40 + real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
4.41 + real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3"
4.42 + realpow_mul "(a*b)^^^n = a^^^n * b^^^n"
4.43 +
4.44 + real_diff_minus "a - b = a + (-1) * b"
4.45 + real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2"
4.46 + real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2"
4.47 + real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"
4.48 + real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2"
4.49 + real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2"
4.50 + real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2"
4.51 +
4.52 +end
5.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2 +++ b/src/sml/IsacKnowledge/RootEq.ML Thu Apr 17 18:01:03 2003 +0200
5.3 @@ -0,0 +1,412 @@
5.4 +(* (c) by Richard Lang
5.5 + theory collecting all knowledge for RootEquations
5.6 + created by: rlang
5.7 + date: 02.09
5.8 + changed by: rlang
5.9 + last change by: rlang
5.10 + date: 02.11.14
5.11 +*)
5.12 +
5.13 +(* use"knowledge/RootEq.ML";
5.14 + use"RootEq.ML";
5.15 +
5.16 + use"ROOT.ML";
5.17 + cd"knowledge";
5.18 +
5.19 + remove_thy"RootEq";
5.20 + use_thy"Isac";
5.21 + *)
5.22 +"******* RootEq.ML begin *******";
5.23 +
5.24 +theory' := overwritel (!theory', [("RootEq.thy",RootEq.thy)]);
5.25 +(*-------------------------functions---------------------*)
5.26 +(* true if bdv is under sqrt of a Equation*)
5.27 +fun is_rootequation_in t v =
5.28 + let
5.29 + fun coeff_in c v = v mem (vars c);
5.30 + fun findroot (_ $ _ $ _ $ _) v = raise error("is_rootequation_in:")
5.31 + (* at the moment there is no term like this, but ....*)
5.32 + | findroot (t as (Const ("Root.nroot",_) $ _ $ t3)) v = coeff_in t3 v
5.33 + | findroot (_ $ t2 $ t3) v = (findroot t2 v) orelse (findroot t3 v)
5.34 + | findroot (t as (Const ("Root.sqrt",_) $ t2)) v = coeff_in t2 v
5.35 + | findroot (_ $ t2) v = (findroot t2 v)
5.36 + | findroot _ _ = false;
5.37 + in
5.38 + findroot t v
5.39 + end;
5.40 +
5.41 + fun is_sqrtequation_in t v =
5.42 + let
5.43 + fun coeff_in c v = v mem (vars c);
5.44 + fun findsqrt (_ $ _ $ _ $ _) v = raise error("is_sqrteqation_in:")
5.45 + (* at the moment there is no term like this, but ....*)
5.46 + | findsqrt (_ $ t1 $ t2) v = (findsqrt t1 v) orelse (findsqrt t2 v)
5.47 + | findsqrt (t as (Const ("Root.sqrt",_) $ a)) v = coeff_in a v
5.48 + | findsqrt (_ $ t1) v = (findsqrt t1 v)
5.49 + | findsqrt _ _ = false;
5.50 + in
5.51 + findsqrt t v
5.52 + end;
5.53 +
5.54 +fun eval_is_rootequation_in _ _ (p as (Const ("RootEq.is'_rootequation'_in",_) $ t $ v)) _ =
5.55 + if is_rootequation_in t v then
5.56 + Some ((term2str p) ^ " = True",
5.57 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
5.58 + else Some ((term2str p) ^ " = True",
5.59 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
5.60 + | eval_is_rootequation_in _ _ _ _ = ((*writeln"### nichts matcht";*) None);
5.61 +
5.62 +fun eval_is_sqrtequation_in _ _ (p as (Const ("RootEq.is'_sqrtequation'_in",_) $ t $ v)) _ =
5.63 + if is_sqrtequation_in t v then
5.64 + Some ((term2str p) ^ " = True",
5.65 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
5.66 + else Some ((term2str p) ^ " = True",
5.67 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
5.68 + | eval_is_sqrtequation_in _ _ _ _ = ((*writeln"### nichts matcht";*) None);
5.69 +
5.70 +(*-------------------------rulse-------------------------*)
5.71 +val rooteq_prls = (*15.10.02:just the following order due to subterm evaluation*)
5.72 + append_rls "rooteq_prls" e_rls
5.73 + [Calc ("Atools.ident",eval_ident "#ident_"),
5.74 + Calc ("Tools.matches",eval_matches ""),
5.75 + Calc ("Tools.lhs" ,eval_lhs ""),
5.76 + Calc ("RootEq.is'_sqrtequation'_in",eval_is_sqrtequation_in ""),
5.77 + Calc ("RootEq.is'_rootequation'_in",eval_is_rootequation_in ""),
5.78 + Calc ("op =",eval_equal "#equal_"),
5.79 + Thm ("not_true",num_str not_true),
5.80 + Thm ("not_false",num_str not_false),
5.81 + Thm ("and_true",num_str and_true),
5.82 + Thm ("and_false",num_str and_false),
5.83 + Thm ("or_true",num_str or_true),
5.84 + Thm ("or_false",num_str or_false)
5.85 + (* Thm ("and_commute",num_str and_commute),
5.86 + Thm ("or_commute",num_str or_commute)
5.87 + *)
5.88 + ];
5.89 +
5.90 +val rooteq_erls =
5.91 + merge_rls "rooteq_erls" root_erls
5.92 + (append_rls "real_divide_divide2_eq" e_rls
5.93 + [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq)
5.94 + ]);
5.95 +
5.96 +val rooteq_srls =
5.97 + append_rls "rooteq_srls" e_rls
5.98 + [Calc ("RootEq.is'_sqrtequation'_in",
5.99 + eval_is_sqrtequation_in ""),
5.100 + Calc ("RootEq.is'_rootequation'_in",eval_is_rootequation_in "")
5.101 + ];
5.102 +
5.103 +ruleset' := overwritel (!ruleset',
5.104 + [("rooteq_erls",rooteq_erls),(*FIXXXME:del with rls.rls'*)
5.105 + ("rooteq_srls",rooteq_srls)
5.106 + ]);
5.107 +
5.108 +(*isolate the bound variable in an sqrt equation; 'bdv' is a meta-constant*)
5.109 + val sqrt_isolate =
5.110 + Rls {id = "sqrt_isolate", preconds = [], rew_ord = ("termlessI",termlessI),
5.111 + erls = rooteq_erls, srls = Erls, calc = [],
5.112 + asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
5.113 + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
5.114 + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_right_1",""),
5.115 + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
5.116 + ("sqrt_square_equation_right_4","")],
5.117 + rules = [
5.118 + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
5.119 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
5.120 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
5.121 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
5.122 + Thm("sqrt_square_equation_both_1",num_str sqrt_square_equation_both_1),
5.123 + (* (sqrt a + sqrt b = sqrt c + sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *)
5.124 + Thm("sqrt_square_equation_both_2",num_str sqrt_square_equation_both_2),
5.125 + (* (sqrt a - sqrt b = sqrt c + sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *)
5.126 + Thm("sqrt_square_equation_both_3",num_str sqrt_square_equation_both_3),
5.127 + (* (sqrt a + sqrt b = sqrt c - sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *)
5.128 + Thm("sqrt_square_equation_both_4",num_str sqrt_square_equation_both_4),
5.129 + (* (sqrt a - sqrt b = sqrt c - sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *)
5.130 + Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *)
5.131 + Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *)
5.132 + Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *)
5.133 + Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *)
5.134 + (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *)
5.135 + Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *)
5.136 + Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *)
5.137 + Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*)
5.138 + Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *)
5.139 + (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *)
5.140 + Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1),
5.141 + (* sqrt(x)=b -> x=b^2 *)
5.142 + Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2),
5.143 + (* c*sqrt(x)=b -> c^2*x=b^2 *)
5.144 + Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3),
5.145 + (* c/sqrt(x)=b -> c^2/x=b^2 *)
5.146 + Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4),
5.147 + (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *)
5.148 + Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1),
5.149 + (* a=sqrt(x) ->a^2=x *)
5.150 + Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2),
5.151 + (* a=c*sqrt(x) ->a^2=c^2*x *)
5.152 + Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3),
5.153 + (* a=c/sqrt(x) ->a^2=c^2/x *)
5.154 + Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4)
5.155 + (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *)
5.156 + ],
5.157 + scr = Script ((term_of o the o (parse thy)) "empty_script")
5.158 + }:rls;
5.159 +ruleset' := overwritel (!ruleset',
5.160 + [("sqrt_isolate",sqrt_isolate)
5.161 + ]);
5.162 +(* -- left 28.08.02--*)
5.163 +(*isolate the bound variable in an sqrt left equation; 'bdv' is a meta-constant*)
5.164 + val l_sqrt_isolate =
5.165 + Rls {id = "l_sqrt_isolate", preconds = [],
5.166 + rew_ord = ("termlessI",termlessI),
5.167 + erls = rooteq_erls, srls = Erls, calc = [], asm_thm = [],
5.168 + rules = [
5.169 + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
5.170 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
5.171 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
5.172 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
5.173 + Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *)
5.174 + Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *)
5.175 + Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *)
5.176 + Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *)
5.177 + (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *)
5.178 + Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1),
5.179 + (* sqrt(x)=b -> x=b^2 *)
5.180 + Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2),
5.181 + (* a*sqrt(x)=b -> a^2*x=b^2*)
5.182 + Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3),
5.183 + (* c/sqrt(x)=b -> c^2/x=b^2 *)
5.184 + Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4)
5.185 + (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *)
5.186 + ],
5.187 + scr = Script ((term_of o the o (parse thy)) "empty_script")
5.188 + }:rls;
5.189 +ruleset' := overwritel (!ruleset',
5.190 + [("l_sqrt_isolate",l_sqrt_isolate)
5.191 + ]);
5.192 +
5.193 +(* -- right 28.8.02--*)
5.194 +(*isolate the bound variable in an sqrt right equation; 'bdv' is a meta-constant*)
5.195 + val r_sqrt_isolate =
5.196 + Rls {id = "r_sqrt_isolate", preconds = [],
5.197 + rew_ord = ("termlessI",termlessI),
5.198 + erls = rooteq_erls, srls = Erls, calc = [], asm_thm = [],
5.199 + rules = [
5.200 + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
5.201 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
5.202 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
5.203 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
5.204 + Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *)
5.205 + Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *)
5.206 + Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*)
5.207 + Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *)
5.208 + (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *)
5.209 + Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1),
5.210 + (* a=sqrt(x) ->a^2=x *)
5.211 + Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2),
5.212 + (* a=c*sqrt(x) ->a^2=c^2*x *)
5.213 + Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3),
5.214 + (* a=c/sqrt(x) ->a^2=c^2/x *)
5.215 + Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4)
5.216 + (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *)
5.217 + ],
5.218 + scr = Script ((term_of o the o (parse thy)) "empty_script")
5.219 + }:rls;
5.220 +ruleset' := overwritel (!ruleset',
5.221 + [("r_sqrt_isolate",r_sqrt_isolate)
5.222 + ]);
5.223 +
5.224 +val rooteq_simplify =
5.225 + Rls {id = "rooteq_simplify",
5.226 + preconds = [], rew_ord = ("termlessI",termlessI),
5.227 + erls = rooteq_erls, srls = Erls, calc = [], asm_thm = [],
5.228 + rules = [Thm ("real_assoc_1",num_str real_assoc_1), (* a+(b+c) = a+b+c *)
5.229 + Thm ("real_assoc_2",num_str real_assoc_2), (* a*(b*c) = a*b*c *)
5.230 + Calc ("op +",eval_binop "#add_"),
5.231 + Calc ("op -",eval_binop "#sub_"),
5.232 + Calc ("op *",eval_binop "#mult_"),
5.233 + Calc ("HOL.divide", eval_cancel "#divide_"),
5.234 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
5.235 + Calc ("Atools.pow" ,eval_binop "#power_"),
5.236 + Thm("real_plus_binom_pow2",num_str real_plus_binom_pow2),
5.237 + Thm("real_minus_binom_pow2",num_str real_minus_binom_pow2),
5.238 + Thm("realpow_mul",num_str realpow_mul), (* (a * b)^n = a^n * b^n*)
5.239 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt b * sqrt c = sqrt(b*c) *)
5.240 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a * sqrt a * sqrt b = a * sqrt(a*b) *)
5.241 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) = a *)
5.242 + Thm("sqrt_square_1",num_str sqrt_square_1) (* sqrt a ^^^ 2 = a *)
5.243 + ],
5.244 + scr = Script ((term_of o the o (parse thy)) "empty_script")
5.245 + }:rls;
5.246 +ruleset' := overwritel (!ruleset',
5.247 + [("rooteq_simplify",rooteq_simplify)
5.248 + ]);
5.249 +
5.250 +(*-------------------------Problem-----------------------*)
5.251 +(*
5.252 +(get_pbt ["root","univariate","equation"]);
5.253 +show_ptyps();
5.254 +*)
5.255 +store_pbt
5.256 + (prep_pbt RootEq.thy
5.257 + (["root","univariate","equation"],
5.258 + [("#Given" ,["equality e_","solveFor v_"]),
5.259 + ("#Where" ,["(lhs e_) is_rootequation_in (v_::real) | \
5.260 + \(rhs e_) is_rootequation_in (v_::real)"]),
5.261 + ("#Find" ,["solutions v_i_"])
5.262 + ],
5.263 + rooteq_prls, None,
5.264 + []));
5.265 +(* ---------sqrt----------- *)
5.266 +store_pbt
5.267 + (prep_pbt RootEq.thy
5.268 + (["sq","root","univariate","equation"],
5.269 + [("#Given" ,["equality e_","solveFor v_"]),
5.270 + ("#Where" ,["(lhs e_) is_sqrtequation_in (v_::real) | \
5.271 + \(rhs e_) is_sqrtequation_in (v_::real)"]),
5.272 + ("#Find" ,["solutions v_i_"])
5.273 + ],
5.274 + rooteq_prls, None,
5.275 + [("RootEq.thy","solve_sq_root_equation")]));
5.276 +
5.277 +store_pbt
5.278 + (prep_pbt RootEq.thy
5.279 + (["normalize","root","univariate","equation"],
5.280 + [("#Given" ,["equality e_","solveFor v_"]),
5.281 + ("#Where" ,["(rhs e_) is_sqrtequation_in (v_::real) | \
5.282 + \(lhs e_) is_sqrtequation_in (v_::real)",
5.283 + "Not(matches ( ?a = ?b + ?c*sqrt(?d)) e_) &\
5.284 + \Not(matches ( ?a = ?b + sqrt(?d)) e_) &\
5.285 + \Not(matches ( ?a = ?c*sqrt(?d)) e_) &\
5.286 + \Not(matches ( ?a = sqrt(?d)) e_)&\
5.287 + \Not(matches ( ?a + b*sqrt(?c) = ?d) e_) &\
5.288 + \Not(matches ( ?a + sqrt(?c) = ?d) e_) &\
5.289 + \Not(matches ( b*sqrt(?c) = ?d) e_) &\
5.290 + \Not(matches ( sqrt(?c) = ?d) e_)"]),
5.291 + ("#Find" ,["solutions v_i_"])
5.292 + ],
5.293 + rooteq_prls, None,
5.294 + [("RootEq.thy","norm_sq_root_equation")]));
5.295 +
5.296 +(*-------------------------methods-----------------------*)
5.297 +(* ---- root 20.8.02 ---*)
5.298 +methods:= overwritel (!methods,
5.299 +[
5.300 +(*-- normalize 20.10.02 --*)
5.301 +prep_met
5.302 + (("RootEq.thy","norm_sq_root_equation"),
5.303 + [("#Given" ,["equality e_","solveFor v_"]),
5.304 + ("#Where" ,["(lhs e_) is_sqrtequation_in v_ | \
5.305 + \(rhs e_) is_sqrtequation_in v_"]),
5.306 + ("#Find" ,["solutions v_i_"])
5.307 + ],
5.308 + {rew_ord'="termlessI",
5.309 + rls'=rooteq_erls,
5.310 + srls=e_rls,
5.311 + prls=rooteq_prls,
5.312 + calc=[],
5.313 + asm_rls=["rooteq_simplify"],
5.314 + asm_thm=[]},
5.315 + "Script Norm_sq_root_equation (e_::bool) (v_::real) = \
5.316 + \(let e_ = ((Repeat(Try (Rewrite makex1_x False))) @@ \
5.317 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
5.318 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
5.319 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
5.320 + \ (Try (Rewrite_Set rooteq_simplify False))) e_ \
5.321 + \ in ((SubProblem (RootEq_,[sq,root,univariate,equation], \
5.322 + \ (RootEq_,no_met)) [bool_ e_, real_ v_])))"
5.323 + )
5.324 +,
5.325 +prep_met
5.326 + (("RootEq.thy","solve_sq_root_equation"),
5.327 + [("#Given" ,["equality e_","solveFor v_"]),
5.328 + ("#Where" ,["(lhs e_) is_sqrtequation_in v_ | \
5.329 + \(rhs e_) is_sqrtequation_in v_"]),
5.330 + ("#Find" ,["solutions v_i_"])
5.331 + ],
5.332 + {rew_ord'="termlessI",
5.333 + rls'=rooteq_erls,
5.334 + srls = rooteq_srls,
5.335 + prls = rooteq_prls,
5.336 + calc = [],
5.337 + asm_rls = ["sqrt_isolate","rooteq_simplify"],
5.338 + asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
5.339 + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
5.340 + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_right_1",""),
5.341 + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
5.342 + ("sqrt_square_equation_right_4","")]},
5.343 + "Script Solve_sq_root_equation (e_::bool) (v_::real) = \
5.344 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] sqrt_isolate True)) @@ \
5.345 + \ (Try (Rewrite_Set rooteq_simplify True)) @@ \
5.346 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
5.347 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
5.348 + \ (Try (Rewrite_Set rooteq_simplify True))) e_;\
5.349 + \ (L_::bool list) = \
5.350 + \ (if (((lhs e_) is_sqrtequation_in v_) | ((rhs e_) is_sqrtequation_in v_)) \
5.351 + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
5.352 + \ (RootEq_,no_met)) [bool_ e_, real_ v_]) \
5.353 + \ else (SubProblem (RootEq_,[univariate,equation], \
5.354 + \ (RootEq_,no_met)) [bool_ e_, real_ v_])) \
5.355 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
5.356 + )
5.357 +,
5.358 +(*-- right 28.08.02 --*)
5.359 +prep_met
5.360 + (("RootEq.thy","solve_right_sq_root_equation"),
5.361 + [("#Given" ,["equality e_","solveFor v_"]),
5.362 + ("#Where" ,["(rhs e_) is_sqrtequation_in v_"]),
5.363 + ("#Find" ,["solutions v_i_"])
5.364 + ],
5.365 + {rew_ord'="termlessI",
5.366 + rls'=rooteq_erls,
5.367 + srls=e_rls,
5.368 + prls=rooteq_prls,
5.369 + calc=[],
5.370 + asm_rls=["r_sqrt_isolate","rooteq_simplify"],
5.371 + asm_thm=[("sqrt_square_1",""),("sqrt_square_equation_right_1",""),
5.372 + ("sqrt_square_equation_right_2","")]},
5.373 + "Script Solve_right_sq_root_equation (e_::bool) (v_::real) = \
5.374 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] r_sqrt_isolate False)) @@ \
5.375 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
5.376 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
5.377 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
5.378 + \ (Try (Rewrite_Set rooteq_simplify False))) e_\
5.379 + \ in if ((rhs e_) is_sqrtequation_in v_) \
5.380 + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
5.381 + \ (RootEq_,no_met)) [bool_ e_, real_ v_]) \
5.382 + \ else ((SubProblem (RootEq_,[univariate,equation], \
5.383 + \ (RootEq_,no_met)) [bool_ e_, real_ v_])))"
5.384 + )
5.385 +,
5.386 +(*-- left 28.08.02 --*)
5.387 +prep_met
5.388 + (("RootEq.thy","solve_left_sq_root_equation"),
5.389 + [("#Given" ,["equality e_","solveFor v_"]),
5.390 + ("#Where" ,["(lhs e_) is_sqrtequation_in v_"]),
5.391 + ("#Find" ,["solutions v_i_"])
5.392 + ],
5.393 + {rew_ord'="termlessI",
5.394 + rls'=rooteq_erls,
5.395 + srls=e_rls,
5.396 + prls=rooteq_prls,
5.397 + calc=[],
5.398 + asm_rls=["l_sqrt_isolate","rooteq_simplify"],
5.399 + asm_thm=[("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
5.400 + ("sqrt_square_equation_left_2","")]},
5.401 + "Script Solve_left_sq_root_equation (e_::bool) (v_::real) = \
5.402 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] l_sqrt_isolate False)) @@ \
5.403 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
5.404 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
5.405 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
5.406 + \ (Try (Rewrite_Set rooteq_simplify False))) e_\
5.407 + \ in if ((lhs e_) is_sqrtequation_in v_) \
5.408 + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
5.409 + \ (RootEq_,no_met)) [bool_ e_, real_ v_]) \
5.410 + \ else ((SubProblem (RootEq_,[univariate,equation], \
5.411 + \ (RootEq_,no_met)) [bool_ e_, real_ v_])))"
5.412 + )
5.413 +]);
5.414 +
5.415 +"******* RootEq.ML end *******";
6.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2 +++ b/src/sml/IsacKnowledge/RootEq.thy Thu Apr 17 18:01:03 2003 +0200
6.3 @@ -0,0 +1,122 @@
6.4 +(* (c) by Richard Lang
6.5 + collecting all knowledge for Root Equations
6.6 + created by: rlang
6.7 + date: 02.08
6.8 + changed by: rlang
6.9 + last change by: rlang
6.10 + date: 02.11.14
6.11 +*)
6.12 +(* use"../knowledge/RootEq.ML";
6.13 + use"knowledge/RootEq.ML";
6.14 + use"RootEq.ML";
6.15 +
6.16 + remove_thy"RootEq";
6.17 + use_thy"Isac";
6.18 +
6.19 + use"ROOT.ML";
6.20 + cd"knowledge";
6.21 + *)
6.22 +
6.23 +RootEq = Root +
6.24 +
6.25 +(*-------------------- consts------------------------------------------------*)
6.26 +consts
6.27 + (*-------------------------root-----------------------*)
6.28 + is'_rootequation'_in :: [real, real] => bool ("_ is'_rootequation'_in _")
6.29 + is'_sqrtequation'_in :: [real, real] => bool ("_ is'_sqrtequation'_in _")
6.30 + (*----------------------scripts-----------------------*)
6.31 + Norm'_sq'_root'_equation
6.32 + :: "[bool,real, \
6.33 + \ bool list] => bool list"
6.34 + ("((Script Norm'_sq'_root'_equation (_ _ =))// \
6.35 + \ (_))" 9)
6.36 + Solve'_sq'_root'_equation
6.37 + :: "[bool,real, \
6.38 + \ bool list] => bool list"
6.39 + ("((Script Solve'_sq'_root'_equation (_ _ =))// \
6.40 + \ (_))" 9)
6.41 + Solve'_left'_sq'_root'_equation
6.42 + :: "[bool,real, \
6.43 + \ bool list] => bool list"
6.44 + ("((Script Solve'_left'_sq'_root'_equation (_ _ =))// \
6.45 + \ (_))" 9)
6.46 + Solve'_right'_sq'_root'_equation
6.47 + :: "[bool,real, \
6.48 + \ bool list] => bool list"
6.49 + ("((Script Solve'_right'_sq'_root'_equation (_ _ =))// \
6.50 + \ (_))" 9)
6.51 +
6.52 +(*-------------------- rules------------------------------------------------*)
6.53 +rules
6.54 +
6.55 +(* normalize *)
6.56 + makex1_x
6.57 + "a^^^1 = a"
6.58 + real_assoc_1
6.59 + "a+(b+c) = a+b+c"
6.60 + real_assoc_2
6.61 + "a*(b*c) = a*b*c"
6.62 +
6.63 + (* simplification of root*)
6.64 + sqrt_square_1
6.65 + "[|0 <= a|] ==> (sqrt a)^^^2 = a"
6.66 + sqrt_square_2
6.67 + "sqrt (a ^^^ 2) = a"
6.68 + sqrt_times_root_1
6.69 + "sqrt a * sqrt b = sqrt(a*b)"
6.70 + sqrt_times_root_2
6.71 + "a * sqrt b * sqrt c = a * sqrt(b*c)"
6.72 +
6.73 + (* isolate one root on the LEFT or RIGHT hand side of the equation *)
6.74 + sqrt_isolate_l_add1
6.75 + "[|bdv occurs_in c|] ==> (a + b*sqrt(c) = d) = (b * sqrt(c) = d+ (-1) * a)"
6.76 + sqrt_isolate_l_add2
6.77 + "[|bdv occurs_in c|] ==>(a + sqrt(c) = d) = ((sqrt(c) = d+ (-1) * a))"
6.78 + sqrt_isolate_l_add3
6.79 + "[|bdv occurs_in c|] ==> (a + b*(e/sqrt(c)) = d) = (b * (e/sqrt(c)) = d+ (-1) * a)"
6.80 + sqrt_isolate_l_add4
6.81 + "[|bdv occurs_in c|] ==>(a + b/sqrt(c) = d) = (b / sqrt(c) = d+ (-1) * a)"
6.82 + sqrt_isolate_r_add1
6.83 + "[|bdv occurs_in f|] ==>(a = d + e*sqrt(f)) = (a + (-1) * d = e*sqrt(f))"
6.84 + sqrt_isolate_r_add2
6.85 + "[|bdv occurs_in f|] ==>(a = d + sqrt(f)) = (a + (-1) * d = sqrt(f))"
6.86 + sqrt_isolate_r_add3
6.87 + "[|bdv occurs_in f|] ==>(a = d + e*(g/sqrt(f))) = (a + (-1) * d = e*(g/sqrt(f)))"
6.88 + sqrt_isolate_r_add4
6.89 + "[|bdv occurs_in f|] ==>(a = d + g/sqrt(f)) = (a + (-1) * d = g/sqrt(f))"
6.90 +
6.91 + (* eliminate isolates sqrt *)
6.92 + sqrt_square_equation_both_1
6.93 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
6.94 + ( (sqrt a + sqrt b = sqrt c + sqrt d) =
6.95 + (a+2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))"
6.96 + sqrt_square_equation_both_2
6.97 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
6.98 + ( (sqrt a - sqrt b = sqrt c + sqrt d) =
6.99 + (a - 2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))"
6.100 + sqrt_square_equation_both_3
6.101 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
6.102 + ( (sqrt a + sqrt b = sqrt c - sqrt d) =
6.103 + (a + 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))"
6.104 + sqrt_square_equation_both_4
6.105 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
6.106 + ( (sqrt a - sqrt b = sqrt c - sqrt d) =
6.107 + (a - 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))"
6.108 + sqrt_square_equation_left_1
6.109 + "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (sqrt (a) = b) = (a = (b^^^2)))"
6.110 + sqrt_square_equation_left_2
6.111 + "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (c*sqrt(a) = b) = (c^^^2*a = b^^^2))"
6.112 + sqrt_square_equation_left_3
6.113 + "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( c/sqrt(a) = b) = (c^^^2 / a = b^^^2)"
6.114 + sqrt_square_equation_left_4
6.115 + "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (c*(d/sqrt (a)) = b) = (c^^^2*(d^^^2/a) = b^^^2))"
6.116 + sqrt_square_equation_right_1
6.117 + "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = sqrt (b)) = (a^^^2 = b))"
6.118 + sqrt_square_equation_right_2
6.119 + "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = c*sqrt (b)) = ((a^^^2) = c^^^2*b))"
6.120 + sqrt_square_equation_right_3
6.121 + "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = c/sqrt (b)) = (a^^^2 = c^^^2/b))"
6.122 + sqrt_square_equation_right_4
6.123 + "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = c*(d/sqrt (b))) = ((a^^^2) = c^^^2*(d^^^2/b)))"
6.124 +
6.125 +end
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/src/sml/IsacKnowledge/RootRat.ML Thu Apr 17 18:01:03 2003 +0200
7.3 @@ -0,0 +1,50 @@
7.4 +(* (c) by Richard Lang
7.5 + collecting all knowledge for Root and Rational
7.6 + created by: rlang
7.7 + date: 02.10
7.8 + changed by: rlang
7.9 + last change by: rlang
7.10 + date: 02.10.21
7.11 +*)
7.12 +(* use"knowledge/RootRat.ML";
7.13 + use"RootRat.ML";
7.14 +
7.15 + use"ROOT.ML";
7.16 + cd"knowledge";
7.17 +
7.18 + remove_thy"RootRat";
7.19 + use_thy"Isac";
7.20 + *)
7.21 +
7.22 +"******* RootRat.ML begin *******";
7.23 +theory' := overwritel (!theory', [("RootRat.thy",RootRat.thy)]);
7.24 +
7.25 +(*-------------------------functions---------------------*)
7.26 +
7.27 +(*-------------------------rulse-------------------------*)
7.28 +val rootrat_erls =
7.29 + merge_rls "rootrat_erls" root_erls
7.30 + (merge_rls "" rational_erls
7.31 + (append_rls "" e_rls
7.32 + []));
7.33 +
7.34 +ruleset' := overwritel (!ruleset',
7.35 + [("rootrat_erls",rootrat_erls) (*FIXXXME:del with rls.rls'*)
7.36 + ]);
7.37 +
7.38 +(*.calculate numeral groundterms.*)
7.39 +val calculate_RootRat =
7.40 + append_rls "calculate_RootRat" calculate_Rational
7.41 + [Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
7.42 + (* w*(z1.0 + z2.0) = w * z1.0 + w * z2.0 *)
7.43 + Thm ("real_mult_1",num_str real_mult_1),
7.44 + (* 1 * z = z *)
7.45 + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)),
7.46 + (* "- z1 = -1 * z1" *)
7.47 + Calc ("Root.sqrt",eval_sqrt "#sqrt_")
7.48 + ];
7.49 +ruleset' := overwritel (!ruleset',
7.50 + [("calculate_RootRat",calculate_RootRat)]);
7.51 +
7.52 +
7.53 +"******* RootRat.ML end *******";
8.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2 +++ b/src/sml/IsacKnowledge/RootRat.thy Thu Apr 17 18:01:03 2003 +0200
8.3 @@ -0,0 +1,16 @@
8.4 +(* (c) by Richard Lang
8.5 + collecting all knowledge for Root and Rational
8.6 + created by: rlang
8.7 + date: 02.10
8.8 + changed by: rlang
8.9 + last change by: rlang
8.10 + date: 02.10.20
8.11 +*)
8.12 +
8.13 +RootRat = Root + Rational +
8.14 +(*-------------------- consts------------------------------------------------*)
8.15 +
8.16 +
8.17 +(*-------------------- rules------------------------------------------------*)
8.18 +
8.19 +end
9.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2 +++ b/src/sml/IsacKnowledge/RootRatEq.ML Thu Apr 17 18:01:03 2003 +0200
9.3 @@ -0,0 +1,134 @@
9.4 +(* (c) by Richard Lang
9.5 + collecting all knowledge for Root and Rational Equations
9.6 + created by: rlang
9.7 + date: 02.10
9.8 + changed by: rlang
9.9 + last change by: rlang
9.10 + date: 02.11.04
9.11 +*)
9.12 +
9.13 +(* use"knowledge/RootRatEq.ML";
9.14 + use"RootRatEq.ML";
9.15 +
9.16 + use"ROOT.ML";
9.17 + cd"knowledge";
9.18 +
9.19 + remove_thy"RootRatEq";
9.20 + use_thy"Isac";
9.21 + *)
9.22 +
9.23 +"******* RootRatEq.ML begin *******";
9.24 +theory' := overwritel (!theory', [("RootRatEq.thy",RootRatEq.thy)]);
9.25 +
9.26 +(*-------------------------functions---------------------*)
9.27 +(* true if denominator contains (sq)root in + or - term
9.28 + 1/(sqrt(x+3)*(x+4)) -> false; 1/(sqrt(x)+2) -> true
9.29 + if false then (term)^2 contains no (sq)root *)
9.30 +fun is_ratrootaddeq_in t v =
9.31 + let
9.32 + fun coeff_in c v = v mem (vars c);
9.33 + fun rootadd (t as (Const ("op +",_) $ t2 $ t3)) v = (is_rootequation_in t2 v) orelse
9.34 + (is_rootequation_in t3 v)
9.35 + | rootadd (t as (Const ("op -",_) $ t2 $ t3)) v = (is_rootequation_in t2 v) orelse
9.36 + (is_rootequation_in t3 v)
9.37 + | rootadd _ _ = false;
9.38 + fun findratroot (_ $ _ $ _ $ _) v = raise error("is_ratrootaddeq_in:")
9.39 + (* at the moment there is no term like this, but ....*)
9.40 + | findratroot (t as (Const ("HOL.divide",_) $ _ $ t3)) v =
9.41 + if (is_rootequation_in t3 v) then rootadd t3 v else false
9.42 + | findratroot _ _ = false;
9.43 + in
9.44 + findratroot t v
9.45 + end;
9.46 +
9.47 +fun eval_is_ratrootaddeq_in _ _ (p as (Const ("RootRatEq.is'_ratrootaddeq'_in",_) $ t $ v)) _ =
9.48 + if is_ratrootaddeq_in t v then
9.49 + Some ((term2str p) ^ " = True",
9.50 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
9.51 + else Some ((term2str p) ^ " = True",
9.52 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
9.53 + | eval_is_ratrootaddeq_in _ _ _ _ = ((*writeln"### nichts matcht";*) None);
9.54 +
9.55 +(*-------------------------rulse-------------------------*)
9.56 +val rootrateq_prls =
9.57 + merge_rls "rootrateq_prls" rateq_prls
9.58 + (merge_rls "rooteq_prls__" rooteq_prls
9.59 + (append_rls "is_ratrootaddeq_in" e_rls
9.60 + [Calc ("RootRatEq.is'_ratrootaddeq'_in",
9.61 + eval_is_ratrootaddeq_in "")
9.62 + ]));
9.63 +
9.64 +
9.65 +val rootrateq_erls =
9.66 + merge_rls "rootrateq_erls" rootrat_erls
9.67 + (merge_rls "" rooteq_erls
9.68 + (merge_rls "" rateq_erls
9.69 + (append_rls "" e_rls
9.70 + [])));
9.71 +
9.72 +ruleset' := overwritel (!ruleset',
9.73 + [("rootrateq_erls",rootrateq_erls) (*FIXXXME:del with rls.rls'*)
9.74 + ]);
9.75 +
9.76 +(* Solves a ratRoot Equation *)
9.77 + val ratroot_solve =
9.78 + Rls {id = "ratroot_solve", preconds = [],
9.79 + rew_ord = ("termlessI",termlessI),
9.80 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
9.81 + rules = [ Thm("rootrat_equation_left",num_str rootrat_equation_left),
9.82 + (* [|c is_rootequation_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c )) *)
9.83 + Thm("rootrat_equation_right",num_str rootrat_equation_right)
9.84 + (* [|f is_rootequation_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e )) *)
9.85 + ],
9.86 + scr = Script ((term_of o the o (parse thy)) "empty_script")
9.87 + }:rls;
9.88 +ruleset' := overwritel (!ruleset',
9.89 + [("ratroot_solve",ratroot_solve)
9.90 + ]);
9.91 +
9.92 +(*-----------------------probleme------------------------*)
9.93 +(*
9.94 +(get_pbt ["rat","root","univariate","equation"]);
9.95 +show_ptyps();
9.96 +*)
9.97 +store_pbt
9.98 + (prep_pbt RootRatEq.thy
9.99 + (["rat","root","univariate","equation"],
9.100 + [("#Given" ,["equality e_","solveFor v_"]),
9.101 + ("#Where" ,["( (lhs e_) is_ratrootaddeq_in (v_::real) )| \
9.102 + \( (rhs e_) is_ratrootaddeq_in (v_::real) )"]),
9.103 + ("#Find" ,["solutions v_i_"])
9.104 + ],
9.105 + rootrateq_prls, None,
9.106 + [("RootRatEq.thy","elim_rootrat_equation")]));
9.107 +
9.108 +(*-------------------------Methode-----------------------*)
9.109 +methods:= overwritel (!methods,
9.110 +[
9.111 +(*-- left 20.10.02 --*)
9.112 +prep_met
9.113 + (("RootRatEq.thy","elim_rootrat_equation"),
9.114 + [("#Given" ,["equality e_","solveFor v_"]),
9.115 + ("#Where" ,["( (lhs e_) is_ratrootaddeq_in (v_::real) ) | \
9.116 + \( (rhs e_) is_ratrootaddeq_in (v_::real) )"]),
9.117 + ("#Find" ,["solutions v_i_"])
9.118 + ],
9.119 + {rew_ord'="termlessI",
9.120 + rls'=rootrateq_erls,
9.121 + srls=e_rls,
9.122 + prls=rootrateq_prls,
9.123 + calc=[],
9.124 + asm_rls=[],
9.125 + asm_thm=[]},
9.126 + "Script Elim_rootrat_equation (e_::bool) (v_::real) = \
9.127 + \(let e_ = ((Try (Rewrite_Set expand_rootbinoms False)) @@ \
9.128 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
9.129 + \ (Try (Rewrite_Set make_rooteq False)) @@ \
9.130 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
9.131 + \ (Try (Rewrite_Set_Inst [(bdv,v_)] \
9.132 + \ ratroot_solve False))) e_ \
9.133 + \ in (SubProblem (RootEq_,[univariate,equation], \
9.134 + \ (RootEq_,no_met)) [bool_ e_, real_ v_]))"
9.135 + )
9.136 +]);
9.137 +"******* RootRatEq.ML end *******";
10.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2 +++ b/src/sml/IsacKnowledge/RootRatEq.thy Thu Apr 17 18:01:03 2003 +0200
10.3 @@ -0,0 +1,44 @@
10.4 +(* (c) by Richard Lang
10.5 + collecting all knowledge for Root and Rational Equations
10.6 + created by: rlang
10.7 + date: 02.10
10.8 + changed by: rlang
10.9 + last change by: rlang
10.10 + date: 02.11.04
10.11 +*)
10.12 +
10.13 +(* use"knowledge/RootRatEq.ML";
10.14 + use"RootRatEq.ML";
10.15 +
10.16 + use"ROOT.ML";
10.17 + cd"knowledge";
10.18 +
10.19 + remove_thy"RootRatEq";
10.20 + use_thy"Isac";
10.21 + *)
10.22 +
10.23 +RootRatEq = RootEq + RatEq + RootRat +
10.24 +
10.25 +(*-------------------- consts-----------------------------------------------*)
10.26 +consts
10.27 +
10.28 + is'_ratrootaddeq'_in :: [real, real] => bool ("_ is'_ratrootaddeq'_in _")
10.29 +
10.30 +(*---------scripts--------------------------*)
10.31 + Elim'_rootrat'_equation
10.32 + :: "[bool,real, \
10.33 + \ bool list] => bool list"
10.34 + ("((Script Elim'_rootrat'_equation (_ _ =))// \
10.35 + \ (_))" 9)
10.36 + (*-------------------- rules------------------------------------------------*)
10.37 +rules
10.38 +
10.39 + (* eliminate ratRootEquation *)
10.40 + rootrat_equation_left
10.41 + "[|c is_rootequation_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c ))"
10.42 + rootrat_equation_right
10.43 + "[|f is_rootequation_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e ))"
10.44 +
10.45 +
10.46 +
10.47 +end
11.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2 +++ b/src/sml/IsacKnowledge/Test.ML Thu Apr 17 18:01:03 2003 +0200
11.3 @@ -0,0 +1,1264 @@
11.4 +(* SML functions for rational arithmetic
11.5 + WN.22.10.99
11.6 + use"../knowledge/Test.ML";
11.7 + use"knowledge/Test.ML";
11.8 + use"Test.ML";
11.9 + *)
11.10 +
11.11 +
11.12 +(** interface isabelle -- isac **)
11.13 +
11.14 +theory' := overwritel (!theory', [("Test.thy",Test.thy)]);
11.15 +
11.16 +(** evaluation of numerals and predicates **)
11.17 +
11.18 +(*does a term contain a root ?*)
11.19 +fun eval_root_free (thmid:string) _ (t as (Const(op0,t0) $ arg)) thy =
11.20 + if strip_thy op0 <> "is'_root'_free"
11.21 + then raise error ("eval_root_free: wrong "^op0)
11.22 + else if const_in (strip_thy op0) arg
11.23 + then Some (mk_thmid thmid ""
11.24 + ((string_of_cterm o cterm_of (sign_of thy)) arg) "",
11.25 + Trueprop $ (mk_equality (t, false_as_term)))
11.26 + else Some (mk_thmid thmid ""
11.27 + ((string_of_cterm o cterm_of (sign_of thy)) arg) "",
11.28 + Trueprop $ (mk_equality (t, true_as_term)))
11.29 + | eval_root_free _ _ _ _ = None;
11.30 +
11.31 +(*does a term contain a root ?*)
11.32 +fun eval_contains_root (thmid:string) _
11.33 + (t as (Const("Test.contains'_root",t0) $ arg)) thy =
11.34 + if "sqrt" mem (ids_of arg)
11.35 + then Some (mk_thmid thmid ""
11.36 + ((string_of_cterm o cterm_of (sign_of thy)) arg) "",
11.37 + Trueprop $ (mk_equality (t, true_as_term)))
11.38 + else Some (mk_thmid thmid ""
11.39 + ((string_of_cterm o cterm_of (sign_of thy)) arg) "",
11.40 + Trueprop $ (mk_equality (t, false_as_term)))
11.41 + | eval_contains_root _ _ _ _ = None;
11.42 +
11.43 +(** term order **)
11.44 +fun term_order (_:subst) tu = (term_ordI [] tu = LESS);
11.45 +
11.46 +(** rule sets **)
11.47 +
11.48 +val testerls =
11.49 + Rls {id = "testerls", preconds = [], rew_ord = ("termlessI",termlessI),
11.50 + erls = e_rls, srls = Erls, calc = [], asm_thm = [],
11.51 + rules = [Thm ("refl",num_str refl),
11.52 + Thm ("le_refl",num_str le_refl),
11.53 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
11.54 + Thm ("not_true",num_str not_true),
11.55 + Thm ("not_false",num_str not_false),
11.56 + Thm ("and_true",and_true),
11.57 + Thm ("and_false",and_false),
11.58 + Thm ("or_true",or_true),
11.59 + Thm ("or_false",or_false),
11.60 + Thm ("and_commute",num_str and_commute),
11.61 + Thm ("or_commute",num_str or_commute),
11.62 +
11.63 + Calc ("Atools.is'_const",eval_const "#is_const_"),
11.64 + Calc ("Tools.matches",eval_matches ""),
11.65 +
11.66 + Calc ("op +",eval_binop "#add_"),
11.67 + Calc ("op *",eval_binop "#mult_"),
11.68 + Calc ("Atools.pow" ,eval_binop "#power_"),
11.69 +
11.70 + Calc ("op <",eval_equ "#less_"),
11.71 + Calc ("op <=",eval_equ "#less_equal_"),
11.72 +
11.73 + Calc ("Atools.ident",eval_ident "#ident_")],
11.74 + scr = Script ((term_of o the o (parse thy))
11.75 + "empty_script")
11.76 + }:rls;
11.77 +
11.78 +(*.for evaluation of conditions in rewrite rules.*)
11.79 +(*FIXXXXXXME 10.8.02: handle like _simplify*)
11.80 +val tval_rls =
11.81 + Rls{id = "tval_rls", preconds = [],
11.82 + rew_ord = ("sqrt_right",sqrt_right false ProtoPure.thy),
11.83 + erls=testerls,srls = e_rls, calc=[],asm_thm = [],
11.84 + rules = [Thm ("refl",num_str refl),
11.85 + Thm ("le_refl",num_str le_refl),
11.86 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
11.87 + Thm ("not_true",num_str not_true),
11.88 + Thm ("not_false",num_str not_false),
11.89 + Thm ("and_true",and_true),
11.90 + Thm ("and_false",and_false),
11.91 + Thm ("or_true",or_true),
11.92 + Thm ("or_false",or_false),
11.93 + Thm ("and_commute",num_str and_commute),
11.94 + Thm ("or_commute",num_str or_commute),
11.95 +
11.96 + Thm ("real_diff_minus",num_str real_diff_minus),
11.97 +
11.98 + Thm ("root_ge0",num_str root_ge0),
11.99 + Thm ("root_add_ge0",num_str root_add_ge0),
11.100 + Thm ("root_ge0_1",num_str root_ge0_1),
11.101 + Thm ("root_ge0_2",num_str root_ge0_2),
11.102 +
11.103 + Calc ("Atools.is'_const",eval_const "#is_const_"),
11.104 + Calc ("Test.is'_root'_free",eval_root_free "#is_root_free_"),
11.105 + Calc ("Tools.matches",eval_matches ""),
11.106 + Calc ("Test.contains'_root",
11.107 + eval_contains_root"#contains_root_"),
11.108 +
11.109 + Calc ("op +",eval_binop "#add_"),
11.110 + Calc ("op *",eval_binop "#mult_"),
11.111 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
11.112 + Calc ("Atools.pow" ,eval_binop "#power_"),
11.113 +
11.114 + Calc ("op <",eval_equ "#less_"),
11.115 + Calc ("op <=",eval_equ "#less_equal_"),
11.116 +
11.117 + Calc ("Atools.ident",eval_ident "#ident_")],
11.118 + scr = Script ((term_of o the o (parse thy))
11.119 + "empty_script")
11.120 + }:rls;
11.121 +
11.122 +
11.123 +ruleset' := overwritel (!ruleset',
11.124 + [("testerls", testerls)
11.125 + ]);
11.126 +
11.127 +
11.128 +(*make () dissappear*)
11.129 +val rearrange_assoc =
11.130 + Rls{id = "rearrange_assoc", preconds = [],
11.131 + rew_ord = ("e_rew_ord",e_rew_ord),
11.132 + erls = e_rls, srls = e_rls, calc = [], asm_thm=[],
11.133 + rules =
11.134 + [Thm ("radd_assoc_RS_sym",num_str (radd_assoc RS sym)),
11.135 + Thm ("rmult_assoc_RS_sym",num_str (rmult_assoc RS sym))],
11.136 + scr = Script ((term_of o the o (parse thy))
11.137 + "empty_script")
11.138 + }:rls;
11.139 +
11.140 +val ac_plus_times =
11.141 + Rls{id = "ac_plus_times", preconds = [], rew_ord = ("term_order",term_order),
11.142 + erls = e_rls, srls = e_rls, calc = [], asm_thm=[],
11.143 + rules =
11.144 + [Thm ("radd_commute",radd_commute),
11.145 + Thm ("radd_left_commute",radd_left_commute),
11.146 + Thm ("radd_assoc",radd_assoc),
11.147 + Thm ("rmult_commute",rmult_commute),
11.148 + Thm ("rmult_left_commute",rmult_left_commute),
11.149 + Thm ("rmult_assoc",rmult_assoc)],
11.150 + scr = Script ((term_of o the o (parse thy))
11.151 + "empty_script")
11.152 + }:rls;
11.153 +
11.154 +(*todo: replace by Rewrite("rnorm_equation_add",num_str rnorm_equation_add)*)
11.155 +val norm_equation =
11.156 + Rls{id = "norm_equation", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
11.157 + erls = tval_rls, srls = e_rls, calc = [], asm_thm=[],
11.158 + rules = [Thm ("rnorm_equation_add",num_str rnorm_equation_add)
11.159 + ],
11.160 + scr = Script ((term_of o the o (parse thy))
11.161 + "empty_script")
11.162 + }:rls;
11.163 +
11.164 +(** problem types **)
11.165 +store_pbt
11.166 + (prep_pbt Test.thy
11.167 + (["test"],
11.168 + [],
11.169 + e_rls, None, []));
11.170 +store_pbt
11.171 + (prep_pbt Test.thy
11.172 + (["equation","test"],
11.173 + [("#Given" ,["equality e_","solveFor v_"]),
11.174 + ("#Where" ,["matches (?a = ?b) e_"]),
11.175 + ("#Find" ,["solutions v_i_"])
11.176 + ],
11.177 + append_rls "matches" e_rls [Calc ("Tools.matches",eval_matches "#matches_")],
11.178 + None, []));
11.179 +
11.180 +store_pbt
11.181 + (prep_pbt Test.thy
11.182 + (["univariate","equation","test"],
11.183 + [("#Given" ,["equality e_","solveFor v_"]),
11.184 + ("#Where" ,["matches (?a = ?b) e_"]),
11.185 + ("#Find" ,["solutions v_i_"])
11.186 + ],
11.187 + append_rls "matches" e_rls [Calc ("Tools.matches",eval_matches "#matches_")],
11.188 + None, []));
11.189 +
11.190 +store_pbt
11.191 + (prep_pbt Test.thy
11.192 + (["linear","univariate","equation","test"],
11.193 + [("#Given" ,["equality e_","solveFor v_"]),
11.194 + ("#Where" ,["(matches ( v_ = 0) e_) | (matches ( ?b*v_ = 0) e_) |\
11.195 + \(matches (?a+v_ = 0) e_) | (matches (?a+?b*v_ = 0) e_) "]),
11.196 + ("#Find" ,["solutions v_i_"])
11.197 + ],
11.198 + append_rls "matches" testerls
11.199 + [Calc ("Tools.matches",eval_matches "#matches_")],
11.200 + None, [("Test.thy","solve_linear")]));
11.201 +
11.202 +(*25.8.01 ------
11.203 +store_pbt
11.204 + (prep_pbt Test.thy
11.205 + (["Test.thy"],
11.206 + [("#Given" ,"boolTestGiven g_"),
11.207 + ("#Find" ,"boolTestFind f_")
11.208 + ],
11.209 + []));
11.210 +
11.211 +store_pbt
11.212 + (prep_pbt Test.thy
11.213 + (["testeq","Test.thy"],
11.214 + [("#Given" ,"boolTestGiven g_"),
11.215 + ("#Find" ,"boolTestFind f_")
11.216 + ],
11.217 + []));
11.218 +
11.219 +
11.220 +val ttt = (term_of o the o (parse Isac.thy)) "(matches ( v_ = 0) e_)";
11.221 +
11.222 + ------ 25.8.01*)
11.223 +
11.224 +
11.225 +(** methods **)
11.226 +
11.227 +methods:= overwritel (!methods,
11.228 +[
11.229 + prep_met
11.230 + (e_metID,(*empty method*)
11.231 + [],
11.232 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
11.233 + asm_rls=[],asm_thm=[]},
11.234 + "Undef")
11.235 +,
11.236 + prep_met
11.237 + (("Test.thy","solve_linear"):metID,
11.238 + [("#Given" ,["equality e_","solveFor v_"]),
11.239 + ("#Where" ,["matches (?a = ?b) e_"]),
11.240 + ("#Find" ,["solutions v_i_"])
11.241 + ],
11.242 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,
11.243 + prls=append_rls "matches" e_rls [Calc ("Tools.matches",eval_matches "")],
11.244 + calc=[],asm_rls=[],asm_thm=[]},
11.245 + "Script Solve_linear (e_::bool) (v_::real)= \
11.246 + \(let e_ =\
11.247 + \ Repeat\
11.248 + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
11.249 + \ (Rewrite_Set Test_simplify False))) e_\
11.250 + \ in [e_::bool])"
11.251 + )
11.252 +(*, prep_met (*test for equations*)
11.253 + (("Test.thy","testeq"):metID,
11.254 + [("#Given" ,["boolTestGiven g_"]),
11.255 + ("#Find" ,["boolTestFind f_"])
11.256 + ],
11.257 + {rew_ord'="e_rew_ord",rls'="tval_rls",asm_rls=[],
11.258 + asm_thm=[("square_equation_left","")]},
11.259 + "Script Testeq (eq_::bool) = \
11.260 + \Repeat \
11.261 + \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False eq_)); \
11.262 + \ e_ = Try (Repeat (Rewrite square_equation_left True e_)); \
11.263 + \ e_ = Try (Repeat (Rewrite rmult_0 False e_)) \
11.264 + \ in e_) Until (is_root_free e_)" (*deleted*)
11.265 + )
11.266 +, ---------27.4.02*)
11.267 +]);
11.268 +
11.269 +
11.270 +
11.271 +
11.272 +ruleset' := overwritel (!ruleset',
11.273 + [("norm_equation", norm_equation),
11.274 + ("ac_plus_times",ac_plus_times),
11.275 + ("rearrange_assoc",rearrange_assoc)
11.276 + ]);
11.277 +
11.278 +
11.279 +
11.280 +
11.281 +(*27.8.01: copy from ModelSpec.sml/term_G.sml*)
11.282 +
11.283 +fun id_of (Var ((id,ix),_)) = if ix=0 then id else id^(string_of_int ix)
11.284 + | id_of (Free (id ,_)) = id
11.285 + | id_of (Const(id ,_)) = id
11.286 + | id_of _ = ""; (* never such an identifier *)
11.287 +
11.288 +fun bin_o (Const (op_,(Type ("fun",
11.289 + [Type (s2,[]),Type ("fun",
11.290 + [Type (s4,tl4),Type (s5,tl5)])])))) =
11.291 + if (s2=s4)andalso(s4=s5)then[op_]else[]
11.292 + | bin_o _ = [];
11.293 +
11.294 +fun bin_op (t1 $ t2) = (bin_op t1) union (bin_op t2)
11.295 + | bin_op t = bin_o t;
11.296 +fun is_bin_op t = ((bin_op t)<>[]);
11.297 +
11.298 +fun bin_op_arg1 ((Const (op_,(Type ("fun",
11.299 + [Type (s2,[]),Type ("fun",
11.300 + [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) =
11.301 + arg1;
11.302 +fun bin_op_arg2 ((Const (op_,(Type ("fun",
11.303 + [Type (s2,[]),Type ("fun",
11.304 + [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) =
11.305 + arg2;
11.306 +
11.307 +
11.308 +exception NO_EQUATION_TERM;
11.309 +fun is_equation ((Const ("op =",(Type ("fun",
11.310 + [Type (_,[]),Type ("fun",
11.311 + [Type (_,[]),Type ("bool",[])])])))) $ _ $ _)
11.312 + = true
11.313 + | is_equation _ = false;
11.314 +fun equ_lhs ((Const ("op =",(Type ("fun",
11.315 + [Type (_,[]),Type ("fun",
11.316 + [Type (_,[]),Type ("bool",[])])])))) $ l $ r)
11.317 + = l
11.318 + | equ_lhs _ = raise NO_EQUATION_TERM;
11.319 +fun equ_rhs ((Const ("op =",(Type ("fun",
11.320 + [Type (_,[]),Type ("fun",
11.321 + [Type (_,[]),Type ("bool",[])])])))) $ l $ r)
11.322 + = r
11.323 + | equ_rhs _ = raise NO_EQUATION_TERM;
11.324 +
11.325 +
11.326 +fun atom (Const (_,Type (_,[]))) = true
11.327 + | atom (Free (_,Type (_,[]))) = true
11.328 + | atom (Var (_,Type (_,[]))) = true
11.329 +(*| atom (_ (_,"?DUMMY" )) = true ..ML-error *)
11.330 + | atom((Const ("Bin.integ_of_bin",_)) $ _) = true
11.331 + | atom _ = false;
11.332 +
11.333 +fun varids (Const (s,Type (_,[]))) = [strip_thy s]
11.334 + | varids (Free (s,Type (_,[]))) = if is_no s then []
11.335 + else [strip_thy s]
11.336 + | varids (Var((s,_),Type (_,[]))) = [strip_thy s]
11.337 +(*| varids (_ (s,"?DUMMY" )) = ..ML-error *)
11.338 + | varids((Const ("Bin.integ_of_bin",_)) $ _)= [](*8.01: superfluous?*)
11.339 + | varids (Abs(a,T,t)) = [a] union (varids t)
11.340 + | varids (t1 $ t2) = (varids t1) union (varids t2)
11.341 + | varids _ = [];
11.342 +(*> val t = term_of (hd (parse Diophant.thy "x"));
11.343 +val t = Free ("x","?DUMMY") : term
11.344 +> varids t;
11.345 +val it = [] : string list [] !!! *)
11.346 +
11.347 +
11.348 +fun bin_ops_only ((Const op_) $ t1 $ t2) =
11.349 + if(is_bin_op (Const op_))
11.350 + then(bin_ops_only t1)andalso(bin_ops_only t2)
11.351 + else false
11.352 + | bin_ops_only t =
11.353 + if atom t then true else bin_ops_only t;
11.354 +
11.355 +fun polynomial opl t bdVar = (* bdVar TODO *)
11.356 + (bin_op t) subset opl andalso (bin_ops_only t);
11.357 +
11.358 +fun poly_equ opl bdVar t = is_equation t (* bdVar TODO *)
11.359 + andalso polynomial opl (equ_lhs t) bdVar
11.360 + andalso polynomial opl (equ_rhs t) bdVar
11.361 + andalso ((varids bdVar) subset (varids (equ_lhs t))
11.362 + orelse(varids bdVar) subset (varids (equ_lhs t)));
11.363 +
11.364 +(*fun max is =
11.365 + let fun max_ m [] = m
11.366 + | max_ m (i::is) = if m<i then max_ i is else max_ m is;
11.367 + in max_ (hd is) is end;
11.368 +> max [1,5,3,7,4,2];
11.369 +val it = 7 : int *)
11.370 +
11.371 +fun max (a,b) = if a < b then b else a;
11.372 +
11.373 +fun degree addl mul bdVar t =
11.374 +let
11.375 +fun deg _ _ v (Const (s,Type (_,[]))) = if v=strip_thy s then 1 else 0
11.376 + | deg _ _ v (Free (s,Type (_,[]))) = if v=strip_thy s then 1 else 0
11.377 + | deg _ _ v (Var((s,_),Type (_,[]))) = if v=strip_thy s then 1 else 0
11.378 +(*| deg _ _ v (_ (s,"?DUMMY" )) = ..ML-error *)
11.379 + | deg _ _ v((Const ("Bin.integ_of_bin",_)) $ _ )= 0
11.380 + | deg addl mul v (h $ t1 $ t2) =
11.381 + if(bin_op h)subset addl
11.382 + then max (deg addl mul v t1 ,deg addl mul v t2)
11.383 + else (*mul!*)(deg addl mul v t1)+(deg addl mul v t2)
11.384 +in if polynomial (addl @ [mul]) t bdVar
11.385 + then Some (deg addl mul (id_of bdVar) t) else (None:int option)
11.386 +end;
11.387 +fun degree_ addl mul bdVar t = (* do not export *)
11.388 + let fun opt (Some i)= i
11.389 + | opt None = 0
11.390 +in opt (degree addl mul bdVar t) end;
11.391 +
11.392 +
11.393 +fun linear addl mul t bdVar = (degree_ addl mul bdVar t)<2;
11.394 +
11.395 +fun linear_equ addl mul bdVar t =
11.396 + if is_equation t
11.397 + then let val degl = degree_ addl mul bdVar (equ_lhs t);
11.398 + val degr = degree_ addl mul bdVar (equ_rhs t)
11.399 + in if (degl>0 orelse degr>0)andalso max(degl,degr)<2
11.400 + then true else false
11.401 + end
11.402 + else false;
11.403 +(* strip_thy op_ before *)
11.404 +fun is_div_op (dv,(Const (op_,(Type ("fun",
11.405 + [Type (s2,[]),Type ("fun",
11.406 + [Type (s4,tl4),Type (s5,tl5)])])))) )= (dv = strip_thy op_)
11.407 + | is_div_op _ = false;
11.408 +
11.409 +fun is_denom bdVar div_op t =
11.410 + let fun is bool[v]dv (Const (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
11.411 + | is bool[v]dv (Free (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
11.412 + | is bool[v]dv (Var((s,_),Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
11.413 + | is bool[v]dv((Const ("Bin.integ_of_bin",_)) $ _) = false
11.414 + | is bool[v]dv (h$n$d) =
11.415 + if is_div_op(dv,h)
11.416 + then (is false[v]dv n)orelse(is true[v]dv d)
11.417 + else (is bool [v]dv n)orelse(is bool[v]dv d)
11.418 +in is false (varids bdVar) (strip_thy div_op) t end;
11.419 +
11.420 +
11.421 +fun rational t div_op bdVar =
11.422 + is_denom bdVar div_op t andalso bin_ops_only t;
11.423 +
11.424 +
11.425 +
11.426 +(** problem types **)
11.427 +
11.428 +store_pbt
11.429 + (prep_pbt Test.thy
11.430 + (["plain_square","univariate","equation","test"],
11.431 + [("#Given" ,["equality e_","solveFor v_"]),
11.432 + ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\
11.433 + \(matches ( ?b*v_ ^^^2 = 0) e_) |\
11.434 + \(matches (?a + v_ ^^^2 = 0) e_) |\
11.435 + \(matches ( v_ ^^^2 = 0) e_)"]),
11.436 + ("#Find" ,["solutions v_i_"])
11.437 + ],
11.438 + append_rls "matches" testerls
11.439 + [Calc ("Tools.matches",eval_matches "#matches_")],
11.440 + None, [("Test.thy","solve_plain_square")]));
11.441 +(*
11.442 + val e_ = (term_of o the o (parse thy)) "e_::bool";
11.443 + val ve = (term_of o the o (parse thy)) "4 + 3*x^^^2 = 0";
11.444 + val env = [(e_,ve)];
11.445 +
11.446 + val pre = (term_of o the o (parse thy))
11.447 + "(matches (a + b*v_ ^^^2 = 0, e_::bool)) |\
11.448 + \(matches ( b*v_ ^^^2 = 0, e_::bool)) |\
11.449 + \(matches (a + v_ ^^^2 = 0, e_::bool)) |\
11.450 + \(matches ( v_ ^^^2 = 0, e_::bool))";
11.451 + val prei = subst_atomic env pre;
11.452 + val cpre = cterm_of (sign_of thy) prei;
11.453 +
11.454 + val Some (ct,_) = rewrite_set_ thy false tval_rls cpre;
11.455 +val ct = "True | False | False | False" : cterm
11.456 +
11.457 +> val Some (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
11.458 +> val Some (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
11.459 +> val Some (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
11.460 +val ct = "True" : cterm
11.461 +
11.462 +*)
11.463 +
11.464 +store_pbt
11.465 + (prep_pbt Test.thy
11.466 + (["polynomial","univariate","equation","test"],
11.467 + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q_ = 0)","solveFor v_"]),
11.468 + ("#Where" ,["False"]),
11.469 + ("#Find" ,["solutions v_i_"])
11.470 + ],
11.471 + e_rls, None, []));
11.472 +
11.473 +store_pbt
11.474 + (prep_pbt Test.thy
11.475 + (["degree_two","polynomial","univariate","equation","test"],
11.476 + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q_ = 0)","solveFor v_"]),
11.477 + ("#Find" ,["solutions v_i_"])
11.478 + ],
11.479 + e_rls, None, []));
11.480 +
11.481 +store_pbt
11.482 + (prep_pbt Test.thy
11.483 + (["pq_formula","degree_two","polynomial","univariate","equation","test"],
11.484 + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q_ = 0)","solveFor v_"]),
11.485 + ("#Find" ,["solutions v_i_"])
11.486 + ],
11.487 + e_rls, None, []));
11.488 +
11.489 +store_pbt
11.490 + (prep_pbt Test.thy
11.491 + (["abc_formula","degree_two","polynomial","univariate","equation","test"],
11.492 + [("#Given" ,["equality (a_ * x ^^^2 + b_ * x + c_ = 0)","solveFor v_"]),
11.493 + ("#Find" ,["solutions v_i_"])
11.494 + ],
11.495 + e_rls, None, []));
11.496 +
11.497 +store_pbt
11.498 + (prep_pbt Test.thy
11.499 + (["squareroot","univariate","equation","test"],
11.500 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.501 + ("#Where" ,["contains_root (e_::bool)"]),
11.502 + ("#Find" ,["solutions v_i_"])
11.503 + ],
11.504 + append_rls "contains_root" e_rls [Calc ("Test.contains'_root",
11.505 + eval_contains_root "#contains_root_")],
11.506 + None, [("Test.thy","square_equation")]));
11.507 +
11.508 +store_pbt
11.509 + (prep_pbt Test.thy
11.510 + (["normalize","univariate","equation","test"],
11.511 + [("#Given" ,["equality e_","solveFor v_"]),
11.512 + ("#Where" ,[]),
11.513 + ("#Find" ,["solutions v_i_"])
11.514 + ],
11.515 + e_rls, None, [("Test.thy","norm_univar_equation")]));
11.516 +
11.517 +store_pbt
11.518 + (prep_pbt Test.thy
11.519 + (["sqroot-test","univariate","equation","test"],
11.520 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.521 + (*("#Where" ,["contains_root (e_::bool)"]),*)
11.522 + ("#Find" ,["solutions v_i_"])
11.523 + ],
11.524 + e_rls, None, []));
11.525 +
11.526 +(*
11.527 +(#ppc o get_pbt) ["sqroot-test","univariate","equation"];
11.528 + *)
11.529 +
11.530 +
11.531 +methods:= overwritel (!methods,
11.532 +[
11.533 + prep_met (*root-equation, version for tests before 8.01.01*)
11.534 + (("Test.thy","sqrt-equ-test"):metID,
11.535 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.536 + ("#Where" ,["contains_root (e_::bool)"]),
11.537 + ("#Find" ,["solutions v_i_"])
11.538 + ],
11.539 + {rew_ord'="e_rew_ord",rls'=tval_rls,
11.540 + srls =append_rls "srls_contains_root" e_rls
11.541 + [Calc ("Test.contains'_root",eval_contains_root "")],
11.542 + prls =append_rls "prls_contains_root" e_rls
11.543 + [Calc ("Test.contains'_root",eval_contains_root "")],
11.544 + calc=[],asm_rls=[],
11.545 + asm_thm=[("square_equation_left",""),
11.546 + ("square_equation_right","")]},
11.547 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.548 + \(let e_ = \
11.549 + \ ((While (contains_root e_) Do\
11.550 + \ ((Rewrite square_equation_left True) @@\
11.551 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.552 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
11.553 + \ (Try (Rewrite_Set isolate_root False)) @@\
11.554 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
11.555 + \ (Try (Rewrite_Set norm_equation False)) @@\
11.556 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.557 + \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
11.558 + \ (Try (Rewrite_Set Test_simplify False)))\
11.559 + \ e_\
11.560 + \ in [e_::bool])"
11.561 + )
11.562 +,
11.563 + prep_met (*root-equation ... for test-*.sml until 8.01*)
11.564 + (("Test.thy","squ-equ-test2"):metID,
11.565 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.566 + ("#Find" ,["solutions v_i_"])
11.567 + ],
11.568 + {rew_ord'="e_rew_ord",rls'=tval_rls,
11.569 + srls = append_rls "srls_contains_root" e_rls
11.570 + [Calc ("Test.contains'_root",eval_contains_root"")],
11.571 + prls=e_rls,calc=[],asm_rls=[],
11.572 + asm_thm=[("square_equation_left",""),
11.573 + ("square_equation_right","")]},
11.574 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.575 + \(let e_ = \
11.576 + \ ((While (contains_root e_) Do\
11.577 + \ ((Rewrite square_equation_left True) @@\
11.578 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.579 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
11.580 + \ (Try (Rewrite_Set isolate_root False)) @@\
11.581 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
11.582 + \ (Try (Rewrite_Set norm_equation False)) @@\
11.583 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.584 + \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
11.585 + \ (Try (Rewrite_Set Test_simplify False)))\
11.586 + \ e_;\
11.587 + \ (L_::real list) = Mstep subproblem_equation_dummy; \
11.588 + \ L_ = Mstep solve_equation_dummy \
11.589 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
11.590 + )
11.591 +,
11.592 + prep_met (*tests subproblem fixed linear*)
11.593 + (("Test.thy","squ-equ-test-subpbl1"):metID,
11.594 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.595 + ("#Find" ,["solutions v_i_"])
11.596 + ],
11.597 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
11.598 + asm_rls=[],asm_thm=[("square_equation_left",""),
11.599 + ("square_equation_right","")]},
11.600 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.601 + \ (let e_ = ((Try (Rewrite_Set norm_equation False)) @@ \
11.602 + \ (Try (Rewrite_Set Test_simplify False))) e_; \
11.603 + \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
11.604 + \ (Test_,solve_linear)) [bool_ e_, real_ v_])\
11.605 + \in Check_elementwise L_ {(v_::real). Assumptions})"
11.606 + )
11.607 +,
11.608 + prep_met (*tests subproblem fixed degree 2*)
11.609 + (("Test.thy","squ-equ-test-subpbl2"):metID,
11.610 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.611 + ("#Find" ,["solutions v_i_"])
11.612 + ],
11.613 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
11.614 + asm_rls=[],asm_thm=[("square_equation_left",""),
11.615 + ("square_equation_right","")]},
11.616 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.617 + \ (let e_ = Try (Rewrite_Set norm_equation False) e_; \
11.618 + \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
11.619 + \ (Test_,solve_by_pq_formula)) [bool_ e_, real_ v_])\
11.620 + \in Check_elementwise L_ {(v_::real). Assumptions})"
11.621 + )
11.622 +,
11.623 + prep_met (*root-equation: see foils..., but notTerminating*)
11.624 + (("Test.thy","square_equation...notTerminating"):metID,
11.625 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.626 + ("#Find" ,["solutions v_i_"])
11.627 + ],
11.628 + {rew_ord'="e_rew_ord",rls'=tval_rls,
11.629 + srls = append_rls "srls_contains_root" e_rls
11.630 + [Calc ("Test.contains'_root",eval_contains_root"")],
11.631 + prls=e_rls,calc=[],asm_rls=[],
11.632 + asm_thm=[("square_equation_left",""),
11.633 + ("square_equation_right","")]},
11.634 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.635 + \(let e_ = \
11.636 + \ ((While (contains_root e_) Do\
11.637 + \ ((Rewrite square_equation_left True) @@\
11.638 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.639 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
11.640 + \ (Try (Rewrite_Set isolate_root False)) @@\
11.641 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
11.642 + \ (Try (Rewrite_Set norm_equation False)) @@\
11.643 + \ (Try (Rewrite_Set Test_simplify False)))\
11.644 + \ e_;\
11.645 + \ (L_::bool list) = \
11.646 + \ (SubProblem (Test_,[linear,univariate,equation,test],\
11.647 + \ (Test_,solve_linear)) [bool_ e_, real_ v_])\
11.648 + \in Check_elementwise L_ {(v_::real). Assumptions})"
11.649 + )
11.650 +,
11.651 + prep_met (*root-equation1:*)
11.652 + (("Test.thy","square_equation1"):metID,
11.653 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.654 + ("#Find" ,["solutions v_i_"])
11.655 + ],
11.656 + {rew_ord'="e_rew_ord",rls'=tval_rls,
11.657 + srls = append_rls "srls_contains_root" e_rls
11.658 + [Calc ("Test.contains'_root",eval_contains_root"")],
11.659 + prls=e_rls,calc=[],asm_rls=[],
11.660 + asm_thm=[("square_equation_left",""),
11.661 + ("square_equation_right","")]},
11.662 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.663 + \(let e_ = \
11.664 + \ ((While (contains_root e_) Do\
11.665 + \ ((Rewrite square_equation_left True) @@\
11.666 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.667 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
11.668 + \ (Try (Rewrite_Set isolate_root False)) @@\
11.669 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
11.670 + \ (Try (Rewrite_Set norm_equation False)) @@\
11.671 + \ (Try (Rewrite_Set Test_simplify False)))\
11.672 + \ e_;\
11.673 + \ (L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
11.674 + \ (Test_,solve_linear)) [bool_ e_, real_ v_])\
11.675 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
11.676 + )
11.677 +,
11.678 + prep_met (*root-equation2*)
11.679 + (("Test.thy","square_equation2"):metID,
11.680 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.681 + ("#Find" ,["solutions v_i_"])
11.682 + ],
11.683 + {rew_ord'="e_rew_ord",rls'=tval_rls,
11.684 + srls = append_rls "srls_contains_root" e_rls
11.685 + [Calc ("Test.contains'_root",eval_contains_root"")],
11.686 + prls=e_rls,calc=[],asm_rls=[],
11.687 + asm_thm=[("square_equation_left",""),
11.688 + ("square_equation_right","")]},
11.689 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.690 + \(let e_ = \
11.691 + \ ((While (contains_root e_) Do\
11.692 + \ (((Rewrite square_equation_left True) Or \
11.693 + \ (Rewrite square_equation_right True)) @@\
11.694 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.695 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
11.696 + \ (Try (Rewrite_Set isolate_root False)) @@\
11.697 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
11.698 + \ (Try (Rewrite_Set norm_equation False)) @@\
11.699 + \ (Try (Rewrite_Set Test_simplify False)))\
11.700 + \ e_;\
11.701 + \ (L_::bool list) = (SubProblem (Test_,[plain_square,univariate,equation,test],\
11.702 + \ (Test_,solve_plain_square)) [bool_ e_, real_ v_])\
11.703 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
11.704 + )
11.705 +,
11.706 + prep_met (*root-equation*)
11.707 + (("Test.thy","square_equation"):metID,
11.708 + [("#Given" ,["equality e_","solveFor v_","errorBound err_"]),
11.709 + ("#Find" ,["solutions v_i_"])
11.710 + ],
11.711 + {rew_ord'="e_rew_ord",rls'=tval_rls,
11.712 + srls = append_rls "srls_contains_root" e_rls
11.713 + [Calc ("Test.contains'_root",eval_contains_root"")],
11.714 + prls=e_rls,calc=[],asm_rls=[],
11.715 + asm_thm=[("square_equation_left",""),
11.716 + ("square_equation_right","")]},
11.717 + "Script Solve_root_equation (e_::bool) (v_::real) (err_::bool) = \
11.718 + \(let e_ = \
11.719 + \ ((While (contains_root e_) Do\
11.720 + \ (((Rewrite square_equation_left True) Or\
11.721 + \ (Rewrite square_equation_right True)) @@\
11.722 + \ (Try (Rewrite_Set Test_simplify False)) @@\
11.723 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
11.724 + \ (Try (Rewrite_Set isolate_root False)) @@\
11.725 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
11.726 + \ (Try (Rewrite_Set norm_equation False)) @@\
11.727 + \ (Try (Rewrite_Set Test_simplify False)))\
11.728 + \ e_;\
11.729 + \ (L_::bool list) = (SubProblem (Test_,[univariate,equation,test],\
11.730 + \ (Test_,no_met)) [bool_ e_, real_ v_])\
11.731 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
11.732 + ) (*#######*)
11.733 +,
11.734 + prep_met (*solve_plain_square*)
11.735 + (("Test.thy","solve_plain_square"):metID,
11.736 + [("#Given",["equality e_","solveFor v_"]),
11.737 + ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\
11.738 + \(matches ( ?b*v_ ^^^2 = 0) e_) |\
11.739 + \(matches (?a + v_ ^^^2 = 0) e_) |\
11.740 + \(matches ( v_ ^^^2 = 0) e_)"]),
11.741 + ("#Find" ,["solutions v_i_"])
11.742 + ],
11.743 + {rew_ord'="e_rew_ord",rls'=tval_rls,calc=[],srls=e_rls,
11.744 + prls = append_rls "prls_matches" testerls
11.745 + [Calc("Tools.matches",eval_matches"#matches_")],
11.746 + asm_rls=[],asm_thm=[]},
11.747 + "Script Solve_plain_square (e_::bool) (v_::real) = \
11.748 + \ (let e_ = ((Try (Rewrite_Set isolate_bdv False)) @@ \
11.749 + \ (Try (Rewrite_Set Test_simplify False)) @@ \
11.750 + \ ((Rewrite square_equality_0 False) Or \
11.751 + \ (Rewrite square_equality True)) @@ \
11.752 + \ (Try (Rewrite_Set tval_rls False))) e_ \
11.753 + \ in ((Or_to_List e_)::bool list))"
11.754 + )
11.755 +,
11.756 + prep_met
11.757 + (("Test.thy","norm_univar_equation"):metID,
11.758 + [("#Given",["equality e_","solveFor v_"]),
11.759 + ("#Where" ,[]),
11.760 + ("#Find" ,["solutions v_i_"])
11.761 + ],
11.762 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls = e_rls,prls=e_rls,
11.763 + calc=[],asm_rls=[],asm_thm=[]},
11.764 + "Script Norm_univar_equation (e_::bool) (v_::real) = \
11.765 + \ (let e_ = ((Try (Rewrite rnorm_equation_add False)) @@ \
11.766 + \ (Try (Rewrite_Set Test_simplify False))) e_ \
11.767 + \ in (SubProblem (Test_,[univariate,equation,test], \
11.768 + \ (Test_,no_met)) [bool_ e_, real_ v_]))"
11.769 + )
11.770 +
11.771 +]);
11.772 +
11.773 +
11.774 +(** rule sets **)
11.775 +
11.776 +val STest_simplify =
11.777 + "Script STest_simplify (t_::real) = \
11.778 + \(Repeat\
11.779 + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
11.780 + \ (Try (Repeat (Rewrite radd_mult_distrib2 False))) @@ \
11.781 + \ (Try (Repeat (Rewrite rdistr_right_assoc False))) @@ \
11.782 + \ (Try (Repeat (Rewrite rdistr_right_assoc_p False))) @@\
11.783 + \ (Try (Repeat (Rewrite rdistr_div_right False))) @@ \
11.784 + \ (Try (Repeat (Rewrite rbinom_power_2 False))) @@ \
11.785 +
11.786 + \ (Try (Repeat (Rewrite radd_commute False))) @@ \
11.787 + \ (Try (Repeat (Rewrite radd_left_commute False))) @@ \
11.788 + \ (Try (Repeat (Rewrite radd_assoc False))) @@ \
11.789 + \ (Try (Repeat (Rewrite rmult_commute False))) @@ \
11.790 + \ (Try (Repeat (Rewrite rmult_left_commute False))) @@ \
11.791 + \ (Try (Repeat (Rewrite rmult_assoc False))) @@ \
11.792 +
11.793 + \ (Try (Repeat (Rewrite radd_real_const_eq False))) @@ \
11.794 + \ (Try (Repeat (Rewrite radd_real_const False))) @@ \
11.795 + \ (Try (Repeat (Calculate plus))) @@ \
11.796 + \ (Try (Repeat (Calculate times))) @@ \
11.797 + \ (Try (Repeat (Calculate divide_))) @@\
11.798 + \ (Try (Repeat (Calculate power_))) @@ \
11.799 +
11.800 + \ (Try (Repeat (Rewrite rcollect_right False))) @@ \
11.801 + \ (Try (Repeat (Rewrite rcollect_one_left False))) @@ \
11.802 + \ (Try (Repeat (Rewrite rcollect_one_left_assoc False))) @@ \
11.803 + \ (Try (Repeat (Rewrite rcollect_one_left_assoc_p False))) @@ \
11.804 +
11.805 + \ (Try (Repeat (Rewrite rshift_nominator False))) @@ \
11.806 + \ (Try (Repeat (Rewrite rcancel_den False))) @@ \
11.807 + \ (Try (Repeat (Rewrite rroot_square_inv False))) @@ \
11.808 + \ (Try (Repeat (Rewrite rroot_times_root False))) @@ \
11.809 + \ (Try (Repeat (Rewrite rroot_times_root_assoc_p False))) @@ \
11.810 + \ (Try (Repeat (Rewrite rsqare False))) @@ \
11.811 + \ (Try (Repeat (Rewrite power_1 False))) @@ \
11.812 + \ (Try (Repeat (Rewrite rtwo_of_the_same False))) @@ \
11.813 + \ (Try (Repeat (Rewrite rtwo_of_the_same_assoc_p False))) @@ \
11.814 +
11.815 + \ (Try (Repeat (Rewrite rmult_1 False))) @@ \
11.816 + \ (Try (Repeat (Rewrite rmult_1_right False))) @@ \
11.817 + \ (Try (Repeat (Rewrite rmult_0 False))) @@ \
11.818 + \ (Try (Repeat (Rewrite rmult_0_right False))) @@ \
11.819 + \ (Try (Repeat (Rewrite radd_0 False))) @@ \
11.820 + \ (Try (Repeat (Rewrite radd_0_right False)))) \
11.821 + \ t_)";
11.822 +
11.823 +
11.824 +(* expects * distributed over + *)
11.825 +val Test_simplify =
11.826 + Rls{id = "Test_simplify", preconds = [],
11.827 + rew_ord = ("sqrt_right",sqrt_right false ProtoPure.thy),
11.828 + erls = tval_rls, srls = e_rls,
11.829 + calc=[("plus" , ("op +", eval_binop "#add_")),
11.830 + ("times" , ("op *", eval_binop "#mult_")),
11.831 + ("divide_" ,("HOL.divide" ,eval_cancel "#divide_")),
11.832 + ("power_", ("Atools.pow", eval_binop "#power_"))
11.833 + ],
11.834 + asm_thm = [],
11.835 + rules = [
11.836 + Thm ("real_diff_minus",num_str real_diff_minus),
11.837 + Thm ("radd_mult_distrib2",num_str radd_mult_distrib2),
11.838 + Thm ("rdistr_right_assoc",num_str rdistr_right_assoc),
11.839 + Thm ("rdistr_right_assoc_p",num_str rdistr_right_assoc_p),
11.840 + Thm ("rdistr_div_right",num_str rdistr_div_right),
11.841 + Thm ("rbinom_power_2",num_str rbinom_power_2),
11.842 +
11.843 + Thm ("radd_commute",num_str radd_commute),
11.844 + Thm ("radd_left_commute",num_str radd_left_commute),
11.845 + Thm ("radd_assoc",num_str radd_assoc),
11.846 + Thm ("rmult_commute",num_str rmult_commute),
11.847 + Thm ("rmult_left_commute",num_str rmult_left_commute),
11.848 + Thm ("rmult_assoc",num_str rmult_assoc),
11.849 +
11.850 + Thm ("radd_real_const_eq",num_str radd_real_const_eq),
11.851 + Thm ("radd_real_const",num_str radd_real_const),
11.852 + (* these 2 rules are invers to distr_div_right wrt. termination.
11.853 + thus they MUST be done IMMEDIATELY before calc *)
11.854 + Calc ("op +", eval_binop "#add_"),
11.855 + Calc ("op *", eval_binop "#mult_"),
11.856 + Calc ("HOL.divide", eval_cancel "#divide_"),
11.857 + Calc ("Atools.pow", eval_binop "#power_"),
11.858 +
11.859 + Thm ("rcollect_right",num_str rcollect_right),
11.860 + Thm ("rcollect_one_left",num_str rcollect_one_left),
11.861 + Thm ("rcollect_one_left_assoc",num_str rcollect_one_left_assoc),
11.862 + Thm ("rcollect_one_left_assoc_p",num_str rcollect_one_left_assoc_p),
11.863 +
11.864 + Thm ("rshift_nominator",num_str rshift_nominator),
11.865 + Thm ("rcancel_den",num_str rcancel_den),
11.866 + Thm ("rroot_square_inv",num_str rroot_square_inv),
11.867 + Thm ("rroot_times_root",num_str rroot_times_root),
11.868 + Thm ("rroot_times_root_assoc_p",num_str rroot_times_root_assoc_p),
11.869 + Thm ("rsqare",num_str rsqare),
11.870 + Thm ("power_1",num_str power_1),
11.871 + Thm ("rtwo_of_the_same",num_str rtwo_of_the_same),
11.872 + Thm ("rtwo_of_the_same_assoc_p",num_str rtwo_of_the_same_assoc_p),
11.873 +
11.874 + Thm ("rmult_1",num_str rmult_1),
11.875 + Thm ("rmult_1_right",num_str rmult_1_right),
11.876 + Thm ("rmult_0",num_str rmult_0),
11.877 + Thm ("rmult_0_right",num_str rmult_0_right),
11.878 + Thm ("radd_0",num_str radd_0),
11.879 + Thm ("radd_0_right",num_str radd_0_right)
11.880 + ],
11.881 + scr = Script ((term_of o the o (parse thy)) STest_simplify)
11.882 + }:rls;
11.883 +
11.884 +
11.885 +
11.886 +
11.887 +
11.888 +(** rule sets **)
11.889 +
11.890 +
11.891 +
11.892 +(*isolate the root in a root-equation*)
11.893 +val isolate_root =
11.894 + Rls{id = "isolate_root", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
11.895 + erls=tval_rls,srls = e_rls, calc=[],asm_thm = [],
11.896 + rules = [Thm ("rroot_to_lhs",num_str rroot_to_lhs),
11.897 + Thm ("rroot_to_lhs_mult",num_str rroot_to_lhs_mult),
11.898 + Thm ("rroot_to_lhs_add_mult",num_str rroot_to_lhs_add_mult),
11.899 + Thm ("risolate_root_add",num_str risolate_root_add),
11.900 + Thm ("risolate_root_mult",num_str risolate_root_mult),
11.901 + Thm ("risolate_root_div",num_str risolate_root_div) ],
11.902 + scr = Script ((term_of o the o (parse thy))
11.903 + "empty_script")
11.904 + }:rls;
11.905 +
11.906 +(*isolate the bound variable in an equation; 'bdv' is a meta-constant*)
11.907 +val isolate_bdv =
11.908 + Rls{id = "isolate_bdv", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
11.909 + erls=tval_rls,srls = e_rls, calc=[],asm_thm = [],
11.910 + rules =
11.911 + [Thm ("risolate_bdv_add",num_str risolate_bdv_add),
11.912 + Thm ("risolate_bdv_mult_add",num_str risolate_bdv_mult_add),
11.913 + Thm ("risolate_bdv_mult",num_str risolate_bdv_mult),
11.914 + Thm ("mult_square",num_str mult_square),
11.915 + Thm ("constant_square",num_str constant_square),
11.916 + Thm ("constant_mult_square",num_str constant_mult_square)
11.917 + ],
11.918 + scr = Script ((term_of o the o (parse thy))
11.919 + "empty_script")
11.920 + }:rls;
11.921 +
11.922 +
11.923 +
11.924 +
11.925 +(* association list for calculate_, calculate
11.926 + "op +" etc. not usable in scripts *)
11.927 +val calclist =
11.928 + [
11.929 + (*as Tools.ML*)
11.930 + ("Var" ,("Tools.Var" ,eval_var "#Var_")),
11.931 + ("matches",("Tools.matches",eval_matches "#matches_")),
11.932 + ("lhs" ,("Tools.lhs" ,eval_lhs "")),
11.933 + (*aus Atools.ML*)
11.934 + ("plus" ,("op +" ,eval_binop "#add_")),
11.935 + ("times" ,("op *" ,eval_binop "#mult_")),
11.936 + ("divide_" ,("HOL.divide" ,eval_cancel "#divide_")),
11.937 + ("power_" ,("Atools.pow" ,eval_binop "#power_")),
11.938 + ("is_const",("Atools.is'_const",eval_const "#is_const_")),
11.939 + ("le" ,("op <" ,eval_equ "#less_")),
11.940 + ("leq" ,("op <=" ,eval_equ "#less_equal_")),
11.941 + ("ident" ,("Atools.ident",eval_ident "#ident_")),
11.942 + (*von hier (ehem.SqRoot*)
11.943 + ("sqrt" ,("Root.sqrt" ,eval_sqrt "#sqrt_")),
11.944 + ("Test.is_root_free",("is'_root'_free", eval_root_free"#is_root_free_")),
11.945 + ("Test.contains_root",("contains'_root",
11.946 + eval_contains_root"#contains_root_"))
11.947 + ];
11.948 +
11.949 +ruleset' := overwritel (!ruleset',
11.950 + [("Test_simplify", Test_simplify),
11.951 + ("tval_rls", tval_rls),
11.952 + ("isolate_root", isolate_root),
11.953 + ("isolate_bdv", isolate_bdv)
11.954 + ]);
11.955 +
11.956 +(*17.9.02 aus SqRoot.ML------------------------------^^^---*)
11.957 +
11.958 +(*8.4.03 aus Poly.ML--------------------------------vvv---
11.959 + make_polynomial ---> make_poly
11.960 + ^-- for user ^-- for systest _ONLY_*)
11.961 +
11.962 +local (*. for make_polytest .*)
11.963 +
11.964 +open Term; (* for type order = EQUAL | LESS | GREATER *)
11.965 +
11.966 +fun pr_ord EQUAL = "EQUAL"
11.967 + | pr_ord LESS = "LESS"
11.968 + | pr_ord GREATER = "GREATER";
11.969 +
11.970 +fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
11.971 + (case a of
11.972 + "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest *)
11.973 + | _ => (((a, 0), T), 0))
11.974 + | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
11.975 + | dest_hd' (Var v) = (v, 2)
11.976 + | dest_hd' (Bound i) = ((("", i), dummyT), 3)
11.977 + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
11.978 +(* RL *)
11.979 +fun get_order_pow (t $ (Free(order,_))) =
11.980 + (case int_of_str (order) of
11.981 + Some d => d
11.982 + | None => 0)
11.983 + | get_order_pow _ = 0;
11.984 +
11.985 +fun size_of_term' (Const(str,_) $ t) =
11.986 + if "Atools.pow"= str then 1000 + size_of_term' t else 1 + size_of_term' t (*WN*)
11.987 + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
11.988 + | size_of_term' (f$t) = size_of_term' f + size_of_term' t
11.989 + | size_of_term' _ = 1;
11.990 +
11.991 +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
11.992 + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
11.993 + | term_ord' pr thy (t, u) =
11.994 + (if pr then
11.995 + let
11.996 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
11.997 + val _=writeln("t= f@ts= \""^
11.998 + ((string_of_cterm o cterm_of (sign_of thy)) f)^"\" @ \"["^
11.999 + (commas(map(string_of_cterm o cterm_of (sign_of thy)) ts))^"]\"");
11.1000 + val _=writeln("u= g@us= \""^
11.1001 + ((string_of_cterm o cterm_of (sign_of thy)) g)^"\" @ \"["^
11.1002 + (commas(map(string_of_cterm o cterm_of (sign_of thy)) us))^"]\"");
11.1003 + val _=writeln("size_of_term(t,u)= ("^
11.1004 + (string_of_int(size_of_term' t))^", "^
11.1005 + (string_of_int(size_of_term' u))^")");
11.1006 + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
11.1007 + val _=writeln("terms_ord(ts,us) = "^
11.1008 + ((pr_ord o terms_ord str false)(ts,us)));
11.1009 + val _=writeln("-------");
11.1010 + in () end
11.1011 + else ();
11.1012 + case int_ord (size_of_term' t, size_of_term' u) of
11.1013 + EQUAL =>
11.1014 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
11.1015 + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
11.1016 + | ord => ord)
11.1017 + end
11.1018 + | ord => ord)
11.1019 +and hd_ord (f, g) = (* ~ term.ML *)
11.1020 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
11.1021 +and terms_ord str pr (ts, us) =
11.1022 + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
11.1023 +in
11.1024 +
11.1025 +fun ord_make_polytest (pr:bool) thy (_:subst) tu =
11.1026 + (term_ord' pr thy(***) tu = LESS );
11.1027 +
11.1028 +end;(*local*)
11.1029 +
11.1030 +rew_ord' := overwritel (!rew_ord',
11.1031 +[("termlessI", termlessI),
11.1032 + ("ord_make_polytest", ord_make_polytest false thy)
11.1033 + ]);
11.1034 +
11.1035 +val scr_make_polytest =
11.1036 +"Script Expand_binomtest t_ =\
11.1037 +\(Repeat \
11.1038 +\((Try (Repeat (Rewrite real_diff_minus False))) @@ \
11.1039 +
11.1040 +\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \
11.1041 +\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \
11.1042 +\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \
11.1043 +\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \
11.1044 +
11.1045 +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
11.1046 +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
11.1047 +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
11.1048 +
11.1049 +\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \
11.1050 +\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \
11.1051 +\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \
11.1052 +\ (Try (Repeat (Rewrite real_add_commute False))) @@ \
11.1053 +\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \
11.1054 +\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \
11.1055 +
11.1056 +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
11.1057 +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
11.1058 +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
11.1059 +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
11.1060 +
11.1061 +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
11.1062 +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
11.1063 +
11.1064 +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
11.1065 +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
11.1066 +
11.1067 +\ (Try (Repeat (Calculate plus ))) @@ \
11.1068 +\ (Try (Repeat (Calculate times ))) @@ \
11.1069 +\ (Try (Repeat (Calculate power_)))) \
11.1070 +\ t_)";
11.1071 +
11.1072 +
11.1073 +val make_polytest =
11.1074 + Rls{id = "make_polytest", preconds = []:term list, rew_ord = ("ord_make_polytest",
11.1075 + ord_make_polytest false Poly.thy),
11.1076 + erls = testerls, srls = Erls,
11.1077 + calc = [("plus" , ("op +", eval_binop "#add_")),
11.1078 + ("times" , ("op *", eval_binop "#mult_")),
11.1079 + ("power_", ("Atools.pow", eval_binop "#power_"))
11.1080 + ],
11.1081 + asm_thm = [],
11.1082 + rules = [Thm ("real_diff_minus",num_str real_diff_minus),
11.1083 + (*"a - b = a + (-1) * b"*)
11.1084 + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
11.1085 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
11.1086 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
11.1087 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
11.1088 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
11.1089 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
11.1090 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
11.1091 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
11.1092 + Thm ("real_mult_1",num_str real_mult_1),
11.1093 + (*"1 * z = z"*)
11.1094 + Thm ("real_mult_0",num_str real_mult_0),
11.1095 + (*"0 * z = 0"*)
11.1096 + Thm ("real_add_zero_left",num_str real_add_zero_left),
11.1097 + (*"0 + z = z"*)
11.1098 +
11.1099 + (*AC-rewriting*)
11.1100 + Thm ("real_mult_commute",num_str real_mult_commute),
11.1101 + (* z * w = w * z *)
11.1102 + Thm ("real_mult_left_commute",num_str real_mult_left_commute),
11.1103 + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
11.1104 + Thm ("real_mult_assoc",num_str real_mult_assoc),
11.1105 + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
11.1106 + Thm ("real_add_commute",num_str real_add_commute),
11.1107 + (*z + w = w + z*)
11.1108 + Thm ("real_add_left_commute",num_str real_add_left_commute),
11.1109 + (*x + (y + z) = y + (x + z)*)
11.1110 + Thm ("real_add_assoc",num_str real_add_assoc),
11.1111 + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
11.1112 +
11.1113 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
11.1114 + (*"r1 * r1 = r1 ^^^ 2"*)
11.1115 + Thm ("realpow_plus_1",num_str realpow_plus_1),
11.1116 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
11.1117 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
11.1118 + (*"z1 + z1 = 2 * z1"*)
11.1119 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
11.1120 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
11.1121 +
11.1122 + Thm ("real_num_collect",num_str real_num_collect),
11.1123 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
11.1124 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
11.1125 + (*"[| l is_const; m is_const |] ==>
11.1126 + l * n + (m * n + k) = (l + m) * n + k"*)
11.1127 + Thm ("real_one_collect",num_str real_one_collect),
11.1128 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
11.1129 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
11.1130 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
11.1131 +
11.1132 + Calc ("op +", eval_binop "#add_"),
11.1133 + Calc ("op *", eval_binop "#mult_"),
11.1134 + Calc ("Atools.pow", eval_binop "#power_")
11.1135 + ],
11.1136 + scr = Script ((term_of o the o (parse thy))
11.1137 + scr_make_polytest)
11.1138 + }:rls;
11.1139 +
11.1140 +val scr_expand_binomtest =
11.1141 +"Script Expand_binomtest t_ =\
11.1142 +\(Repeat \
11.1143 +\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \
11.1144 +\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \
11.1145 +\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \
11.1146 +\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \
11.1147 +\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \
11.1148 +\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \
11.1149 +
11.1150 +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
11.1151 +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
11.1152 +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
11.1153 +
11.1154 +\ (Try (Repeat (Calculate plus ))) @@ \
11.1155 +\ (Try (Repeat (Calculate times ))) @@ \
11.1156 +\ (Try (Repeat (Calculate power_))) @@ \
11.1157 +
11.1158 +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
11.1159 +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
11.1160 +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
11.1161 +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
11.1162 +
11.1163 +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
11.1164 +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
11.1165 +
11.1166 +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
11.1167 +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
11.1168 +
11.1169 +\ (Try (Repeat (Calculate plus ))) @@ \
11.1170 +\ (Try (Repeat (Calculate times ))) @@ \
11.1171 +\ (Try (Repeat (Calculate power_)))) \
11.1172 +\ t_)";
11.1173 +
11.1174 +val expand_binomtest =
11.1175 + Rls{id = "expand_binomtest", preconds = [],
11.1176 + rew_ord = ("termlessI",termlessI),
11.1177 + erls = testerls, srls = Erls,
11.1178 + calc = [("plus" , ("op +", eval_binop "#add_")),
11.1179 + ("times" , ("op *", eval_binop "#mult_")),
11.1180 + ("power_", ("Atools.pow", eval_binop "#power_"))
11.1181 + ],
11.1182 + asm_thm = [],
11.1183 + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
11.1184 + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
11.1185 + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
11.1186 + (*"(a + b)*(a + b) = ...*)
11.1187 + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
11.1188 + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
11.1189 + Thm ("real_minus_binom_times",num_str real_minus_binom_times),
11.1190 + (*"(a - b)*(a - b) = ...*)
11.1191 + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
11.1192 + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
11.1193 + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
11.1194 + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
11.1195 + (*RL 020915*)
11.1196 + Thm ("real_pp_binom_times",num_str real_pp_binom_times),
11.1197 + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
11.1198 + Thm ("real_pm_binom_times",num_str real_pm_binom_times),
11.1199 + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
11.1200 + Thm ("real_mp_binom_times",num_str real_mp_binom_times),
11.1201 + (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
11.1202 + Thm ("real_mm_binom_times",num_str real_mm_binom_times),
11.1203 + (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
11.1204 + Thm ("realpow_multI",num_str realpow_multI),
11.1205 + (*(a*b)^^^n = a^^^n * b^^^n*)
11.1206 + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
11.1207 + (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *)
11.1208 + Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3),
11.1209 + (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *)
11.1210 +
11.1211 +
11.1212 + (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
11.1213 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
11.1214 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
11.1215 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
11.1216 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
11.1217 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
11.1218 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
11.1219 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
11.1220 + *)
11.1221 +
11.1222 + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
11.1223 + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
11.1224 + Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*)
11.1225 +
11.1226 + Calc ("op +", eval_binop "#add_"),
11.1227 + Calc ("op *", eval_binop "#mult_"),
11.1228 + Calc ("Atools.pow", eval_binop "#power_"),
11.1229 + (*
11.1230 + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
11.1231 + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
11.1232 + Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
11.1233 + Thm ("real_add_commute",num_str real_add_commute), (**)
11.1234 + Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
11.1235 + Thm ("real_add_assoc",num_str real_add_assoc), (**)
11.1236 + *)
11.1237 +
11.1238 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
11.1239 + (*"r1 * r1 = r1 ^^^ 2"*)
11.1240 + Thm ("realpow_plus_1",num_str realpow_plus_1),
11.1241 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
11.1242 + (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
11.1243 + (*"z1 + z1 = 2 * z1"*)*)
11.1244 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
11.1245 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
11.1246 +
11.1247 + Thm ("real_num_collect",num_str real_num_collect),
11.1248 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
11.1249 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
11.1250 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
11.1251 + Thm ("real_one_collect",num_str real_one_collect),
11.1252 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
11.1253 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
11.1254 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
11.1255 +
11.1256 + Calc ("op +", eval_binop "#add_"),
11.1257 + Calc ("op *", eval_binop "#mult_"),
11.1258 + Calc ("Atools.pow", eval_binop "#power_")
11.1259 + ],
11.1260 + scr = Script ((term_of o the o (parse thy)) scr_expand_binomtest)
11.1261 + }:rls;
11.1262 +
11.1263 +
11.1264 +ruleset' := overwritel (!ruleset',
11.1265 + [("make_polytest", make_polytest),
11.1266 + ("expand_binomtest", expand_binomtest)
11.1267 + ]);