(* Use of this source code is governed by the license described	* * in the LICENSE file at the root of the source tree.		*)
(* A theory of constructed rational numbers *)
Set Implicit Arguments.
Inductive Rat :=
RatIntro : nat -> posnat -> Rat.
Definition ratCD(r1 r2 : Rat) : (nat * nat * posnat) :=
match (r1, r2) with
| (RatIntro n1 d1, RatIntro n2 d2) =>
((n1 * d2), (n2 * d1), (posnatMult d1 d2))
end.
Definition ratMult(r1 r2 : Rat) : Rat :=
match (r1, r2) with
| (RatIntro n1 d1, RatIntro n2 d2) =>
RatIntro (n1 * n2) (posnatMult d1 d2)
end.
Definition rat1 := (RatIntro 1 (pos 1)).
Definition rat0 := (RatIntro 0 (pos 1)).
Definition ratAdd(r1 r2 : Rat) : Rat :=
match ratCD r1 r2 with
| (n1, n2, d) =>
RatIntro (n1 + n2) d
end.
Definition ratSubtract(r1 r2: Rat) : Rat :=
match ratCD r1 r2 with
| (n1, n2, d) =>
RatIntro (n1 - n2) d
end.
Definition beqRat(r1 r2 : Rat) :=
match (ratCD r1 r2) with
| (n1, n2, _) =>
if (eq_nat_dec n1 n2) then true else false
end.
Definition bleRat(r1 r2 : Rat) :=
match (ratCD r1 r2) with
| (n1, n2, _) =>
if (le_gt_dec n1 n2) then true else false
end.
Definition eqRat(r1 r2 : Rat) :=
beqRat r1 r2 = true.
Definition leRat(r1 r2 : Rat) :=
bleRat r1 r2 = true.
Definition maxRat(r1 r2 : Rat) :=
if (bleRat r1 r2) then r2 else r1.
Definition minRat(r1 r2 : Rat) :=
if (bleRat r1 r2) then r1 else r2.
Definition ratDistance(r1 r2 : Rat) :=
ratSubtract (maxRat r1 r2) (minRat r1 r2).
Ltac rattac_one :=
match goal with
(* rules that solve goals *)
| [|- posnatMult ?x1 ?x2 = posnatMult ?x2 ?x1] => apply posnatMult_comm
| [|- posnatToNat (posnatMult ?x1 ?x2) = posnatToNat (posnatMult ?x2 ?x1)] => rewrite posnatMult_comm; trivial
| [|- ?x1 * ?x2 = ?x2 * ?x1 ] => apply mult_comm
| [|- (mult (?x1 + ?x2) _)  = (mult (?x2 + ?x1) _ )] => f_equal
| [|- ?x1 * ?x2 * _ = ?x2 * ?x1 * _ ] => f_equal
| [ |- posnatToNat ?p > 0 ] => destruct p; unfold posnatToNat; omega
(* inversion on hypotheses *)
| [H1 : ?n * ?x = ?n0 * ?x1, H2: ?n1 * ?x1 = ?n * ?x0 |- ?n1 * ?x = ?n0 * ?x0 ] => eapply (@mult_same_l x1)(* ;
[idtac | rewrite mult_assoc ;
rewrite (mult_comm x1 n1);
rewrite H2;
rewrite <- mult_assoc ;
rewrite (mult_comm x x0) ;
repeat rewrite mult_assoc;
f_equal] *)
| [H : ?x = ?n * (posnatToNat ?p) |- ?x = (posnatToNat ?p) * ?n ] => rewrite H
| [H : RatIntro _ _ = RatIntro _ _ |- _ ] => inversion H; clear H; subst
| [H : (eqRat _ _) |- _ ] => unfold eqRat, beqRat in H
| [H : (leRat _ _) |- _ ] => unfold leRat, bleRat in H
| [H : ?r = RatIntro _ _ |- context[match ?r with | RatIntro _ _ => _ end] ] => rewrite r
| [|- context[match ?r with | RatIntro _ _ => _ end] ] => case_eq r; intuition idtac
| [H : (_ , _) = (_ , _) |- _ ] => inversion H; clear H; subst
| [|- (_, _) = (_, _) ] => f_equal
| [H: context[ratCD _ _] |- _ ] => unfold ratCD in *
| [H : context[match rat0 with | RatIntro _ _ => _ end ] |- _ ] => unfold rat0 in H
| [H1 : context[match ?r with | RatIntro _ _ => _ end], H2 : ?r = RatIntro _ _ |- _ ] => rewrite H2 in H1
| [H : context[match ?r with | RatIntro _ _ => _ end ] |- _ ] => case_eq r; intuition idtac
| [|- context[let (_, _) := ?x in _] ] => case_eq x; intuition idtac
| [H : context[ratAdd _ _] |- _ ] => unfold ratAdd in H
| [H : context[ratMult _ _] |- _ ] => unfold ratMult in H
| [H: context [eq_nat_dec ?x ?y] |- _] => destruct (eq_nat_dec x y)
| [H: context [le_gt_dec ?x ?y] |- _] => destruct (le_gt_dec x y)
| [|- (if (eq_nat_dec ?x ?y) then true else false) = true ] => assert (x = y); destruct (eq_nat_dec x y); trivial
| [|- (if (le_gt_dec ?x ?y) then true else false) = true ] => assert (x <= y); [idtac | destruct (le_gt_dec x y); trivial]
| [|- context[posnatMult _ _ ] ] => unfold posnatMult
| [|- (eqRat _ _) ] => unfold eqRat, beqRat
| [|- (leRat _ _) ] => unfold leRat, bleRat
| [|- (posnatEq _ _ ) ] => econstructor
| [|- context[(posnatToNat _)] ] => unfold posnatToNat in *
| [H : context[let (_, _) := ?p in _] |- _] => destruct p
end.
Ltac rattac :=
intuition idtac; unfold ratCD in *;
repeat (rattac_one; subst); repeat rewrite mult_1_r; repeat rewrite plus_0_r; trivial; try congruence; try omega.
rattac.
Qed.
Infix "*" := ratMult : rat_scope.
Local Open Scope rat_scope.
Notation "n / d" := (RatIntro n (pos d)) : rat_scope.
Notation "0" := rat0 : rat_scope.
Notation "1" := rat1 : rat_scope.
Infix "+" := ratAdd : rat_scope.
Delimit Scope rat_scope with rat.
Notation " |  a - b |" := (ratDistance a%rat b%rat) (at level 30, a at next level, b at next level) : rat_scope.
Infix "<=" := leRat : rat_scope.
Infix "==" := eqRat (at level 70) : rat_scope.
intuition.
case_eq (bleRat r1 r2); intuition.
right.
intuition.
congruence.
Qed.
intuition.
case_eq (beqRat r1 r2); intuition.
right.
intuition.
congruence.
Qed.
rattac.
Qed.
rattac.
Qed.
rattac.
match goal with H:_, G:_ |- _ => ring [H G] end.
Qed.
rattac.
Qed.
induction n2; destruct n3; intuition; simpl in *; try omega.
exfalso.
remember (n2 * n1)%nat as x.
omega.
eapply le_n_S.
eapply IHn2; eauto.
omega.
Qed.
intuition.
eapply mult_le_compat_r_iff_h; eauto.
Qed.
rattac.
eapply (@mult_le_compat_r_iff x1); trivial.
rewrite <- mult_assoc.
rewrite (mult_comm x).
rewrite mult_assoc.
eapply le_trans.
eapply mult_le_compat.
eapply l.
eauto.
repeat rewrite <- mult_assoc.
repeat rewrite (mult_comm x0).
repeat rewrite mult_assoc.
eapply mult_le_compat; eauto.
Qed.
rattac.
Qed.
rattac.
Qed.
(* Definition eqRat_setoid : Setoid_Theory Rat eqRat. econstructor; red. eapply eqRat_refl. eapply eqRat_symm. eapply eqRat_trans. Defined. *)
Add Parametric Relation : Rat leRat
reflexivity proved by leRat_refl
transitivity proved by leRat_trans
as leRat_rel.
Add Parametric Relation : Rat eqRat
reflexivity proved by eqRat_refl
symmetry proved by eqRat_symm
transitivity proved by eqRat_trans
as eqRat_rel.
Global Instance Subrelation_eq_le : subrelation eqRat leRat.
repeat red.
intuition.
eapply eqRat_impl_leRat.
trivial.
Qed.
Global Instance eqRat_resp_leRat :
forall x,
Proper (eqRat ==> Basics.flip Basics.impl)
(leRat x).
intuition.
repeat red; intuition.
simpl.
unfold respectful.
intuition.
eapply leRat_trans.
eapply H0.
eapply eqRat_impl_leRat.
symmetry.
trivial.
Qed.
Local Open Scope rat_scope.
rattac.
Qed.
intuition.
Qed.
intuition.
Qed.
rattac.
Qed.
rattac;
inversion H;
subst;
rewrite mult_1_r;
trivial.
Qed.
intuition.
rewrite ratAdd_comm.
apply ratAdd_0_r.
Qed.
rattac.
Qed.
rattac.
inversion H; clear H; subst.
Local Open Scope nat_scope.
Ltac arithNormalize_step :=
repeat rewrite mult_succ_r in *;
repeat rewrite mult_plus_distr_r in *;
repeat rewrite mult_plus_distr_l in *;
repeat rewrite mult_minus_distr_r in *;
repeat rewrite mult_minus_distr_l in *;
repeat rewrite plus_assoc in *;
repeat rewrite mult_assoc in *.
Ltac arithNormalize := repeat arithNormalize_step.
Ltac arithSimplify :=
match goal with
| [|- _ + ?x = _ + ?x] => f_equal
| [|- _ + (?x1 * ?x2) = _ + (?x2 * ?x1) ] => f_equal
| [|- _ + (?x1 * ?x2 * ?x3) = _ + (?x1 * ?x3 * ?x2) ] => f_equal
| [|- _ + (?x1 * ?x2 * ?x3 * ?x4 * ?x5 * ?x6) = _ + (?x1 * ?x3 * ?x2 * ?x4 * ?x5 * ?x6) ] => f_equal
| [|- _ * ?x1 = _ * ?x1] => f_equal
| [|- _ * ?x = _ ] => rewrite mult_comm; repeat rewrite mult_assoc; arithSimplify
| [|- _ + ?x = _ ] => rewrite plus_comm; repeat rewrite plus_assoc; arithSimplify
| [|- _ * ?x1 <= _ * ?x1] => apply mult_le_compat; auto
| [|- _ * ?x1 <= _ * ?x1] => apply plus_le_compat; auto
| [|- _ * ?x <= _ ] => rewrite mult_comm; repeat rewrite mult_assoc; arithSimplify
| [|- _ + ?x <= _ ] => rewrite plus_comm; repeat rewrite plus_assoc; arithSimplify
end.
arithNormalize.
arithSimplify.
arithSimplify.
do 5 arithSimplify.
do 5 arithSimplify.
Qed.
Local Open Scope rat_scope.
rattac;
inversion H0; clear H0; subst;
inversion H; clear H; subst;
arithNormalize;
arithSimplify.
Qed.
rattac.
arithNormalize.
f_equal.
f_equal.
rewrite mult_comm.
rewrite (mult_comm _ x1).
repeat rewrite mult_assoc.
f_equal.
rewrite mult_comm.
rewrite e.
apply mult_comm.
do 3 arithSimplify.
Qed.
intuition.
eapply eqRat_trans.
eapply ratAdd_eqRat_compat_l; eauto.
repeat rewrite (ratAdd_comm r2).
eapply ratAdd_eqRat_compat_l; eauto.
Qed.
rattac.
unfold leRat, bleRat in *.
rattac.
arithNormalize.
apply plus_le_compat.
apply mult_le_compat; trivial.
repeat rewrite <- mult_assoc.
repeat rewrite (mult_comm x0).
repeat rewrite mult_assoc.
apply mult_le_compat; trivial.
apply mult_le_compat; trivial.
rewrite <- mult_assoc.
rewrite (mult_comm x1).
rewrite mult_assoc.
apply mult_le_compat; trivial.
Qed.
intuition.
eapply leRat_trans.
eapply ratAdd_leRat_compat_l; eauto.
rewrite ratAdd_comm.
eapply leRat_trans.
apply ratAdd_leRat_compat_l; eauto.
rewrite ratAdd_comm.
intuition.
Qed.

Theorem ratMult_leRat_compat : forall (r1 r2 r3 r4 : Rat),
leRat r1 r2 ->
leRat r3 r4 ->
leRat (ratMult r1 r3) (ratMult r2 r4).