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 |
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"} |