src/HOL/Tools/numeral_simprocs.ML
changeset 44064 5bce8ff0d9ae
parent 40878 7695e4de4d86
child 44945 2625de88c994
child 44983 b36eedcd1633
equal deleted inserted replaced
44063:4588597ba37e 44064:5bce8ff0d9ae
    95 
    95 
    96 (*Don't reduce fractions; sums must be proved by rule add_frac_eq.
    96 (*Don't reduce fractions; sums must be proved by rule add_frac_eq.
    97   Fractions are reduced later by the cancel_numeral_factor simproc.*)
    97   Fractions are reduced later by the cancel_numeral_factor simproc.*)
    98 fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
    98 fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
    99 
    99 
   100 val mk_divide = HOLogic.mk_binop @{const_name Rings.divide};
   100 val mk_divide = HOLogic.mk_binop @{const_name Fields.divide};
   101 
   101 
   102 (*Build term (p / q) * t*)
   102 (*Build term (p / q) * t*)
   103 fun mk_fcoeff ((p, q), t) =
   103 fun mk_fcoeff ((p, q), t) =
   104   let val T = Term.fastype_of t
   104   let val T = Term.fastype_of t
   105   in mk_times (mk_divide (mk_number T p, mk_number T q), t) end;
   105   in mk_times (mk_divide (mk_number T p, mk_number T q), t) end;
   106 
   106 
   107 (*Express t as a product of a fraction with other sorted terms*)
   107 (*Express t as a product of a fraction with other sorted terms*)
   108 fun dest_fcoeff sign (Const (@{const_name Groups.uminus}, _) $ t) = dest_fcoeff (~sign) t
   108 fun dest_fcoeff sign (Const (@{const_name Groups.uminus}, _) $ t) = dest_fcoeff (~sign) t
   109   | dest_fcoeff sign (Const (@{const_name Rings.divide}, _) $ t $ u) =
   109   | dest_fcoeff sign (Const (@{const_name Fields.divide}, _) $ t $ u) =
   110     let val (p, t') = dest_coeff sign t
   110     let val (p, t') = dest_coeff sign t
   111         val (q, u') = dest_coeff 1 u
   111         val (q, u') = dest_coeff 1 u
   112     in (mk_frac (p, q), mk_divide (t', u')) end
   112     in (mk_frac (p, q), mk_divide (t', u')) end
   113   | dest_fcoeff sign t =
   113   | dest_fcoeff sign t =
   114     let val (p, t') = dest_coeff sign t
   114     let val (p, t') = dest_coeff sign t
   389 
   389 
   390 (*Version for fields*)
   390 (*Version for fields*)
   391 structure DivideCancelNumeralFactor = CancelNumeralFactorFun
   391 structure DivideCancelNumeralFactor = CancelNumeralFactorFun
   392  (open CancelNumeralFactorCommon
   392  (open CancelNumeralFactorCommon
   393   val prove_conv = Arith_Data.prove_conv
   393   val prove_conv = Arith_Data.prove_conv
   394   val mk_bal   = HOLogic.mk_binop @{const_name Rings.divide}
   394   val mk_bal   = HOLogic.mk_binop @{const_name Fields.divide}
   395   val dest_bal = HOLogic.dest_bin @{const_name Rings.divide} Term.dummyT
   395   val dest_bal = HOLogic.dest_bin @{const_name Fields.divide} Term.dummyT
   396   val cancel = @{thm mult_divide_mult_cancel_left} RS trans
   396   val cancel = @{thm mult_divide_mult_cancel_left} RS trans
   397   val neg_exchanges = false
   397   val neg_exchanges = false
   398 )
   398 )
   399 
   399 
   400 structure EqCancelNumeralFactor = CancelNumeralFactorFun
   400 structure EqCancelNumeralFactor = CancelNumeralFactorFun
   568 
   568 
   569 (*Version for all fields, including unordered ones (type complex).*)
   569 (*Version for all fields, including unordered ones (type complex).*)
   570 structure DivideCancelFactor = ExtractCommonTermFun
   570 structure DivideCancelFactor = ExtractCommonTermFun
   571  (open CancelFactorCommon
   571  (open CancelFactorCommon
   572   val prove_conv = Arith_Data.prove_conv
   572   val prove_conv = Arith_Data.prove_conv
   573   val mk_bal   = HOLogic.mk_binop @{const_name Rings.divide}
   573   val mk_bal   = HOLogic.mk_binop @{const_name Fields.divide}
   574   val dest_bal = HOLogic.dest_bin @{const_name Rings.divide} Term.dummyT
   574   val dest_bal = HOLogic.dest_bin @{const_name Fields.divide} Term.dummyT
   575   fun simp_conv _ _ = SOME @{thm mult_divide_mult_cancel_left_if}
   575   fun simp_conv _ _ = SOME @{thm mult_divide_mult_cancel_left_if}
   576 );
   576 );
   577 
   577 
   578 val cancel_factors =
   578 val cancel_factors =
   579   map (Arith_Data.prep_simproc @{theory})
   579   map (Arith_Data.prep_simproc @{theory})
   637  fun proc2 phi ss ct =
   637  fun proc2 phi ss ct =
   638   let
   638   let
   639     val (l,r) = Thm.dest_binop ct
   639     val (l,r) = Thm.dest_binop ct
   640     val T = ctyp_of_term l
   640     val T = ctyp_of_term l
   641   in (case (term_of l, term_of r) of
   641   in (case (term_of l, term_of r) of
   642       (Const(@{const_name Rings.divide},_)$_$_, _) =>
   642       (Const(@{const_name Fields.divide},_)$_$_, _) =>
   643         let val (x,y) = Thm.dest_binop l val z = r
   643         let val (x,y) = Thm.dest_binop l val z = r
   644             val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   644             val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   645             val ynz = prove_nz ss T y
   645             val ynz = prove_nz ss T y
   646         in SOME (Thm.implies_elim (instantiate' [SOME T] (map SOME [y,x,z]) add_frac_num) ynz)
   646         in SOME (Thm.implies_elim (instantiate' [SOME T] (map SOME [y,x,z]) add_frac_num) ynz)
   647         end
   647         end
   648      | (_, Const (@{const_name Rings.divide},_)$_$_) =>
   648      | (_, Const (@{const_name Fields.divide},_)$_$_) =>
   649         let val (x,y) = Thm.dest_binop r val z = l
   649         let val (x,y) = Thm.dest_binop r val z = l
   650             val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   650             val _ = map (HOLogic.dest_number o term_of) [x,y,z]
   651             val ynz = prove_nz ss T y
   651             val ynz = prove_nz ss T y
   652         in SOME (Thm.implies_elim (instantiate' [SOME T] (map SOME [y,z,x]) add_num_frac) ynz)
   652         in SOME (Thm.implies_elim (instantiate' [SOME T] (map SOME [y,z,x]) add_num_frac) ynz)
   653         end
   653         end
   654      | _ => NONE)
   654      | _ => NONE)
   655   end
   655   end
   656   handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
   656   handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
   657 
   657 
   658  fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b
   658  fun is_number (Const(@{const_name Fields.divide},_)$a$b) = is_number a andalso is_number b
   659    | is_number t = can HOLogic.dest_number t
   659    | is_number t = can HOLogic.dest_number t
   660 
   660 
   661  val is_number = is_number o term_of
   661  val is_number = is_number o term_of
   662 
   662 
   663  fun proc3 phi ss ct =
   663  fun proc3 phi ss ct =
   664   (case term_of ct of
   664   (case term_of ct of
   665     Const(@{const_name Orderings.less},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
   665     Const(@{const_name Orderings.less},_)$(Const(@{const_name Fields.divide},_)$_$_)$_ =>
   666       let
   666       let
   667         val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   667         val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   668         val _ = map is_number [a,b,c]
   668         val _ = map is_number [a,b,c]
   669         val T = ctyp_of_term c
   669         val T = ctyp_of_term c
   670         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_less_eq"}
   670         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_less_eq"}
   671       in SOME (mk_meta_eq th) end
   671       in SOME (mk_meta_eq th) end
   672   | Const(@{const_name Orderings.less_eq},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
   672   | Const(@{const_name Orderings.less_eq},_)$(Const(@{const_name Fields.divide},_)$_$_)$_ =>
   673       let
   673       let
   674         val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   674         val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   675         val _ = map is_number [a,b,c]
   675         val _ = map is_number [a,b,c]
   676         val T = ctyp_of_term c
   676         val T = ctyp_of_term c
   677         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_le_eq"}
   677         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_le_eq"}
   678       in SOME (mk_meta_eq th) end
   678       in SOME (mk_meta_eq th) end
   679   | Const(@{const_name HOL.eq},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
   679   | Const(@{const_name HOL.eq},_)$(Const(@{const_name Fields.divide},_)$_$_)$_ =>
   680       let
   680       let
   681         val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   681         val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
   682         val _ = map is_number [a,b,c]
   682         val _ = map is_number [a,b,c]
   683         val T = ctyp_of_term c
   683         val T = ctyp_of_term c
   684         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_eq_eq"}
   684         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_eq_eq"}
   685       in SOME (mk_meta_eq th) end
   685       in SOME (mk_meta_eq th) end
   686   | Const(@{const_name Orderings.less},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
   686   | Const(@{const_name Orderings.less},_)$_$(Const(@{const_name Fields.divide},_)$_$_) =>
   687     let
   687     let
   688       val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
   688       val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
   689         val _ = map is_number [a,b,c]
   689         val _ = map is_number [a,b,c]
   690         val T = ctyp_of_term c
   690         val T = ctyp_of_term c
   691         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "less_divide_eq"}
   691         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "less_divide_eq"}
   692       in SOME (mk_meta_eq th) end
   692       in SOME (mk_meta_eq th) end
   693   | Const(@{const_name Orderings.less_eq},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
   693   | Const(@{const_name Orderings.less_eq},_)$_$(Const(@{const_name Fields.divide},_)$_$_) =>
   694     let
   694     let
   695       val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
   695       val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
   696         val _ = map is_number [a,b,c]
   696         val _ = map is_number [a,b,c]
   697         val T = ctyp_of_term c
   697         val T = ctyp_of_term c
   698         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "le_divide_eq"}
   698         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "le_divide_eq"}
   699       in SOME (mk_meta_eq th) end
   699       in SOME (mk_meta_eq th) end
   700   | Const(@{const_name HOL.eq},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
   700   | Const(@{const_name HOL.eq},_)$_$(Const(@{const_name Fields.divide},_)$_$_) =>
   701     let
   701     let
   702       val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
   702       val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
   703         val _ = map is_number [a,b,c]
   703         val _ = map is_number [a,b,c]
   704         val T = ctyp_of_term c
   704         val T = ctyp_of_term c
   705         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "eq_divide_eq"}
   705         val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "eq_divide_eq"}