diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v index 3e79a7fe6c..008eba87d2 100644 --- a/theories/Arith/Arith_base.v +++ b/theories/Arith/Arith_base.v @@ -287,7 +287,7 @@ Hint Resolve minus_diag_reverse_stt: arith. (* Minus.minus_diag_reverse *) #[local] Lemma minus_plus_simpl_l_reverse_stt n m p : n - m = p + n - (p + m). Proof. - now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub. + now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub. Qed. Add Search Blacklist "Coq.Arith.Arith_base.minus_plus_simpl_l_reverse_stt". #[global] @@ -346,7 +346,7 @@ Hint Resolve mult_assoc_reverse_stt Nat.mul_assoc: arith. (* Mult.mult_assoc_rev #[local] Lemma mult_O_le_stt n m : m = 0 \/ n <= m * n. Proof. - destruct m; [left|right]; simpl; trivial using Nat.le_add_r. + destruct m; [left|right]; simpl; trivial using Nat.le_add_r. Qed. Add Search Blacklist "Coq.Arith.Arith_base.mult_O_le_stt". #[global] diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 8e7dcf0900..0d8f4c187d 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -160,22 +160,22 @@ Notation nat_compare_S := Nat.compare_succ (only parsing). Lemma nat_compare_lt n m : n (n ?= m) = Lt. Proof. - symmetry. apply Nat.compare_lt_iff. + symmetry. apply Nat.compare_lt_iff. Qed. Lemma nat_compare_gt n m : n>m <-> (n ?= m) = Gt. Proof. - symmetry. apply Nat.compare_gt_iff. + symmetry. apply Nat.compare_gt_iff. Qed. Lemma nat_compare_le n m : n<=m <-> (n ?= m) <> Gt. Proof. - symmetry. apply Nat.compare_le_iff. + symmetry. apply Nat.compare_le_iff. Qed. Lemma nat_compare_ge n m : n>=m <-> (n ?= m) <> Lt. Proof. - symmetry. apply Nat.compare_ge_iff. + symmetry. apply Nat.compare_ge_iff. Qed. (** Some projections of the above equivalences. *) @@ -223,30 +223,30 @@ Notation leb_iff := Nat.leb_le (only parsing). Lemma leb_iff_conv m n : (n <=? m) = false <-> m < n. Proof. - rewrite Nat.leb_nle. apply Nat.nle_gt. + rewrite Nat.leb_nle. apply Nat.nle_gt. Qed. Lemma leb_correct m n : m <= n -> (m <=? n) = true. Proof. - apply Nat.leb_le. + apply Nat.leb_le. Qed. Lemma leb_complete m n : (m <=? n) = true -> m <= n. Proof. - apply Nat.leb_le. + apply Nat.leb_le. Qed. Lemma leb_correct_conv m n : m < n -> (n <=? m) = false. Proof. - apply leb_iff_conv. + apply leb_iff_conv. Qed. Lemma leb_complete_conv m n : (n <=? m) = false -> m < n. Proof. - apply leb_iff_conv. + apply leb_iff_conv. Qed. Lemma leb_compare n m : (n <=? m) = true <-> (n ?= m) <> Gt. Proof. - rewrite Nat.compare_le_iff. apply Nat.leb_le. + rewrite Nat.compare_le_iff. apply Nat.leb_le. Qed. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 8f733dab06..62045412ab 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -39,12 +39,12 @@ Qed. Lemma eq_eq_nat n m : n = m -> eq_nat n m. Proof. - apply eq_nat_is_eq. + apply eq_nat_is_eq. Qed. Lemma eq_nat_eq n m : eq_nat n m -> n = m. Proof. - apply eq_nat_is_eq. + apply eq_nat_is_eq. Qed. Theorem eq_nat_elim : diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 7b55f8bb04..47ecad799a 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -29,7 +29,7 @@ Qed. Lemma fact_neq_0 n : fact n <> 0. Proof. - apply Nat.neq_0_lt_0, lt_O_fact. + apply Nat.neq_0_lt_0, lt_O_fact. Qed. Lemma fact_le n m : n <= m -> fact n <= fact m. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 7f27f8a00a..fa481a1c43 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -15,1318 +15,1318 @@ From Stdlib Require Import NAxioms NProperties OrdersFacts DecidableClass. (** Implementation of [NAxiomsSig] by [nat] *) Module Nat - <: NAxiomsSig - <: UsualDecidableTypeFull - <: OrderedTypeFull - <: TotalOrder. - -(** Operations over [nat] are defined in a separate module *) - -Include Corelib.Init.Nat. - -(** When including property functors, inline t eq zero one two lt le succ *) - -Set Inline Level 50. - -(** All operations are well-defined (trivial here since eq is Leibniz) *) - -Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence. -#[local] Obligation Tactic := simpl_relation. -#[global] Program Instance succ_wd : Proper (eq==>eq) S. -#[global] Program Instance pred_wd : Proper (eq==>eq) pred. -#[global] Program Instance add_wd : Proper (eq==>eq==>eq) plus. -#[global] Program Instance sub_wd : Proper (eq==>eq==>eq) minus. -#[global] Program Instance mul_wd : Proper (eq==>eq==>eq) mult. -#[global] Program Instance pow_wd : Proper (eq==>eq==>eq) pow. -#[global] Program Instance div_wd : Proper (eq==>eq==>eq) div. -#[global] Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. -#[global] Program Instance lt_wd : Proper (eq==>eq==>iff) lt. -#[global] Program Instance testbit_wd : Proper (eq==>eq==>eq) testbit. - -(** Bi-directional induction. *) - -Theorem bi_induction : - forall A : nat -> Prop, Proper (eq==>iff) A -> - A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n. -Proof. - intros A A_wd A0 AS; apply nat_ind. - - assumption. - - intros; now apply -> AS. -Qed. - -(** Recursion function *) - -Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := - nat_rect (fun _ => A). - -#[global] Instance recursion_wd {A} (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. -Proof. - intros a a' Ha f f' Hf n n' <-. - induction n; simpl; auto. - apply Hf; auto. -Qed. - -Theorem recursion_0 : - forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a. -Proof. reflexivity. Qed. - -Theorem recursion_succ : - forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). -Proof. - unfold Proper, respectful in *. - intros A Aeq a f ? ? n. - induction n; simpl; auto. -Qed. - -(** ** Remaining constants not defined in Stdlib.Init.Nat *) - -(** NB: Aliasing [le] is mandatory, since only a Definition can implement + <: NAxiomsSig + <: UsualDecidableTypeFull + <: OrderedTypeFull + <: TotalOrder. + + (** Operations over [nat] are defined in a separate module *) + + Include Corelib.Init.Nat. + + (** When including property functors, inline t eq zero one two lt le succ *) + + Set Inline Level 50. + + (** All operations are well-defined (trivial here since eq is Leibniz) *) + + Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence. + #[local] Obligation Tactic := simpl_relation. + #[global] Program Instance succ_wd : Proper (eq==>eq) S. + #[global] Program Instance pred_wd : Proper (eq==>eq) pred. + #[global] Program Instance add_wd : Proper (eq==>eq==>eq) plus. + #[global] Program Instance sub_wd : Proper (eq==>eq==>eq) minus. + #[global] Program Instance mul_wd : Proper (eq==>eq==>eq) mult. + #[global] Program Instance pow_wd : Proper (eq==>eq==>eq) pow. + #[global] Program Instance div_wd : Proper (eq==>eq==>eq) div. + #[global] Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. + #[global] Program Instance lt_wd : Proper (eq==>eq==>iff) lt. + #[global] Program Instance testbit_wd : Proper (eq==>eq==>eq) testbit. + + (** Bi-directional induction. *) + + Theorem bi_induction : + forall A : nat -> Prop, Proper (eq==>iff) A -> + A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n. + Proof. + intros A A_wd A0 AS; apply nat_ind. + - assumption. + - intros; now apply -> AS. + Qed. + + (** Recursion function *) + + Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := + nat_rect (fun _ => A). + + #[global] Instance recursion_wd {A} (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. + Proof. + intros a a' Ha f f' Hf n n' <-. + induction n; simpl; auto. + apply Hf; auto. + Qed. + + Theorem recursion_0 : + forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a. + Proof. reflexivity. Qed. + + Theorem recursion_succ : + forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A), + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> + forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). + Proof. + unfold Proper, respectful in *. + intros A Aeq a f ? ? n. + induction n; simpl; auto. + Qed. + + (** ** Remaining constants not defined in Stdlib.Init.Nat *) + + (** NB: Aliasing [le] is mandatory, since only a Definition can implement an interface Parameter... *) -Definition eq := @Logic.eq nat. -Definition le := Peano.le. -Definition lt := Peano.lt. - -(** ** Basic specifications : pred add sub mul *) - -Lemma pred_succ n : pred (S n) = n. -Proof. reflexivity. Qed. - -Lemma pred_0 : pred 0 = 0. -Proof. reflexivity. Qed. - -Lemma one_succ : 1 = S 0. -Proof. reflexivity. Qed. - -Lemma two_succ : 2 = S 1. -Proof. reflexivity. Qed. - -Lemma add_0_l n : 0 + n = n. -Proof. reflexivity. Qed. - -Lemma add_succ_l n m : (S n) + m = S (n + m). -Proof. reflexivity. Qed. - -Lemma sub_0_r n : n - 0 = n. -Proof. now destruct n. Qed. - -Lemma sub_succ_r n m : n - (S m) = pred (n - m). -Proof. - revert m; induction n; intro m; destruct m; simpl; auto. - apply sub_0_r. -Qed. - -Lemma mul_0_l n : 0 * n = 0. -Proof. reflexivity. Qed. - -Lemma mul_succ_l n m : S n * m = n * m + m. -Proof. - assert (succ_r : forall x y, x+S y = S(x+y)) by now intro x; induction x. - assert (comm : forall x y, x+y = y+x). - { intro x; induction x; simpl; auto. - intros; rewrite succ_r; now f_equal. } - now rewrite comm. -Qed. - -Lemma lt_succ_r n m : n < S m <-> n <= m. -Proof. - split. - - apply Peano.le_S_n. - - induction 1; auto. -Qed. - -(** ** Boolean comparisons *) - -Lemma eqb_eq n m : eqb n m = true <-> n = m. -Proof. - revert m. - induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn; split; try easy. - - now intros ->. - - now injection 1. -Qed. - -#[global] -Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := { - Decidable_spec := Nat.eqb_eq x y -}. - -Lemma leb_le n m : (n <=? m) = true <-> n <= m. -Proof. - revert m. - induction n as [|n IHn]; intro m; destruct m; simpl. - - now split. - - split; trivial. - intros; apply Peano.le_0_n. - - now split. - - rewrite IHn; split. - + apply Peano.le_n_S. - + apply Peano.le_S_n. -Qed. - -#[global] -Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := { - Decidable_spec := Nat.leb_le x y -}. - -Lemma ltb_lt n m : (n n < m. -Proof. apply leb_le. Qed. - -(* Note: Decidable_lt_nat, Decidable_ge_nat, Decidable_gt_nat are not required, + Definition eq := @Logic.eq nat. + Definition le := Peano.le. + Definition lt := Peano.lt. + + (** ** Basic specifications : pred add sub mul *) + + Lemma pred_succ n : pred (S n) = n. + Proof. reflexivity. Qed. + + Lemma pred_0 : pred 0 = 0. + Proof. reflexivity. Qed. + + Lemma one_succ : 1 = S 0. + Proof. reflexivity. Qed. + + Lemma two_succ : 2 = S 1. + Proof. reflexivity. Qed. + + Lemma add_0_l n : 0 + n = n. + Proof. reflexivity. Qed. + + Lemma add_succ_l n m : (S n) + m = S (n + m). + Proof. reflexivity. Qed. + + Lemma sub_0_r n : n - 0 = n. + Proof. now destruct n. Qed. + + Lemma sub_succ_r n m : n - (S m) = pred (n - m). + Proof. + revert m; induction n; intro m; destruct m; simpl; auto. + apply sub_0_r. + Qed. + + Lemma mul_0_l n : 0 * n = 0. + Proof. reflexivity. Qed. + + Lemma mul_succ_l n m : S n * m = n * m + m. + Proof. + assert (succ_r : forall x y, x+S y = S(x+y)) by now intro x; induction x. + assert (comm : forall x y, x+y = y+x). + { intro x; induction x; simpl; auto. + intros; rewrite succ_r; now f_equal. } + now rewrite comm. + Qed. + + Lemma lt_succ_r n m : n < S m <-> n <= m. + Proof. + split. + - apply Peano.le_S_n. + - induction 1; auto. + Qed. + + (** ** Boolean comparisons *) + + Lemma eqb_eq n m : eqb n m = true <-> n = m. + Proof. + revert m. + induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn; split; try easy. + - now intros ->. + - now injection 1. + Qed. + + #[global] + Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := { + Decidable_spec := Nat.eqb_eq x y + }. + + Lemma leb_le n m : (n <=? m) = true <-> n <= m. + Proof. + revert m. + induction n as [|n IHn]; intro m; destruct m; simpl. + - now split. + - split; trivial. + intros; apply Peano.le_0_n. + - now split. + - rewrite IHn; split. + + apply Peano.le_n_S. + + apply Peano.le_S_n. + Qed. + + #[global] + Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := { + Decidable_spec := Nat.leb_le x y + }. + + Lemma ltb_lt n m : (n n < m. + Proof. apply leb_le. Qed. + + (* Note: Decidable_lt_nat, Decidable_ge_nat, Decidable_gt_nat are not required, because lt, ge and gt are defined based on le in a way which type class resolution seems to understand. *) -(** ** Decidability of equality over [nat]. *) + (** ** Decidability of equality over [nat]. *) -Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}. -Proof. - intro n; induction n as [|n IHn]; intro m; destruct m as [|m]. - - now left. - - now right. - - now right. - - destruct (IHn m); [left|right]; auto. -Defined. + Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}. + Proof. + intro n; induction n as [|n IHn]; intro m; destruct m as [|m]. + - now left. + - now right. + - now right. + - destruct (IHn m); [left|right]; auto. + Defined. -(** ** Ternary comparison *) + (** ** Ternary comparison *) -(** With [nat], it would be easier to prove first [compare_spec], + (** With [nat], it would be easier to prove first [compare_spec], then the properties below. But then we wouldn't be able to benefit from functor [BoolOrderFacts] *) -Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m. -Proof. - revert m; induction n as [|n IHn]; intro m; destruct m; - simpl; rewrite ?IHn; split; auto; easy. -Qed. - -Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m. -Proof. - revert m; induction n as [|n IHn]; intro m; destruct m; - simpl; rewrite ?IHn; split; try easy. - - intros _; apply Peano.le_n_S, Peano.le_0_n. - - apply Peano.le_n_S. - - apply Peano.le_S_n. -Qed. - -Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. -Proof. - revert m; induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn. - - now split. - - split; intros. - + apply Peano.le_0_n. - + easy. - - split. - + now destruct 1. - + inversion 1. - - split; intros. - + now apply Peano.le_n_S. - + now apply Peano.le_S_n. -Qed. - -Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m). -Proof. revert m; induction n; intro m; destruct m; simpl; trivial. Qed. - -Lemma compare_succ n m : (S n ?= S m) = (n ?= m). -Proof. reflexivity. Qed. - - -(** ** Minimum, maximum *) - -Lemma max_l : forall n m, m <= n -> max n m = n. -Proof. exact Peano.max_l. Qed. - -Lemma max_r : forall n m, n <= m -> max n m = m. -Proof. exact Peano.max_r. Qed. - -Lemma min_l : forall n m, n <= m -> min n m = n. -Proof. exact Peano.min_l. Qed. - -Lemma min_r : forall n m, m <= n -> min n m = m. -Proof. exact Peano.min_r. Qed. - -(** Some more advanced properties of comparison and orders, + Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m. + Proof. + revert m; induction n as [|n IHn]; intro m; destruct m; + simpl; rewrite ?IHn; split; auto; easy. + Qed. + + Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m. + Proof. + revert m; induction n as [|n IHn]; intro m; destruct m; + simpl; rewrite ?IHn; split; try easy. + - intros _; apply Peano.le_n_S, Peano.le_0_n. + - apply Peano.le_n_S. + - apply Peano.le_S_n. + Qed. + + Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. + Proof. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn. + - now split. + - split; intros. + + apply Peano.le_0_n. + + easy. + - split. + + now destruct 1. + + inversion 1. + - split; intros. + + now apply Peano.le_n_S. + + now apply Peano.le_S_n. + Qed. + + Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m). + Proof. revert m; induction n; intro m; destruct m; simpl; trivial. Qed. + + Lemma compare_succ n m : (S n ?= S m) = (n ?= m). + Proof. reflexivity. Qed. + + + (** ** Minimum, maximum *) + + Lemma max_l : forall n m, m <= n -> max n m = n. + Proof. exact Peano.max_l. Qed. + + Lemma max_r : forall n m, n <= m -> max n m = m. + Proof. exact Peano.max_r. Qed. + + Lemma min_l : forall n m, n <= m -> min n m = n. + Proof. exact Peano.min_l. Qed. + + Lemma min_r : forall n m, m <= n -> min n m = m. + Proof. exact Peano.min_r. Qed. + + (** Some more advanced properties of comparison and orders, including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) -Include BoolOrderFacts. + Include BoolOrderFacts. -(** We can now derive all properties of basic functions and orders, + (** We can now derive all properties of basic functions and orders, and use these properties for proving the specs of more advanced functions. *) -Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -Lemma strong_induction_le (A : nat -> Prop) : - A 0 -> (forall n, (forall m, m <= n -> A m) -> A (S n)) -> forall n, A n. -Proof. apply Private_strong_induction_le; intros x y ->; reflexivity. Qed. - -(** ** Power *) - -Lemma pow_neg_r a b : b<0 -> a^b = 0. -Proof. inversion 1. Qed. - -Lemma pow_0_r a : a^0 = 1. -Proof. reflexivity. Qed. - -Lemma pow_succ_r a b : 0<=b -> a^(S b) = a * a^b. -Proof. reflexivity. Qed. - -(** ** Square *) - -Lemma square_spec n : square n = n * n. -Proof. reflexivity. Qed. - -(** ** Parity *) - -Definition Even n := exists m, n = 2*m. -Definition Odd n := exists m, n = 2*m+1. - -Module Private_Parity. - -Lemma Even_0 : Even 0. -Proof. exists 0; reflexivity. Qed. - -Lemma Even_1 : ~ Even 1. -Proof. - intros ([|], H); try discriminate. - simpl in H. - now rewrite <- plus_n_Sm in H. -Qed. - -Lemma Even_2 n : Even n <-> Even (S (S n)). -Proof. - split; intros (m,H). - - exists (S m). - rewrite H; simpl. - now rewrite plus_n_Sm. - - destruct m as [|m]; try discriminate. - exists m. - simpl in H; rewrite <- plus_n_Sm in H. - now inversion H. -Qed. - -Lemma Odd_0 : ~ Odd 0. -Proof. now intros ([|], H). Qed. - -Lemma Odd_1 : Odd 1. -Proof. exists 0; reflexivity. Qed. - -Lemma Odd_2 n : Odd n <-> Odd (S (S n)). -Proof. - split; intros (m,H). - - exists (S m). - rewrite H. simpl. - now rewrite <- (plus_n_Sm m). - - destruct m as [|m]; try discriminate. - exists m. - simpl in H; rewrite <- plus_n_Sm in H. - inversion H; simpl. - now rewrite <- !plus_n_Sm, <- !plus_n_O. -Qed. - -End Private_Parity. -Import Private_Parity. - -Lemma even_spec : forall n, even n = true <-> Even n. -Proof. - fix even_spec 1. - intro n; destruct n as [|[|n]]; simpl. - - split; [ intros; apply Even_0 | trivial ]. - - split; [ discriminate | intro H; elim (Even_1 H) ]. - - rewrite even_spec. - apply Even_2. -Qed. - -Lemma odd_spec : forall n, odd n = true <-> Odd n. -Proof. - unfold odd. - fix odd_spec 1. - intro n; destruct n as [|[|n]]; simpl. - - split; [ discriminate | intro H; elim (Odd_0 H) ]. - - split; [ intros; apply Odd_1 | trivial ]. - - rewrite odd_spec. - apply Odd_2. -Qed. - -(** ** Division *) - -Lemma divmod_spec : forall x y q u, u <= y -> - let (q',u') := divmod x y q u in - x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y. -Proof. - intro x; induction x as [|x IHx]. - - simpl; intuition. - - intros y q u H. - destruct u as [|u]; simpl divmod. - + generalize (IHx y (S q) y (le_n y)). - destruct divmod as (q',u'). - intros (EQ,LE); split; trivial. - rewrite <- EQ, sub_0_r, sub_diag, add_0_r. - now rewrite !add_succ_l, <- add_succ_r, <- add_assoc, mul_succ_r. - + assert (H' : u <= y). - { apply le_trans with (S u); trivial. - do 2 constructor. } - generalize (IHx y q u H'). - destruct divmod as (q',u'). - intros (EQ,LE); split; trivial. - rewrite <- EQ, !add_succ_l, <- add_succ_r; f_equal. - now rewrite <- sub_succ_l. -Qed. - -Lemma div_mod_eq x y : x = y*(x/y) + x mod y. -Proof. - destruct y as [|y]; [reflexivity | ]. - unfold div, modulo. - generalize (divmod_spec x y 0 y (le_n y)). - destruct divmod as (q,u). - intros (U,V). - simpl in *. - now rewrite mul_0_r, sub_diag, !add_0_r in U. -Qed. - -(** The [y <> 0] hypothesis is needed to fit in [NAxiomsSig]. *) -Lemma div_mod x y : y <> 0 -> x = y*(x/y) + x mod y. -Proof. - intros _; apply div_mod_eq. -Qed. - -Lemma mod_bound_pos x y : 0<=x -> 0 0 <= x mod y < y. -Proof. - intros Hx Hy. - split. - - apply le_0_l. - - destruct y; [ now elim Hy | clear Hy ]. - unfold modulo. - apply lt_succ_r, le_sub_l. -Qed. - -(** ** Square root *) - -Lemma sqrt_iter_spec : forall k p q r, - q = p+p -> r<=q -> - let s := sqrt_iter k p q r in - s*s <= k + p*p + (q - r) < (S s)*(S s). -Proof. - intro k; induction k as [|k IHk]. - - (* k = 0 *) - simpl; intros p q r Hq Hr. - split. - + apply le_add_r. - + apply lt_succ_r. - rewrite mul_succ_r, add_assoc, (add_comm p), <- add_assoc. - apply add_le_mono_l. - rewrite <- Hq. - apply le_sub_l. - - (* k = S k' *) - intros p q r; destruct r as [|r]. - + (* r = 0 *) - intros Hq _. - replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). - 2:{ rewrite sub_diag, sub_0_r, add_0_r. simpl. - rewrite add_succ_r; f_equal. rewrite <- add_assoc; f_equal. - rewrite mul_succ_r, (add_comm p), <- add_assoc. now f_equal. } - apply IHk; simpl. - * now rewrite add_succ_r, Hq. - * apply le_n. - + (* r = S r' *) - intros Hq Hr. - replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)) - by (simpl; rewrite <- add_succ_r; f_equal; rewrite <- sub_succ_l; trivial). - apply IHk; trivial. - apply le_trans with (S r); trivial. - do 2 constructor. -Qed. - -Lemma sqrt_specif n : (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n). -Proof. - set (s:=sqrt n). - replace n with (n + 0*0 + (0-0)). - - apply sqrt_iter_spec; auto. - - simpl. - now rewrite !add_0_r. -Qed. - -Definition sqrt_spec a (Ha:0<=a) := sqrt_specif a. - -Lemma sqrt_neg a : a<0 -> sqrt a = 0. -Proof. inversion 1. Qed. - -(** ** Logarithm *) - -Lemma log2_iter_spec : forall k p q r, - 2^(S p) = q + S r -> r < 2^p -> - let s := log2_iter k p q r in - 2^s <= k + q < 2^(S s). -Proof. - intro k; induction k as [|k IHk]. - - (* k = 0 *) - intros p q r EQ LT. - simpl log2_iter; cbv zeta. + Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + + Lemma strong_induction_le (A : nat -> Prop) : + A 0 -> (forall n, (forall m, m <= n -> A m) -> A (S n)) -> forall n, A n. + Proof. apply Private_strong_induction_le; intros x y ->; reflexivity. Qed. + + (** ** Power *) + + Lemma pow_neg_r a b : b<0 -> a^b = 0. + Proof. inversion 1. Qed. + + Lemma pow_0_r a : a^0 = 1. + Proof. reflexivity. Qed. + + Lemma pow_succ_r a b : 0<=b -> a^(S b) = a * a^b. + Proof. reflexivity. Qed. + + (** ** Square *) + + Lemma square_spec n : square n = n * n. + Proof. reflexivity. Qed. + + (** ** Parity *) + + Definition Even n := exists m, n = 2*m. + Definition Odd n := exists m, n = 2*m+1. + + Module Private_Parity. + + Lemma Even_0 : Even 0. + Proof. exists 0; reflexivity. Qed. + + Lemma Even_1 : ~ Even 1. + Proof. + intros ([|], H); try discriminate. + simpl in H. + now rewrite <- plus_n_Sm in H. + Qed. + + Lemma Even_2 n : Even n <-> Even (S (S n)). + Proof. + split; intros (m,H). + - exists (S m). + rewrite H; simpl. + now rewrite plus_n_Sm. + - destruct m as [|m]; try discriminate. + exists m. + simpl in H; rewrite <- plus_n_Sm in H. + now inversion H. + Qed. + + Lemma Odd_0 : ~ Odd 0. + Proof. now intros ([|], H). Qed. + + Lemma Odd_1 : Odd 1. + Proof. exists 0; reflexivity. Qed. + + Lemma Odd_2 n : Odd n <-> Odd (S (S n)). + Proof. + split; intros (m,H). + - exists (S m). + rewrite H. simpl. + now rewrite <- (plus_n_Sm m). + - destruct m as [|m]; try discriminate. + exists m. + simpl in H; rewrite <- plus_n_Sm in H. + inversion H; simpl. + now rewrite <- !plus_n_Sm, <- !plus_n_O. + Qed. + + End Private_Parity. + Import Private_Parity. + + Lemma even_spec : forall n, even n = true <-> Even n. + Proof. + fix even_spec 1. + intro n; destruct n as [|[|n]]; simpl. + - split; [ intros; apply Even_0 | trivial ]. + - split; [ discriminate | intro H; elim (Even_1 H) ]. + - rewrite even_spec. + apply Even_2. + Qed. + + Lemma odd_spec : forall n, odd n = true <-> Odd n. + Proof. + unfold odd. + fix odd_spec 1. + intro n; destruct n as [|[|n]]; simpl. + - split; [ discriminate | intro H; elim (Odd_0 H) ]. + - split; [ intros; apply Odd_1 | trivial ]. + - rewrite odd_spec. + apply Odd_2. + Qed. + + (** ** Division *) + + Lemma divmod_spec : forall x y q u, u <= y -> + let (q',u') := divmod x y q u in + x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y. + Proof. + intro x; induction x as [|x IHx]. + - simpl; intuition. + - intros y q u H. + destruct u as [|u]; simpl divmod. + + generalize (IHx y (S q) y (le_n y)). + destruct divmod as (q',u'). + intros (EQ,LE); split; trivial. + rewrite <- EQ, sub_0_r, sub_diag, add_0_r. + now rewrite !add_succ_l, <- add_succ_r, <- add_assoc, mul_succ_r. + + assert (H' : u <= y). + { apply le_trans with (S u); trivial. + do 2 constructor. } + generalize (IHx y q u H'). + destruct divmod as (q',u'). + intros (EQ,LE); split; trivial. + rewrite <- EQ, !add_succ_l, <- add_succ_r; f_equal. + now rewrite <- sub_succ_l. + Qed. + + Lemma div_mod_eq x y : x = y*(x/y) + x mod y. + Proof. + destruct y as [|y]; [reflexivity | ]. + unfold div, modulo. + generalize (divmod_spec x y 0 y (le_n y)). + destruct divmod as (q,u). + intros (U,V). + simpl in *. + now rewrite mul_0_r, sub_diag, !add_0_r in U. + Qed. + + (** The [y <> 0] hypothesis is needed to fit in [NAxiomsSig]. *) + Lemma div_mod x y : y <> 0 -> x = y*(x/y) + x mod y. + Proof. + intros _; apply div_mod_eq. + Qed. + + Lemma mod_bound_pos x y : 0<=x -> 0 0 <= x mod y < y. + Proof. + intros Hx Hy. split. - + rewrite add_0_l, (add_le_mono_l _ _ (2^p)). - simpl pow in EQ. - rewrite add_0_r in EQ; rewrite EQ, add_comm. - apply add_le_mono_r, LT. - + rewrite EQ, add_comm. - apply add_lt_mono_l. - apply lt_succ_r, le_0_l. - - (* k = S k' *) - intros p q r EQ LT. - destruct r as [|r]. - + (* r = 0 *) - rewrite add_succ_r, add_0_r in EQ. - rewrite add_succ_l, <- add_succ_r. - apply IHk. - * rewrite <- EQ. - remember (S p) as p'; simpl. - now rewrite add_0_r. - * rewrite EQ; constructor. - + (* r = S r' *) - rewrite add_succ_l, <- add_succ_r. - apply IHk. - * now rewrite add_succ_l, <- add_succ_r. - * apply le_lt_trans with (S r); trivial. + - apply le_0_l. + - destruct y; [ now elim Hy | clear Hy ]. + unfold modulo. + apply lt_succ_r, le_sub_l. + Qed. + + (** ** Square root *) + + Lemma sqrt_iter_spec : forall k p q r, + q = p+p -> r<=q -> + let s := sqrt_iter k p q r in + s*s <= k + p*p + (q - r) < (S s)*(S s). + Proof. + intro k; induction k as [|k IHk]. + - (* k = 0 *) + simpl; intros p q r Hq Hr. + split. + + apply le_add_r. + + apply lt_succ_r. + rewrite mul_succ_r, add_assoc, (add_comm p), <- add_assoc. + apply add_le_mono_l. + rewrite <- Hq. + apply le_sub_l. + - (* k = S k' *) + intros p q r; destruct r as [|r]. + + (* r = 0 *) + intros Hq _. + replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). + 2:{ rewrite sub_diag, sub_0_r, add_0_r. simpl. + rewrite add_succ_r; f_equal. rewrite <- add_assoc; f_equal. + rewrite mul_succ_r, (add_comm p), <- add_assoc. now f_equal. } + apply IHk; simpl. + * now rewrite add_succ_r, Hq. + * apply le_n. + + (* r = S r' *) + intros Hq Hr. + replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)) + by (simpl; rewrite <- add_succ_r; f_equal; rewrite <- sub_succ_l; trivial). + apply IHk; trivial. + apply le_trans with (S r); trivial. do 2 constructor. -Qed. - -Lemma log2_spec n : 0 - 2^(log2 n) <= n < 2^(S (log2 n)). -Proof. - intros. - set (s:=log2 n). - replace n with (pred n + 1). - - apply log2_iter_spec; auto. - - rewrite add_1_r. - apply succ_pred. - now apply neq_sym, lt_neq. -Qed. - -Lemma log2_nonpos n : n<=0 -> log2 n = 0. -Proof. inversion 1; now subst. Qed. - -(** ** Properties of [iter] *) - -Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : - (forall a, f (g a) = h (f a)) -> forall n a, - f (iter n g a) = iter n h (f a). -Proof. - intros H n a. - induction n as [|n Hn]. - - reflexivity. - - simpl. rewrite H, Hn. reflexivity. -Qed. - -Lemma iter_swap : - forall n (A:Type) (f:A -> A) (x:A), - iter n f (f x) = f (iter n f x). -Proof. - intros. symmetry. now apply iter_swap_gen. -Qed. - -Lemma iter_succ : - forall n (A:Type) (f:A -> A) (x:A), - iter (S n) f x = f (iter n f x). -Proof. - reflexivity. -Qed. - -Lemma iter_succ_r : - forall n (A:Type) (f:A -> A) (x:A), - iter (S n) f x = iter n f (f x). -Proof. - intros; now rewrite iter_succ, iter_swap. -Qed. - -Lemma iter_add : - forall p q (A:Type) (f:A -> A) (x:A), - iter (p+q) f x = iter p f (iter q f x). -Proof. - intro p. induction p as [|p IHp]. - - reflexivity. - - intros q A f x. simpl. now rewrite IHp. -Qed. - -Lemma iter_ind (A:Type) (f:A -> A) (a:A) (P:nat -> A -> Prop) : - P 0 a -> - (forall n a', P n a' -> P (S n) (f a')) -> - forall n, P n (iter n f a). -Proof. - intros H0 HS n. induction n as [|n Hn]. - - exact H0. - - apply HS. exact Hn. -Qed. - -Lemma iter_rect (A:Type) (f:A -> A) (a:A) (P:nat -> A -> Type) : - P 0 a -> - (forall n a', P n a' -> P (S n) (f a')) -> - forall n, P n (iter n f a). -Proof. - intros H0 HS n. induction n as [|n Hn]. - - exact H0. - - apply HS. exact Hn. -Defined. - -Lemma iter_invariant : - forall (n:nat) (A:Type) (f:A -> A) (Inv:A -> Prop), - (forall x:A, Inv x -> Inv (f x)) -> - forall x:A, Inv x -> Inv (iter n f x). -Proof. - intros; apply iter_ind; trivial. -Qed. - -(** ** Gcd *) - -Definition divide x y := exists z, y=z*x. -Notation "( x | y )" := (divide x y) (at level 0) : nat_scope. - -Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b). -Proof. - fix gcd_divide 1. - intros [|a] b; simpl. - - split. - + now exists 0. - + exists 1; simpl. - now rewrite <- plus_n_O. - - fold (b mod (S a)). - destruct (gcd_divide (b mod (S a)) (S a)) as (H,H'). + Qed. + + Lemma sqrt_specif n : (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n). + Proof. + set (s:=sqrt n). + replace n with (n + 0*0 + (0-0)). + - apply sqrt_iter_spec; auto. + - simpl. + now rewrite !add_0_r. + Qed. + + Definition sqrt_spec a (Ha:0<=a) := sqrt_specif a. + + Lemma sqrt_neg a : a<0 -> sqrt a = 0. + Proof. inversion 1. Qed. + + (** ** Logarithm *) + + Lemma log2_iter_spec : forall k p q r, + 2^(S p) = q + S r -> r < 2^p -> + let s := log2_iter k p q r in + 2^s <= k + q < 2^(S s). + Proof. + intro k; induction k as [|k IHk]. + - (* k = 0 *) + intros p q r EQ LT. + simpl log2_iter; cbv zeta. + split. + + rewrite add_0_l, (add_le_mono_l _ _ (2^p)). + simpl pow in EQ. + rewrite add_0_r in EQ; rewrite EQ, add_comm. + apply add_le_mono_r, LT. + + rewrite EQ, add_comm. + apply add_lt_mono_l. + apply lt_succ_r, le_0_l. + - (* k = S k' *) + intros p q r EQ LT. + destruct r as [|r]. + + (* r = 0 *) + rewrite add_succ_r, add_0_r in EQ. + rewrite add_succ_l, <- add_succ_r. + apply IHk. + * rewrite <- EQ. + remember (S p) as p'; simpl. + now rewrite add_0_r. + * rewrite EQ; constructor. + + (* r = S r' *) + rewrite add_succ_l, <- add_succ_r. + apply IHk. + * now rewrite add_succ_l, <- add_succ_r. + * apply le_lt_trans with (S r); trivial. + do 2 constructor. + Qed. + + Lemma log2_spec n : 0 + 2^(log2 n) <= n < 2^(S (log2 n)). + Proof. + intros. + set (s:=log2 n). + replace n with (pred n + 1). + - apply log2_iter_spec; auto. + - rewrite add_1_r. + apply succ_pred. + now apply neq_sym, lt_neq. + Qed. + + Lemma log2_nonpos n : n<=0 -> log2 n = 0. + Proof. inversion 1; now subst. Qed. + + (** ** Properties of [iter] *) + + Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : + (forall a, f (g a) = h (f a)) -> forall n a, + f (iter n g a) = iter n h (f a). + Proof. + intros H n a. + induction n as [|n Hn]. + - reflexivity. + - simpl. rewrite H, Hn. reflexivity. + Qed. + + Lemma iter_swap : + forall n (A:Type) (f:A -> A) (x:A), + iter n f (f x) = f (iter n f x). + Proof. + intros. symmetry. now apply iter_swap_gen. + Qed. + + Lemma iter_succ : + forall n (A:Type) (f:A -> A) (x:A), + iter (S n) f x = f (iter n f x). + Proof. + reflexivity. + Qed. + + Lemma iter_succ_r : + forall n (A:Type) (f:A -> A) (x:A), + iter (S n) f x = iter n f (f x). + Proof. + intros; now rewrite iter_succ, iter_swap. + Qed. + + Lemma iter_add : + forall p q (A:Type) (f:A -> A) (x:A), + iter (p+q) f x = iter p f (iter q f x). + Proof. + intro p. induction p as [|p IHp]. + - reflexivity. + - intros q A f x. simpl. now rewrite IHp. + Qed. + + Lemma iter_ind (A:Type) (f:A -> A) (a:A) (P:nat -> A -> Prop) : + P 0 a -> + (forall n a', P n a' -> P (S n) (f a')) -> + forall n, P n (iter n f a). + Proof. + intros H0 HS n. induction n as [|n Hn]. + - exact H0. + - apply HS. exact Hn. + Qed. + + Lemma iter_rect (A:Type) (f:A -> A) (a:A) (P:nat -> A -> Type) : + P 0 a -> + (forall n a', P n a' -> P (S n) (f a')) -> + forall n, P n (iter n f a). + Proof. + intros H0 HS n. induction n as [|n Hn]. + - exact H0. + - apply HS. exact Hn. + Defined. + + Lemma iter_invariant : + forall (n:nat) (A:Type) (f:A -> A) (Inv:A -> Prop), + (forall x:A, Inv x -> Inv (f x)) -> + forall x:A, Inv x -> Inv (iter n f x). + Proof. + intros; apply iter_ind; trivial. + Qed. + + (** ** Gcd *) + + Definition divide x y := exists z, y=z*x. + Notation "( x | y )" := (divide x y) (at level 0) : nat_scope. + + Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b). + Proof. + fix gcd_divide 1. + intros [|a] b; simpl. + - split. + + now exists 0. + + exists 1; simpl. + now rewrite <- plus_n_O. + - fold (b mod (S a)). + destruct (gcd_divide (b mod (S a)) (S a)) as (H,H'). + set (a':=S a) in *. + split; auto. + rewrite (div_mod_eq b a') at 2. + destruct H as (u,Hu), H' as (v,Hv). + rewrite mul_comm. + exists ((b/a')*v + u). + rewrite mul_add_distr_r. + now rewrite <- mul_assoc, <- Hv, <- Hu. + Qed. + + Lemma gcd_divide_l : forall a b, (gcd a b | a). + Proof. apply gcd_divide. Qed. + + Lemma gcd_divide_r : forall a b, (gcd a b | b). + Proof. apply gcd_divide. Qed. + + Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). + Proof. + fix gcd_greatest 1. + intros [|a] b; simpl; auto. + fold (b mod (S a)). + intros c H H'. + apply gcd_greatest; auto. set (a':=S a) in *. - split; auto. - rewrite (div_mod_eq b a') at 2. + rewrite (div_mod_eq b a') in H'. destruct H as (u,Hu), H' as (v,Hv). - rewrite mul_comm. - exists ((b/a')*v + u). - rewrite mul_add_distr_r. - now rewrite <- mul_assoc, <- Hv, <- Hu. -Qed. - -Lemma gcd_divide_l : forall a b, (gcd a b | a). -Proof. apply gcd_divide. Qed. - -Lemma gcd_divide_r : forall a b, (gcd a b | b). -Proof. apply gcd_divide. Qed. - -Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). -Proof. - fix gcd_greatest 1. - intros [|a] b; simpl; auto. - fold (b mod (S a)). - intros c H H'. - apply gcd_greatest; auto. - set (a':=S a) in *. - rewrite (div_mod_eq b a') in H'. - destruct H as (u,Hu), H' as (v,Hv). - exists (v - (b/a')*u). - rewrite mul_comm in Hv. - rewrite mul_sub_distr_r, <- Hv, <- mul_assoc, <-Hu. - now rewrite add_comm, add_sub. -Qed. - -Lemma gcd_nonneg a b : 0<=gcd a b. -Proof. apply le_0_l. Qed. - - -(** ** Bitwise operations *) - -Definition double_S : forall n, double (S n) = S (S (double n)) - := fun n => add_succ_r (S n) n. - -Definition double_add : forall n m, double (n + m) = double n + double m - := fun n m => add_shuffle1 n m n m. - -Lemma double_twice : forall n, double n = 2*n. -Proof. simpl; intros; now rewrite add_0_r. Qed. - -(* We use a Module Type to hide intermediate lemmas we will get from Natural + exists (v - (b/a')*u). + rewrite mul_comm in Hv. + rewrite mul_sub_distr_r, <- Hv, <- mul_assoc, <-Hu. + now rewrite add_comm, add_sub. + Qed. + + Lemma gcd_nonneg a b : 0<=gcd a b. + Proof. apply le_0_l. Qed. + + + (** ** Bitwise operations *) + + Definition double_S : forall n, double (S n) = S (S (double n)) + := fun n => add_succ_r (S n) n. + + Definition double_add : forall n m, double (n + m) = double n + double m + := fun n m => add_shuffle1 n m n m. + + Lemma double_twice : forall n, double n = 2*n. + Proof. simpl; intros; now rewrite add_0_r. Qed. + + (* We use a Module Type to hide intermediate lemmas we will get from Natural anyway. *) -Module Type PrivateBitwiseSpec. - (* needed to implement Numbers.NatInt.NZBitsSpec *) - Parameter testbit_odd_0 : forall a : nat, testbit (add (mul 2 a) 1) 0 = true. - Parameter testbit_even_0 : forall a : nat, testbit (mul 2 a) 0 = false. - Parameter testbit_odd_succ : forall a n : nat, le 0 n -> - testbit (add (mul 2 a) 1) (succ n) = testbit a n. - Parameter testbit_even_succ : forall a n : nat, le 0 n -> - testbit (mul 2 a) (succ n) = testbit a n. - Parameter testbit_neg_r : forall a n : nat, lt n 0 -> testbit a n = false. - Parameter shiftr_spec : forall a n m : nat, le 0 m -> - testbit (shiftr a n) m = testbit a (add m n). - Parameter shiftl_spec_high : - forall a n m : nat, le 0 m -> - le n m -> testbit (shiftl a n) m = testbit a (sub m n). - Parameter shiftl_spec_low : - forall a n m : nat, lt m n -> testbit (shiftl a n) m = false. - Parameter land_spec : - forall a b n : nat, testbit (land a b) n = testbit a n && testbit b n. - Parameter lor_spec : - forall a b n : nat, testbit (lor a b) n = testbit a n || testbit b n. - Parameter ldiff_spec : - forall a b n : nat, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). - Parameter lxor_spec : - forall a b n : nat, testbit (lxor a b) n = xorb (testbit a n) (testbit b n). - Parameter div2_spec : - forall a : nat, eq (div2 a) (shiftr a 1). - (* not yet generalized to Numbers.Natural.Abstract *) - Parameter div2_double : forall n, div2 (2*n) = n. - Parameter div2_succ_double : forall n, div2 (S (2*n)) = n. - Parameter div2_bitwise : forall op n a b, - div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). - Parameter odd_bitwise : forall op n a b, - odd (bitwise op (S n) a b) = op (odd a) (odd b). - Parameter testbit_bitwise_1 : forall op, (forall b, op false b = false) -> - forall n m a b, a<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). - Parameter testbit_bitwise_2 : forall op, op false false = false -> - forall n m a b, a<=n -> b<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). -End PrivateBitwiseSpec. - -(* The following module has to be included (it semmes that importing it is not + Module Type PrivateBitwiseSpec. + (* needed to implement Numbers.NatInt.NZBitsSpec *) + Parameter testbit_odd_0 : forall a : nat, testbit (add (mul 2 a) 1) 0 = true. + Parameter testbit_even_0 : forall a : nat, testbit (mul 2 a) 0 = false. + Parameter testbit_odd_succ : forall a n : nat, le 0 n -> + testbit (add (mul 2 a) 1) (succ n) = testbit a n. + Parameter testbit_even_succ : forall a n : nat, le 0 n -> + testbit (mul 2 a) (succ n) = testbit a n. + Parameter testbit_neg_r : forall a n : nat, lt n 0 -> testbit a n = false. + Parameter shiftr_spec : forall a n m : nat, le 0 m -> + testbit (shiftr a n) m = testbit a (add m n). + Parameter shiftl_spec_high : + forall a n m : nat, le 0 m -> + le n m -> testbit (shiftl a n) m = testbit a (sub m n). + Parameter shiftl_spec_low : + forall a n m : nat, lt m n -> testbit (shiftl a n) m = false. + Parameter land_spec : + forall a b n : nat, testbit (land a b) n = testbit a n && testbit b n. + Parameter lor_spec : + forall a b n : nat, testbit (lor a b) n = testbit a n || testbit b n. + Parameter ldiff_spec : + forall a b n : nat, + testbit (ldiff a b) n = testbit a n && negb (testbit b n). + Parameter lxor_spec : + forall a b n : nat, testbit (lxor a b) n = xorb (testbit a n) (testbit b n). + Parameter div2_spec : + forall a : nat, eq (div2 a) (shiftr a 1). + (* not yet generalized to Numbers.Natural.Abstract *) + Parameter div2_double : forall n, div2 (2*n) = n. + Parameter div2_succ_double : forall n, div2 (S (2*n)) = n. + Parameter div2_bitwise : forall op n a b, + div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). + Parameter odd_bitwise : forall op n a b, + odd (bitwise op (S n) a b) = op (odd a) (odd b). + Parameter testbit_bitwise_1 : forall op, (forall b, op false b = false) -> + forall n m a b, a<=n -> + testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). + Parameter testbit_bitwise_2 : forall op, op false false = false -> + forall n m a b, a<=n -> b<=n -> + testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). + End PrivateBitwiseSpec. + + (* The following module has to be included (it semmes that importing it is not enough to implement NZBitsSpec), therefore it has to be "Private", otherwise, its lemmas will appear twice in [Search]es *) -Module PrivateImplementsBitwiseSpec : PrivateBitwiseSpec. - -Lemma div2_double n : div2 (2*n) = n. -Proof. - induction n; trivial. - simpl mul. - rewrite add_succ_r; simpl. - now f_equal. -Qed. - -Lemma div2_succ_double n : div2 (S (2*n)) = n. -Proof. - induction n; trivial. - simpl; f_equal. - now rewrite add_succ_r. -Qed. - -Lemma le_div2 n : div2 (S n) <= n. -Proof. - revert n. - fix le_div2 1. - intro n; destruct n as [|n]; simpl; trivial. - apply lt_succ_r. - destruct n; [simpl|]; trivial. - now constructor. -Qed. - -Lemma lt_div2 n : 0 < n -> div2 n < n. -Proof. - destruct n. - - inversion 1. - - intros _; apply lt_succ_r, le_div2. -Qed. - -Lemma div2_decr a n : a <= S n -> div2 a <= n. -Proof. - destruct a as [|a]; intros H. - - simpl; apply le_0_l. - - apply succ_le_mono in H. - apply le_trans with a; [ apply le_div2 | trivial ]. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_0_l : forall n, testbit 0 n = false. -Proof. now intro n; induction n. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. -Proof. unfold testbit; rewrite odd_spec; now exists a. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_even_0 a : testbit (2*a) 0 = false. -Proof. - unfold testbit, odd. - rewrite (proj2 (even_spec _)); trivial. - now exists a. -Qed. - -Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n. -Proof. - unfold testbit; fold testbit. - rewrite add_1_r; f_equal. - apply div2_succ_double. -Qed. - -Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n. -Proof. unfold testbit; fold testbit; f_equal; apply div2_double. Qed. - -Lemma shiftr_specif : forall a n m, - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros a n; induction n as [|n IHn]; intros m. - - now rewrite add_0_r. - - now rewrite add_succ_r, <- add_succ_l, <- IHn. -Qed. - -Lemma shiftl_specif_high : forall a n m, n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros a n; induction n as [|n IHn]; intros m H; [ trivial | ]. - - now rewrite sub_0_r. - - destruct m; [ inversion H | ]. - simpl; apply succ_le_mono in H. - change (shiftl a (S n)) with (double (shiftl a n)). - rewrite double_twice, div2_double. - now apply IHn. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma shiftl_spec_low : forall a n m, m - testbit (shiftl a n) m = false. -Proof. - intros a n; induction n as [|n IHn]; intros m H; [ inversion H | ]. - change (shiftl a (S n)) with (double (shiftl a n)). - destruct m; simpl. - - unfold odd; apply negb_false_iff. - apply even_spec. - exists (shiftl a n). - apply double_twice. - - rewrite double_twice, div2_double. - apply IHn. - now apply succ_le_mono. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma div2_bitwise : forall op n a b, - div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). -Proof. - intros op n a b; unfold bitwise; fold bitwise. - destruct (op (odd a) (odd b)). - - now rewrite div2_succ_double. - - now rewrite add_0_l, div2_double. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma odd_bitwise : forall op n a b, - odd (bitwise op (S n) a b) = op (odd a) (odd b). -Proof. - intros op n a b; unfold bitwise; fold bitwise. - destruct (op (odd a) (odd b)). - - apply odd_spec. - rewrite add_comm; eexists; eauto. - - unfold odd; apply negb_false_iff. - apply even_spec. - rewrite add_0_l; eexists; eauto. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) -> - forall n m a b, a<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). -Proof. - intros op Hop. - intro n; induction n as [|n IHn]; intros m a b Ha. - - simpl; inversion Ha; subst. - now rewrite testbit_0_l. - - destruct m. - + apply odd_bitwise. - + unfold testbit; fold testbit; rewrite div2_bitwise. - apply IHn; now apply div2_decr. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma testbit_bitwise_2 : forall op, op false false = false -> - forall n m a b, a<=n -> b<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). -Proof. - intros op Hop. - intro n; induction n as [|n IHn]; intros m a b Ha Hb. - - simpl; inversion Ha; inversion Hb; subst. - now rewrite testbit_0_l. - - destruct m. - + apply odd_bitwise. - + unfold testbit; fold testbit; rewrite div2_bitwise. - apply IHn; now apply div2_decr. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma land_spec a b n : - testbit (land a b) n = testbit a n && testbit b n. -Proof. unfold land; apply testbit_bitwise_1; trivial. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma ldiff_spec a b n : - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. unfold ldiff; apply testbit_bitwise_1; trivial. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma lor_spec a b n : - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - unfold lor; apply testbit_bitwise_2. - - trivial. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_l; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_r; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma lxor_spec a b n : - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - unfold lxor; apply testbit_bitwise_2. - - trivial. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_l; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_r; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma div2_spec a : div2 a = shiftr a 1. -Proof. reflexivity. Qed. - -(** Aliases with extra dummy hypothesis, to fulfil the interface *) - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_neg_r a n (H:n<0) : testbit a n = false. -Proof. inversion H. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m. -End PrivateImplementsBitwiseSpec. -Include PrivateImplementsBitwiseSpec. - -Lemma div_0_r a : a / 0 = 0. -Proof. reflexivity. Qed. - -Lemma mod_0_r a : a mod 0 = a. -Proof. reflexivity. Qed. - -(** Properties of advanced functions (pow, sqrt, log2, ...) *) - -Include NExtraPreProp <+ NExtraProp0. - -Lemma binary_induction (A : nat -> Prop) : - A 0 -> (forall n, A n -> A (2 * n)) -> (forall n, A n -> A (2 * n + 1)) - -> forall n, A n. -Proof. apply Private_binary_induction; intros x y ->; reflexivity. Qed. - -(** Properties of tail-recursive addition and multiplication *) - -Lemma tail_add_spec n m : tail_add n m = n + m. -Proof. - revert m; induction n as [|n IH]; simpl; trivial; intros. - now rewrite IH, add_succ_r. -Qed. - -Lemma tail_addmul_spec r n m : tail_addmul r n m = r + n * m. -Proof. - revert m r; induction n as [| n IH]; simpl; trivial; intros. - rewrite IH, tail_add_spec. - rewrite add_assoc. - f_equal; apply add_comm. -Qed. - -Lemma tail_mul_spec n m : tail_mul n m = n * m. -Proof. unfold tail_mul; now rewrite tail_addmul_spec. Qed. - -(** Additional results about [Even] and [Odd] *) - -Definition Even_Odd_dec n : {Even n} + {Odd n}. -Proof. - induction n as [|n IHn]. - - left; apply Even_0. - - elim IHn; intros. - + right; apply Even_succ, Even_succ_succ; assumption. - + left; apply Odd_succ, Odd_succ_succ; assumption. -Defined. - -Lemma Even_add_split n m : - Even (n + m) -> Even n /\ Even m \/ Odd n /\ Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_split n m : - Odd (n + m) -> Odd n /\ Even m \/ Even n /\ Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_Even_add n m: Even n -> Even m -> Even (n + m). -Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. - -Lemma Odd_add_l n m : Odd n -> Even m -> Odd (n + m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_r n m : Even n -> Odd m -> Odd (n + m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_Odd_add n m : Odd n -> Odd m -> Even (n + m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_add_aux n m : - (Odd (n + m) <-> Odd n /\ Even m \/ Even n /\ Odd m) /\ - (Even (n + m) <-> Even n /\ Even m \/ Odd n /\ Odd m). -Proof. - split; split. - - apply Odd_add_split. - - intros [[HO HE]|[HE HO]]; [ apply Odd_add_l | apply Odd_add_r ]; assumption. - - apply Even_add_split. - - intros [[HO HE]|[HE HO]]; [ apply Even_Even_add | apply Odd_Odd_add ]; assumption. -Qed. - -Lemma Even_add_Even_inv_r n m : Even (n + m) -> Even n -> Even m. -Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. - -Lemma Even_add_Even_inv_l n m : Even (n + m) -> Even m -> Even n. -Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. - -Lemma Even_add_Odd_inv_r n m : Even (n + m) -> Odd n -> Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_add_Odd_inv_l n m : Even (n + m) -> Odd m -> Odd n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Even_inv_l n m : Odd (n + m) -> Odd m -> Even n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Even_inv_r n m : Odd (n + m) -> Odd n -> Even m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Odd_inv_l n m : Odd (n + m) -> Even m -> Odd n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Odd_inv_r n m : Odd (n + m) -> Even n -> Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_mul_aux n m : - (Odd (n * m) <-> Odd n /\ Odd m) /\ (Even (n * m) <-> Even n \/ Even m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_mul, even_mul; unfold odd; do 2 destruct even; tauto. -Qed. - -Lemma Even_mul_l n m : Even n -> Even (n * m). -Proof. rewrite <- ? even_spec, even_mul; do 2 destruct even; auto. Qed. - -Lemma Even_mul_r n m : Even m -> Even (n * m). -Proof. rewrite <- ? even_spec, even_mul; do 2 destruct even; auto. Qed. - -Lemma Even_mul_inv_r n m : Even (n * m) -> Odd n -> Even m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_mul; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_mul_inv_l n m : Even (n * m) -> Odd m -> Even n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_mul; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_mul n m : Odd n -> Odd m -> Odd (n * m). -Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. - -Lemma Odd_mul_inv_l n m : Odd (n * m) -> Odd n. -Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. - -Lemma Odd_mul_inv_r n m : Odd (n * m) -> Odd m. -Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. - -Lemma Even_div2 n : Even n -> div2 n = div2 (S n). -Proof. intros [p ->]; rewrite div2_succ_double; apply div2_double. Qed. - -Lemma Odd_div2 n : Odd n -> S (div2 n) = div2 (S n). -Proof. - intros [p ->]; rewrite add_1_r, div2_succ_double; cbn. - f_equal; symmetry; apply div2_double. -Qed. - -Lemma div2_Even n : div2 n = div2 (S n) -> Even n. -Proof. - destruct (Even_or_Odd n) as [Ev|Od]; trivial. - apply Odd_div2 in Od; rewrite <- Od. - intro Od'; destruct (neq_succ_diag_r _ Od'). -Qed. - -Lemma div2_Odd n : S (div2 n) = div2 (S n) -> Odd n. -Proof. - destruct (Even_or_Odd n) as [Ev|Od]; trivial. - apply Even_div2 in Ev; rewrite <- Ev. - intro Ev'; symmetry in Ev'; destruct (neq_succ_diag_r _ Ev'). -Qed. - -Lemma Even_Odd_div2 n : - (Even n <-> div2 n = div2 (S n)) /\ (Odd n <-> S (div2 n) = div2 (S n)). -Proof. - split; split; [ apply Even_div2 | apply div2_Even | apply Odd_div2 | apply div2_Odd ]. -Qed. - -Lemma Even_Odd_double n : - (Even n <-> n = double (div2 n)) /\ (Odd n <-> n = S (double (div2 n))). -Proof. - revert n. - fix Even_Odd_double 1. - intros n; destruct n as [|[|n]]. - - (* n = 0 *) - split; split; intros H; [ reflexivity | apply Even_0 | apply Odd_0 in H as [] | inversion H ]. - - (* n = 1 *) - split; split; intros H; [ apply Even_1 in H as [] | inversion H | reflexivity | apply Odd_1 ]. - - (* n = (S (S n')) *) - destruct (Even_Odd_double n) as ((Ev,Ev'),(Od,Od')). - split; split; simpl div2; rewrite ? double_S, ? Even_succ_succ, ? Odd_succ_succ. - + intros; do 2 f_equal; auto. - + injection 1; auto. - + intros; do 2 f_equal; auto. - + injection 1; auto. -Qed. - -Lemma Even_double n : Even n -> n = double (div2 n). -Proof. - exact (proj1 (proj1 (Even_Odd_double n))). -Qed. - -Lemma double_Even n : n = double (div2 n) -> Even n. -Proof. - exact (proj2 (proj1 (Even_Odd_double n))). -Qed. - -Lemma Odd_double n : Odd n -> n = S (double (div2 n)). -Proof. - exact (proj1 (proj2 (Even_Odd_double n))). -Qed. - -Lemma double_Odd n : n = S (double (div2 n)) -> Odd n. -Proof. - exact (proj2 (proj2 (Even_Odd_double n))). -Qed. - -(** Inductive definition of even and odd *) -Inductive Even_alt : nat -> Prop := -| Even_alt_O : Even_alt 0 -| Even_alt_S : forall n, Odd_alt n -> Even_alt (S n) -with Odd_alt : nat -> Prop := -| Odd_alt_S : forall n, Even_alt n -> Odd_alt (S n). - -Lemma Even_alt_Even : forall n, Even_alt n <-> Even n. -Proof. - fix Even_alt_Even 1. - intros n; destruct n as [|[|n]]; simpl. - - split; [now exists 0 | constructor]. - - split. - + inversion_clear 1 as [|? H0]. - inversion_clear H0. - + now rewrite <- Nat.even_spec. - - rewrite Nat.Even_succ_succ, <- Even_alt_Even. - split. - + inversion_clear 1 as [|? H0]. - now inversion_clear H0. - + now do 2 constructor. -Qed. - -Lemma Odd_alt_Odd : forall n, Odd_alt n <-> Odd n. -Proof. - fix Odd_alt_Odd 1. - intros n; destruct n as [|[|n]]; simpl. - - split. - + inversion_clear 1. - + now rewrite <- Nat.odd_spec. - - split; [ now exists 0 | do 2 constructor ]. - - rewrite Nat.Odd_succ_succ, <- Odd_alt_Odd. - split. - + inversion_clear 1 as [? H0]. - now inversion_clear H0. - + now do 2 constructor. -Qed. - -Scheme Odd_alt_Even_alt_ind := Minimality for Odd_alt Sort Prop -with Even_alt_Odd_alt_ind := Minimality for Even_alt Sort Prop. - -Lemma Odd_Even_ind (P Q : nat -> Prop) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Odd n -> P n. -Proof. - intros HSE H0 HSO n HO%Odd_alt_Odd. - apply Odd_alt_Even_alt_ind with Q; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -Lemma Even_Odd_ind (P Q : nat -> Prop) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Even n -> Q n. -Proof. - intros HSE H0 HSO n HE%Even_alt_Even. - apply Even_alt_Odd_alt_ind with P; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -(* Anomaly see Issue #15413 + Module PrivateImplementsBitwiseSpec : PrivateBitwiseSpec. + + Lemma div2_double n : div2 (2*n) = n. + Proof. + induction n; trivial. + simpl mul. + rewrite add_succ_r; simpl. + now f_equal. + Qed. + + Lemma div2_succ_double n : div2 (S (2*n)) = n. + Proof. + induction n; trivial. + simpl; f_equal. + now rewrite add_succ_r. + Qed. + + Lemma le_div2 n : div2 (S n) <= n. + Proof. + revert n. + fix le_div2 1. + intro n; destruct n as [|n]; simpl; trivial. + apply lt_succ_r. + destruct n; [simpl|]; trivial. + now constructor. + Qed. + + Lemma lt_div2 n : 0 < n -> div2 n < n. + Proof. + destruct n. + - inversion 1. + - intros _; apply lt_succ_r, le_div2. + Qed. + + Lemma div2_decr a n : a <= S n -> div2 a <= n. + Proof. + destruct a as [|a]; intros H. + - simpl; apply le_0_l. + - apply succ_le_mono in H. + apply le_trans with a; [ apply le_div2 | trivial ]. + Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma testbit_0_l : forall n, testbit 0 n = false. + Proof. now intro n; induction n. Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. + Proof. unfold testbit; rewrite odd_spec; now exists a. Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma testbit_even_0 a : testbit (2*a) 0 = false. + Proof. + unfold testbit, odd. + rewrite (proj2 (even_spec _)); trivial. + now exists a. + Qed. + + Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n. + Proof. + unfold testbit; fold testbit. + rewrite add_1_r; f_equal. + apply div2_succ_double. + Qed. + + Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n. + Proof. unfold testbit; fold testbit; f_equal; apply div2_double. Qed. + + Lemma shiftr_specif : forall a n m, + testbit (shiftr a n) m = testbit a (m+n). + Proof. + intros a n; induction n as [|n IHn]; intros m. + - now rewrite add_0_r. + - now rewrite add_succ_r, <- add_succ_l, <- IHn. + Qed. + + Lemma shiftl_specif_high : forall a n m, n<=m -> + testbit (shiftl a n) m = testbit a (m-n). + Proof. + intros a n; induction n as [|n IHn]; intros m H; [ trivial | ]. + - now rewrite sub_0_r. + - destruct m; [ inversion H | ]. + simpl; apply succ_le_mono in H. + change (shiftl a (S n)) with (double (shiftl a n)). + rewrite double_twice, div2_double. + now apply IHn. + Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma shiftl_spec_low : forall a n m, m + testbit (shiftl a n) m = false. + Proof. + intros a n; induction n as [|n IHn]; intros m H; [ inversion H | ]. + change (shiftl a (S n)) with (double (shiftl a n)). + destruct m; simpl. + - unfold odd; apply negb_false_iff. + apply even_spec. + exists (shiftl a n). + apply double_twice. + - rewrite double_twice, div2_double. + apply IHn. + now apply succ_le_mono. + Qed. + + (* not yet generalized, part of the interface at this point *) + Lemma div2_bitwise : forall op n a b, + div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). + Proof. + intros op n a b; unfold bitwise; fold bitwise. + destruct (op (odd a) (odd b)). + - now rewrite div2_succ_double. + - now rewrite add_0_l, div2_double. + Qed. + + (* not yet generalized, part of the interface at this point *) + Lemma odd_bitwise : forall op n a b, + odd (bitwise op (S n) a b) = op (odd a) (odd b). + Proof. + intros op n a b; unfold bitwise; fold bitwise. + destruct (op (odd a) (odd b)). + - apply odd_spec. + rewrite add_comm; eexists; eauto. + - unfold odd; apply negb_false_iff. + apply even_spec. + rewrite add_0_l; eexists; eauto. + Qed. + + (* not yet generalized, part of the interface at this point *) + Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) -> + forall n m a b, a<=n -> + testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). + Proof. + intros op Hop. + intro n; induction n as [|n IHn]; intros m a b Ha. + - simpl; inversion Ha; subst. + now rewrite testbit_0_l. + - destruct m. + + apply odd_bitwise. + + unfold testbit; fold testbit; rewrite div2_bitwise. + apply IHn; now apply div2_decr. + Qed. + + (* not yet generalized, part of the interface at this point *) + Lemma testbit_bitwise_2 : forall op, op false false = false -> + forall n m a b, a<=n -> b<=n -> + testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). + Proof. + intros op Hop. + intro n; induction n as [|n IHn]; intros m a b Ha Hb. + - simpl; inversion Ha; inversion Hb; subst. + now rewrite testbit_0_l. + - destruct m. + + apply odd_bitwise. + + unfold testbit; fold testbit; rewrite div2_bitwise. + apply IHn; now apply div2_decr. + Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma land_spec a b n : + testbit (land a b) n = testbit a n && testbit b n. + Proof. unfold land; apply testbit_bitwise_1; trivial. Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma ldiff_spec a b n : + testbit (ldiff a b) n = testbit a n && negb (testbit b n). + Proof. unfold ldiff; apply testbit_bitwise_1; trivial. Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma lor_spec a b n : + testbit (lor a b) n = testbit a n || testbit b n. + Proof. + unfold lor; apply testbit_bitwise_2. + - trivial. + - destruct (compare_spec a b) as [H|H|H]. + + rewrite max_l; subst; trivial. + + now apply lt_le_incl in H; rewrite max_r. + + now apply lt_le_incl in H; rewrite max_l. + - destruct (compare_spec a b) as [H|H|H]. + + rewrite max_r; subst; trivial. + + now apply lt_le_incl in H; rewrite max_r. + + now apply lt_le_incl in H; rewrite max_l. + Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma lxor_spec a b n : + testbit (lxor a b) n = xorb (testbit a n) (testbit b n). + Proof. + unfold lxor; apply testbit_bitwise_2. + - trivial. + - destruct (compare_spec a b) as [H|H|H]. + + rewrite max_l; subst; trivial. + + now apply lt_le_incl in H; rewrite max_r. + + now apply lt_le_incl in H; rewrite max_l. + - destruct (compare_spec a b) as [H|H|H]. + + rewrite max_r; subst; trivial. + + now apply lt_le_incl in H; rewrite max_r. + + now apply lt_le_incl in H; rewrite max_l. + Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma div2_spec a : div2 a = shiftr a 1. + Proof. reflexivity. Qed. + + (** Aliases with extra dummy hypothesis, to fulfil the interface *) + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Lemma testbit_neg_r a n (H:n<0) : testbit a n = false. + Proof. inversion H. Qed. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m. + + (* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) + Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m. + End PrivateImplementsBitwiseSpec. + Include PrivateImplementsBitwiseSpec. + + Lemma div_0_r a : a / 0 = 0. + Proof. reflexivity. Qed. + + Lemma mod_0_r a : a mod 0 = a. + Proof. reflexivity. Qed. + + (** Properties of advanced functions (pow, sqrt, log2, ...) *) + + Include NExtraPreProp <+ NExtraProp0. + + Lemma binary_induction (A : nat -> Prop) : + A 0 -> (forall n, A n -> A (2 * n)) -> (forall n, A n -> A (2 * n + 1)) + -> forall n, A n. + Proof. apply Private_binary_induction; intros x y ->; reflexivity. Qed. + + (** Properties of tail-recursive addition and multiplication *) + + Lemma tail_add_spec n m : tail_add n m = n + m. + Proof. + revert m; induction n as [|n IH]; simpl; trivial; intros. + now rewrite IH, add_succ_r. + Qed. + + Lemma tail_addmul_spec r n m : tail_addmul r n m = r + n * m. + Proof. + revert m r; induction n as [| n IH]; simpl; trivial; intros. + rewrite IH, tail_add_spec. + rewrite add_assoc. + f_equal; apply add_comm. + Qed. + + Lemma tail_mul_spec n m : tail_mul n m = n * m. + Proof. unfold tail_mul; now rewrite tail_addmul_spec. Qed. + + (** Additional results about [Even] and [Odd] *) + + Definition Even_Odd_dec n : {Even n} + {Odd n}. + Proof. + induction n as [|n IHn]. + - left; apply Even_0. + - elim IHn; intros. + + right; apply Even_succ, Even_succ_succ; assumption. + + left; apply Odd_succ, Odd_succ_succ; assumption. + Defined. + + Lemma Even_add_split n m : + Even (n + m) -> Even n /\ Even m \/ Odd n /\ Odd m. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_add_split n m : + Odd (n + m) -> Odd n /\ Even m \/ Even n /\ Odd m. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Even_Even_add n m: Even n -> Even m -> Even (n + m). + Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. + + Lemma Odd_add_l n m : Odd n -> Even m -> Odd (n + m). + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_add_r n m : Even n -> Odd m -> Odd (n + m). + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_Odd_add n m : Odd n -> Odd m -> Even (n + m). + Proof. + rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Even_add_aux n m : + (Odd (n + m) <-> Odd n /\ Even m \/ Even n /\ Odd m) /\ + (Even (n + m) <-> Even n /\ Even m \/ Odd n /\ Odd m). + Proof. + split; split. + - apply Odd_add_split. + - intros [[HO HE]|[HE HO]]; [ apply Odd_add_l | apply Odd_add_r ]; assumption. + - apply Even_add_split. + - intros [[HO HE]|[HE HO]]; [ apply Even_Even_add | apply Odd_Odd_add ]; assumption. + Qed. + + Lemma Even_add_Even_inv_r n m : Even (n + m) -> Even n -> Even m. + Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. + + Lemma Even_add_Even_inv_l n m : Even (n + m) -> Even m -> Even n. + Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. + + Lemma Even_add_Odd_inv_r n m : Even (n + m) -> Odd n -> Odd m. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Even_add_Odd_inv_l n m : Even (n + m) -> Odd m -> Odd n. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_add_Even_inv_l n m : Odd (n + m) -> Odd m -> Even n. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_add_Even_inv_r n m : Odd (n + m) -> Odd n -> Even m. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_add_Odd_inv_l n m : Odd (n + m) -> Even m -> Odd n. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_add_Odd_inv_r n m : Odd (n + m) -> Even n -> Odd m. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Even_mul_aux n m : + (Odd (n * m) <-> Odd n /\ Odd m) /\ (Even (n * m) <-> Even n \/ Even m). + Proof. + rewrite <- ? even_spec, <- ? odd_spec, odd_mul, even_mul; unfold odd; do 2 destruct even; tauto. + Qed. + + Lemma Even_mul_l n m : Even n -> Even (n * m). + Proof. rewrite <- ? even_spec, even_mul; do 2 destruct even; auto. Qed. + + Lemma Even_mul_r n m : Even m -> Even (n * m). + Proof. rewrite <- ? even_spec, even_mul; do 2 destruct even; auto. Qed. + + Lemma Even_mul_inv_r n m : Even (n * m) -> Odd n -> Even m. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, even_mul; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Even_mul_inv_l n m : Even (n * m) -> Odd m -> Even n. + Proof. + rewrite <- ? even_spec, <- ? odd_spec, even_mul; unfold odd; do 2 destruct even; auto. + Qed. + + Lemma Odd_mul n m : Odd n -> Odd m -> Odd (n * m). + Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. + + Lemma Odd_mul_inv_l n m : Odd (n * m) -> Odd n. + Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. + + Lemma Odd_mul_inv_r n m : Odd (n * m) -> Odd m. + Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. + + Lemma Even_div2 n : Even n -> div2 n = div2 (S n). + Proof. intros [p ->]; rewrite div2_succ_double; apply div2_double. Qed. + + Lemma Odd_div2 n : Odd n -> S (div2 n) = div2 (S n). + Proof. + intros [p ->]; rewrite add_1_r, div2_succ_double; cbn. + f_equal; symmetry; apply div2_double. + Qed. + + Lemma div2_Even n : div2 n = div2 (S n) -> Even n. + Proof. + destruct (Even_or_Odd n) as [Ev|Od]; trivial. + apply Odd_div2 in Od; rewrite <- Od. + intro Od'; destruct (neq_succ_diag_r _ Od'). + Qed. + + Lemma div2_Odd n : S (div2 n) = div2 (S n) -> Odd n. + Proof. + destruct (Even_or_Odd n) as [Ev|Od]; trivial. + apply Even_div2 in Ev; rewrite <- Ev. + intro Ev'; symmetry in Ev'; destruct (neq_succ_diag_r _ Ev'). + Qed. + + Lemma Even_Odd_div2 n : + (Even n <-> div2 n = div2 (S n)) /\ (Odd n <-> S (div2 n) = div2 (S n)). + Proof. + split; split; [ apply Even_div2 | apply div2_Even | apply Odd_div2 | apply div2_Odd ]. + Qed. + + Lemma Even_Odd_double n : + (Even n <-> n = double (div2 n)) /\ (Odd n <-> n = S (double (div2 n))). + Proof. + revert n. + fix Even_Odd_double 1. + intros n; destruct n as [|[|n]]. + - (* n = 0 *) + split; split; intros H; [ reflexivity | apply Even_0 | apply Odd_0 in H as [] | inversion H ]. + - (* n = 1 *) + split; split; intros H; [ apply Even_1 in H as [] | inversion H | reflexivity | apply Odd_1 ]. + - (* n = (S (S n')) *) + destruct (Even_Odd_double n) as ((Ev,Ev'),(Od,Od')). + split; split; simpl div2; rewrite ? double_S, ? Even_succ_succ, ? Odd_succ_succ. + + intros; do 2 f_equal; auto. + + injection 1; auto. + + intros; do 2 f_equal; auto. + + injection 1; auto. + Qed. + + Lemma Even_double n : Even n -> n = double (div2 n). + Proof. + exact (proj1 (proj1 (Even_Odd_double n))). + Qed. + + Lemma double_Even n : n = double (div2 n) -> Even n. + Proof. + exact (proj2 (proj1 (Even_Odd_double n))). + Qed. + + Lemma Odd_double n : Odd n -> n = S (double (div2 n)). + Proof. + exact (proj1 (proj2 (Even_Odd_double n))). + Qed. + + Lemma double_Odd n : n = S (double (div2 n)) -> Odd n. + Proof. + exact (proj2 (proj2 (Even_Odd_double n))). + Qed. + + (** Inductive definition of even and odd *) + Inductive Even_alt : nat -> Prop := + | Even_alt_O : Even_alt 0 + | Even_alt_S : forall n, Odd_alt n -> Even_alt (S n) + with Odd_alt : nat -> Prop := + | Odd_alt_S : forall n, Even_alt n -> Odd_alt (S n). + + Lemma Even_alt_Even : forall n, Even_alt n <-> Even n. + Proof. + fix Even_alt_Even 1. + intros n; destruct n as [|[|n]]; simpl. + - split; [now exists 0 | constructor]. + - split. + + inversion_clear 1 as [|? H0]. + inversion_clear H0. + + now rewrite <- Nat.even_spec. + - rewrite Nat.Even_succ_succ, <- Even_alt_Even. + split. + + inversion_clear 1 as [|? H0]. + now inversion_clear H0. + + now do 2 constructor. + Qed. + + Lemma Odd_alt_Odd : forall n, Odd_alt n <-> Odd n. + Proof. + fix Odd_alt_Odd 1. + intros n; destruct n as [|[|n]]; simpl. + - split. + + inversion_clear 1. + + now rewrite <- Nat.odd_spec. + - split; [ now exists 0 | do 2 constructor ]. + - rewrite Nat.Odd_succ_succ, <- Odd_alt_Odd. + split. + + inversion_clear 1 as [? H0]. + now inversion_clear H0. + + now do 2 constructor. + Qed. + + Scheme Odd_alt_Even_alt_ind := Minimality for Odd_alt Sort Prop + with Even_alt_Odd_alt_ind := Minimality for Even_alt Sort Prop. + + Lemma Odd_Even_ind (P Q : nat -> Prop) : + (forall n, Even n -> Q n -> P (S n)) -> + Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Odd n -> P n. + Proof. + intros HSE H0 HSO n HO%Odd_alt_Odd. + apply Odd_alt_Even_alt_ind with Q; try assumption. + - intros m HSE'%Even_alt_Even; auto. + - intros m HSO'%Odd_alt_Odd; auto. + Qed. + + Lemma Even_Odd_ind (P Q : nat -> Prop) : + (forall n, Even n -> Q n -> P (S n)) -> + Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Even n -> Q n. + Proof. + intros HSE H0 HSO n HE%Even_alt_Even. + apply Even_alt_Odd_alt_ind with P; try assumption. + - intros m HSE'%Even_alt_Even; auto. + - intros m HSO'%Odd_alt_Odd; auto. + Qed. + + (* Anomaly see Issue #15413 Combined Scheme Even_Odd_mutind from Even_Odd_ind, Odd_Even_ind. *) -Scheme Odd_alt_Even_alt_sind := Minimality for Odd_alt Sort SProp -with Even_alt_Odd_alt_sind := Minimality for Even_alt Sort SProp. - -Lemma Odd_Even_sind (P Q : nat -> SProp) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Odd n -> P n. -Proof. - intros HSE H0 HSO n HO%Odd_alt_Odd. - apply Odd_alt_Even_alt_sind with Q; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -Lemma Even_Odd_sind (P Q : nat -> SProp) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Even n -> Q n. -Proof. - intros HSE H0 HSO n HE%Even_alt_Even. - apply Even_alt_Odd_alt_sind with P; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -(* Anomaly see Issue #15413 + Scheme Odd_alt_Even_alt_sind := Minimality for Odd_alt Sort SProp + with Even_alt_Odd_alt_sind := Minimality for Even_alt Sort SProp. + + Lemma Odd_Even_sind (P Q : nat -> SProp) : + (forall n, Even n -> Q n -> P (S n)) -> + Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Odd n -> P n. + Proof. + intros HSE H0 HSO n HO%Odd_alt_Odd. + apply Odd_alt_Even_alt_sind with Q; try assumption. + - intros m HSE'%Even_alt_Even; auto. + - intros m HSO'%Odd_alt_Odd; auto. + Qed. + + Lemma Even_Odd_sind (P Q : nat -> SProp) : + (forall n, Even n -> Q n -> P (S n)) -> + Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Even n -> Q n. + Proof. + intros HSE H0 HSO n HE%Even_alt_Even. + apply Even_alt_Odd_alt_sind with P; try assumption. + - intros m HSE'%Even_alt_Even; auto. + - intros m HSO'%Odd_alt_Odd; auto. + Qed. + + (* Anomaly see Issue #15413 Combined Scheme Even_Odd_mutsind from Even_Odd_sind, Odd_Even_sind. *) -(** additional versions of parity predicates in [Type] + (** additional versions of parity predicates in [Type] useful for eliminating into [Type], but still with opaque proofs *) -Definition EvenT n := { m | n = 2 * m }. -Definition OddT n := { m | n = 2 * m + 1 }. - -Lemma EvenT_0 : EvenT 0. -Proof. exists 0; reflexivity. Qed. - -Lemma EvenT_2 n : EvenT n -> EvenT (S (S n)). -Proof. - intros [m H]; exists (S m); rewrite H. - cbn; rewrite add_succ_r; reflexivity. -Qed. - -Lemma OddT_1 : OddT 1. -Proof. exists 0; reflexivity. Qed. - -Lemma OddT_2 n : OddT n -> OddT (S (S n)). -Proof. - intros [m H]; exists (S m). - rewrite H, ? mul_succ_r, <- ? add_1_r, add_assoc; reflexivity. -Qed. - -Lemma EvenT_S_OddT n : EvenT (S n) -> OddT n. -Proof. - intros [[|k] HE]; inversion HE. - exists k; rewrite add_succ_r, add_1_r; reflexivity. -Qed. - -Lemma OddT_S_EvenT n : OddT (S n) -> EvenT n. -Proof. - intros [k HO]; rewrite add_1_r in HO; injection HO; intros ->. - exists k; reflexivity. -Qed. - -Lemma even_EvenT : forall n, even n = true -> EvenT n. -Proof. - fix even_specT 1. - intro n; destruct n as [|[|n]]; simpl. - - intros; apply EvenT_0. - - intros H; discriminate. - - intros He%even_specT; apply EvenT_2; assumption. -Qed. - -Lemma odd_OddT : forall n, odd n = true -> OddT n. -Proof. - unfold odd. - fix odd_specT 1. - intro n; destruct n as [|[|n]]; simpl. - - intro H; discriminate. - - intros; apply OddT_1. - - intros He%odd_specT; apply OddT_2; assumption. -Qed. - -Lemma EvenT_Even n : EvenT n -> Even n. -Proof. intros [k ?]; exists k; assumption. Qed. - -Lemma OddT_Odd n : OddT n -> Odd n. -Proof. intros [k ?]; exists k; assumption. Qed. - -Lemma Even_EvenT n : Even n -> EvenT n. -Proof. intros; apply even_EvenT, even_spec; assumption. Qed. - -Lemma Odd_OddT n : Odd n -> OddT n. -Proof. intros; apply odd_OddT, odd_spec; assumption. Qed. - -Lemma EvenT_even n : EvenT n -> even n = true. -Proof. intros; apply even_spec, EvenT_Even; assumption. Qed. - -Lemma OddT_odd n : OddT n -> odd n = true. -Proof. intros; apply odd_spec, OddT_Odd; assumption. Qed. - -Lemma EvenT_OddT_dec n : EvenT n + OddT n. -Proof. - case_eq (even n); intros Hp. - - left; apply even_EvenT; assumption. - - right; apply odd_OddT. - unfold odd; rewrite Hp; reflexivity. -Qed. - -Lemma OddT_EvenT_rect (P Q : nat -> Type) : - (forall n, EvenT n -> Q n -> P (S n)) -> - Q 0 -> (forall n, OddT n -> P n -> Q (S n)) -> forall n, OddT n -> P n. -Proof. - intros HQP HQ0 HPQ. - fix OddT_EvenT_rect 1. - intros [|[|n]]. - - intros [[|k] H0]; inversion H0. - - intros _; apply (HQP _ EvenT_0 HQ0). - - intros HOSS. - assert (EvenT (S n)) as HES by apply (OddT_S_EvenT _ HOSS). - assert (OddT n) as HO by apply (EvenT_S_OddT _ HES). - apply (HQP _ HES (HPQ _ HO (OddT_EvenT_rect _ HO))). -Qed. - -Lemma EvenT_OddT_rect (P Q : nat -> Type) : - (forall n, EvenT n -> Q n -> P (S n)) -> - Q 0 -> (forall n, OddT n -> P n -> Q (S n)) -> forall n, EvenT n -> Q n. -Proof. - intros HQP HQ0 HPQ [|n] HES; [ assumption | ]. - assert (OddT n) as HO by apply (EvenT_S_OddT _ HES). - apply HPQ, (OddT_EvenT_rect P Q); assumption. -Qed. - -(* Anomaly see Issue #15413 + Definition EvenT n := { m | n = 2 * m }. + Definition OddT n := { m | n = 2 * m + 1 }. + + Lemma EvenT_0 : EvenT 0. + Proof. exists 0; reflexivity. Qed. + + Lemma EvenT_2 n : EvenT n -> EvenT (S (S n)). + Proof. + intros [m H]; exists (S m); rewrite H. + cbn; rewrite add_succ_r; reflexivity. + Qed. + + Lemma OddT_1 : OddT 1. + Proof. exists 0; reflexivity. Qed. + + Lemma OddT_2 n : OddT n -> OddT (S (S n)). + Proof. + intros [m H]; exists (S m). + rewrite H, ? mul_succ_r, <- ? add_1_r, add_assoc; reflexivity. + Qed. + + Lemma EvenT_S_OddT n : EvenT (S n) -> OddT n. + Proof. + intros [[|k] HE]; inversion HE. + exists k; rewrite add_succ_r, add_1_r; reflexivity. + Qed. + + Lemma OddT_S_EvenT n : OddT (S n) -> EvenT n. + Proof. + intros [k HO]; rewrite add_1_r in HO; injection HO; intros ->. + exists k; reflexivity. + Qed. + + Lemma even_EvenT : forall n, even n = true -> EvenT n. + Proof. + fix even_specT 1. + intro n; destruct n as [|[|n]]; simpl. + - intros; apply EvenT_0. + - intros H; discriminate. + - intros He%even_specT; apply EvenT_2; assumption. + Qed. + + Lemma odd_OddT : forall n, odd n = true -> OddT n. + Proof. + unfold odd. + fix odd_specT 1. + intro n; destruct n as [|[|n]]; simpl. + - intro H; discriminate. + - intros; apply OddT_1. + - intros He%odd_specT; apply OddT_2; assumption. + Qed. + + Lemma EvenT_Even n : EvenT n -> Even n. + Proof. intros [k ?]; exists k; assumption. Qed. + + Lemma OddT_Odd n : OddT n -> Odd n. + Proof. intros [k ?]; exists k; assumption. Qed. + + Lemma Even_EvenT n : Even n -> EvenT n. + Proof. intros; apply even_EvenT, even_spec; assumption. Qed. + + Lemma Odd_OddT n : Odd n -> OddT n. + Proof. intros; apply odd_OddT, odd_spec; assumption. Qed. + + Lemma EvenT_even n : EvenT n -> even n = true. + Proof. intros; apply even_spec, EvenT_Even; assumption. Qed. + + Lemma OddT_odd n : OddT n -> odd n = true. + Proof. intros; apply odd_spec, OddT_Odd; assumption. Qed. + + Lemma EvenT_OddT_dec n : EvenT n + OddT n. + Proof. + case_eq (even n); intros Hp. + - left; apply even_EvenT; assumption. + - right; apply odd_OddT. + unfold odd; rewrite Hp; reflexivity. + Qed. + + Lemma OddT_EvenT_rect (P Q : nat -> Type) : + (forall n, EvenT n -> Q n -> P (S n)) -> + Q 0 -> (forall n, OddT n -> P n -> Q (S n)) -> forall n, OddT n -> P n. + Proof. + intros HQP HQ0 HPQ. + fix OddT_EvenT_rect 1. + intros [|[|n]]. + - intros [[|k] H0]; inversion H0. + - intros _; apply (HQP _ EvenT_0 HQ0). + - intros HOSS. + assert (EvenT (S n)) as HES by apply (OddT_S_EvenT _ HOSS). + assert (OddT n) as HO by apply (EvenT_S_OddT _ HES). + apply (HQP _ HES (HPQ _ HO (OddT_EvenT_rect _ HO))). + Qed. + + Lemma EvenT_OddT_rect (P Q : nat -> Type) : + (forall n, EvenT n -> Q n -> P (S n)) -> + Q 0 -> (forall n, OddT n -> P n -> Q (S n)) -> forall n, EvenT n -> Q n. + Proof. + intros HQP HQ0 HPQ [|n] HES; [ assumption | ]. + assert (OddT n) as HO by apply (EvenT_S_OddT _ HES). + apply HPQ, (OddT_EvenT_rect P Q); assumption. + Qed. + + (* Anomaly see Issue #15413 Combined Scheme EvenT_OddT_mutrect from EvenT_OddT_rect, OddT_EvenT_rect. *) End Nat. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 94919962cd..739b8e7bbf 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -39,24 +39,24 @@ Import EqNotations. Lemma le_unique: forall m n (le_mn1 le_mn2 : m <= n), le_mn1 = le_mn2. Proof. -intros m n. -generalize (eq_refl (S n)). -generalize n at -1. -induction (S n) as [|n0 IHn0]; try discriminate. -clear n; intros n [= <-] le_mn1 le_mn2. -pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2). - 2: reflexivity. -generalize def_n2; revert le_mn1 le_mn2. -generalize n0 at 1 4 5 7; intros n1 le_mn1. -destruct le_mn1 as [|? le_mn1]; intros le_mn2; destruct le_mn2 as [|? le_mn2]. -+ now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl). -+ intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0. - now destruct (Nat.nle_succ_diag_l _ le_mn0). -+ intros def_n0; generalize le_mn1; rewrite def_n0; intros le_mn0. - now destruct (Nat.nle_succ_diag_l _ le_mn0). -+ intros def_n0. injection def_n0 as [= ->]. - rewrite (UIP_nat _ _ def_n0 eq_refl); simpl. - assert (H : le_mn1 = le_mn2). - * now apply IHn0. - * now rewrite H. + intros m n. + generalize (eq_refl (S n)). + generalize n at -1. + induction (S n) as [|n0 IHn0]; try discriminate. + clear n; intros n [= <-] le_mn1 le_mn2. + pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2). + 2: reflexivity. + generalize def_n2; revert le_mn1 le_mn2. + generalize n0 at 1 4 5 7; intros n1 le_mn1. + destruct le_mn1 as [|? le_mn1]; intros le_mn2; destruct le_mn2 as [|? le_mn2]. + + now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl). + + intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0. + now destruct (Nat.nle_succ_diag_l _ le_mn0). + + intros def_n0; generalize le_mn1; rewrite def_n0; intros le_mn0. + now destruct (Nat.nle_succ_diag_l _ le_mn0). + + intros def_n0. injection def_n0 as [= ->]. + rewrite (UIP_nat _ _ def_n0 eq_refl); simpl. + assert (H : le_mn1 = le_mn2). + * now apply IHn0. + * now rewrite H. Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 36c18012d7..4c2f5e0e4d 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -18,30 +18,30 @@ Implicit Types m n p : nat. Section Well_founded_Nat. -Variable A : Type. + Variable A : Type. -Variable f : A -> nat. -Definition ltof (a b:A) := f a < f b. -Definition gtof (a b:A) := f b > f a. + Variable f : A -> nat. + Definition ltof (a b:A) := f a < f b. + Definition gtof (a b:A) := f b > f a. -Theorem well_founded_ltof : well_founded ltof. -Proof. - assert (H : forall n (a:A), f a < n -> Acc ltof a). - { intro n; induction n as [|n IHn]. - - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. - - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb. - apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } - intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. -Defined. + Theorem well_founded_ltof : well_founded ltof. + Proof. + assert (H : forall n (a:A), f a < n -> Acc ltof a). + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. + - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb. + apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } + intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. + Defined. -Register well_founded_ltof as num.nat.well_founded_ltof. + Register well_founded_ltof as num.nat.well_founded_ltof. -Theorem well_founded_gtof : well_founded gtof. -Proof. - exact well_founded_ltof. -Defined. + Theorem well_founded_gtof : well_founded gtof. + Proof. + exact well_founded_ltof. + Defined. -(** It is possible to directly prove the induction principle going + (** It is possible to directly prove the induction principle going back to primitive recursion on natural numbers ([induction_ltof1]) or to use the previous lemmas to extract a program with a fixpoint ([induction_ltof2]) @@ -63,56 +63,56 @@ the ML-like program for [induction_ltof2] is : ]] *) -Theorem induction_ltof1 : - forall P:A -> Type, - (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - intros P F. - assert (H : forall n (a:A), f a < n -> P a). - { intro n; induction n as [|n IHn]. - - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. - - intros a Ha. apply F. unfold ltof. intros b Hb. - apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } - intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. -Defined. - -Theorem induction_gtof1 : - forall P:A -> Type, - (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - exact induction_ltof1. -Defined. + Theorem induction_ltof1 : + forall P:A -> Type, + (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. + Proof. + intros P F. + assert (H : forall n (a:A), f a < n -> P a). + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. + - intros a Ha. apply F. unfold ltof. intros b Hb. + apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } + intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. + Defined. + + Theorem induction_gtof1 : + forall P:A -> Type, + (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. + Proof. + exact induction_ltof1. + Defined. -Theorem induction_ltof2 : - forall P:A -> Type, - (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - exact (well_founded_induction_type well_founded_ltof). -Defined. + Theorem induction_ltof2 : + forall P:A -> Type, + (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. + Proof. + exact (well_founded_induction_type well_founded_ltof). + Defined. -Theorem induction_gtof2 : - forall P:A -> Type, - (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - exact induction_ltof2. -Defined. + Theorem induction_gtof2 : + forall P:A -> Type, + (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. + Proof. + exact induction_ltof2. + Defined. -(** If a relation [R] is compatible with [lt] i.e. if [x R y => f(x) < f(y)] + (** If a relation [R] is compatible with [lt] i.e. if [x R y => f(x) < f(y)] then [R] is well-founded. *) -Variable R : A -> A -> Prop. + Variable R : A -> A -> Prop. -Hypothesis H_compat : forall x y:A, R x y -> f x < f y. + Hypothesis H_compat : forall x y:A, R x y -> f x < f y. -Theorem well_founded_lt_compat : well_founded R. -Proof. - assert (H : forall n (a:A), f a < n -> Acc R a). - { intro n; induction n as [|n IHn]. - - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. - - intros a Ha. apply Acc_intro. intros b Hb. - apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } - intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. -Defined. + Theorem well_founded_lt_compat : well_founded R. + Proof. + assert (H : forall n (a:A), f a < n -> Acc R a). + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. + - intros a Ha. apply Acc_intro. intros b Hb. + apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } + intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. + Defined. End Well_founded_Nat. diff --git a/theories/Array/PArray.v b/theories/Array/PArray.v index 3fc8322910..40f60c4e7a 100644 --- a/theories/Array/PArray.v +++ b/theories/Array/PArray.v @@ -52,16 +52,16 @@ Qed. Lemma get_set_same_default A (t : array A) (i : int) : t.[i <- default t].[i] = default t. Proof. - case_eq (i default t -> (x a = true \/ b = true. Proof. - intros; apply orb_true_iff; trivial. + intros; apply orb_true_iff; trivial. Qed. Lemma orb_true_intro : forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true. Proof. - intros; apply orb_true_iff; trivial. + intros; apply orb_true_iff; trivial. Qed. #[global] Hint Resolve orb_true_intro: bool. @@ -337,7 +337,7 @@ Hint Resolve orb_true_intro: bool. Lemma orb_false_intro : forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. Proof. - intros. subst. reflexivity. + intros. subst. reflexivity. Qed. #[global] Hint Resolve orb_false_intro: bool. @@ -350,7 +350,7 @@ Qed. Lemma orb_diag : forall b, b || b = b. Proof. - destr_bool. + destr_bool. Qed. (** [true] is a zero for [orb] *) @@ -470,7 +470,7 @@ Notation andb_false_b := andb_false_l (only parsing). Lemma andb_diag : forall b, b && b = b. Proof. - destr_bool. + destr_bool. Qed. (** [true] is neutral for [andb] *) @@ -1025,12 +1025,12 @@ Notation ReflectF := Datatypes.ReflectF (only parsing). Lemma reflect_iff : forall P b, reflect P b -> (P<->b=true). Proof. - destruct 1; intuition; discriminate. + destruct 1; intuition; discriminate. Qed. Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b. Proof. - destr_bool; intuition. + destr_bool; intuition. Defined. (** It would be nice to join [reflect_iff] and [iff_reflect] @@ -1041,7 +1041,7 @@ Defined. Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}. Proof. - destruct 1; auto. + destruct 1; auto. Defined. (** Reciprocally, from a decidability, we could state a @@ -1051,13 +1051,13 @@ Defined. Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). Proof. - destruct b, b'; now constructor. + destruct b, b'; now constructor. Defined. (** Notations *) Module BoolNotations. -Infix "<=" := le : bool_scope. -Infix "<" := lt : bool_scope. -Infix "?=" := compare (at level 70) : bool_scope. -Infix "=?" := eqb (at level 70) : bool_scope. + Infix "<=" := le : bool_scope. + Infix "<" := lt : bool_scope. + Infix "?=" := compare (at level 70) : bool_scope. + Infix "=?" := eqb (at level 70) : bool_scope. End BoolNotations. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index f608aa249c..813aef7b16 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -18,34 +18,40 @@ Inductive IfProp (A B:Prop) : bool -> Prop := Hint Resolve Iftrue Iffalse: bool. Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A. -destruct 1; intros; auto with bool. -case diff_true_false; auto with bool. +Proof. + destruct 1; intros; auto with bool. + case diff_true_false; auto with bool. Qed. Lemma Iffalse_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = false -> B. -destruct 1; intros; auto with bool. -case diff_true_false; trivial with bool. +Proof. + destruct 1; intros; auto with bool. + case diff_true_false; trivial with bool. Qed. Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A. -intros A B H. -inversion H. -assumption. +Proof. + intros A B H. + inversion H. + assumption. Qed. Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B. -intros A B H. -inversion H. -assumption. +Proof. + intros A B H. + inversion H. + assumption. Qed. Lemma IfProp_or : forall (A B:Prop) (b:bool), IfProp A B b -> A \/ B. -destruct 1; auto with bool. +Proof. + destruct 1; auto with bool. Qed. Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. -intros A B b; destruct b; intro H. -- left; inversion H; auto with bool. -- right; inversion H; auto with bool. +Proof. + intros A B b; destruct b; intro H. + - left; inversion H; auto with bool. + - right; inversion H; auto with bool. Qed. diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index 786c5c675d..77a4167e37 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -22,25 +22,25 @@ Class Decidable (P : Prop) := { Lemma Decidable_sound : forall P (H : Decidable P), Decidable_witness = true -> P. Proof. -intros P H Hp; apply -> Decidable_spec; assumption. + intros P H Hp; apply -> Decidable_spec; assumption. Qed. Lemma Decidable_complete : forall P (H : Decidable P), P -> Decidable_witness = true. Proof. -intros P H Hp; apply <- Decidable_spec; assumption. + intros P H Hp; apply <- Decidable_spec; assumption. Qed. Lemma Decidable_sound_alt : forall P (H : Decidable P), ~ P -> Decidable_witness = false. Proof. -intros P [wit spec] Hd; simpl; destruct wit; tauto. + intros P [wit spec] Hd; simpl; destruct wit; tauto. Qed. Lemma Decidable_complete_alt : forall P (H : Decidable P), Decidable_witness = false -> ~ P. Proof. -intros P [wit spec] Hd Hc; simpl in *; intuition congruence. + intros P [wit spec] Hd Hc; simpl in *; intuition congruence. Qed. (** The generic function that should be used to program, together with some diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 84826df682..7a6ecb6360 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -29,1078 +29,1078 @@ Hint Extern 1 (Equivalence _) => constructor; congruence : core. Module WFacts_fun (E:DecidableType)(Import M:WSfun E). -Notation eq_dec := E.eq_dec. -Definition eqb x y := if eq_dec x y then true else false. - -Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true). -Proof. - destruct b; destruct b'; intuition. -Qed. - -Lemma eq_option_alt : forall (elt:Type)(o o':option elt), - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- subst; split; auto. -- destruct o; destruct o'; try rewrite H; auto. - symmetry; rewrite <- H; auto. -Qed. - -Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), - MapsTo x e m -> MapsTo x e' m -> e=e'. -Proof. -intros. -generalize (find_1 H) (find_1 H0); clear H H0. -intros; rewrite H in H0; injection H0; auto. -Qed. - -(** ** Specifications written using equivalences *) - -Section IffSpec. -Variable elt elt' elt'': Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m). -Proof. -unfold In. -split; intros (e0,H0); exists e0. -- apply (MapsTo_1 H H0); auto. -- apply (MapsTo_1 (E.eq_sym H) H0); auto. -Qed. - -Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. -split; apply MapsTo_1; auto. -Qed. - -Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. -Proof. -intros; rewrite mem_in_iff; destruct (mem x m); intuition. -Qed. - -Lemma In_dec : forall m x, { In x m } + { ~ In x m }. -Proof. - intros. - generalize (mem_in_iff m x). - destruct (mem x m); [left|right]; intuition. -Qed. - -Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e. -Proof. -split; [apply find_1|apply find_2]. -Qed. - -Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. -Proof. -split; intros. -- rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. - split; try discriminate. intro H'; elim H; exists e; auto. -- intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. -Qed. - -Lemma in_find_iff : forall m x, In x m <-> find x m <> None. -Proof. -intros; rewrite <- not_find_in_iff, mem_in_iff. -destruct mem; intuition. -Qed. - -Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. -Proof. -split; [apply equal_1|apply equal_2]. -Qed. - -Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False. -Proof. -intuition; apply (empty_1 H). -Qed. - -Lemma empty_in_iff : forall x, In x (empty elt) <-> False. -Proof. -unfold In. -split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. -Qed. - -Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. -Proof. -split; [apply is_empty_1|apply is_empty_2]. -Qed. - -Lemma add_mapsto_iff : forall m x y e e', - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ - (~E.eq x y /\ MapsTo y e' m). -Proof. -intros. -intuition. -- destruct (eq_dec x y); [left|right]. - + split; auto. - symmetry; apply (MapsTo_fun (e':=e) H); auto with map. - + split; auto; apply add_3 with x e; auto. -- subst; auto with map. -Qed. - -Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. -Proof. -unfold In; split. -- intros (e',H). - destruct (eq_dec x y) as [E|E]; auto. - right; exists e'; auto. - apply (add_3 E H). -- destruct (eq_dec x y) as [E|E]; auto. - + intros. - exists e; apply add_1; auto. - + intros [H|(e',H)]. - * destruct E; auto. - * exists e'; apply add_2; auto. -Qed. - -Lemma add_neq_mapsto_iff : forall m x y e e', - ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma add_neq_in_iff : forall m x y e, - ~ E.eq x y -> (In y (add x e m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- apply (add_3 H H0). -- apply add_2; auto. -Qed. - -Lemma remove_mapsto_iff : forall m x y e, - MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. -intros. -split; intros. -- split. - + assert (In y (remove x m)) by (exists e; auto). - intro H1; apply (remove_1 H1 H0). - + apply remove_3 with x; auto. -- apply remove_2; intuition. -Qed. - -Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. -unfold In; split. -- intros (e,H). - split. - + assert (In y (remove x m)) by (exists e; auto). - intro H1; apply (remove_1 H1 H0). - + exists e; apply remove_3 with x; auto. -- intros (H,(e,H0)); exists e; apply remove_2; auto. -Qed. - -Lemma remove_neq_mapsto_iff : forall m x y e, - ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma remove_neq_in_iff : forall m x y, - ~ E.eq x y -> (In y (remove x m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- apply (remove_3 H0). -- apply remove_2; auto. -Qed. - -Lemma elements_mapsto_iff : forall m x e, - MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). -Proof. -split; [apply elements_1 | apply elements_2]. -Qed. - -Lemma elements_in_iff : forall m x, - In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). -Proof. -unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. -Qed. - -Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), - MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. -Proof. -split. -- case_eq (find x m); intros. - + exists e. - split. - * apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map. - * apply find_2; auto with map. - + assert (In x (map f m)) by (exists b; auto). - destruct (map_2 H1) as (a,H2). - rewrite (find_1 H2) in H; discriminate. -- intros (a,(H,H0)). - subst b; auto with map. -Qed. - -Lemma map_in_iff : forall m x (f : elt -> elt'), - In x (map f m) <-> In x m. -Proof. -split; intros; eauto with map. -destruct H as (a,H). -exists (f a); auto with map. -Qed. - -Lemma mapi_in_iff : forall m x (f:key->elt->elt'), - In x (mapi f m) <-> In x m. -Proof. -split; intros; eauto with map. -destruct H as (a,H). -destruct (mapi_1 f H) as (y,(H0,H1)). -exists (f y a); auto. -Qed. - -(** Unfortunately, we don't have simple equivalences for [mapi] + Notation eq_dec := E.eq_dec. + Definition eqb x y := if eq_dec x y then true else false. + + Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true). + Proof. + destruct b; destruct b'; intuition. + Qed. + + Lemma eq_option_alt : forall (elt:Type)(o o':option elt), + o=o' <-> (forall e, o=Some e <-> o'=Some e). + Proof. + split; intros. + - subst; split; auto. + - destruct o; destruct o'; try rewrite H; auto. + symmetry; rewrite <- H; auto. + Qed. + + Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), + MapsTo x e m -> MapsTo x e' m -> e=e'. + Proof. + intros. + generalize (find_1 H) (find_1 H0); clear H H0. + intros; rewrite H in H0; injection H0; auto. + Qed. + + (** ** Specifications written using equivalences *) + + Section IffSpec. + Variable elt elt' elt'': Type. + Implicit Type m: t elt. + Implicit Type x y z: key. + Implicit Type e: elt. + + Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m). + Proof. + unfold In. + split; intros (e0,H0); exists e0. + - apply (MapsTo_1 H H0); auto. + - apply (MapsTo_1 (E.eq_sym H) H0); auto. + Qed. + + Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). + Proof. + split; apply MapsTo_1; auto. + Qed. + + Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. + Proof. + split; [apply mem_1|apply mem_2]. + Qed. + + Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. + Proof. + intros; rewrite mem_in_iff; destruct (mem x m); intuition. + Qed. + + Lemma In_dec : forall m x, { In x m } + { ~ In x m }. + Proof. + intros. + generalize (mem_in_iff m x). + destruct (mem x m); [left|right]; intuition. + Qed. + + Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e. + Proof. + split; [apply find_1|apply find_2]. + Qed. + + Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. + Proof. + split; intros. + - rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. + split; try discriminate. intro H'; elim H; exists e; auto. + - intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. + Qed. + + Lemma in_find_iff : forall m x, In x m <-> find x m <> None. + Proof. + intros; rewrite <- not_find_in_iff, mem_in_iff. + destruct mem; intuition. + Qed. + + Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. + Proof. + split; [apply equal_1|apply equal_2]. + Qed. + + Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False. + Proof. + intuition; apply (empty_1 H). + Qed. + + Lemma empty_in_iff : forall x, In x (empty elt) <-> False. + Proof. + unfold In. + split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. + Qed. + + Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. + Proof. + split; [apply is_empty_1|apply is_empty_2]. + Qed. + + Lemma add_mapsto_iff : forall m x y e e', + MapsTo y e' (add x e m) <-> + (E.eq x y /\ e=e') \/ + (~E.eq x y /\ MapsTo y e' m). + Proof. + intros. + intuition. + - destruct (eq_dec x y); [left|right]. + + split; auto. + symmetry; apply (MapsTo_fun (e':=e) H); auto with map. + + split; auto; apply add_3 with x e; auto. + - subst; auto with map. + Qed. + + Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. + Proof. + unfold In; split. + - intros (e',H). + destruct (eq_dec x y) as [E|E]; auto. + right; exists e'; auto. + apply (add_3 E H). + - destruct (eq_dec x y) as [E|E]; auto. + + intros. + exists e; apply add_1; auto. + + intros [H|(e',H)]. + * destruct E; auto. + * exists e'; apply add_2; auto. + Qed. + + Lemma add_neq_mapsto_iff : forall m x y e e', + ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). + Proof. + split; [apply add_3|apply add_2]; auto. + Qed. + + Lemma add_neq_in_iff : forall m x y e, + ~ E.eq x y -> (In y (add x e m) <-> In y m). + Proof. + split; intros (e',H0); exists e'. + - apply (add_3 H H0). + - apply add_2; auto. + Qed. + + Lemma remove_mapsto_iff : forall m x y e, + MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. + Proof. + intros. + split; intros. + - split. + + assert (In y (remove x m)) by (exists e; auto). + intro H1; apply (remove_1 H1 H0). + + apply remove_3 with x; auto. + - apply remove_2; intuition. + Qed. + + Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. + Proof. + unfold In; split. + - intros (e,H). + split. + + assert (In y (remove x m)) by (exists e; auto). + intro H1; apply (remove_1 H1 H0). + + exists e; apply remove_3 with x; auto. + - intros (H,(e,H0)); exists e; apply remove_2; auto. + Qed. + + Lemma remove_neq_mapsto_iff : forall m x y e, + ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). + Proof. + split; [apply remove_3|apply remove_2]; auto. + Qed. + + Lemma remove_neq_in_iff : forall m x y, + ~ E.eq x y -> (In y (remove x m) <-> In y m). + Proof. + split; intros (e',H0); exists e'. + - apply (remove_3 H0). + - apply remove_2; auto. + Qed. + + Lemma elements_mapsto_iff : forall m x e, + MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). + Proof. + split; [apply elements_1 | apply elements_2]. + Qed. + + Lemma elements_in_iff : forall m x, + In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). + Proof. + unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. + Qed. + + Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), + MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. + Proof. + split. + - case_eq (find x m); intros. + + exists e. + split. + * apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map. + * apply find_2; auto with map. + + assert (In x (map f m)) by (exists b; auto). + destruct (map_2 H1) as (a,H2). + rewrite (find_1 H2) in H; discriminate. + - intros (a,(H,H0)). + subst b; auto with map. + Qed. + + Lemma map_in_iff : forall m x (f : elt -> elt'), + In x (map f m) <-> In x m. + Proof. + split; intros; eauto with map. + destruct H as (a,H). + exists (f a); auto with map. + Qed. + + Lemma mapi_in_iff : forall m x (f:key->elt->elt'), + In x (mapi f m) <-> In x m. + Proof. + split; intros; eauto with map. + destruct H as (a,H). + destruct (mapi_1 f H) as (y,(H0,H1)). + exists (f y a); auto. + Qed. + + (** Unfortunately, we don't have simple equivalences for [mapi] and [MapsTo]. The only correct one needs compatibility of [f]. *) -Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), - MapsTo x b (mapi f m) -> - exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. -Proof. -intros; case_eq (find x m); intros. -- exists e. - destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)). - + apply find_2; auto with map. - + exists y; repeat split; auto with map. - apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map. -- assert (In x (mapi f m)) by (exists b; auto). - destruct (mapi_2 H1) as (a,H2). - rewrite (find_1 H2) in H0; discriminate. -Qed. - -Lemma mapi_1bis : forall m x e (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - MapsTo x e m -> MapsTo x (f x e) (mapi f m). -Proof. -intros. -destruct (mapi_1 f H0) as (y,(H1,H2)). -replace (f x e) with (f y e) by auto. -auto. -Qed. - -Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). -Proof. -split. -- intros. - destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))). - exists a; split; auto. - subst b; auto. -- intros (a,(H0,H1)). - subst b. - apply mapi_1bis; auto. -Qed. - -(** Things are even worse for [map2] : we don't try to state any + Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), + MapsTo x b (mapi f m) -> + exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. + Proof. + intros; case_eq (find x m); intros. + - exists e. + destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)). + + apply find_2; auto with map. + + exists y; repeat split; auto with map. + apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map. + - assert (In x (mapi f m)) by (exists b; auto). + destruct (mapi_2 H1) as (a,H2). + rewrite (find_1 H2) in H0; discriminate. + Qed. + + Lemma mapi_1bis : forall m x e (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> + MapsTo x e m -> MapsTo x (f x e) (mapi f m). + Proof. + intros. + destruct (mapi_1 f H0) as (y,(H1,H2)). + replace (f x e) with (f y e) by auto. + auto. + Qed. + + Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> + (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). + Proof. + split. + - intros. + destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))). + exists a; split; auto. + subst b; auto. + - intros (a,(H0,H1)). + subst b. + apply mapi_1bis; auto. + Qed. + + (** Things are even worse for [map2] : we don't try to state any equivalence, see instead boolean results below. *) -End IffSpec. - -(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) - -Ltac map_iff := - repeat (progress ( - rewrite add_mapsto_iff || rewrite add_in_iff || - rewrite remove_mapsto_iff || rewrite remove_in_iff || - rewrite empty_mapsto_iff || rewrite empty_in_iff || - rewrite map_mapsto_iff || rewrite map_in_iff || - rewrite mapi_in_iff)). - -(** ** Specifications written using boolean predicates *) - -Section BoolSpec. - -Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. -Proof. -intros. -generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. -destruct (find x m); destruct (mem x m); auto. -- intros. - rewrite <- H0; exists e; rewrite H; auto. -- intuition. - destruct H0 as (e,H0). - destruct (H e); intuition discriminate. -Qed. - -Variable elt elt' elt'' : Type. -Implicit Types m : t elt. -Implicit Types x y z : key. -Implicit Types e : elt. - -Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. -Proof. -intros. -generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). -destruct (mem x m); destruct (mem y m); intuition. -Qed. - -Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. -Proof. -intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff. -apply MapsTo_iff; auto. -Qed. - -Lemma empty_o : forall x, find x (empty elt) = None. -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition. -Qed. - -Lemma empty_a : forall x, mem x (empty elt) = false. -Proof. -intros. -case_eq (mem x (empty elt)); intros; auto. -generalize (mem_2 H). -rewrite empty_in_iff; intuition. -Qed. - -Lemma add_eq_o : forall m x y e, - E.eq x y -> find y (add x e m) = Some e. -Proof. -auto with map. -Qed. - -Lemma add_neq_o : forall m x y e, - ~ E.eq x y -> find y (add x e m) = find y m. -Proof. -intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. -apply add_neq_mapsto_iff; auto. -Qed. -#[local] -Hint Resolve add_neq_o : map. - -Lemma add_o : forall m x y e, - find y (add x e m) = if eq_dec x y then Some e else find y m. -Proof. -intros; destruct (eq_dec x y); auto with map. -Qed. - -Lemma add_eq_b : forall m x y e, - E.eq x y -> mem y (add x e m) = true. -Proof. -intros; rewrite mem_find_b; rewrite add_eq_o; auto. -Qed. - -Lemma add_neq_b : forall m x y e, - ~E.eq x y -> mem y (add x e m) = mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. -Qed. - -Lemma add_b : forall m x y e, - mem y (add x e m) = eqb x y || mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. -destruct (eq_dec x y); simpl; auto. -Qed. - -Lemma remove_eq_o : forall m x y, - E.eq x y -> find y (remove x m) = None. -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. -Qed. -#[local] -Hint Resolve remove_eq_o : map. - -Lemma remove_neq_o : forall m x y, - ~ E.eq x y -> find y (remove x m) = find y m. -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. -Qed. -#[local] -Hint Resolve remove_neq_o : map. - -Lemma remove_o : forall m x y, - find y (remove x m) = if eq_dec x y then None else find y m. -Proof. -intros; destruct (eq_dec x y); auto with map. -Qed. - -Lemma remove_eq_b : forall m x y, - E.eq x y -> mem y (remove x m) = false. -Proof. -intros; rewrite mem_find_b; rewrite remove_eq_o; auto. -Qed. - -Lemma remove_neq_b : forall m x y, - ~ E.eq x y -> mem y (remove x m) = mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. -Qed. - -Lemma remove_b : forall m x y, - mem y (remove x m) = negb (eqb x y) && mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. -destruct (eq_dec x y); auto. -Qed. - -Lemma map_o : forall m x (f:elt->elt'), - find x (map f m) = Datatypes.option_map f (find x m). -Proof. -intros. -generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) - (fun b => map_mapsto_iff m x b f). -destruct (find x (map f m)); destruct (find x m); simpl; auto; intros. -- rewrite <- H; rewrite H1; exists e0; rewrite H0; auto. -- destruct (H e) as [_ H2]. - rewrite H1 in H2. - destruct H2 as (a,(_,H2)); auto. - rewrite H0 in H2; discriminate. -- rewrite <- H; rewrite H1; exists e; rewrite H0; auto. -Qed. - -Lemma map_b : forall m x (f:elt->elt'), - mem x (map f m) = mem x m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite map_o. -destruct (find x m); simpl; auto. -Qed. - -Lemma mapi_b : forall m x (f:key->elt->elt'), - mem x (mapi f m) = mem x m. -Proof. -intros. -generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f). -destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros. -- symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. -- rewrite <- H; rewrite H1; rewrite H0; auto. -Qed. - -Lemma mapi_o : forall m x (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - find x (mapi f m) = Datatypes.option_map (f x) (find x m). -Proof. -intros. -generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) - (fun b => mapi_mapsto_iff m x b H). -destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. -- rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. -- destruct (H0 e) as [_ H3]. - rewrite H2 in H3. - destruct H3 as (a,(_,H3)); auto. - rewrite H1 in H3; discriminate. -- rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. -Qed. - -Lemma map2_1bis : forall (m: t elt)(m': t elt') x - (f:option elt->option elt'->option elt''), - f None None = None -> - find x (map2 f m m') = f (find x m) (find x m'). -Proof. -intros. -case_eq (find x m); intros. -- rewrite <- H0. - apply map2_1; auto with map. - left; exists e; auto with map. -- case_eq (find x m'); intros. - + rewrite <- H0; rewrite <- H1. - apply map2_1; auto. - right; exists e; auto with map. - + rewrite H. - case_eq (find x (map2 f m m')); intros; auto with map. - assert (In x (map2 f m m')) by (exists e; auto with map). - destruct (map2_2 H3) as [(e0,H4)|(e0,H4)]. - * rewrite (find_1 H4) in H0; discriminate. - * rewrite (find_1 H4) in H1; discriminate. -Qed. - -Lemma elements_o : forall m x, - find x m = findA (eqb x) (elements m). -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, elements_mapsto_iff. -unfold eqb. -rewrite <- findA_NoDupA; dintuition; try apply elements_3w; eauto. -Qed. - -Lemma elements_b : forall m x, - mem x m = existsb (fun p => eqb x (fst p)) (elements m). -Proof. -intros. -generalize (mem_in_iff m x)(elements_in_iff m x) - (existsb_exists (fun p => eqb x (fst p)) (elements m)). -destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros. -- symmetry; rewrite H1. - destruct H0 as (H0,_). - destruct H0 as (e,He); [ intuition |]. - rewrite InA_alt in He. - destruct He as ((y,e'),(Ha1,Ha2)). - compute in Ha1; destruct Ha1; subst e'. - exists (y,e); split; simpl; auto. - unfold eqb; destruct (eq_dec x y); intuition. -- rewrite <- H; rewrite H0. - destruct H1 as (H1,_). - destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|]. - simpl in Ha2. - unfold eqb in *; destruct (eq_dec x y); auto; try discriminate. - exists e; rewrite InA_alt. - exists (y,e); intuition. - compute; auto. -Qed. - -End BoolSpec. - -Section Equalities. - -Variable elt:Type. - - (** Another characterisation of [Equal] *) - -Lemma Equal_mapsto_iff : forall m1 m2 : t elt, - Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). -Proof. -intros m1 m2. split; [intros Heq k e|intros Hiff]. -- rewrite 2 find_mapsto_iff, Heq. split; auto. -- intro k. rewrite eq_option_alt. intro e. - rewrite <- 2 find_mapsto_iff; auto. -Qed. - -(** * Relations between [Equal], [Equiv] and [Equivb]. *) - -(** First, [Equal] is [Equiv] with Leibniz on elements. *) - -Lemma Equal_Equiv : forall (m m' : t elt), - Equal m m' <-> Equiv Logic.eq m m'. -Proof. -intros. rewrite Equal_mapsto_iff. split; intros. -- split. - + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. - + intros; apply MapsTo_fun with m k; auto; rewrite H; auto. -- split; intros H'. - + destruct H. - assert (Hin : In k m') by (rewrite <- H; exists e; auto). - destruct Hin as (e',He'). - rewrite (H0 k e e'); auto. - + destruct H. - assert (Hin : In k m) by (rewrite H; exists e; auto). - destruct Hin as (e',He'). - rewrite <- (H0 k e' e); auto. -Qed. - -(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] + End IffSpec. + + (** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) + + Ltac map_iff := + repeat (progress ( + rewrite add_mapsto_iff || rewrite add_in_iff || + rewrite remove_mapsto_iff || rewrite remove_in_iff || + rewrite empty_mapsto_iff || rewrite empty_in_iff || + rewrite map_mapsto_iff || rewrite map_in_iff || + rewrite mapi_in_iff)). + + (** ** Specifications written using boolean predicates *) + + Section BoolSpec. + + Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. + Proof. + intros. + generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. + destruct (find x m); destruct (mem x m); auto. + - intros. + rewrite <- H0; exists e; rewrite H; auto. + - intuition. + destruct H0 as (e,H0). + destruct (H e); intuition discriminate. + Qed. + + Variable elt elt' elt'' : Type. + Implicit Types m : t elt. + Implicit Types x y z : key. + Implicit Types e : elt. + + Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. + Proof. + intros. + generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). + destruct (mem x m); destruct (mem y m); intuition. + Qed. + + Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. + Proof. + intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff. + apply MapsTo_iff; auto. + Qed. + + Lemma empty_o : forall x, find x (empty elt) = None. + Proof. + intros. rewrite eq_option_alt. intro e. + rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition. + Qed. + + Lemma empty_a : forall x, mem x (empty elt) = false. + Proof. + intros. + case_eq (mem x (empty elt)); intros; auto. + generalize (mem_2 H). + rewrite empty_in_iff; intuition. + Qed. + + Lemma add_eq_o : forall m x y e, + E.eq x y -> find y (add x e m) = Some e. + Proof. + auto with map. + Qed. + + Lemma add_neq_o : forall m x y e, + ~ E.eq x y -> find y (add x e m) = find y m. + Proof. + intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. + apply add_neq_mapsto_iff; auto. + Qed. + #[local] + Hint Resolve add_neq_o : map. + + Lemma add_o : forall m x y e, + find y (add x e m) = if eq_dec x y then Some e else find y m. + Proof. + intros; destruct (eq_dec x y); auto with map. + Qed. + + Lemma add_eq_b : forall m x y e, + E.eq x y -> mem y (add x e m) = true. + Proof. + intros; rewrite mem_find_b; rewrite add_eq_o; auto. + Qed. + + Lemma add_neq_b : forall m x y e, + ~E.eq x y -> mem y (add x e m) = mem y m. + Proof. + intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. + Qed. + + Lemma add_b : forall m x y e, + mem y (add x e m) = eqb x y || mem y m. + Proof. + intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. + destruct (eq_dec x y); simpl; auto. + Qed. + + Lemma remove_eq_o : forall m x y, + E.eq x y -> find y (remove x m) = None. + Proof. + intros. rewrite eq_option_alt. intro e. + rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. + Qed. + #[local] + Hint Resolve remove_eq_o : map. + + Lemma remove_neq_o : forall m x y, + ~ E.eq x y -> find y (remove x m) = find y m. + Proof. + intros. rewrite eq_option_alt. intro e. + rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. + Qed. + #[local] + Hint Resolve remove_neq_o : map. + + Lemma remove_o : forall m x y, + find y (remove x m) = if eq_dec x y then None else find y m. + Proof. + intros; destruct (eq_dec x y); auto with map. + Qed. + + Lemma remove_eq_b : forall m x y, + E.eq x y -> mem y (remove x m) = false. + Proof. + intros; rewrite mem_find_b; rewrite remove_eq_o; auto. + Qed. + + Lemma remove_neq_b : forall m x y, + ~ E.eq x y -> mem y (remove x m) = mem y m. + Proof. + intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. + Qed. + + Lemma remove_b : forall m x y, + mem y (remove x m) = negb (eqb x y) && mem y m. + Proof. + intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. + destruct (eq_dec x y); auto. + Qed. + + Lemma map_o : forall m x (f:elt->elt'), + find x (map f m) = Datatypes.option_map f (find x m). + Proof. + intros. + generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) + (fun b => map_mapsto_iff m x b f). + destruct (find x (map f m)); destruct (find x m); simpl; auto; intros. + - rewrite <- H; rewrite H1; exists e0; rewrite H0; auto. + - destruct (H e) as [_ H2]. + rewrite H1 in H2. + destruct H2 as (a,(_,H2)); auto. + rewrite H0 in H2; discriminate. + - rewrite <- H; rewrite H1; exists e; rewrite H0; auto. + Qed. + + Lemma map_b : forall m x (f:elt->elt'), + mem x (map f m) = mem x m. + Proof. + intros; do 2 rewrite mem_find_b; rewrite map_o. + destruct (find x m); simpl; auto. + Qed. + + Lemma mapi_b : forall m x (f:key->elt->elt'), + mem x (mapi f m) = mem x m. + Proof. + intros. + generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f). + destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros. + - symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. + - rewrite <- H; rewrite H1; rewrite H0; auto. + Qed. + + Lemma mapi_o : forall m x (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> + find x (mapi f m) = Datatypes.option_map (f x) (find x m). + Proof. + intros. + generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) + (fun b => mapi_mapsto_iff m x b H). + destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. + - rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. + - destruct (H0 e) as [_ H3]. + rewrite H2 in H3. + destruct H3 as (a,(_,H3)); auto. + rewrite H1 in H3; discriminate. + - rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. + Qed. + + Lemma map2_1bis : forall (m: t elt)(m': t elt') x + (f:option elt->option elt'->option elt''), + f None None = None -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros. + case_eq (find x m); intros. + - rewrite <- H0. + apply map2_1; auto with map. + left; exists e; auto with map. + - case_eq (find x m'); intros. + + rewrite <- H0; rewrite <- H1. + apply map2_1; auto. + right; exists e; auto with map. + + rewrite H. + case_eq (find x (map2 f m m')); intros; auto with map. + assert (In x (map2 f m m')) by (exists e; auto with map). + destruct (map2_2 H3) as [(e0,H4)|(e0,H4)]. + * rewrite (find_1 H4) in H0; discriminate. + * rewrite (find_1 H4) in H1; discriminate. + Qed. + + Lemma elements_o : forall m x, + find x m = findA (eqb x) (elements m). + Proof. + intros. rewrite eq_option_alt. intro e. + rewrite <- find_mapsto_iff, elements_mapsto_iff. + unfold eqb. + rewrite <- findA_NoDupA; dintuition; try apply elements_3w; eauto. + Qed. + + Lemma elements_b : forall m x, + mem x m = existsb (fun p => eqb x (fst p)) (elements m). + Proof. + intros. + generalize (mem_in_iff m x)(elements_in_iff m x) + (existsb_exists (fun p => eqb x (fst p)) (elements m)). + destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros. + - symmetry; rewrite H1. + destruct H0 as (H0,_). + destruct H0 as (e,He); [ intuition |]. + rewrite InA_alt in He. + destruct He as ((y,e'),(Ha1,Ha2)). + compute in Ha1; destruct Ha1; subst e'. + exists (y,e); split; simpl; auto. + unfold eqb; destruct (eq_dec x y); intuition. + - rewrite <- H; rewrite H0. + destruct H1 as (H1,_). + destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|]. + simpl in Ha2. + unfold eqb in *; destruct (eq_dec x y); auto; try discriminate. + exists e; rewrite InA_alt. + exists (y,e); intuition. + compute; auto. + Qed. + + End BoolSpec. + + Section Equalities. + + Variable elt:Type. + + (** Another characterisation of [Equal] *) + + Lemma Equal_mapsto_iff : forall m1 m2 : t elt, + Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). + Proof. + intros m1 m2. split; [intros Heq k e|intros Hiff]. + - rewrite 2 find_mapsto_iff, Heq. split; auto. + - intro k. rewrite eq_option_alt. intro e. + rewrite <- 2 find_mapsto_iff; auto. + Qed. + + (** * Relations between [Equal], [Equiv] and [Equivb]. *) + + (** First, [Equal] is [Equiv] with Leibniz on elements. *) + + Lemma Equal_Equiv : forall (m m' : t elt), + Equal m m' <-> Equiv Logic.eq m m'. + Proof. + intros. rewrite Equal_mapsto_iff. split; intros. + - split. + + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. + + intros; apply MapsTo_fun with m k; auto; rewrite H; auto. + - split; intros H'. + + destruct H. + assert (Hin : In k m') by (rewrite <- H; exists e; auto). + destruct Hin as (e',He'). + rewrite (H0 k e e'); auto. + + destruct H. + assert (Hin : In k m) by (rewrite H; exists e; auto). + destruct Hin as (e',He'). + rewrite <- (H0 k e' e); auto. + Qed. + + (** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] are related. *) -Section Cmp. -Variable eq_elt : elt->elt->Prop. -Variable cmp : elt->elt->bool. + Section Cmp. + Variable eq_elt : elt->elt->Prop. + Variable cmp : elt->elt->bool. -Definition compat_cmp := - forall e e', cmp e e' = true <-> eq_elt e e'. + Definition compat_cmp := + forall e e', cmp e e' = true <-> eq_elt e e'. -Lemma Equiv_Equivb : compat_cmp -> - forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. -Proof. - unfold Equivb, Equiv, Cmp; intuition. - - red in H; rewrite H; eauto. - - red in H; rewrite <-H; eauto. -Qed. -End Cmp. + Lemma Equiv_Equivb : compat_cmp -> + forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. + Proof. + unfold Equivb, Equiv, Cmp; intuition. + - red in H; rewrite H; eauto. + - red in H; rewrite <-H; eauto. + Qed. + End Cmp. -(** Composition of the two last results: relation between [Equal] + (** Composition of the two last results: relation between [Equal] and [Equivb]. *) -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> - forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. -Proof. - intros; rewrite Equal_Equiv. - apply Equiv_Equivb; auto. -Qed. - -Lemma Equal_Equivb_eqdec : - forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in - forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. -Proof. -intros; apply Equal_Equivb. -unfold cmp; clear cmp; intros. -destruct eq_elt_dec; now intuition. -Qed. - -End Equalities. - -(** * [Equal] is a setoid equality. *) - -Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. -Proof. red; reflexivity. Qed. - -Lemma Equal_sym : forall (elt:Type)(m m' : t elt), - Equal m m' -> Equal m' m. -Proof. unfold Equal; auto. Qed. - -Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), - Equal m m' -> Equal m' m'' -> Equal m m''. -Proof. unfold Equal; congruence. Qed. - -Lemma Equal_ST : forall elt:Type, Equivalence (@Equal elt). -Proof. -constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. -Qed. - -Add Relation key E.eq - reflexivity proved by E.eq_refl - symmetry proved by E.eq_sym - transitivity proved by E.eq_trans - as KeySetoid. - -Arguments Equal {elt} m m'. - -Add Parametric Relation (elt : Type) : (t elt) Equal - reflexivity proved by (@Equal_refl elt) - symmetry proved by (@Equal_sym elt) - transitivity proved by (@Equal_trans elt) - as EqualSetoid. - -Add Parametric Morphism elt : (@In elt) - with signature E.eq ==> Equal ==> iff as In_m. -Proof. -unfold Equal; intros k k' Hk m m' Hm. -rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. -Qed. - -Add Parametric Morphism elt : (@MapsTo elt) - with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m. -Proof. -unfold Equal; intros k k' Hk e m m' Hm. -rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; - intuition. -Qed. - -Add Parametric Morphism elt : (@Empty elt) - with signature Equal ==> iff as Empty_m. -Proof. -unfold Empty; intros m m' Hm. split; intros; intro. -- rewrite <-Hm in H0; eapply H, H0. -- rewrite Hm in H0; eapply H, H0. -Qed. - -Add Parametric Morphism elt : (@is_empty elt) - with signature Equal ==> eq as is_empty_m. -Proof. -intros m m' Hm. -rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. -Qed. - -Add Parametric Morphism elt : (@mem elt) - with signature E.eq ==> Equal ==> eq as mem_m. -Proof. -intros k k' Hk m m' Hm. -rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. -Qed. - -Add Parametric Morphism elt : (@find elt) - with signature E.eq ==> Equal ==> eq as find_m. -Proof. -intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. -rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. -Qed. - -Add Parametric Morphism elt : (@add elt) - with signature E.eq ==> eq ==> Equal ==> Equal as add_m. -Proof. -intros k k' Hk e m m' Hm y. -rewrite add_o, add_o; do 2 destruct eq_dec as [|?Hnot]; auto. -- elim Hnot; rewrite <-Hk; auto. -- elim Hnot; rewrite Hk; auto. -Qed. - -Add Parametric Morphism elt : (@remove elt) - with signature E.eq ==> Equal ==> Equal as remove_m. -Proof. -intros k k' Hk m m' Hm y. -rewrite remove_o, remove_o; do 2 destruct eq_dec as [|?Hnot]; auto. -- elim Hnot; rewrite <-Hk; auto. -- elim Hnot; rewrite Hk; auto. -Qed. - -Add Parametric Morphism elt elt' : (@map elt elt') - with signature eq ==> Equal ==> Equal as map_m. -Proof. -intros f m m' Hm y. -rewrite map_o, map_o, Hm; auto. -Qed. - -(* Later: Add Morphism cardinal *) - -(* old name: *) -Notation not_find_mapsto_iff := not_find_in_iff. + Lemma Equal_Equivb : forall cmp, + (forall e e', cmp e e' = true <-> e = e') -> + forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. + Proof. + intros; rewrite Equal_Equiv. + apply Equiv_Equivb; auto. + Qed. -End WFacts_fun. + Lemma Equal_Equivb_eqdec : + forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), + let cmp := fun e e' => if eq_elt_dec e e' then true else false in + forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. + Proof. + intros; apply Equal_Equivb. + unfold cmp; clear cmp; intros. + destruct eq_elt_dec; now intuition. + Qed. -(** * Same facts for self-contained weak sets and for full maps *) + End Equalities. -Module WFacts (M:WS) := WFacts_fun M.E M. -Module Facts := WFacts. + (** * [Equal] is a setoid equality. *) -(** * Additional Properties for weak maps + Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. + Proof. red; reflexivity. Qed. - Results about [fold], [elements], induction principles... -*) - -Module WProperties_fun (E:DecidableType)(M:WSfun E). - Module Import F:=WFacts_fun E M. - Import M. + Lemma Equal_sym : forall (elt:Type)(m m' : t elt), + Equal m m' -> Equal m' m. + Proof. unfold Equal; auto. Qed. - Section Elt. - Variable elt:Type. + Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), + Equal m m' -> Equal m' m'' -> Equal m m''. + Proof. unfold Equal; congruence. Qed. - Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). - - Lemma Add_transpose_neqkey : forall k1 k2 e1 e2 m1 m2 m3, - ~ E.eq k1 k2 -> Add k1 e1 m1 m2 -> Add k2 e2 m2 m3 -> - { m | Add k2 e2 m1 m /\ Add k1 e1 m m3 }. + Lemma Equal_ST : forall elt:Type, Equivalence (@Equal elt). Proof. - intros. - exists (add k2 e2 m1). - split. - - { easy. } - - unfold Add; intros. - rewrite H1. - destruct (E.eq_dec k1 y). - - assert (~ E.eq k2 y). - + contradict H. - apply E.eq_trans with (y:=y); auto. - + now rewrite add_neq_o, add_eq_o, H0, add_eq_o by assumption. - - destruct (E.eq_dec k2 y). - + now rewrite add_eq_o, add_neq_o, add_eq_o by assumption. - + now rewrite add_neq_o, H0, add_neq_o, add_neq_o, add_neq_o by assumption. + constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. - Notation eqke := (@eq_key_elt elt). - Notation eqk := (@eq_key elt). + Add Relation key E.eq + reflexivity proved by E.eq_refl + symmetry proved by E.eq_sym + transitivity proved by E.eq_trans + as KeySetoid. - Instance eqk_equiv : Equivalence eqk. - Proof. unfold eq_key; split; eauto. Qed. + Arguments Equal {elt} m m'. - Instance eqke_equiv : Equivalence eqke. - Proof. - unfold eq_key_elt; split; repeat red; firstorder. - - eauto. - - congruence. - Qed. + Add Parametric Relation (elt : Type) : (t elt) Equal + reflexivity proved by (@Equal_refl elt) + symmetry proved by (@Equal_sym elt) + transitivity proved by (@Equal_trans elt) + as EqualSetoid. - (** Complements about InA, NoDupA and findA *) - - Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, - E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l. + Add Parametric Morphism elt : (@In elt) + with signature E.eq ==> Equal ==> iff as In_m. Proof. - intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt. - intros ((k',e') & (Hk',He') & H); simpl in *. - exists (k',e'); split; auto. - red; simpl; eauto. + unfold Equal; intros k k' Hk m m' Hm. + rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. Qed. - Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + Add Parametric Morphism elt : (@MapsTo elt) + with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m. Proof. - induction 1; auto. - constructor; auto. - destruct x as (k,e). - eauto using InA_eqke_eqk. + unfold Equal; intros k k' Hk e m m' Hm. + rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; + intuition. Qed. - Lemma findA_rev : forall l k, NoDupA eqk l -> - findA (eqb k) l = findA (eqb k) (rev l). + Add Parametric Morphism elt : (@Empty elt) + with signature Equal ==> iff as Empty_m. Proof. - intros. - case_eq (findA (eqb k) l). - - intros. symmetry. - unfold eqb. - rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by (eauto using NoDupA_rev with * ); eauto. - - case_eq (findA (eqb k) (rev l)); auto. - intros e. - unfold eqb. - rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by (eauto using NoDupA_rev with * ). - intro Eq; rewrite Eq; auto. + unfold Empty; intros m m' Hm. split; intros; intro. + - rewrite <-Hm in H0; eapply H, H0. + - rewrite Hm in H0; eapply H, H0. Qed. - (** * Elements *) - - Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. + Add Parametric Morphism elt : (@is_empty elt) + with signature Equal ==> eq as is_empty_m. Proof. - intros. - unfold Empty. - split; intros. - - assert (forall a, ~ List.In a (elements m)). { - red; intros. - apply (H (fst a) (snd a)). - rewrite elements_mapsto_iff. - rewrite InA_alt; exists a; auto. - split; auto; split; auto. - } - destruct (elements m); auto. - elim (H0 p); simpl; auto. - - red; intros. - rewrite elements_mapsto_iff in H0. - rewrite InA_alt in H0; destruct H0. - rewrite H in H0; destruct H0 as (_,H0); inversion H0. + intros m m' Hm. + rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. Qed. - Lemma elements_empty : elements (@empty elt) = nil. + Add Parametric Morphism elt : (@mem elt) + with signature E.eq ==> Equal ==> eq as mem_m. Proof. - rewrite <-elements_Empty; apply empty_1. + intros k k' Hk m m' Hm. + rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. Qed. - (** * Conversions between maps and association lists. *) - - Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := - fun p => f (fst p) (snd p). - - Definition of_list := - List.fold_right (uncurry (@add _)) (empty elt). - - Definition to_list := elements. - - Lemma of_list_1 : forall l k e, - NoDupA eqk l -> - (MapsTo k e (of_list l) <-> InA eqke (k,e) l). + Add Parametric Morphism elt : (@find elt) + with signature E.eq ==> Equal ==> eq as find_m. Proof. - induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. - - rewrite empty_mapsto_iff, InA_nil; intuition. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k e Hnodup'); clear Hnodup'. - rewrite add_mapsto_iff, InA_cons, <- IH. - unfold eq_key_elt at 1; simpl. - split; destruct 1 as [H|H]; try (intuition;fail). - destruct (eq_dec k k'); [left|right]; split; auto. - contradict Hnotin. - apply InA_eqke_eqk with k e; intuition. + intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. + rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. Qed. - Lemma of_list_1b : forall l k, - NoDupA eqk l -> - find k (of_list l) = findA (eqb k) l. + Add Parametric Morphism elt : (@add elt) + with signature E.eq ==> eq ==> Equal ==> Equal as add_m. Proof. - induction l as [|(k',e') l IH]; simpl; intros k Hnodup. - - apply empty_o. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k Hnodup'); clear Hnodup'. - rewrite add_o, IH. - unfold eqb; do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. + intros k k' Hk e m m' Hm y. + rewrite add_o, add_o; do 2 destruct eq_dec as [|?Hnot]; auto. + - elim Hnot; rewrite <-Hk; auto. + - elim Hnot; rewrite Hk; auto. Qed. - Lemma of_list_2 : forall l, NoDupA eqk l -> - equivlistA eqke l (to_list (of_list l)). + Add Parametric Morphism elt : (@remove elt) + with signature E.eq ==> Equal ==> Equal as remove_m. Proof. - intros l Hnodup (k,e). - rewrite <- elements_mapsto_iff, of_list_1; intuition. + intros k k' Hk m m' Hm y. + rewrite remove_o, remove_o; do 2 destruct eq_dec as [|?Hnot]; auto. + - elim Hnot; rewrite <-Hk; auto. + - elim Hnot; rewrite Hk; auto. Qed. - Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. + Add Parametric Morphism elt elt' : (@map elt elt') + with signature eq ==> Equal ==> Equal as map_m. Proof. - intros s k. - rewrite of_list_1b, elements_o; auto. - apply elements_3w. + intros f m m' Hm y. + rewrite map_o, map_o, Hm; auto. Qed. - (** * Fold *) + (* Later: Add Morphism cardinal *) - (** Alternative specification via [fold_right] *) + (* old name: *) + Notation not_find_mapsto_iff := not_find_in_iff. - Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : - fold f m i = List.fold_right (uncurry f) i (rev (elements m)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. +End WFacts_fun. - (** ** Induction principles about fold contributed by S. Lescuyer *) +(** * Same facts for self-contained weak sets and for full maps *) - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise map m we are considering. *) +Module WFacts (M:WS) := WFacts_fun M.E M. +Module Facts := WFacts. - Lemma fold_rec : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m, Empty m -> P m i) -> - (forall k e a m' m'', MapsTo k e m -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Hempty Hstep. - rewrite fold_spec_right. - set (F:=uncurry f). - set (l:=rev (elements m)). - assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). { - intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, elements_mapsto_iff. auto. - } - assert (Hdup : NoDupA eqk l). { - unfold l. apply NoDupA_rev; try red; unfold eq_key. - - auto with typeclass_instances. - - apply elements_3w. - } - assert (Hsame : forall k, find k m = findA (eqb k) l). { - intros k. unfold l. rewrite elements_o, findA_rev; auto. - apply elements_3w. - } - clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. - - (* empty *) - intros m Hsame; simpl. - apply Hempty. intros k e. - rewrite find_mapsto_iff, Hsame; simpl; discriminate. - - (* step *) - intros m Hsame; destruct a as (k,e); simpl. - apply Hstep' with (of_list l); auto. - + rewrite InA_cons; left; red; auto. - + inversion_clear Hdup. contradict H. destruct H as (e',He'). - apply InA_eqke_eqk with k e'; auto. - rewrite <- of_list_1; auto. - + intro k'. rewrite Hsame, add_o, of_list_1b. - * simpl. - unfold eqb. do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. - * inversion_clear Hdup; auto. - + apply IHl. - * intros; eapply Hstep'; eauto. - * inversion_clear Hdup; auto. - * intros; apply of_list_1b. inversion_clear Hdup; auto. - Qed. +(** * Additional Properties for weak maps - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) + Results about [fold], [elements], induction principles... +*) - Theorem fold_rec_bis : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - (P (empty _) i) -> - (forall k e a m', MapsTo k e m -> ~In k m' -> - P m' a -> P (add k e m') (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Pmorphism Pempty Pstep. - apply fold_rec; intros. - - apply Pmorphism with (empty _); auto. intro k. rewrite empty_o. - case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. - intro H'; elim (H k e'); auto. - - apply Pmorphism with (add k e m'); try intro; auto. - Qed. +Module WProperties_fun (E:DecidableType)(M:WSfun E). + Module Import F:=WFacts_fun E M. + Import M. + + Section Elt. + Variable elt:Type. + + Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). + + Lemma Add_transpose_neqkey : forall k1 k2 e1 e2 m1 m2 m3, + ~ E.eq k1 k2 -> Add k1 e1 m1 m2 -> Add k2 e2 m2 m3 -> + { m | Add k2 e2 m1 m /\ Add k1 e1 m m3 }. + Proof. + intros. + exists (add k2 e2 m1). + split. + + { easy. } + + unfold Add; intros. + rewrite H1. + destruct (E.eq_dec k1 y). + - assert (~ E.eq k2 y). + + contradict H. + apply E.eq_trans with (y:=y); auto. + + now rewrite add_neq_o, add_eq_o, H0, add_eq_o by assumption. + - destruct (E.eq_dec k2 y). + + now rewrite add_eq_o, add_neq_o, add_eq_o by assumption. + + now rewrite add_neq_o, H0, add_neq_o, add_neq_o, add_neq_o by assumption. + Qed. + + Notation eqke := (@eq_key_elt elt). + Notation eqk := (@eq_key elt). + + Instance eqk_equiv : Equivalence eqk. + Proof. unfold eq_key; split; eauto. Qed. + + Instance eqke_equiv : Equivalence eqke. + Proof. + unfold eq_key_elt; split; repeat red; firstorder. + - eauto. + - congruence. + Qed. + + (** Complements about InA, NoDupA and findA *) + + Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, + E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l. + Proof. + intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt. + intros ((k',e') & (Hk',He') & H); simpl in *. + exists (k',e'); split; auto. + red; simpl; eauto. + Qed. + + Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + Proof. + induction 1; auto. + constructor; auto. + destruct x as (k,e). + eauto using InA_eqke_eqk. + Qed. + + Lemma findA_rev : forall l k, NoDupA eqk l -> + findA (eqb k) l = findA (eqb k) (rev l). + Proof. + intros. + case_eq (findA (eqb k) l). + - intros. symmetry. + unfold eqb. + rewrite <- findA_NoDupA, InA_rev, findA_NoDupA + by (eauto using NoDupA_rev with * ); eauto. + - case_eq (findA (eqb k) (rev l)); auto. + intros e. + unfold eqb. + rewrite <- findA_NoDupA, InA_rev, findA_NoDupA + by (eauto using NoDupA_rev with * ). + intro Eq; rewrite Eq; auto. + Qed. + + (** * Elements *) + + Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. + Proof. + intros. + unfold Empty. + split; intros. + - assert (forall a, ~ List.In a (elements m)). { + red; intros. + apply (H (fst a) (snd a)). + rewrite elements_mapsto_iff. + rewrite InA_alt; exists a; auto. + split; auto; split; auto. + } + destruct (elements m); auto. + elim (H0 p); simpl; auto. + - red; intros. + rewrite elements_mapsto_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. + Qed. + + Lemma elements_empty : elements (@empty elt) = nil. + Proof. + rewrite <-elements_Empty; apply empty_1. + Qed. + + (** * Conversions between maps and association lists. *) + + Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := + fun p => f (fst p) (snd p). + + Definition of_list := + List.fold_right (uncurry (@add _)) (empty elt). + + Definition to_list := elements. + + Lemma of_list_1 : forall l k e, + NoDupA eqk l -> + (MapsTo k e (of_list l) <-> InA eqke (k,e) l). + Proof. + induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. + - rewrite empty_mapsto_iff, InA_nil; intuition. + - unfold uncurry; simpl. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k e Hnodup'); clear Hnodup'. + rewrite add_mapsto_iff, InA_cons, <- IH. + unfold eq_key_elt at 1; simpl. + split; destruct 1 as [H|H]; try (intuition;fail). + destruct (eq_dec k k'); [left|right]; split; auto. + contradict Hnotin. + apply InA_eqke_eqk with k e; intuition. + Qed. + + Lemma of_list_1b : forall l k, + NoDupA eqk l -> + find k (of_list l) = findA (eqb k) l. + Proof. + induction l as [|(k',e') l IH]; simpl; intros k Hnodup. + - apply empty_o. + - unfold uncurry; simpl. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k Hnodup'); clear Hnodup'. + rewrite add_o, IH. + unfold eqb; do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. + Qed. + + Lemma of_list_2 : forall l, NoDupA eqk l -> + equivlistA eqke l (to_list (of_list l)). + Proof. + intros l Hnodup (k,e). + rewrite <- elements_mapsto_iff, of_list_1; intuition. + Qed. + + Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. + Proof. + intros s k. + rewrite of_list_1b, elements_o; auto. + apply elements_3w. + Qed. + + (** * Fold *) + + (** Alternative specification via [fold_right] *) + + Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : + fold f m i = List.fold_right (uncurry f) i (rev (elements m)). + Proof. + rewrite fold_1. symmetry. apply fold_left_rev_right. + Qed. + + (** ** Induction principles about fold contributed by S. Lescuyer *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise map m we are considering. *) - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), - P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> - P (fold f m i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. + Lemma fold_rec : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m, Empty m -> P m i) -> + (forall k e a m' m'', MapsTo k e m -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Hempty Hstep. + rewrite fold_spec_right. + set (F:=uncurry f). + set (l:=rev (elements m)). + assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). { + intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. + revert H; unfold l; rewrite InA_rev, elements_mapsto_iff. auto. + } + assert (Hdup : NoDupA eqk l). { + unfold l. apply NoDupA_rev; try red; unfold eq_key. + - auto with typeclass_instances. + - apply elements_3w. + } + assert (Hsame : forall k, find k m = findA (eqb k) l). { + intros k. unfold l. rewrite elements_o, findA_rev; auto. + apply elements_3w. + } + clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. + - (* empty *) + intros m Hsame; simpl. + apply Hempty. intros k e. + rewrite find_mapsto_iff, Hsame; simpl; discriminate. + - (* step *) + intros m Hsame; destruct a as (k,e); simpl. + apply Hstep' with (of_list l); auto. + + rewrite InA_cons; left; red; auto. + + inversion_clear Hdup. contradict H. destruct H as (e',He'). + apply InA_eqke_eqk with k e'; auto. + rewrite <- of_list_1; auto. + + intro k'. rewrite Hsame, add_o, of_list_1b. + * simpl. + unfold eqb. do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. + * inversion_clear Hdup; auto. + + apply IHl. + * intros; eapply Hstep'; eauto. + * inversion_clear Hdup; auto. + * intros; apply of_list_1b. inversion_clear Hdup; auto. + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + Theorem fold_rec_bis : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + (P (empty _) i) -> + (forall k e a m', MapsTo k e m -> ~In k m' -> + P m' a -> P (add k e m') (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Pmorphism Pempty Pstep. + apply fold_rec; intros. + - apply Pmorphism with (empty _); auto. intro k. rewrite empty_o. + case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. + intro H'; elim (H k e'); auto. + - apply Pmorphism with (add k e m'); try intro; auto. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), + P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> + P (fold f m i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : the step hypothesis must here be applicable anywhere. At the same time, it looks more like an induction principle, and hence can be easier to use. *) - Lemma fold_rec_weak : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - P (empty _) i -> - (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> - forall m, P m (fold f m i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) - (m : t elt), - R i j -> - (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> - R (fold f m i) (fold g m j). - Proof. - intros A B R f g i j m Rempty Rstep. - rewrite 2 fold_spec_right. set (l:=rev (elements m)). - assert (Rstep' : forall k e a b, InA eqke (k,e) l -> - R a b -> R (f k e a) (g k e b)) by - (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; assumption). - clearbody l; clear Rstep m. - induction l; simpl; auto. - apply Rstep'; auto. - destruct a; simpl; rewrite InA_cons; left; red; auto. - Qed. - - (** From the induction principle on [fold], we can deduce some general + Lemma fold_rec_weak : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + P (empty _) i -> + (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> + forall m, P m (fold f m i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) + (m : t elt), + R i j -> + (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> + R (fold f m i) (fold g m j). + Proof. + intros A B R f g i j m Rempty Rstep. + rewrite 2 fold_spec_right. set (l:=rev (elements m)). + assert (Rstep' : forall k e a b, InA eqke (k,e) l -> + R a b -> R (f k e a) (g k e b)) by + (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; assumption). + clearbody l; clear Rstep m. + induction l; simpl; auto. + apply Rstep'; auto. + destruct a; simpl; rewrite InA_cons; left; red; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general induction principles on maps. *) - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - Lemma map_induction_bis : - forall P : t elt -> Type, - (forall m m', Equal m m' -> P m -> P m') -> - P (empty _) -> - (forall x e m, ~In x m -> P m -> P (add x e m)) -> - forall m, P m. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m. - Proof. - intros. - apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. - - intros m' Heq k'. - rewrite empty_o. - case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. - intro; elim (Heq k' e'); auto. - - intros k e a m' m'' _ _ Hadd Heq k'. - red in Heq. rewrite Hadd, 2 add_o, Heq; auto. - Qed. - - Section Fold_More. - - (** ** Additional properties of fold *) - - (** When a function [f] is compatible and allows transpositions, we can + Lemma map_induction : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. + Qed. + + Lemma map_induction_bis : + forall P : t elt -> Type, + (forall m m', Equal m m' -> P m -> P m') -> + P (empty _) -> + (forall x e m, ~In x m -> P m -> P (add x e m)) -> + forall m, P m. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m. + Proof. + intros. + apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. + - intros m' Heq k'. + rewrite empty_o. + case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. + intro; elim (Heq k' e'); auto. + - intros k e a m' m'' _ _ Hadd Heq k'. + red in Heq. rewrite Hadd, 2 add_o, Heq; auto. + Qed. + + Section Fold_More. + + (** ** Additional properties of fold *) + + (** When a function [f] is compatible and allows transpositions, we can compute [fold f] in any order. *) - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A). + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A). - (** This is more convenient than a [compat_op eqke ...]. + (** This is more convenient than a [compat_op eqke ...]. In fact, every [compat_op], [compat_bool], etc, should become a [Proper] someday. *) - Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f. - - Lemma fold_init : - forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). - Proof. - intros. apply fold_rel with (R:=eqA); auto. - intros. apply Comp; auto. - Qed. - - Lemma fold_Empty : - forall m i, Empty m -> eqA (fold f m i) i. - Proof. - intros. apply fold_rec_nodep with (P:=fun a => eqA a i). - - reflexivity. - - intros. elim (H k e); auto. - Qed. - - (** As noticed by P. Casteran, asking for the general [SetoidList.transpose] + Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f. + + Lemma fold_init : + forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros. apply Comp; auto. + Qed. + + Lemma fold_Empty : + forall m i, Empty m -> eqA (fold f m i) i. + Proof. + intros. apply fold_rec_nodep with (P:=fun a => eqA a i). + - reflexivity. + - intros. elim (H k e); auto. + Qed. + + (** As noticed by P. Casteran, asking for the general [SetoidList.transpose] here is too restrictive. Think for instance of [f] being [M.add] : in general, [M.add k e (M.add k e' m)] is not equivalent to [M.add k e' (M.add k e m)]. Fortunately, we will never encounter this @@ -1115,734 +1115,734 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). FSets could also benefit from a restricted [transpose], but for this case the gain is unclear. *) - Definition transpose_neqkey := - forall k k' e e' a, ~E.eq k k' -> - eqA (f k e (f k' e' a)) (f k' e' (f k e a)). - - Hypothesis Tra : transpose_neqkey. - - Lemma fold_commutes : forall i m k e, ~In k m -> - eqA (fold f m (f k e i)) (f k e (fold f m i)). - Proof. - intros i m k e Hnotin. - apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. - - reflexivity. - - intros. - transitivity (f k0 e0 (f k e b)). - + apply Comp; auto. - + apply Tra; auto. - contradict Hnotin; rewrite <- Hnotin; exists e0; auto. - Qed. - - #[local] - Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. - - Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros. - rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. - assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. - apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke). - 1:auto with typeclass_instances. - 1:auto. - 2: auto with crelations. - 4, 5: auto with map. - - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. - - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. - - intros (k,e) (k',e'); unfold eq_key, uncurry; simpl; auto. - - rewrite <- NoDupA_altdef; auto. - - intros (k,e). - rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. - auto with crelations. - Qed. - - Lemma fold_Equal2 : forall m1 m2 i j, Equal m1 m2 -> eqA i j -> - eqA (fold f m1 i) (fold f m2 j). - Proof. - intros. - rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. - assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. - apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke). - 1:auto with typeclass_instances. - 1, 10: auto. - 2: auto with crelations. - 4, 5: auto with map. - - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. - - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. - - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. - rewrite h'. - auto. - - rewrite <- NoDupA_altdef; auto. - - intros (k,e). - rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. - auto with crelations. - Qed. - - - Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> - eqA (fold f m2 i) (f k e (fold f m1 i)). - Proof. - intros. - rewrite 2 fold_spec_right. - set (f':=uncurry f). - change (f k e (fold_right f' i (rev (elements m1)))) - with (f' (k,e) (fold_right f' i (rev (elements m1)))). - assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. - assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. - apply fold_right_add_restr with - (R:=complement eqk)(eqA:=eqke)(eqB:=eqA). - 1:auto with typeclass_instances. - 1:auto. - 2: auto with crelations. - 4, 5: auto with map. - - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto. - - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto. - - unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto. - - rewrite <- NoDupA_altdef; auto. - - rewrite InA_rev, <- elements_mapsto_iff. firstorder. - - intros (a,b). - rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, - 2 find_mapsto_iff. - unfold eq_key_elt; simpl. - rewrite H0. - rewrite add_o. - destruct (eq_dec k a) as [EQ|NEQ]; split; auto. - + intros EQ'; inversion EQ'; auto. - + intuition; subst; auto. - elim H. exists b; rewrite EQ; auto with map. - + intuition. - elim NEQ; auto. - Qed. - - Lemma fold_add : forall m k e i, ~In k m -> - eqA (fold f (add k e m) i) (f k e (fold f m i)). - Proof. - intros. apply fold_Add; try red; auto. - Qed. - - End Fold_More. - - (** * Cardinal *) - - Lemma cardinal_fold : forall m : t elt, - cardinal m = fold (fun _ _ => S) m 0. - Proof. - intros; rewrite cardinal_1, fold_1. - symmetry; apply fold_left_S_0; auto. - Qed. - - Lemma cardinal_Empty : forall m : t elt, - Empty m <-> cardinal m = 0. - Proof. - intros. - rewrite cardinal_1, elements_Empty. - destruct (elements m); intuition; discriminate. - Qed. - - Lemma Equal_cardinal : forall m m' : t elt, - Equal m m' -> cardinal m = cardinal m'. - Proof. - intros; do 2 rewrite cardinal_fold. - apply fold_Equal with (eqA:=eq); compute; auto. - Qed. - - Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. - Proof. - intros; rewrite <- cardinal_Empty; auto. - Qed. - - Lemma cardinal_2 : - forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=eq); compute; auto. - Qed. - - Lemma cardinal_Add_In: - forall m m' x e, In x m -> Add x e m m' -> cardinal m' = cardinal m. - Proof. - assert (forall k e m, MapsTo k e m -> Add k e (remove k m) m) as remove_In_Add. - { intros. unfold Add. - intros. - rewrite F.add_o. - destruct (F.eq_dec k y). - - apply find_1. rewrite <-MapsTo_m; [exact H|assumption|reflexivity|reflexivity]. - - rewrite F.remove_neq_o by assumption. reflexivity. - } - intros. - assert (Equal (remove x m) (remove x m')). - { intros y. rewrite 2!F.remove_o. - destruct (F.eq_dec x y). - - reflexivity. - - unfold Add in H0. rewrite H0. - rewrite F.add_neq_o by assumption. reflexivity. - } - apply Equal_cardinal in H1. - rewrite 2!cardinal_fold. - destruct H as (e' & H). - rewrite fold_Add with (eqA:=eq) (m1:=remove x m) (m2:=m) (k:=x) (e:=e'); - try now (compute; auto). - 2:apply remove_1; reflexivity. - 2:apply remove_In_Add; assumption. - rewrite fold_Add with (eqA:=eq) (m1:=remove x m') (m2:=m') (k:=x) (e:=e); - try now (compute; auto). - - rewrite <- 2!cardinal_fold. congruence. - - apply remove_1. reflexivity. - - apply remove_In_Add. - apply find_2. unfold Add in H0. rewrite H0. - rewrite F.add_eq_o; reflexivity. - Qed. - - Lemma cardinal_inv_1 : forall m : t elt, - cardinal m = 0 -> Empty m. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - #[local] - Hint Resolve cardinal_inv_1 : map. - - Lemma cardinal_inv_2 : - forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros; rewrite M.cardinal_1 in *. - generalize (elements_mapsto_iff m). - destruct (elements m); try discriminate. - exists p; auto. - rewrite H0; destruct p; simpl; auto. - constructor; red; auto. - Qed. - - Lemma cardinal_inv_2b : - forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros. - generalize (@cardinal_inv_2 m); destruct cardinal. - - elim H;auto. - - eauto. - Qed. - - (** * Additional notions over maps *) - - Definition Disjoint (m m' : t elt) := - forall k, ~(In k m /\ In k m'). - - Definition Partition (m m1 m2 : t elt) := - Disjoint m1 m2 /\ - (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - - (** * Emulation of some functions lacking in the interface *) - - Definition filter (f : key -> elt -> bool)(m : t elt) := - fold (fun k e m => if f k e then add k e m else m) m (empty _). - - Definition for_all (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then b else false) m true. - - Definition exists_ (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then true else b) m false. - - Definition partition (f : key -> elt -> bool)(m : t elt) := - (filter f m, filter (fun k e => negb (f k e)) m). - - (** [update] adds to [m1] all the bindings of [m2]. It can be seen as + Definition transpose_neqkey := + forall k k' e e' a, ~E.eq k k' -> + eqA (f k e (f k' e' a)) (f k' e' (f k e a)). + + Hypothesis Tra : transpose_neqkey. + + Lemma fold_commutes : forall i m k e, ~In k m -> + eqA (fold f m (f k e i)) (f k e (fold f m i)). + Proof. + intros i m k e Hnotin. + apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. + - reflexivity. + - intros. + transitivity (f k0 e0 (f k e b)). + + apply Comp; auto. + + apply Tra; auto. + contradict Hnotin; rewrite <- Hnotin; exists e0; auto. + Qed. + + #[local] + Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. + + Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). + Proof. + intros. + rewrite 2 fold_spec_right. + assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. + assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. + apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke). + 1:auto with typeclass_instances. + 1:auto. + 2: auto with crelations. + 4, 5: auto with map. + - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. + - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. + - intros (k,e) (k',e'); unfold eq_key, uncurry; simpl; auto. + - rewrite <- NoDupA_altdef; auto. + - intros (k,e). + rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. + auto with crelations. + Qed. + + Lemma fold_Equal2 : forall m1 m2 i j, Equal m1 m2 -> eqA i j -> + eqA (fold f m1 i) (fold f m2 j). + Proof. + intros. + rewrite 2 fold_spec_right. + assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. + assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. + apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke). + 1:auto with typeclass_instances. + 1, 10: auto. + 2: auto with crelations. + 4, 5: auto with map. + - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. + - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. + - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. + rewrite h'. + auto. + - rewrite <- NoDupA_altdef; auto. + - intros (k,e). + rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. + auto with crelations. + Qed. + + + Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> + eqA (fold f m2 i) (f k e (fold f m1 i)). + Proof. + intros. + rewrite 2 fold_spec_right. + set (f':=uncurry f). + change (f k e (fold_right f' i (rev (elements m1)))) + with (f' (k,e) (fold_right f' i (rev (elements m1)))). + assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. + assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. + apply fold_right_add_restr with + (R:=complement eqk)(eqA:=eqke)(eqB:=eqA). + 1:auto with typeclass_instances. + 1:auto. + 2: auto with crelations. + 4, 5: auto with map. + - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto. + - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto. + - unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto. + - rewrite <- NoDupA_altdef; auto. + - rewrite InA_rev, <- elements_mapsto_iff. firstorder. + - intros (a,b). + rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, + 2 find_mapsto_iff. + unfold eq_key_elt; simpl. + rewrite H0. + rewrite add_o. + destruct (eq_dec k a) as [EQ|NEQ]; split; auto. + + intros EQ'; inversion EQ'; auto. + + intuition; subst; auto. + elim H. exists b; rewrite EQ; auto with map. + + intuition. + elim NEQ; auto. + Qed. + + Lemma fold_add : forall m k e i, ~In k m -> + eqA (fold f (add k e m) i) (f k e (fold f m i)). + Proof. + intros. apply fold_Add; try red; auto. + Qed. + + End Fold_More. + + (** * Cardinal *) + + Lemma cardinal_fold : forall m : t elt, + cardinal m = fold (fun _ _ => S) m 0. + Proof. + intros; rewrite cardinal_1, fold_1. + symmetry; apply fold_left_S_0; auto. + Qed. + + Lemma cardinal_Empty : forall m : t elt, + Empty m <-> cardinal m = 0. + Proof. + intros. + rewrite cardinal_1, elements_Empty. + destruct (elements m); intuition; discriminate. + Qed. + + Lemma Equal_cardinal : forall m m' : t elt, + Equal m m' -> cardinal m = cardinal m'. + Proof. + intros; do 2 rewrite cardinal_fold. + apply fold_Equal with (eqA:=eq); compute; auto. + Qed. + + Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. + Proof. + intros; rewrite <- cardinal_Empty; auto. + Qed. + + Lemma cardinal_2 : + forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). + Proof. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ _ => S) x e). + apply fold_Add with (eqA:=eq); compute; auto. + Qed. + + Lemma cardinal_Add_In: + forall m m' x e, In x m -> Add x e m m' -> cardinal m' = cardinal m. + Proof. + assert (forall k e m, MapsTo k e m -> Add k e (remove k m) m) as remove_In_Add. + { intros. unfold Add. + intros. + rewrite F.add_o. + destruct (F.eq_dec k y). + - apply find_1. rewrite <-MapsTo_m; [exact H|assumption|reflexivity|reflexivity]. + - rewrite F.remove_neq_o by assumption. reflexivity. + } + intros. + assert (Equal (remove x m) (remove x m')). + { intros y. rewrite 2!F.remove_o. + destruct (F.eq_dec x y). + - reflexivity. + - unfold Add in H0. rewrite H0. + rewrite F.add_neq_o by assumption. reflexivity. + } + apply Equal_cardinal in H1. + rewrite 2!cardinal_fold. + destruct H as (e' & H). + rewrite fold_Add with (eqA:=eq) (m1:=remove x m) (m2:=m) (k:=x) (e:=e'); + try now (compute; auto). + 2:apply remove_1; reflexivity. + 2:apply remove_In_Add; assumption. + rewrite fold_Add with (eqA:=eq) (m1:=remove x m') (m2:=m') (k:=x) (e:=e); + try now (compute; auto). + - rewrite <- 2!cardinal_fold. congruence. + - apply remove_1. reflexivity. + - apply remove_In_Add. + apply find_2. unfold Add in H0. rewrite H0. + rewrite F.add_eq_o; reflexivity. + Qed. + + Lemma cardinal_inv_1 : forall m : t elt, + cardinal m = 0 -> Empty m. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + #[local] + Hint Resolve cardinal_inv_1 : map. + + Lemma cardinal_inv_2 : + forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. + Proof. + intros; rewrite M.cardinal_1 in *. + generalize (elements_mapsto_iff m). + destruct (elements m); try discriminate. + exists p; auto. + rewrite H0; destruct p; simpl; auto. + constructor; red; auto. + Qed. + + Lemma cardinal_inv_2b : + forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. + Proof. + intros. + generalize (@cardinal_inv_2 m); destruct cardinal. + - elim H;auto. + - eauto. + Qed. + + (** * Additional notions over maps *) + + Definition Disjoint (m m' : t elt) := + forall k, ~(In k m /\ In k m'). + + Definition Partition (m m1 m2 : t elt) := + Disjoint m1 m2 /\ + (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). + + (** * Emulation of some functions lacking in the interface *) + + Definition filter (f : key -> elt -> bool)(m : t elt) := + fold (fun k e m => if f k e then add k e m else m) m (empty _). + + Definition for_all (f : key -> elt -> bool)(m : t elt) := + fold (fun k e b => if f k e then b else false) m true. + + Definition exists_ (f : key -> elt -> bool)(m : t elt) := + fold (fun k e b => if f k e then true else b) m false. + + Definition partition (f : key -> elt -> bool)(m : t elt) := + (filter f m, filter (fun k e => negb (f k e)) m). + + (** [update] adds to [m1] all the bindings of [m2]. It can be seen as an [union] operator which gives priority to its 2nd argument in case of binding conflit. *) - Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. + Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. - (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. + (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. It can be seen as an [inter] operator, with priority to its 1st argument in case of binding conflit. *) - Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. - - (** [diff] erases from [m1] all bindings whose key is in [m2]. *) - - Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. - - Section Specs. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma filter_iff : forall m k e, - MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. - Proof. - unfold filter. - set (f':=fun k e m => if f k e then add k e m else m). - intro m. pattern m, (fold f' m (empty _)). apply fold_rec. - - - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. - elim (Hm' k e); auto. - - - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. - unfold f'; simpl. - case_eq (f k e); intros Hfke; simpl; - rewrite !add_mapsto_iff, IH; clear IH; intuition. - + rewrite <- Hfke; apply Hf; auto. - + destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto. - elim Hn; exists e'; rewrite Hk; auto. - + assert (f k e = f k' e') by (apply Hf; auto). congruence. - Qed. - - Lemma for_all_iff : forall m, - for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). - Proof. - unfold for_all. - set (f':=fun k e b => if f k e then b else false). - intro m. pattern m, (fold f' m true). apply fold_rec. - - - intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto. - - - intros k e b m1 m2 _ Hn Hadd IH. clear m. - change (Equal m2 (add k e m1)) in Hadd. - unfold f'; simpl. case_eq (f k e); intros Hfke. - (* f k e = true *) - + rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'. - * rewrite Hadd, add_mapsto_iff in Hke'. - destruct Hke' as [(?,?)|(?,?)]; auto. - rewrite <- Hfke; apply Hf; auto. - * apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. - contradict Hn; exists e'; rewrite Hn; auto. - (* f k e = false *) - + split; try discriminate. - intros Hmapsto. rewrite <- Hfke. apply Hmapsto. - rewrite Hadd, add_mapsto_iff; auto. - Qed. - - Lemma exists_iff : forall m, - exists_ f m = true <-> - (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). - Proof. - unfold exists_. - set (f':=fun k e b => if f k e then true else b). - intro m. pattern m, (fold f' m false). apply fold_rec. - - - intros m' Hm'. split; try discriminate. - intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. - - - intros k e b m1 m2 _ Hn Hadd IH. clear m. - change (Equal m2 (add k e m1)) in Hadd. - unfold f'; simpl. case_eq (f k e); intros Hfke. - (* f k e = true *) - + split; [intros _|auto]. - exists (k,e); simpl; split; auto. - rewrite Hadd, add_mapsto_iff; auto. - (* f k e = false *) - + rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *. - * exists (k',e'); simpl; split; auto. - rewrite Hadd, add_mapsto_iff; right; split; auto. - contradict Hn. exists e'; rewrite Hn; auto. - * rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)]. - -- assert (f k' e' = f k e) by (apply Hf; auto). congruence. - -- exists (k',e'); auto. - Qed. - - End Specs. - - Lemma Disjoint_alt : forall m m', - Disjoint m m' <-> - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). - Proof. - unfold Disjoint; split. - - intros H k v v' H1 H2. - apply H with k; split. - + exists v; trivial. - + exists v'; trivial. - - intros H k ((v,Hv),(v',Hv')). - eapply H; eauto. - Qed. - - Section Partition. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma partition_iff_1 : forall m m1 k e, - m1 = fst (partition f m) -> - (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). - Proof. - unfold partition; simpl; intros. subst m1. - apply filter_iff; auto. - Qed. - - Lemma partition_iff_2 : forall m m2 k e, - m2 = snd (partition f m) -> - (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). - Proof. - unfold partition; simpl; intros. subst m2. - rewrite filter_iff. - - split; intros (H,H'); split; auto. - + destruct (f k e); simpl in *; auto. - + rewrite H'; auto. - - repeat red; intros. f_equal. apply Hf; auto. - Qed. - - Lemma partition_Partition : forall m m1 m2, - partition f m = (m1,m2) -> Partition m m1 m2. - Proof. - intros. split. - - rewrite Disjoint_alt. intros k e e'. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence. - - intros k e. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - destruct (f k e); intuition. - Qed. - - End Partition. - - Lemma Partition_In : forall m m1 m2 k, - Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. - Proof. - intros m m1 m2 k Hm Hk. - destruct (In_dec m1 k) as [H|H]; [left|right]; auto. - destruct Hm as (Hm,Hm'). - destruct Hk as (e,He); rewrite Hm' in He; destruct He. - - elim H; exists e; auto. - - exists e; auto. - Defined. - - Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. - Proof. - intros m1 m2 H k (H1,H2). elim (H k); auto. - Qed. - - Lemma Partition_sym : forall m m1 m2, - Partition m m1 m2 -> Partition m m2 m1. - Proof. - intros m m1 m2 (H,H'); split. - - apply Disjoint_sym; auto. - - intros; rewrite H'; intuition. - Qed. - - Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> - (Empty m <-> (Empty m1 /\ Empty m2)). - Proof. - intros m m1 m2 (Hdisj,Heq). split. - - intro He. - split; intros k e Hke; elim (He k e); rewrite Heq; auto. - - intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. - + elim (He1 k e); auto. - + elim (He2 k e); auto. - Qed. - - Lemma Partition_Add : - forall m m' x e , ~In x m -> Add x e m m' -> - forall m1 m2, Partition m' m1 m2 -> - exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ - Add x e m3 m2 /\ Partition m m1 m3). - Proof. - unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). - assert (Heq : Equal m (remove x m')). { - change (Equal m' (add x e m)) in Hadd. rewrite Hadd. - intro k. rewrite remove_o, add_o. - destruct eq_dec as [He|Hne]; auto. - rewrite <- He, <- not_find_in_iff; auto. - } - assert (H : MapsTo x e m'). { - change (Equal m' (add x e m)) in Hadd; rewrite Hadd. - apply add_1; auto. - } - rewrite Hor in H; destruct H. - - - (* first case : x in m1 *) - exists (remove x m1); left. split; [|split]. - + (* add *) - change (Equal m1 (add x e (remove x m1))). - intro k. - rewrite add_o, remove_o. - destruct eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H1; destruct H1; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e|exists e']; auto. - apply MapsTo_1 with k'; auto. - - - (* second case : x in m2 *) - exists (remove x m2); right. split; [|split]. - + (* add *) - change (Equal m2 (add x e (remove x m2))). - intro k. - rewrite add_o, remove_o. - destruct eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H2; destruct H2; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e'|exists e]; auto. - apply MapsTo_1 with k'; auto. - Qed. - - Lemma Partition_fold : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - transpose_neqkey eqA f -> - forall m m1 m2 i, - Partition m m1 m2 -> - eqA (fold f m i) (fold f m1 (fold f m2 i)). - Proof. - intros A eqA st f Comp Tra. - induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. - - - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. - rewrite (Partition_Empty Hp) in Hm. destruct Hm. - rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. - - - intros m1 m2 i Hp. - destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). - + (* fst case: m3 is (k,e)::m1 *) - assert (~In k m3). { - contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. + + (** [diff] erases from [m1] all bindings whose key is in [m2]. *) + + Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. + + Section Specs. + Variable f : key -> elt -> bool. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. + + Lemma filter_iff : forall m k e, + MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. + Proof. + unfold filter. + set (f':=fun k e m => if f k e then add k e m else m). + intro m. pattern m, (fold f' m (empty _)). apply fold_rec. + + - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. + elim (Hm' k e); auto. + + - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. + unfold f'; simpl. + case_eq (f k e); intros Hfke; simpl; + rewrite !add_mapsto_iff, IH; clear IH; intuition. + + rewrite <- Hfke; apply Hf; auto. + + destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto. + elim Hn; exists e'; rewrite Hk; auto. + + assert (f k e = f k' e') by (apply Hf; auto). congruence. + Qed. + + Lemma for_all_iff : forall m, + for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). + Proof. + unfold for_all. + set (f':=fun k e b => if f k e then b else false). + intro m. pattern m, (fold f' m true). apply fold_rec. + + - intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto. + + - intros k e b m1 m2 _ Hn Hadd IH. clear m. + change (Equal m2 (add k e m1)) in Hadd. + unfold f'; simpl. case_eq (f k e); intros Hfke. + (* f k e = true *) + + rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'. + * rewrite Hadd, add_mapsto_iff in Hke'. + destruct Hke' as [(?,?)|(?,?)]; auto. + rewrite <- Hfke; apply Hf; auto. + * apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. + contradict Hn; exists e'; rewrite Hn; auto. + (* f k e = false *) + + split; try discriminate. + intros Hmapsto. rewrite <- Hfke. apply Hmapsto. + rewrite Hadd, add_mapsto_iff; auto. + Qed. + + Lemma exists_iff : forall m, + exists_ f m = true <-> + (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). + Proof. + unfold exists_. + set (f':=fun k e b => if f k e then true else b). + intro m. pattern m, (fold f' m false). apply fold_rec. + + - intros m' Hm'. split; try discriminate. + intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. + + - intros k e b m1 m2 _ Hn Hadd IH. clear m. + change (Equal m2 (add k e m1)) in Hadd. + unfold f'; simpl. case_eq (f k e); intros Hfke. + (* f k e = true *) + + split; [intros _|auto]. + exists (k,e); simpl; split; auto. + rewrite Hadd, add_mapsto_iff; auto. + (* f k e = false *) + + rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *. + * exists (k',e'); simpl; split; auto. + rewrite Hadd, add_mapsto_iff; right; split; auto. + contradict Hn. exists e'; rewrite Hn; auto. + * rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)]. + -- assert (f k' e' = f k e) by (apply Hf; auto). congruence. + -- exists (k',e'); auto. + Qed. + + End Specs. + + Lemma Disjoint_alt : forall m m', + Disjoint m m' <-> + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). + Proof. + unfold Disjoint; split. + - intros H k v v' H1 H2. + apply H with k; split. + + exists v; trivial. + + exists v'; trivial. + - intros H k ((v,Hv),(v',Hv')). + eapply H; eauto. + Qed. + + Section Partition. + Variable f : key -> elt -> bool. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. + + Lemma partition_iff_1 : forall m m1 k e, + m1 = fst (partition f m) -> + (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). + Proof. + unfold partition; simpl; intros. subst m1. + apply filter_iff; auto. + Qed. + + Lemma partition_iff_2 : forall m m2 k e, + m2 = snd (partition f m) -> + (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). + Proof. + unfold partition; simpl; intros. subst m2. + rewrite filter_iff. + - split; intros (H,H'); split; auto. + + destruct (f k e); simpl in *; auto. + + rewrite H'; auto. + - repeat red; intros. f_equal. apply Hf; auto. + Qed. + + Lemma partition_Partition : forall m m1 m2, + partition f m = (m1,m2) -> Partition m m1 m2. + Proof. + intros. split. + - rewrite Disjoint_alt. intros k e e'. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence. + - intros k e. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + destruct (f k e); intuition. + Qed. + + End Partition. + + Lemma Partition_In : forall m m1 m2 k, + Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. + Proof. + intros m m1 m2 k Hm Hk. + destruct (In_dec m1 k) as [H|H]; [left|right]; auto. + destruct Hm as (Hm,Hm'). + destruct Hk as (e,He); rewrite Hm' in He; destruct He. + - elim H; exists e; auto. + - exists e; auto. + Defined. + + Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. + Proof. + intros m1 m2 H k (H1,H2). elim (H k); auto. + Qed. + + Lemma Partition_sym : forall m m1 m2, + Partition m m1 m2 -> Partition m m2 m1. + Proof. + intros m m1 m2 (H,H'); split. + - apply Disjoint_sym; auto. + - intros; rewrite H'; intuition. + Qed. + + Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> + (Empty m <-> (Empty m1 /\ Empty m2)). + Proof. + intros m m1 m2 (Hdisj,Heq). split. + - intro He. + split; intros k e Hke; elim (He k e); rewrite Heq; auto. + - intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. + + elim (He1 k e); auto. + + elim (He2 k e); auto. + Qed. + + Lemma Partition_Add : + forall m m' x e , ~In x m -> Add x e m m' -> + forall m1 m2, Partition m' m1 m2 -> + exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ + Add x e m3 m2 /\ Partition m m1 m3). + Proof. + unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). + assert (Heq : Equal m (remove x m')). { + change (Equal m' (add x e m)) in Hadd. rewrite Hadd. + intro k. rewrite remove_o, add_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He, <- not_find_in_iff; auto. } - transitivity (f k e (fold f m i)). - * apply fold_Add with (eqA:=eqA); auto. - * symmetry. - transitivity (f k e (fold f m3 (fold f m2 i))). - -- apply fold_Add with (eqA:=eqA); auto. - -- apply Comp; auto. - symmetry; apply IH; auto. - + (* snd case: m3 is (k,e)::m2 *) - assert (~In k m3). { - contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + assert (H : MapsTo x e m'). { + change (Equal m' (add x e m)) in Hadd; rewrite Hadd. + apply add_1; auto. } - assert (~In k m1). { - contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. - } - transitivity (f k e (fold f m i)). - * apply fold_Add with (eqA:=eqA); auto. - * transitivity (f k e (fold f m1 (fold f m3 i))). - -- apply Comp; auto using IH. - -- transitivity (fold f m1 (f k e (fold f m3 i))). - ++ symmetry. - apply fold_commutes with (eqA:=eqA); auto. - ++ apply fold_init with (eqA:=eqA); auto. - symmetry. - apply fold_Add with (eqA:=eqA); auto. - Qed. - - Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> - cardinal m = cardinal m1 + cardinal m2. - Proof. - intros. - rewrite (cardinal_fold m), (cardinal_fold m1). - set (f:=fun (_:key)(_:elt)=>S). - setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). - - rewrite <- cardinal_fold. - apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - - apply Partition_fold with (eqA:=eq); repeat red; auto. - Qed. - - Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> - let f := fun k (_:elt) => mem k m1 in - Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). - Proof. - intros m m1 m2 Hm f. - assert (Hf : Proper (E.eq==>eq==>eq) f). - { intros k k' Hk e e' _; unfold f; rewrite Hk; auto. } - set (m1':= fst (partition f m)). - set (m2':= snd (partition f m)). - split; rewrite Equal_mapsto_iff; intros k e. - - rewrite (@partition_iff_1 f Hf m m1') by auto. - unfold f. - rewrite <- mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - + exists e; auto. - + elim (Hm k); split; auto; exists e; auto. - - rewrite (@partition_iff_2 f Hf m m2') by auto. - unfold f. - rewrite <- not_mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - + elim (Hm k); split; auto; exists e; auto. - + elim H1; exists e; auto. - Qed. - - Lemma update_mapsto_iff : forall m m' k e, - MapsTo k e (update m m') <-> - (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). - Proof. - unfold update. - intros m m'. - pattern m', (fold (@add _) m' m). apply fold_rec. - - - intros m0 Hm0 k e. - assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). - intuition. - elim (Hm0 k e); auto. - - - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd. - rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. - Qed. - - Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> - { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. - Proof. - intros m m' k e H. rewrite update_mapsto_iff in H. - destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. - elim H'; exists e; auto. - Defined. - - Lemma update_in_iff : forall m m' k, - In k (update m m') <-> In k m \/ In k m'. - Proof. - intros m m' k. split. - - intros (e,H); rewrite update_mapsto_iff in H. - destruct H; [right|left]; exists e; intuition. - - destruct (In_dec m' k) as [H|H]. - + destruct H as (e,H). intros _; exists e. - rewrite update_mapsto_iff; left; auto. - + destruct 1 as [H'|H']; [|elim H; auto]. - destruct H' as (e,H'). exists e. - rewrite update_mapsto_iff; right; auto. - Qed. - - Lemma diff_mapsto_iff : forall m m' k e, - MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. - Proof. - intros m m' k e. - unfold diff. - rewrite filter_iff. - - intuition. - rewrite mem_1 in *; auto; discriminate. - - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma diff_in_iff : forall m m' k, - In k (diff m m') <-> In k m /\ ~In k m'. - Proof. - intros m m' k. split. - - intros (e,H); rewrite diff_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - - intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. + rewrite Hor in H; destruct H. + + - (* first case : x in m1 *) + exists (remove x m1); left. split; [|split]. + + (* add *) + change (Equal m1 (add x e (remove x m1))). + intro k. + rewrite add_o, remove_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H1; destruct H1; auto. + + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e|exists e']; auto. + apply MapsTo_1 with k'; auto. + + - (* second case : x in m2 *) + exists (remove x m2); right. split; [|split]. + + (* add *) + change (Equal m2 (add x e (remove x m2))). + intro k. + rewrite add_o, remove_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H2; destruct H2; auto. + + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e'|exists e]; auto. + apply MapsTo_1 with k'; auto. + Qed. + + Lemma Partition_fold : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), + Proper (E.eq==>eq==>eqA==>eqA) f -> + transpose_neqkey eqA f -> + forall m m1 m2 i, + Partition m m1 m2 -> + eqA (fold f m i) (fold f m1 (fold f m2 i)). + Proof. + intros A eqA st f Comp Tra. + induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. + + - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. + rewrite (Partition_Empty Hp) in Hm. destruct Hm. + rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. + + - intros m1 m2 i Hp. + destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). + + (* fst case: m3 is (k,e)::m1 *) + assert (~In k m3). { + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + } + transitivity (f k e (fold f m i)). + * apply fold_Add with (eqA:=eqA); auto. + * symmetry. + transitivity (f k e (fold f m3 (fold f m2 i))). + -- apply fold_Add with (eqA:=eqA); auto. + -- apply Comp; auto. + symmetry; apply IH; auto. + + (* snd case: m3 is (k,e)::m2 *) + assert (~In k m3). { + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + } + assert (~In k m1). { + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + } + transitivity (f k e (fold f m i)). + * apply fold_Add with (eqA:=eqA); auto. + * transitivity (f k e (fold f m1 (fold f m3 i))). + -- apply Comp; auto using IH. + -- transitivity (fold f m1 (f k e (fold f m3 i))). + ++ symmetry. + apply fold_commutes with (eqA:=eqA); auto. + ++ apply fold_init with (eqA:=eqA); auto. + symmetry. + apply fold_Add with (eqA:=eqA); auto. + Qed. + + Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> + cardinal m = cardinal m1 + cardinal m2. + Proof. + intros. + rewrite (cardinal_fold m), (cardinal_fold m1). + set (f:=fun (_:key)(_:elt)=>S). + setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). + - rewrite <- cardinal_fold. + apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. + - apply Partition_fold with (eqA:=eq); repeat red; auto. + Qed. + + Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> + let f := fun k (_:elt) => mem k m1 in + Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). + Proof. + intros m m1 m2 Hm f. + assert (Hf : Proper (E.eq==>eq==>eq) f). + { intros k k' Hk e e' _; unfold f; rewrite Hk; auto. } + set (m1':= fst (partition f m)). + set (m2':= snd (partition f m)). + split; rewrite Equal_mapsto_iff; intros k e. + - rewrite (@partition_iff_1 f Hf m m1') by auto. + unfold f. + rewrite <- mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + + exists e; auto. + + elim (Hm k); split; auto; exists e; auto. + - rewrite (@partition_iff_2 f Hf m m2') by auto. + unfold f. + rewrite <- not_mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + + elim (Hm k); split; auto; exists e; auto. + + elim H1; exists e; auto. + Qed. + + Lemma update_mapsto_iff : forall m m' k e, + MapsTo k e (update m m') <-> + (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). + Proof. + unfold update. + intros m m'. + pattern m', (fold (@add _) m' m). apply fold_rec. + + - intros m0 Hm0 k e. + assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). + intuition. + elim (Hm0 k e); auto. + + - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd. + rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. + Qed. + + Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> + { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. + Proof. + intros m m' k e H. rewrite update_mapsto_iff in H. + destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. + elim H'; exists e; auto. + Defined. + + Lemma update_in_iff : forall m m' k, + In k (update m m') <-> In k m \/ In k m'. + Proof. + intros m m' k. split. + - intros (e,H); rewrite update_mapsto_iff in H. + destruct H; [right|left]; exists e; intuition. + - destruct (In_dec m' k) as [H|H]. + + destruct H as (e,H). intros _; exists e. + rewrite update_mapsto_iff; left; auto. + + destruct 1 as [H'|H']; [|elim H; auto]. + destruct H' as (e,H'). exists e. + rewrite update_mapsto_iff; right; auto. + Qed. + + Lemma diff_mapsto_iff : forall m m' k e, + MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. + Proof. + intros m m' k e. + unfold diff. + rewrite filter_iff. + - intuition. + rewrite mem_1 in *; auto; discriminate. + - intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma diff_in_iff : forall m m' k, + In k (diff m m') <-> In k m /\ ~In k m'. + Proof. + intros m m' k. split. + - intros (e,H); rewrite diff_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + - intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. + Qed. + + Lemma restrict_mapsto_iff : forall m m' k e, + MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. + Proof. + intros m m' k e. + unfold restrict. + rewrite filter_iff. + - intuition. + - intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma restrict_in_iff : forall m m' k, + In k (restrict m m') <-> In k m /\ In k m'. + Proof. + intros m m' k. split. + - intros (e,H); rewrite restrict_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + - intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. + Qed. + + (** specialized versions analyzing only keys (resp. elements) *) + + Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). + Definition filter_range (f : elt -> bool) := filter (fun _ => f). + Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). + Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). + Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). + Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). + Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). + Definition partition_range (f : elt -> bool) := partition (fun _ => f). + + End Elt. + + Add Parametric Morphism elt : (@cardinal elt) + with signature Equal ==> eq as cardinal_m. + Proof. intros; apply Equal_cardinal; auto. Qed. + + Add Parametric Morphism elt : (@Disjoint elt) + with signature Equal ==> Equal ==> iff as Disjoint_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. + - rewrite <- Hm1, <- Hm2; auto. + - rewrite Hm1, Hm2; auto. + Qed. + + Add Parametric Morphism elt : (@Partition elt) + with signature Equal ==> Equal ==> Equal ==> iff as Partition_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. + rewrite <- Hm2, <- Hm3. + split; intros (H,H'); split; auto; intros. + - rewrite <- Hm1, <- Hm2, <- Hm3; auto. + - rewrite Hm1, Hm2, Hm3; auto. + Qed. + + Add Parametric Morphism elt : (@update elt) + with signature Equal ==> Equal ==> Equal as update_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (update m1 m2) with (update m1' m2); unfold update. + - apply fold_Equal with (eqA:=Equal); auto. + + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. + + intros k k' e e' i Hneq x. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + - apply fold_init with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. + Qed. + + Add Parametric Morphism elt : (@restrict elt) + with signature Equal ==> Equal ==> Equal as restrict_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (restrict m1 m2) with (restrict m1' m2); + unfold restrict, filter. + - apply fold_rel with (R:=Equal); try red; auto. + intros k e i i' H Hii' x. + pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *) + destruct mem; rewrite Hii'; auto. + - apply fold_Equal with (eqA:=Equal); auto. + + intros k k' Hk e e' He m m' Hm; simpl in *. + pattern (mem k m2); rewrite Hk. (* idem *) + destruct mem; rewrite ?Hk,?He,Hm; red; auto. + + intros k k' e e' i Hneq x. + case_eq (mem k m2); case_eq (mem k' m2); intros; auto. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + Qed. + + Add Parametric Morphism elt : (@diff elt) + with signature Equal ==> Equal ==> Equal as diff_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (diff m1 m2) with (diff m1' m2); + unfold diff, filter. + - apply fold_rel with (R:=Equal); try red; auto. + intros k e i i' H Hii' x. + pattern (mem k m2); rewrite Hm2. (* idem *) + destruct mem; simpl; rewrite Hii'; auto. + - apply fold_Equal with (eqA:=Equal); auto. + + intros k k' Hk e e' He m m' Hm; simpl in *. + pattern (mem k m2); rewrite Hk. (* idem *) + destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto. + + intros k k' e e' i Hneq x. + case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. Qed. - Lemma restrict_mapsto_iff : forall m m' k e, - MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. - Proof. - intros m m' k e. - unfold restrict. - rewrite filter_iff. - - intuition. - - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma restrict_in_iff : forall m m' k, - In k (restrict m m') <-> In k m /\ In k m'. - Proof. - intros m m' k. split. - - intros (e,H); rewrite restrict_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - - intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. - Qed. - - (** specialized versions analyzing only keys (resp. elements) *) - - Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). - Definition filter_range (f : elt -> bool) := filter (fun _ => f). - Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). - Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). - Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). - Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). - Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). - Definition partition_range (f : elt -> bool) := partition (fun _ => f). - - End Elt. - - Add Parametric Morphism elt : (@cardinal elt) - with signature Equal ==> eq as cardinal_m. - Proof. intros; apply Equal_cardinal; auto. Qed. - - Add Parametric Morphism elt : (@Disjoint elt) - with signature Equal ==> Equal ==> iff as Disjoint_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. - - rewrite <- Hm1, <- Hm2; auto. - - rewrite Hm1, Hm2; auto. - Qed. - - Add Parametric Morphism elt : (@Partition elt) - with signature Equal ==> Equal ==> Equal ==> iff as Partition_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. - rewrite <- Hm2, <- Hm3. - split; intros (H,H'); split; auto; intros. - - rewrite <- Hm1, <- Hm2, <- Hm3; auto. - - rewrite Hm1, Hm2, Hm3; auto. - Qed. - - Add Parametric Morphism elt : (@update elt) - with signature Equal ==> Equal ==> Equal as update_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - setoid_replace (update m1 m2) with (update m1' m2); unfold update. - - apply fold_Equal with (eqA:=Equal); auto. - + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. - + intros k k' e e' i Hneq x. - rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. - - apply fold_init with (eqA:=Equal); auto. - intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. - Qed. - - Add Parametric Morphism elt : (@restrict elt) - with signature Equal ==> Equal ==> Equal as restrict_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - setoid_replace (restrict m1 m2) with (restrict m1' m2); - unfold restrict, filter. - - apply fold_rel with (R:=Equal); try red; auto. - intros k e i i' H Hii' x. - pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *) - destruct mem; rewrite Hii'; auto. - - apply fold_Equal with (eqA:=Equal); auto. - + intros k k' Hk e e' He m m' Hm; simpl in *. - pattern (mem k m2); rewrite Hk. (* idem *) - destruct mem; rewrite ?Hk,?He,Hm; red; auto. - + intros k k' e e' i Hneq x. - case_eq (mem k m2); case_eq (mem k' m2); intros; auto. - rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. - Qed. - - Add Parametric Morphism elt : (@diff elt) - with signature Equal ==> Equal ==> Equal as diff_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - setoid_replace (diff m1 m2) with (diff m1' m2); - unfold diff, filter. - - apply fold_rel with (R:=Equal); try red; auto. - intros k e i i' H Hii' x. - pattern (mem k m2); rewrite Hm2. (* idem *) - destruct mem; simpl; rewrite Hii'; auto. - - apply fold_Equal with (eqA:=Equal); auto. - + intros k k' Hk e e' He m m' Hm; simpl in *. - pattern (mem k m2); rewrite Hk. (* idem *) - destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto. - + intros k k' e e' i Hneq x. - case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto. - rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. - Qed. - End WProperties_fun. (** * Same Properties for self-contained weak maps and for full maps *) @@ -1853,445 +1853,445 @@ Module Properties := WProperties. (** * Properties specific to maps with ordered keys *) Module OrdProperties (M:S). - Module Import ME := OrderedTypeFacts M.E. - Module Import O:=KeyOrderedType M.E. - Module Import P:=Properties M. - Import F. - Import M. - - Section Elt. - Variable elt:Type. - - Notation eqke := (@eqke elt). - Notation eqk := (@eqk elt). - Notation ltk := (@ltk elt). - Notation cardinal := (@cardinal elt). - Notation Equal := (@Equal elt). - Notation Add := (@Add elt). - - Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. - Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. - - Section Elements. - - Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), - sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. - Proof. - apply SortA_equivlistA_eqlistA; auto with typeclass_instances. - Qed. - - Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. - - Definition gtb (p p':key*elt) := - match E.compare (fst p) (fst p') with GT _ => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). - - Definition elements_lt p m := List.filter (gtb p) (elements m). - Definition elements_ge p m := List.filter (leb p) (elements m). - - Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. - Proof. - intros (x,e) (y,e'); unfold gtb, O.ltk; simpl. - destruct (E.compare x y); intuition; try discriminate; ME.order. - Qed. - - Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. - Proof. - intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl. - destruct (E.compare x y); intuition; try discriminate; ME.order. - Qed. - - Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p). - Proof. - red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); - destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. - - unfold O.ltk in *; simpl in *; intros. - symmetry; rewrite H2. - apply ME.eq_lt with a; auto with ordered_type. - rewrite <- H1; auto. - - unfold O.ltk in *; simpl in *; intros. - rewrite H1. - apply ME.eq_lt with b; auto. - rewrite <- H2; auto. - Qed. - - Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p). - Proof. - red; intros x a b H. - unfold leb; f_equal; apply gtb_compat; auto. - Qed. - - #[local] - Hint Resolve gtb_compat leb_compat elements_3 : map. - - Lemma elements_split : forall p m, - elements m = elements_lt p m ++ elements_ge p m. - Proof. - unfold elements_lt, elements_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk). - 1-3: auto with typeclass_instances. - 2: auto with map. - intros; destruct x; destruct y; destruct p. - rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. - assert (~ltk (t1,e0) (k,e1)). - - unfold gtb, O.ltk in *; simpl in *. - destruct (E.compare k t1); intuition; try discriminate; ME.order. - - unfold O.ltk in *; simpl in *; ME.order. - Qed. - - Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (elements m') - (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). - Proof. - intros; unfold elements_lt, elements_ge. - apply sort_equivlistA_eqlistA. - - auto with map. - - apply (@SortA_app _ eqke). - + auto with typeclass_instances. - + apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. - + constructor; auto with map. - * apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. - * rewrite (@InfA_alt _ eqke). 2-4: auto with typeclass_instances. - -- intros. - rewrite filter_InA in H1 by auto with map. destruct H1. - rewrite leb_1 in H2. - destruct y; unfold O.ltk in *; simpl in *. - rewrite <- elements_mapsto_iff in H1. - assert (~E.eq x t0). - ++ contradict H. - exists e0; apply MapsTo_1 with t0; auto with ordered_type. - ++ ME.order. - -- apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. - + intros. - rewrite filter_InA in H1 by auto with map. destruct H1. - rewrite gtb_1 in H3. - destruct y; destruct x0; unfold O.ltk in *; simpl in *. - inversion_clear H2. - * red in H4; simpl in *; destruct H4. - ME.order. - * rewrite filter_InA in H4 by auto with map. destruct H4. - rewrite leb_1 in H4. - unfold O.ltk in *; simpl in *; ME.order. - - red; intros a; destruct a. - rewrite InA_app_iff, InA_cons, 2 filter_InA, - <-2 elements_mapsto_iff, leb_1, gtb_1, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by auto with map. - unfold O.eqke, O.ltk; simpl. - destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto with ordered_type. - + elim H; exists e0; apply MapsTo_1 with t0; auto. - + fold (~E.lt t0 x); auto with ordered_type. - Qed. - - Lemma elements_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> - eqlistA eqke (elements m') (elements m ++ (x,e)::nil). - Proof. - intros. - apply sort_equivlistA_eqlistA. - - auto with map. - - apply (@SortA_app _ eqke). - + auto with typeclass_instances. - + auto with map. - + auto. - + intros. - inversion_clear H2. - * destruct x0; destruct y. - rewrite <- elements_mapsto_iff in H1. - unfold O.eqke, O.ltk in *; simpl in *; destruct H3. - apply ME.lt_eq with x; auto with ordered_type. - apply H; firstorder. - * inversion H3. - - red; intros a; destruct a. - rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff. - unfold O.eqke; simpl. intuition auto with relations. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m). - + exists e0; auto. - + generalize (H t0 H1). - ME.order. - Qed. - - Lemma elements_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> - eqlistA eqke (elements m') ((x,e)::elements m). - Proof. - intros. - apply sort_equivlistA_eqlistA. - - auto with map. - - change (sort ltk (((x,e)::nil) ++ elements m)). - apply (@SortA_app _ eqke). - + auto with typeclass_instances. - + auto. - + auto with map. - + intros. - inversion_clear H1. - * destruct y; destruct x0. - rewrite <- elements_mapsto_iff in H2. - unfold O.eqke, O.ltk in *; simpl in *; destruct H3. - apply ME.eq_lt with x; auto. - apply H; firstorder. - * inversion H3. - - red; intros a; destruct a. - rewrite InA_cons, <- 2 elements_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff. - unfold O.eqke; simpl. intuition auto with relations. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by - (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma elements_Equal_eqlistA : forall (m m': t elt), - Equal m m' -> eqlistA eqke (elements m) (elements m'). - Proof. - intros. - apply sort_equivlistA_eqlistA. 1-2: auto with map. - red; intros. - destruct x; do 2 rewrite <- elements_mapsto_iff. - do 2 rewrite find_mapsto_iff; rewrite H; split; auto. - Qed. - - End Elements. - - Section Min_Max_Elt. - - (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None - | (x,e)::nil => Some (x,e) - | (x,e)::l => max_elt_aux l - end. - Definition max_elt m := max_elt_aux (elements m). - - Lemma max_elt_Above : - forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). - Proof. - red; intros. - rewrite remove_in_iff in H0. - destruct H0. - rewrite elements_in_iff in H1. - destruct H1. - unfold max_elt in *. - generalize (elements_3 m). - revert x e H y x0 H0 H1. - induction (elements m). - - simpl; intros; try discriminate. - - intros. - destruct a; destruct l; simpl in *. - + injection H as [= -> ->]. - inversion_clear H1. - * red in H; simpl in *; intuition. - elim H0; eauto with ordered_type. - * inversion H. - + change (max_elt_aux (p::l) = Some (x,e)) in H. - generalize (IHl x e H); clear IHl; intros IHl. - inversion_clear H1; [ | inversion_clear H2; eauto ]. - red in H3; simpl in H3; destruct H3. - destruct p as (p1,p2). - destruct (E.eq_dec p1 x) as [Heq|Hneq]. - * apply ME.lt_eq with p1; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - * apply E.lt_trans with p1; auto. - -- inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - -- eapply IHl; eauto with ordered_type. - ++ econstructor; eauto. - red; eauto with ordered_type. - ++ inversion H2; auto. - Qed. - - Lemma max_elt_MapsTo : - forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold max_elt in *. - rewrite elements_mapsto_iff. - induction (elements m). - - simpl; try discriminate. - - destruct a; destruct l; simpl in *. - + injection H; intros; subst; constructor; red; auto with ordered_type. - + constructor 2; auto. - Qed. - - Lemma max_elt_Empty : - forall m, max_elt m = None -> Empty m. - Proof. - intros. - unfold max_elt in *. - rewrite elements_Empty. - induction (elements m); auto. - destruct a; destruct l; simpl in *; try discriminate. - assert (H':=IHl H); discriminate. - Qed. - - Definition min_elt m : option (key*elt) := match elements m with - | nil => None - | (x,e)::_ => Some (x,e) - end. - - Lemma min_elt_Below : - forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). - Proof. - unfold min_elt, Below; intros. - rewrite remove_in_iff in H0; destruct H0. - rewrite elements_in_iff in H1. - destruct H1. - generalize (elements_3 m). - destruct (elements m). - - try discriminate. - - destruct p; injection H as [= -> ->]; intros H4. - inversion_clear H1 as [? ? H2|? ? H2]. - + red in H2; destruct H2; simpl in *; ME.order. - + inversion_clear H4. rename H1 into H3. - rewrite (@InfA_alt _ eqke) in H3 by auto with typeclass_instances. - apply (H3 (y,x0)); auto. - Qed. - - Lemma min_elt_MapsTo : - forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold min_elt in *. - rewrite elements_mapsto_iff. - destruct (elements m). - - simpl; try discriminate. - - destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto with ordered_type. - Qed. - - Lemma min_elt_Empty : - forall m, min_elt m = None -> Empty m. - Proof. - intros. - unfold min_elt in *. - rewrite elements_Empty. - destruct (elements m); auto. - destruct p; simpl in *; discriminate. - Qed. - - End Min_Max_Elt. - - Section Induction_Principles. - - Lemma map_induction_max : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - - apply X; apply cardinal_inv_1; auto. - - - case_eq (max_elt m); intros. - + destruct p. - assert (Add k e (remove k m) m). - * red; intros. - rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. - apply find_1; apply MapsTo_1 with k; auto. - apply max_elt_MapsTo; auto. - * apply X0 with (remove k m) k e; auto with map. - -- apply IHn. - assert (S n = S (cardinal (remove k m))). - ++ rewrite Heqn. - eapply cardinal_2; eauto with map ordered_type. - ++ inversion H1; auto. - -- eapply max_elt_Above; eauto. - - + apply X; apply max_elt_Empty; auto. - Qed. - - Lemma map_induction_min : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - - apply X; apply cardinal_inv_1; auto. - - - case_eq (min_elt m); intros. - + destruct p. - assert (Add k e (remove k m) m). - * red; intros. - rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. - apply find_1; apply MapsTo_1 with k; auto. - apply min_elt_MapsTo; auto. - * apply X0 with (remove k m) k e; auto. - -- apply IHn. - assert (S n = S (cardinal (remove k m))). - ++ rewrite Heqn. - eapply cardinal_2; eauto with map ordered_type. - ++ inversion H1; auto. - -- eapply min_elt_Below; eauto. - - + apply X; apply min_elt_Empty; auto. - Qed. - - End Induction_Principles. - - Section Fold_properties. - - (** The following lemma has already been proved on Weak Maps, + Module Import ME := OrderedTypeFacts M.E. + Module Import O:=KeyOrderedType M.E. + Module Import P:=Properties M. + Import F. + Import M. + + Section Elt. + Variable elt:Type. + + Notation eqke := (@eqke elt). + Notation eqk := (@eqk elt). + Notation ltk := (@ltk elt). + Notation cardinal := (@cardinal elt). + Notation Equal := (@Equal elt). + Notation Add := (@Add elt). + + Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. + Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. + + Section Elements. + + Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), + sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. + Proof. + apply SortA_equivlistA_eqlistA; auto with typeclass_instances. + Qed. + + Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. + + Definition gtb (p p':key*elt) := + match E.compare (fst p) (fst p') with GT _ => true | _ => false end. + Definition leb p := fun p' => negb (gtb p p'). + + Definition elements_lt p m := List.filter (gtb p) (elements m). + Definition elements_ge p m := List.filter (leb p) (elements m). + + Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. + Proof. + intros (x,e) (y,e'); unfold gtb, O.ltk; simpl. + destruct (E.compare x y); intuition; try discriminate; ME.order. + Qed. + + Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. + Proof. + intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl. + destruct (E.compare x y); intuition; try discriminate; ME.order. + Qed. + + Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p). + Proof. + red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. + generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); + destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. + - unfold O.ltk in *; simpl in *; intros. + symmetry; rewrite H2. + apply ME.eq_lt with a; auto with ordered_type. + rewrite <- H1; auto. + - unfold O.ltk in *; simpl in *; intros. + rewrite H1. + apply ME.eq_lt with b; auto. + rewrite <- H2; auto. + Qed. + + Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p). + Proof. + red; intros x a b H. + unfold leb; f_equal; apply gtb_compat; auto. + Qed. + + #[local] + Hint Resolve gtb_compat leb_compat elements_3 : map. + + Lemma elements_split : forall p m, + elements m = elements_lt p m ++ elements_ge p m. + Proof. + unfold elements_lt, elements_ge, leb; intros. + apply filter_split with (eqA:=eqk) (ltA:=ltk). + 1-3: auto with typeclass_instances. + 2: auto with map. + intros; destruct x; destruct y; destruct p. + rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. + assert (~ltk (t1,e0) (k,e1)). + - unfold gtb, O.ltk in *; simpl in *. + destruct (E.compare k t1); intuition; try discriminate; ME.order. + - unfold O.ltk in *; simpl in *; ME.order. + Qed. + + Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> + eqlistA eqke (elements m') + (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). + Proof. + intros; unfold elements_lt, elements_ge. + apply sort_equivlistA_eqlistA. + - auto with map. + - apply (@SortA_app _ eqke). + + auto with typeclass_instances. + + apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. + + constructor; auto with map. + * apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. + * rewrite (@InfA_alt _ eqke). 2-4: auto with typeclass_instances. + -- intros. + rewrite filter_InA in H1 by auto with map. destruct H1. + rewrite leb_1 in H2. + destruct y; unfold O.ltk in *; simpl in *. + rewrite <- elements_mapsto_iff in H1. + assert (~E.eq x t0). + ++ contradict H. + exists e0; apply MapsTo_1 with t0; auto with ordered_type. + ++ ME.order. + -- apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. + + intros. + rewrite filter_InA in H1 by auto with map. destruct H1. + rewrite gtb_1 in H3. + destruct y; destruct x0; unfold O.ltk in *; simpl in *. + inversion_clear H2. + * red in H4; simpl in *; destruct H4. + ME.order. + * rewrite filter_InA in H4 by auto with map. destruct H4. + rewrite leb_1 in H4. + unfold O.ltk in *; simpl in *; ME.order. + - red; intros a; destruct a. + rewrite InA_app_iff, InA_cons, 2 filter_InA, + <-2 elements_mapsto_iff, leb_1, gtb_1, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by auto with map. + unfold O.eqke, O.ltk; simpl. + destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto with ordered_type. + + elim H; exists e0; apply MapsTo_1 with t0; auto. + + fold (~E.lt t0 x); auto with ordered_type. + Qed. + + Lemma elements_Add_Above : forall m m' x e, + Above x m -> Add x e m m' -> + eqlistA eqke (elements m') (elements m ++ (x,e)::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA. + - auto with map. + - apply (@SortA_app _ eqke). + + auto with typeclass_instances. + + auto with map. + + auto. + + intros. + inversion_clear H2. + * destruct x0; destruct y. + rewrite <- elements_mapsto_iff in H1. + unfold O.eqke, O.ltk in *; simpl in *; destruct H3. + apply ME.lt_eq with x; auto with ordered_type. + apply H; firstorder. + * inversion H3. + - red; intros a; destruct a. + rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff. + unfold O.eqke; simpl. intuition auto with relations. + destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. + exfalso. + assert (In t0 m). + + exists e0; auto. + + generalize (H t0 H1). + ME.order. + Qed. + + Lemma elements_Add_Below : forall m m' x e, + Below x m -> Add x e m m' -> + eqlistA eqke (elements m') ((x,e)::elements m). + Proof. + intros. + apply sort_equivlistA_eqlistA. + - auto with map. + - change (sort ltk (((x,e)::nil) ++ elements m)). + apply (@SortA_app _ eqke). + + auto with typeclass_instances. + + auto. + + auto with map. + + intros. + inversion_clear H1. + * destruct y; destruct x0. + rewrite <- elements_mapsto_iff in H2. + unfold O.eqke, O.ltk in *; simpl in *; destruct H3. + apply ME.eq_lt with x; auto. + apply H; firstorder. + * inversion H3. + - red; intros a; destruct a. + rewrite InA_cons, <- 2 elements_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff. + unfold O.eqke; simpl. intuition auto with relations. + destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. + exfalso. + assert (In t0 m) by + (exists e0; auto). + generalize (H t0 H1). + ME.order. + Qed. + + Lemma elements_Equal_eqlistA : forall (m m': t elt), + Equal m m' -> eqlistA eqke (elements m) (elements m'). + Proof. + intros. + apply sort_equivlistA_eqlistA. 1-2: auto with map. + red; intros. + destruct x; do 2 rewrite <- elements_mapsto_iff. + do 2 rewrite find_mapsto_iff; rewrite H; split; auto. + Qed. + + End Elements. + + Section Min_Max_Elt. + + (** We emulate two [max_elt] and [min_elt] functions. *) + + Fixpoint max_elt_aux (l:list (key*elt)) := match l with + | nil => None + | (x,e)::nil => Some (x,e) + | (x,e)::l => max_elt_aux l + end. + Definition max_elt m := max_elt_aux (elements m). + + Lemma max_elt_Above : + forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). + Proof. + red; intros. + rewrite remove_in_iff in H0. + destruct H0. + rewrite elements_in_iff in H1. + destruct H1. + unfold max_elt in *. + generalize (elements_3 m). + revert x e H y x0 H0 H1. + induction (elements m). + - simpl; intros; try discriminate. + - intros. + destruct a; destruct l; simpl in *. + + injection H as [= -> ->]. + inversion_clear H1. + * red in H; simpl in *; intuition. + elim H0; eauto with ordered_type. + * inversion H. + + change (max_elt_aux (p::l) = Some (x,e)) in H. + generalize (IHl x e H); clear IHl; intros IHl. + inversion_clear H1; [ | inversion_clear H2; eauto ]. + red in H3; simpl in H3; destruct H3. + destruct p as (p1,p2). + destruct (E.eq_dec p1 x) as [Heq|Hneq]. + * apply ME.lt_eq with p1; auto. + inversion_clear H2. + inversion_clear H5. + red in H2; simpl in H2; ME.order. + * apply E.lt_trans with p1; auto. + -- inversion_clear H2. + inversion_clear H5. + red in H2; simpl in H2; ME.order. + -- eapply IHl; eauto with ordered_type. + ++ econstructor; eauto. + red; eauto with ordered_type. + ++ inversion H2; auto. + Qed. + + Lemma max_elt_MapsTo : + forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. + Proof. + intros. + unfold max_elt in *. + rewrite elements_mapsto_iff. + induction (elements m). + - simpl; try discriminate. + - destruct a; destruct l; simpl in *. + + injection H; intros; subst; constructor; red; auto with ordered_type. + + constructor 2; auto. + Qed. + + Lemma max_elt_Empty : + forall m, max_elt m = None -> Empty m. + Proof. + intros. + unfold max_elt in *. + rewrite elements_Empty. + induction (elements m); auto. + destruct a; destruct l; simpl in *; try discriminate. + assert (H':=IHl H); discriminate. + Qed. + + Definition min_elt m : option (key*elt) := match elements m with + | nil => None + | (x,e)::_ => Some (x,e) + end. + + Lemma min_elt_Below : + forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). + Proof. + unfold min_elt, Below; intros. + rewrite remove_in_iff in H0; destruct H0. + rewrite elements_in_iff in H1. + destruct H1. + generalize (elements_3 m). + destruct (elements m). + - try discriminate. + - destruct p; injection H as [= -> ->]; intros H4. + inversion_clear H1 as [? ? H2|? ? H2]. + + red in H2; destruct H2; simpl in *; ME.order. + + inversion_clear H4. rename H1 into H3. + rewrite (@InfA_alt _ eqke) in H3 by auto with typeclass_instances. + apply (H3 (y,x0)); auto. + Qed. + + Lemma min_elt_MapsTo : + forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. + Proof. + intros. + unfold min_elt in *. + rewrite elements_mapsto_iff. + destruct (elements m). + - simpl; try discriminate. + - destruct p; simpl in *. + injection H; intros; subst; constructor; red; auto with ordered_type. + Qed. + + Lemma min_elt_Empty : + forall m, min_elt m = None -> Empty m. + Proof. + intros. + unfold min_elt in *. + rewrite elements_Empty. + destruct (elements m); auto. + destruct p; simpl in *; discriminate. + Qed. + + End Min_Max_Elt. + + Section Induction_Principles. + + Lemma map_induction_max : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + - apply X; apply cardinal_inv_1; auto. + + - case_eq (max_elt m); intros. + + destruct p. + assert (Add k e (remove k m) m). + * red; intros. + rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. + apply find_1; apply MapsTo_1 with k; auto. + apply max_elt_MapsTo; auto. + * apply X0 with (remove k m) k e; auto with map. + -- apply IHn. + assert (S n = S (cardinal (remove k m))). + ++ rewrite Heqn. + eapply cardinal_2; eauto with map ordered_type. + ++ inversion H1; auto. + -- eapply max_elt_Above; eauto. + + + apply X; apply max_elt_Empty; auto. + Qed. + + Lemma map_induction_min : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + - apply X; apply cardinal_inv_1; auto. + + - case_eq (min_elt m); intros. + + destruct p. + assert (Add k e (remove k m) m). + * red; intros. + rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. + apply find_1; apply MapsTo_1 with k; auto. + apply min_elt_MapsTo; auto. + * apply X0 with (remove k m) k e; auto. + -- apply IHn. + assert (S n = S (cardinal (remove k m))). + ++ rewrite Heqn. + eapply cardinal_2; eauto with map ordered_type. + ++ inversion H1; auto. + -- eapply min_elt_Below; eauto. + + + apply X; apply min_elt_Empty; auto. + Qed. + + End Induction_Principles. + + Section Fold_properties. + + (** The following lemma has already been proved on Weak Maps, but with one additional hypothesis (some [transpose] fact). *) - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros m1 m2 A eqA st f i Hf Heq. - rewrite 2 fold_spec_right. - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - - intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. - - apply eqlistA_rev. apply elements_Equal_eqlistA. auto. - Qed. - - Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Above x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). - - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. - + apply eqlistA_rev. - apply elements_Add_Above; auto. - - rewrite distr_rev; simpl. - reflexivity. - Qed. - - Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Below x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (fold f m1 (f x e i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). - - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. - + apply eqlistA_rev. - simpl; apply elements_Add_Below; auto. - - rewrite distr_rev; simpl. - rewrite fold_right_app. - reflexivity. - Qed. - - End Fold_properties. - - End Elt. + Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Proper (E.eq==>eq==>eqA==>eqA) f -> + Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). + Proof. + intros m1 m2 A eqA st f i Hf Heq. + rewrite 2 fold_spec_right. + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + - intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. + - apply eqlistA_rev. apply elements_Equal_eqlistA. auto. + Qed. + + Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), + Above x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (f x e (fold f m1 i)). + Proof. + intros. rewrite 2 fold_spec_right. set (f':=uncurry f). + transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). + - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. + + apply eqlistA_rev. + apply elements_Add_Above; auto. + - rewrite distr_rev; simpl. + reflexivity. + Qed. + + Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), + Below x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (fold f m1 (f x e i)). + Proof. + intros. rewrite 2 fold_spec_right. set (f':=uncurry f). + transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). + - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. + + apply eqlistA_rev. + simpl; apply elements_Add_Below; auto. + - rewrite distr_rev; simpl. + rewrite fold_right_app. + reflexivity. + Qed. + + End Fold_properties. + + End Elt. End OrdProperties. diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index 59ffeda0c7..fe7bbde954 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -130,69 +130,69 @@ Module Type WSfun (E : DecidableType). Section Spec. - Variable m m' m'' : t elt. - Variable x y z : key. - Variable e e' : elt. + Variable m m' m'' : t elt. + Variable x y z : key. + Variable e e' : elt. - Parameter MapsTo : key -> elt -> t elt -> Prop. + Parameter MapsTo : key -> elt -> t elt -> Prop. - Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. + Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. - Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. - Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). + Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). - Definition eq_key_elt (p p':key*elt) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). + Definition eq_key_elt (p p':key*elt) := + E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - (** Specification of [MapsTo] *) - Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. + (** Specification of [MapsTo] *) + Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - (** Specification of [mem] *) - Parameter mem_1 : In x m -> mem x m = true. - Parameter mem_2 : mem x m = true -> In x m. + (** Specification of [mem] *) + Parameter mem_1 : In x m -> mem x m = true. + Parameter mem_2 : mem x m = true -> In x m. - (** Specification of [empty] *) - Parameter empty_1 : Empty empty. + (** Specification of [empty] *) + Parameter empty_1 : Empty empty. - (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty m -> is_empty m = true. - Parameter is_empty_2 : is_empty m = true -> Empty m. + (** Specification of [is_empty] *) + Parameter is_empty_1 : Empty m -> is_empty m = true. + Parameter is_empty_2 : is_empty m = true -> Empty m. - (** Specification of [add] *) - Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). - Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + (** Specification of [add] *) + Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). + Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - (** Specification of [remove] *) - Parameter remove_1 : E.eq x y -> ~ In y (remove x m). - Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. + (** Specification of [remove] *) + Parameter remove_1 : E.eq x y -> ~ In y (remove x m). + Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - (** Specification of [find] *) - Parameter find_1 : MapsTo x e m -> find x m = Some e. - Parameter find_2 : find x m = Some e -> MapsTo x e m. + (** Specification of [find] *) + Parameter find_1 : MapsTo x e m -> find x m = Some e. + Parameter find_2 : find x m = Some e -> MapsTo x e m. - (** Specification of [elements] *) - Parameter elements_1 : - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Parameter elements_2 : - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - (** When compared with ordered maps, here comes the only + (** Specification of [elements] *) + Parameter elements_1 : + MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Parameter elements_2 : + InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + (** When compared with ordered maps, here comes the only property that is really weaker: *) - Parameter elements_3w : NoDupA eq_key (elements m). + Parameter elements_3w : NoDupA eq_key (elements m). - (** Specification of [cardinal] *) - Parameter cardinal_1 : cardinal m = length (elements m). + (** Specification of [cardinal] *) + Parameter cardinal_1 : cardinal m = length (elements m). - (** Specification of [fold] *) - Parameter fold_1 : - forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + (** Specification of [fold] *) + Parameter fold_1 : + forall (A : Type) (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - (** Equality of maps *) + (** Equality of maps *) - (** Caveat: there are at least three distinct equality predicates on maps. + (** Caveat: there are at least three distinct equality predicates on maps. - The simplest (and maybe most natural) way is to consider keys up to their equivalence [E.eq], but elements up to Leibniz equality, in the spirit of [eq_key_elt] above. This leads to predicate [Equal]. @@ -205,21 +205,21 @@ Module Type WSfun (E : DecidableType). it can be generalized in a [Equiv] expecting a more general (possibly non-decidable) equality predicate on elements *) - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). - (** Specification of [equal] *) + (** Specification of [equal] *) - Variable cmp : elt -> elt -> bool. + Variable cmp : elt -> elt -> bool. - Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. - Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. + Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. + Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. End Spec. - End Types. + End Types. (** Specification of [map] *) Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), @@ -272,11 +272,11 @@ End WS. Module Type Sfun (E : OrderedType). Include WSfun E. Section elt. - Variable elt:Type. - Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). - (* Additional specification of [elements] *) - Parameter elements_3 : forall m, sort lt_key (elements m). - (** Remark: since [fold] is specified via [elements], this stronger + Variable elt:Type. + Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). + (* Additional specification of [elements] *) + Parameter elements_3 : forall m, sort lt_key (elements m). + (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) End elt. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index fd2a6e3edd..68b128b246 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -21,1279 +21,1279 @@ Unset Strict Implicit. Module Raw (X:OrderedType). -Module Import MX := OrderedTypeFacts X. -Module Import PX := KeyOrderedType X. - -Definition key := X.t. -Definition t (elt:Type) := list (X.t * elt). - -Section Elt. -Variable elt : Type. - -Notation eqk := (eqk (elt:=elt)). -Notation eqke := (eqke (elt:=elt)). -Notation ltk := (ltk (elt:=elt)). -Notation MapsTo := (MapsTo (elt:=elt)). -Notation In := (In (elt:=elt)). -Notation Sort := (sort ltk). -Notation Inf := (lelistA (ltk)). - -(** * [empty] *) - -Definition empty : t elt := nil. - -Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. - -Lemma empty_1 : Empty empty. -Proof. - unfold Empty,empty. - intros a e. - intro abs. - inversion abs. -Qed. -#[local] -Hint Resolve empty_1 : core. - -Lemma empty_sorted : Sort empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. -Proof. - unfold Empty, PX.MapsTo. - intros m. - case m;auto. - intros (k,e) l inlist. - absurd (InA eqke (k, e) ((k, e) :: l)); auto with ordered_type. -Qed. - -Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. - intros m. - case m;auto. - intros p l abs. - inversion abs. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) {struct s} : bool := - match s with - | nil => false - | (k',_) :: l => - match X.compare k k' with - | LT _ => false - | EQ _ => true - | GT _ => mem k l - end - end. - -Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. -Proof. - intros m Hm; induction m as [|[a m]]; intros x H; simpl in *. - - destruct H as [? H]; inversion H. - - apply In_inv in H; destruct H as [H|H]. - + destruct (elim_compare_eq H) as [? Hr]; rewrite Hr; reflexivity. - + destruct (X.compare x a); [|reflexivity|apply IHm; inversion_clear Hm; auto]. - absurd (In x ((a, m) :: m0)); [|destruct H as [y v]; exists y; constructor 2; auto]. - apply Sort_Inf_NotIn with m; [inversion_clear Hm; auto|]. - constructor; apply l. -Qed. - -Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. -Proof. - intros m Hm; induction m as [|[a m]]; intros x H; simpl in *. - - discriminate. - - destruct X.compare; [discriminate| |]. - + exists m; apply InA_cons_hd; split; auto. - + inversion_clear Hm; destruct IHm with x as [e He]; auto. - exists e; apply InA_cons_tl; auto. -Qed. - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) {struct s} : option elt := - match s with - | nil => None - | (k',x)::s' => - match X.compare k k' with - | LT _ => None - | EQ _ => Some x - | GT _ => find k s' - end - end. - -Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. - induction m as [|[a m]]; intros x e H; simpl in *; [congruence|]. - destruct X.compare; [congruence| |]. - - apply InA_cons_hd; split; compute; congruence. - - apply InA_cons_tl; apply IHm; auto. -Qed. - -Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. -Proof. -intros m Hm; induction Hm as [|[a m] l Hm IHHm Hr]; intros x e H; simpl in *. -- inversion H. -- apply InA_cons in H; destruct H as [H|H]. - * unfold eqke in H; simpl in H. - destruct elim_compare_eq with x a as [H' r]; [tauto|]. - rewrite r; f_equal; symmetry; tauto. - * destruct elim_compare_gt with x a as [H' r]; [|rewrite r; apply IHHm, H]. - apply InA_eqke_eqk in H. - apply (Sort_Inf_In Hm Hr H). -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => - match X.compare k k' with - | LT _ => (k,x)::s - | EQ _ => (k,x)::l - | GT _ => (k',y) :: add k x l - end - end. - -Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. -intros m x y e; generalize y; clear y. -unfold PX.MapsTo. -induction m as [|[y e'] m IHm]; simpl. -- auto with ordered_type. -- intros; destruct X.compare; auto with ordered_type. -Qed. - -Lemma add_2 : forall m x y e e', - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. -intros m x y e e' He H; unfold PX.MapsTo in *. -induction m as [|[z e''] m IHm]; simpl. -- auto. -- destruct X.compare as [Hlt|Heq|Hgt]; simpl. - + auto with ordered_type. - + apply InA_cons_tl; apply InA_cons in H; destruct H; [|assumption]. - compute in H; intuition order. - + apply InA_cons in H; destruct H; [now auto with ordered_type|]. - apply InA_cons_tl; apply IHm, H. -Qed. - -Lemma add_3 : forall m x y e e', - ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. -intros m x y e e' He H; unfold PX.MapsTo in *. -induction m as [|[z e''] m IHm]; simpl in *. -- apply (In_inv_3 H); auto with ordered_type. -- destruct X.compare as [Hlt|Heq|Hgt]; simpl. - + apply (In_inv_3 H); auto with ordered_type. - + constructor 2; apply (In_inv_3 H); auto with ordered_type. - + inversion_clear H; auto. -Qed. - -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), - Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0,H1. - simpl; case (X.compare x x''); intuition. -Qed. -#[local] -Hint Resolve add_Inf : core. - -Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x',e'). - simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := - match s with - | nil => nil - | (k',x) :: l => - match X.compare k k' with - | LT _ => s - | EQ _ => l - | GT _ => (k',x) :: remove k l - end - end. - -Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). -Proof. -intros m Hm x y He [e H]; revert e H. -induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *; intros e H. -- now inversion H. -- destruct X.compare as [Hlt|Heq|Hgt]. - + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. - apply InA_eqke_eqk in H; apply (Sort_Inf_In Hm Hr) in H. - compute in H; order. - + apply InA_eqke_eqk in H; apply (Sort_Inf_In Hm Hr) in H. - compute in H; order. - + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. - apply (IHHm e), H. -Qed. - -Lemma remove_2 : forall m (Hm:Sort m) x y e, - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. -intros m Hm x y e He H. -induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *. -- now inversion H. -- destruct X.compare as [Hlt|Heq|Hgt]. - + assumption. - + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. - apply H. - + apply InA_cons in H; destruct H. - * apply InA_cons_hd; assumption. - * apply InA_cons_tl, IHHm, H. -Qed. - -Lemma remove_3 : forall m (Hm:Sort m) x y e, - MapsTo y e (remove x m) -> MapsTo y e m. -Proof. -intros m Hm x y e H. -induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *. -- now inversion H. -- destruct X.compare as [Hlt|Heq|Hgt]. - + assumption. - + apply InA_cons_tl, H. - + apply InA_cons in H; destruct H. - * apply InA_cons_hd; assumption. - * apply InA_cons_tl, IHHm, H. -Qed. - -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), - Inf (x',e') m -> Inf (x',e') (remove x m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0. - simpl; case (X.compare x x''); intuition. - inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. -Qed. -#[local] -Hint Resolve remove_Inf : core. - -Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x',e'). - simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. -Qed. - -(** * [elements] *) - -Definition elements (m: t elt) := m. - -Lemma elements_1 : forall m x e, - MapsTo x e m -> InA eqke (x,e) (elements m). -Proof. - auto. -Qed. - -Lemma elements_2 : forall m x e, - InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. - auto. -Qed. - -Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). -Proof. - auto. -Qed. - -Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). -Proof. - intros. - apply Sort_NoDupA. - apply elements_3; auto. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. -induction m as [|[k e] m]; simpl; auto. -Qed. - -(** * [equal] *) - -Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool := - match m, m' with - | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | EQ _ => cmp e e' && equal cmp l l' - | _ => false - end - | _, _ => false - end. - -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. -intros m Hm m' Hm' cmp; revert m' Hm'. -induction Hm as [|[a e] m Hm IHHm Hr]; simpl in *; intros [|[a' e'] m'] Hm' H. -+ reflexivity. -+ destruct H as [H _]; specialize (H a') as [_ H]. - destruct H; [exists e'; constructor; reflexivity|inversion H]. -+ destruct H as [H _]; specialize (H a) as [H _]. - destruct H; [exists e; constructor; reflexivity|inversion H]. -+ apply Sorted_inv in Hm'; destruct Hm' as [Hm' Hr']. - destruct (X.compare a a') as [Hlt|Heq|Hgt]; [exfalso| |exfalso]. - - destruct H as [H _]; specialize (H a) as [H _]. - destruct H as [e'' H]; [eexists; constructor; reflexivity|]. - apply InA_cons in H; destruct H as [H|H]. - * apply (gt_not_eq Hlt); symmetry; apply H. - * apply InA_eqke_eqk, (Sort_Inf_In Hm' Hr') in H. - compute in H; order. - - apply andb_true_iff; split. - * destruct H as [_ H]; apply H with a. - { apply InA_cons_hd; reflexivity. } - { apply InA_cons_hd; auto with ordered_type. } - * apply IHHm; [assumption|]; split. - { intros k; destruct H as [H _]; specialize (H k). - split; intros [e'' Hk]. - + destruct H as [H _]; destruct H as [e''' H]. - - exists e''; apply InA_cons_tl; apply Hk. - - apply InA_cons in H; destruct H as [[H _]|H]. - * assert (Hs := Sort_Inf_In Hm Hr (InA_eqke_eqk Hk)). - elim (gt_not_eq Hs); simpl; etransitivity; [eassumption|symmetry; assumption]. - * exists e'''; assumption. - + destruct H as [_ H]; destruct H as [e''' H]. - - exists e''; apply InA_cons_tl; apply Hk. - - apply InA_cons in H; destruct H as [[H _]|H]. - * assert (Hs := Sort_Inf_In Hm' Hr' (InA_eqke_eqk Hk)). - elim (gt_not_eq Hs); simpl; etransitivity; eassumption. - * exists e'''; assumption. - } - { intros; destruct H as [_ H]; apply H with k; apply InA_cons_tl; assumption. } - - destruct H as [H _]; specialize (H a') as [_ H]. - destruct H as [e'' H]; [eexists; constructor; reflexivity|]. - apply InA_cons in H; destruct H as [H|H]. - * apply (gt_not_eq Hgt); symmetry; apply H. - * apply InA_eqke_eqk, (Sort_Inf_In Hm Hr) in H. - compute in H; order. -Qed. - -Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, - equal cmp m m' = true -> Equivb cmp m m'. -Proof. -intros m Hm m' Hm' cmp; revert m' Hm'. -induction Hm as [|[a e] m Hm IHHm Hr]; simpl in *; intros [|[a' e'] m'] Hm' H; try congruence. -+ split; [tauto|inversion 1]. -+ destruct X.compare as [?|Heq|?]; try congruence. - apply Sorted_inv in Hm'; destruct Hm' as [Hm' Hr']. - apply andb_true_iff in H; destruct H as [Hc He]; split. - - intros k; split; intros [v Hk]; apply InA_cons in Hk; destruct Hk as [Hk|Hk]. - * exists e'; apply InA_cons_hd; split; [|reflexivity]. - transitivity a; [apply Hk|apply Heq]. - * assert (Hi : In k m'). - { apply (IHHm m' Hm' He); exists v; apply Hk. } - destruct Hi as [w Hw]; exists w; apply InA_cons_tl, Hw. - * exists e; apply InA_cons_hd; split; [|reflexivity]. - transitivity a'; [apply Hk|symmetry; apply Heq]. - * assert (Hi : In k m). - { apply (IHHm m' Hm' He); exists v; apply Hk. } - destruct Hi as [w Hw]; exists w; apply InA_cons_tl, Hw. - - intros k e1 e2 He1 He2. - apply InA_cons in He1, He2. - destruct He1 as [He1|He1]; destruct He2 as [He2|He2]. - * replace e1 with e by (symmetry; apply He1). - replace e2 with e' by (symmetry; apply He2). - apply Hc. - * assert (Hi : In k m). - { apply (IHHm m' Hm' He); exists e2; apply He2. } - destruct Hi as [w Hw]. - apply InA_eqke_eqk, (Sort_Inf_In Hm Hr) in Hw. - destruct He1 as [He1 _]. - elim (eq_not_gt He1); apply Hw. - * assert (Hi : In k m'). - { apply (IHHm m' Hm' He); exists e1; apply He1. } - destruct Hi as [w Hw]. - apply InA_eqke_eqk, (Sort_Inf_In Hm' Hr') in Hw. - destruct He2 as [He2 _]. - elim (eq_not_gt He2); apply Hw. - * destruct (IHHm m' Hm' He) as [_ IH]. - apply (IH k e1 e2 He1 He2). -Qed. - -(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) - -Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> - (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). -Proof. - intros. - inversion H; subst. - inversion H0; subst. - destruct x; destruct y; compute in H1, H2. - split; intros. - - apply equal_2; auto. - simpl. - elim_comp. - rewrite H2; simpl. - apply equal_1; auto. - - apply equal_2; auto. - generalize (equal_1 H H0 H3). - simpl. - elim_comp. - rewrite H2; simpl; auto. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work + Module Import MX := OrderedTypeFacts X. + Module Import PX := KeyOrderedType X. + + Definition key := X.t. + Definition t (elt:Type) := list (X.t * elt). + + Section Elt. + Variable elt : Type. + + Notation eqk := (eqk (elt:=elt)). + Notation eqke := (eqke (elt:=elt)). + Notation ltk := (ltk (elt:=elt)). + Notation MapsTo := (MapsTo (elt:=elt)). + Notation In := (In (elt:=elt)). + Notation Sort := (sort ltk). + Notation Inf := (lelistA (ltk)). + + (** * [empty] *) + + Definition empty : t elt := nil. + + Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + + Lemma empty_1 : Empty empty. + Proof. + unfold Empty,empty. + intros a e. + intro abs. + inversion abs. + Qed. + #[local] + Hint Resolve empty_1 : core. + + Lemma empty_sorted : Sort empty. + Proof. + unfold empty; auto. + Qed. + + (** * [is_empty] *) + + Definition is_empty (l : t elt) : bool := if l then true else false. + + Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. + Proof. + unfold Empty, PX.MapsTo. + intros m. + case m;auto. + intros (k,e) l inlist. + absurd (InA eqke (k, e) ((k, e) :: l)); auto with ordered_type. + Qed. + + Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. + Proof. + intros m. + case m;auto. + intros p l abs. + inversion abs. + Qed. + + (** * [mem] *) + + Fixpoint mem (k : key) (s : t elt) {struct s} : bool := + match s with + | nil => false + | (k',_) :: l => + match X.compare k k' with + | LT _ => false + | EQ _ => true + | GT _ => mem k l + end + end. + + Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. + Proof. + intros m Hm; induction m as [|[a m]]; intros x H; simpl in *. + - destruct H as [? H]; inversion H. + - apply In_inv in H; destruct H as [H|H]. + + destruct (elim_compare_eq H) as [? Hr]; rewrite Hr; reflexivity. + + destruct (X.compare x a); [|reflexivity|apply IHm; inversion_clear Hm; auto]. + absurd (In x ((a, m) :: m0)); [|destruct H as [y v]; exists y; constructor 2; auto]. + apply Sort_Inf_NotIn with m; [inversion_clear Hm; auto|]. + constructor; apply l. + Qed. + + Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. + Proof. + intros m Hm; induction m as [|[a m]]; intros x H; simpl in *. + - discriminate. + - destruct X.compare; [discriminate| |]. + + exists m; apply InA_cons_hd; split; auto. + + inversion_clear Hm; destruct IHm with x as [e He]; auto. + exists e; apply InA_cons_tl; auto. + Qed. + + (** * [find] *) + + Fixpoint find (k:key) (s: t elt) {struct s} : option elt := + match s with + | nil => None + | (k',x)::s' => + match X.compare k k' with + | LT _ => None + | EQ _ => Some x + | GT _ => find k s' + end + end. + + Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. + Proof. + induction m as [|[a m]]; intros x e H; simpl in *; [congruence|]. + destruct X.compare; [congruence| |]. + - apply InA_cons_hd; split; compute; congruence. + - apply InA_cons_tl; apply IHm; auto. + Qed. + + Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. + Proof. + intros m Hm; induction Hm as [|[a m] l Hm IHHm Hr]; intros x e H; simpl in *. + - inversion H. + - apply InA_cons in H; destruct H as [H|H]. + * unfold eqke in H; simpl in H. + destruct elim_compare_eq with x a as [H' r]; [tauto|]. + rewrite r; f_equal; symmetry; tauto. + * destruct elim_compare_gt with x a as [H' r]; [|rewrite r; apply IHHm, H]. + apply InA_eqke_eqk in H. + apply (Sort_Inf_In Hm Hr H). + Qed. + + (** * [add] *) + + Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => + match X.compare k k' with + | LT _ => (k,x)::s + | EQ _ => (k,x)::l + | GT _ => (k',y) :: add k x l + end + end. + + Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). + Proof. + intros m x y e; generalize y; clear y. + unfold PX.MapsTo. + induction m as [|[y e'] m IHm]; simpl. + - auto with ordered_type. + - intros; destruct X.compare; auto with ordered_type. + Qed. + + Lemma add_2 : forall m x y e e', + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Proof. + intros m x y e e' He H; unfold PX.MapsTo in *. + induction m as [|[z e''] m IHm]; simpl. + - auto. + - destruct X.compare as [Hlt|Heq|Hgt]; simpl. + + auto with ordered_type. + + apply InA_cons_tl; apply InA_cons in H; destruct H; [|assumption]. + compute in H; intuition order. + + apply InA_cons in H; destruct H; [now auto with ordered_type|]. + apply InA_cons_tl; apply IHm, H. + Qed. + + Lemma add_3 : forall m x y e e', + ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + Proof. + intros m x y e e' He H; unfold PX.MapsTo in *. + induction m as [|[z e''] m IHm]; simpl in *. + - apply (In_inv_3 H); auto with ordered_type. + - destruct X.compare as [Hlt|Heq|Hgt]; simpl. + + apply (In_inv_3 H); auto with ordered_type. + + constructor 2; apply (In_inv_3 H); auto with ordered_type. + + inversion_clear H; auto. + Qed. + + Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), + Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). + Proof. + induction m. + - simpl; intuition. + - intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0,H1. + simpl; case (X.compare x x''); intuition. + Qed. + #[local] + Hint Resolve add_Inf : core. + + Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). + Proof. + induction m. + - simpl; intuition. + - intros. + destruct a as (x',e'). + simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. + constructor; auto. + apply Inf_eq with (x',e'); auto. + Qed. + + (** * [remove] *) + + Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := + match s with + | nil => nil + | (k',x) :: l => + match X.compare k k' with + | LT _ => s + | EQ _ => l + | GT _ => (k',x) :: remove k l + end + end. + + Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). + Proof. + intros m Hm x y He [e H]; revert e H. + induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *; intros e H. + - now inversion H. + - destruct X.compare as [Hlt|Heq|Hgt]. + + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. + apply InA_eqke_eqk in H; apply (Sort_Inf_In Hm Hr) in H. + compute in H; order. + + apply InA_eqke_eqk in H; apply (Sort_Inf_In Hm Hr) in H. + compute in H; order. + + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. + apply (IHHm e), H. + Qed. + + Lemma remove_2 : forall m (Hm:Sort m) x y e, + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Proof. + intros m Hm x y e He H. + induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *. + - now inversion H. + - destruct X.compare as [Hlt|Heq|Hgt]. + + assumption. + + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. + apply H. + + apply InA_cons in H; destruct H. + * apply InA_cons_hd; assumption. + * apply InA_cons_tl, IHHm, H. + Qed. + + Lemma remove_3 : forall m (Hm:Sort m) x y e, + MapsTo y e (remove x m) -> MapsTo y e m. + Proof. + intros m Hm x y e H. + induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *. + - now inversion H. + - destruct X.compare as [Hlt|Heq|Hgt]. + + assumption. + + apply InA_cons_tl, H. + + apply InA_cons in H; destruct H. + * apply InA_cons_hd; assumption. + * apply InA_cons_tl, IHHm, H. + Qed. + + Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), + Inf (x',e') m -> Inf (x',e') (remove x m). + Proof. + induction m. + - simpl; intuition. + - intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0. + simpl; case (X.compare x x''); intuition. + inversion_clear Hm. + apply Inf_lt with (x'',e''); auto. + Qed. + #[local] + Hint Resolve remove_Inf : core. + + Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). + Proof. + induction m. + - simpl; intuition. + - intros. + destruct a as (x',e'). + simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. + Qed. + + (** * [elements] *) + + Definition elements (m: t elt) := m. + + Lemma elements_1 : forall m x e, + MapsTo x e m -> InA eqke (x,e) (elements m). + Proof. + auto. + Qed. + + Lemma elements_2 : forall m x e, + InA eqke (x,e) (elements m) -> MapsTo x e m. + Proof. + auto. + Qed. + + Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). + Proof. + auto. + Qed. + + Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). + Proof. + intros. + apply Sort_NoDupA. + apply elements_3; auto. + Qed. + + (** * [fold] *) + + Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := + match m with + | nil => acc + | (k,e)::m' => fold f m' (f k e acc) + end. + + Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + Proof. + induction m as [|[k e] m]; simpl; auto. + Qed. + + (** * [equal] *) + + Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool := + match m, m' with + | nil, nil => true + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | EQ _ => cmp e e' && equal cmp l l' + | _ => false + end + | _, _ => false + end. + + Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + + Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + intros m Hm m' Hm' cmp; revert m' Hm'. + induction Hm as [|[a e] m Hm IHHm Hr]; simpl in *; intros [|[a' e'] m'] Hm' H. + + reflexivity. + + destruct H as [H _]; specialize (H a') as [_ H]. + destruct H; [exists e'; constructor; reflexivity|inversion H]. + + destruct H as [H _]; specialize (H a) as [H _]. + destruct H; [exists e; constructor; reflexivity|inversion H]. + + apply Sorted_inv in Hm'; destruct Hm' as [Hm' Hr']. + destruct (X.compare a a') as [Hlt|Heq|Hgt]; [exfalso| |exfalso]. + - destruct H as [H _]; specialize (H a) as [H _]. + destruct H as [e'' H]; [eexists; constructor; reflexivity|]. + apply InA_cons in H; destruct H as [H|H]. + * apply (gt_not_eq Hlt); symmetry; apply H. + * apply InA_eqke_eqk, (Sort_Inf_In Hm' Hr') in H. + compute in H; order. + - apply andb_true_iff; split. + * destruct H as [_ H]; apply H with a. + { apply InA_cons_hd; reflexivity. } + { apply InA_cons_hd; auto with ordered_type. } + * apply IHHm; [assumption|]; split. + { intros k; destruct H as [H _]; specialize (H k). + split; intros [e'' Hk]. + + destruct H as [H _]; destruct H as [e''' H]. + - exists e''; apply InA_cons_tl; apply Hk. + - apply InA_cons in H; destruct H as [[H _]|H]. + * assert (Hs := Sort_Inf_In Hm Hr (InA_eqke_eqk Hk)). + elim (gt_not_eq Hs); simpl; etransitivity; [eassumption|symmetry; assumption]. + * exists e'''; assumption. + + destruct H as [_ H]; destruct H as [e''' H]. + - exists e''; apply InA_cons_tl; apply Hk. + - apply InA_cons in H; destruct H as [[H _]|H]. + * assert (Hs := Sort_Inf_In Hm' Hr' (InA_eqke_eqk Hk)). + elim (gt_not_eq Hs); simpl; etransitivity; eassumption. + * exists e'''; assumption. + } + { intros; destruct H as [_ H]; apply H with k; apply InA_cons_tl; assumption. } + - destruct H as [H _]; specialize (H a') as [_ H]. + destruct H as [e'' H]; [eexists; constructor; reflexivity|]. + apply InA_cons in H; destruct H as [H|H]. + * apply (gt_not_eq Hgt); symmetry; apply H. + * apply InA_eqke_eqk, (Sort_Inf_In Hm Hr) in H. + compute in H; order. + Qed. + + Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, + equal cmp m m' = true -> Equivb cmp m m'. + Proof. + intros m Hm m' Hm' cmp; revert m' Hm'. + induction Hm as [|[a e] m Hm IHHm Hr]; simpl in *; intros [|[a' e'] m'] Hm' H; try congruence. + + split; [tauto|inversion 1]. + + destruct X.compare as [?|Heq|?]; try congruence. + apply Sorted_inv in Hm'; destruct Hm' as [Hm' Hr']. + apply andb_true_iff in H; destruct H as [Hc He]; split. + - intros k; split; intros [v Hk]; apply InA_cons in Hk; destruct Hk as [Hk|Hk]. + * exists e'; apply InA_cons_hd; split; [|reflexivity]. + transitivity a; [apply Hk|apply Heq]. + * assert (Hi : In k m'). + { apply (IHHm m' Hm' He); exists v; apply Hk. } + destruct Hi as [w Hw]; exists w; apply InA_cons_tl, Hw. + * exists e; apply InA_cons_hd; split; [|reflexivity]. + transitivity a'; [apply Hk|symmetry; apply Heq]. + * assert (Hi : In k m). + { apply (IHHm m' Hm' He); exists v; apply Hk. } + destruct Hi as [w Hw]; exists w; apply InA_cons_tl, Hw. + - intros k e1 e2 He1 He2. + apply InA_cons in He1, He2. + destruct He1 as [He1|He1]; destruct He2 as [He2|He2]. + * replace e1 with e by (symmetry; apply He1). + replace e2 with e' by (symmetry; apply He2). + apply Hc. + * assert (Hi : In k m). + { apply (IHHm m' Hm' He); exists e2; apply He2. } + destruct Hi as [w Hw]. + apply InA_eqke_eqk, (Sort_Inf_In Hm Hr) in Hw. + destruct He1 as [He1 _]. + elim (eq_not_gt He1); apply Hw. + * assert (Hi : In k m'). + { apply (IHHm m' Hm' He); exists e1; apply He1. } + destruct Hi as [w Hw]. + apply InA_eqke_eqk, (Sort_Inf_In Hm' Hr') in Hw. + destruct He2 as [He2 _]. + elim (eq_not_gt He2); apply Hw. + * destruct (IHHm m' Hm' He) as [_ IH]. + apply (IH k e1 e2 He1 He2). + Qed. + + (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) + + Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> + eqk x y -> cmp (snd x) (snd y) = true -> + (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). + Proof. + intros. + inversion H; subst. + inversion H0; subst. + destruct x; destruct y; compute in H1, H2. + split; intros. + - apply equal_2; auto. + simpl. + elim_comp. + rewrite H2; simpl. + apply equal_1; auto. + - apply equal_2; auto. + generalize (equal_1 H H0 H3). + simpl. + elim_comp. + rewrite H2; simpl; auto. + Qed. + + Variable elt':Type. + + (** * [map] and [mapi] *) + + Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f e) :: map f m' + end. + + Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + + End Elt. + Section Elt2. + (* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - intros m x e f. - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + unfold MapsTo in *; auto. -Qed. - -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. -Proof. - intros m x f. - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x0,e0). - inversion_clear H; auto. -Qed. - -#[local] -Hint Resolve map_lelistA : core. - -Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), - sort (@ltk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - exact (map_lelistA _ _ H0). -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> - exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - intros m x e f. - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + exists x'. - destruct H0; simpl in *. - split. - * auto with ordered_type. - * constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + destruct IHm as (y, hyp); auto. - exists y; intuition auto with ordered_type. -Qed. - - -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), - In x (mapi f m) -> In x m. -Proof. - intros m x f. - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,f x e) (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear H; auto. -Qed. - -#[local] -Hint Resolve mapi_lelistA : core. - -Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), - sort (@ltk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. -Qed. - -End Elt2. -Section Elt3. - -(** * [map2] *) - -Variable elt elt' elt'' : Type. -Variable f : option elt -> option elt' -> option elt''. - -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Fixpoint map2_l (m : t elt) : t elt'' := - match m with - | nil => nil - | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) - end. - -Fixpoint map2_r (m' : t elt') : t elt'' := - match m' with - | nil => nil - | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') - end. - -Fixpoint map2 (m : t elt) : t elt' -> t elt'' := - match m with - | nil => map2_r - | (k,e) :: l => - fix map2_aux (m' : t elt') : t elt'' := - match m' with - | nil => map2_l m - | (k',e') :: l' => - match X.compare k k' with - | LT _ => option_cons k (f (Some e) None) (map2 l m') - | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l') - | GT _ => option_cons k' (f None (Some e')) (map2_aux l') + Variable elt elt' : Type. + + (** Specification of [map] *) + + Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). + Proof. + intros m x e f. + induction m. + - inversion 1. + + - destruct a as (x',e'). + simpl. + inversion_clear 1. + + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + + unfold MapsTo in *; auto. + Qed. + + Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. + Proof. + intros m x f. + induction m; simpl. + - intros (e,abs). + inversion abs. + + - destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + + destruct IHm as (e'',hyp). + * exists e'; auto. + * exists e''. + constructor 2; auto. + Qed. + + Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') (map f m). + Proof. + induction m; simpl; auto. + intros. + destruct a as (x0,e0). + inversion_clear H; auto. + Qed. + + #[local] + Hint Resolve map_lelistA : core. + + Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), + sort (@ltk elt') (map f m). + Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + exact (map_lelistA _ _ H0). + Qed. + + (** Specification of [mapi] *) + + Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> + exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). + Proof. + intros m x e f. + induction m. + - inversion 1. + + - destruct a as (x',e'). + simpl. + inversion_clear 1. + + exists x'. + destruct H0; simpl in *. + split. + * auto with ordered_type. + * constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + + destruct IHm as (y, hyp); auto. + exists y; intuition auto with ordered_type. + Qed. + + + Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), + In x (mapi f m) -> In x m. + Proof. + intros m x f. + induction m; simpl. + - intros (e,abs). + inversion abs. + + - destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + + destruct IHm as (e'',hyp). + * exists e'; auto. + * exists e''. + constructor 2; auto. + Qed. + + Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,f x e) (mapi f m). + Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear H; auto. + Qed. + + #[local] + Hint Resolve mapi_lelistA : core. + + Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), + sort (@ltk elt') (mapi f m). + Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. + Qed. + + End Elt2. + Section Elt3. + + (** * [map2] *) + + Variable elt elt' elt'' : Type. + Variable f : option elt -> option elt' -> option elt''. + + Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + + Fixpoint map2_l (m : t elt) : t elt'' := + match m with + | nil => nil + | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) + end. + + Fixpoint map2_r (m' : t elt') : t elt'' := + match m' with + | nil => nil + | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') + end. + + Fixpoint map2 (m : t elt) : t elt' -> t elt'' := + match m with + | nil => map2_r + | (k,e) :: l => + fix map2_aux (m' : t elt') : t elt'' := + match m' with + | nil => map2_l m + | (k',e') :: l' => + match X.compare k k' with + | LT _ => option_cons k (f (Some e) None) (map2 l m') + | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l') + | GT _ => option_cons k' (f None (Some e')) (map2_aux l') + end end - end - end. - -Notation oee' := (option elt * option elt')%type. - -Fixpoint combine (m : t elt) : t elt' -> t oee' := - match m with - | nil => map (fun e' => (None,Some e')) - | (k,e) :: l => - fix combine_aux (m':t elt') : list (key * oee') := - match m' with - | nil => map (fun e => (Some e,None)) m - | (k',e') :: l' => - match X.compare k k' with - | LT _ => (k,(Some e, None))::combine l m' - | EQ _ => (k,(Some e, Some e'))::combine l l' - | GT _ => (k',(None,Some e'))::combine_aux l' + end. + + Notation oee' := (option elt * option elt')%type. + + Fixpoint combine (m : t elt) : t elt' -> t oee' := + match m with + | nil => map (fun e' => (None,Some e')) + | (k,e) :: l => + fix combine_aux (m':t elt') : list (key * oee') := + match m' with + | nil => map (fun e => (Some e,None)) m + | (k',e') :: l' => + match X.compare k k' with + | LT _ => (k,(Some e, None))::combine l m' + | EQ _ => (k,(Some e, Some e'))::combine l l' + | GT _ => (k',(None,Some e'))::combine_aux l' + end end - end - end. - -Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := - List.fold_right (fun p => f (fst p) (snd p)) i l. - -Definition map2_alt m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) m1 nil. - -Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. -Proof. - unfold map2_alt. - induction m. - - simpl; auto; intros. - (* map2_r *) - induction m'; try destruct a; simpl; auto. - rewrite IHm'; auto. - (* fin map2_r *) - - induction m'; destruct a. - + simpl; f_equal. - (* map2_l *) - clear IHm. - induction m; try destruct a; simpl; auto. - rewrite IHm; auto. - (* fin map2_l *) - + destruct a0. - simpl. - destruct (X.compare t0 t1); simpl; f_equal. - * apply IHm. - * apply IHm. - * apply IHm'. -Qed. - -Lemma combine_lelistA : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') m' -> - lelistA (@ltk oee') (x,e'') (combine m m'). -Proof. - induction m. - - intros. - simpl. - exact (map_lelistA _ _ H0). - - induction m'. - + intros. - destruct a. - replace (combine ((t0, e0) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. - exact (map_lelistA _ _ H). - + intros. - simpl. - destruct a as (k,e0); destruct a0 as (k',e0'). - destruct (X.compare k k'). - * inversion_clear H; auto. - * inversion_clear H; auto. - * inversion_clear H0; auto. -Qed. -#[local] -Hint Resolve combine_lelistA : core. - -Lemma combine_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), - sort (@ltk oee') (combine m m'). -Proof. - induction m. - - intros; clear Hm. - simpl. - apply map_sorted; auto. - - induction m'. - + intros; clear Hm'. - destruct a. - replace (combine ((t0, e) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. - apply map_sorted; auto. - + intros. - simpl. - destruct a as (k,e); destruct a0 as (k',e'). - destruct (X.compare k k') as [Hlt|Heq|Hlt]. - * inversion_clear Hm. - constructor; auto. - assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. - exact (combine_lelistA _ H0 H1). - * inversion_clear Hm; inversion_clear Hm'. - constructor; auto. - assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_lelistA _ H0 H3). - * inversion_clear Hm; inversion_clear Hm'. - constructor; auto. - change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) - (combine ((k,e)::m) m')). - assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto. - exact (combine_lelistA _ H3 H2). -Qed. - -Lemma map2_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), - sort (@ltk elt'') (map2 m m'). -Proof. - intros. - rewrite <- map2_alt_equiv. - unfold map2_alt. - assert (H0:=combine_sorted Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun p : oee' => f (fst p) (snd p)). - assert (H1:=map_sorted (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. - clear f' f H0 l0 Hm Hm' m m'. - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; auto. - simpl. - constructor; auto. - clear IHl1. - induction l1. - + simpl; auto. - + destruct a; destruct o; simpl; auto. - * inversion_clear H0; auto. - * inversion_clear H0. - red in H1; simpl in H1. - inversion_clear H. - apply IHl1; auto. - apply Inf_lt with (t1, None (A:=elt'')); auto. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - induction m. - - intros. - simpl. - induction m'. - + intros; simpl; auto. - + simpl; destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - inversion_clear Hm'; auto. - - induction m'. - + (* m' = nil *) - intros; destruct a; simpl. - destruct (X.compare x t0) as [Hlt| |Hlt]; simpl; auto. - inversion_clear Hm; clear H0 Hlt Hm' IHm t0. - induction m; simpl; auto. - inversion_clear H. - destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - + (* m' <> nil *) - intros. - destruct a as (k,e); destruct a0 as (k',e'); simpl. - inversion Hm; inversion Hm'; subst. - destruct (X.compare k k'); simpl; - destruct (X.compare x k); - elim_comp || destruct (X.compare x k'); simpl; auto. - * rewrite IHm; auto; simpl; elim_comp; auto. - * rewrite IHm; auto; simpl; elim_comp; auto. - * rewrite IHm; auto; simpl; elim_comp; auto. - * change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto. - simpl find; elim_comp; auto. - * change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto. - simpl find; elim_comp; auto. - * change (find x (combine ((k, e) :: m) m') = - at_least_one (find x m) (find x m')). - rewrite IHm'; auto. - simpl find; elim_comp; auto. -Qed. - -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f o o' - end. - -Lemma map2_0 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). -Proof. - intros. - rewrite <- map2_alt_equiv. - unfold map2_alt. - assert (H:=combine_1 Hm Hm' x). - assert (H2:=combine_sorted Hm Hm'). - set (f':= fun p : oee' => f (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. - generalize H; clear H. - match goal with |- ?m=?n -> ?p=?q => - assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. - induction m0; simpl in *; intuition. - - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *. - + (* x < k *) - destruct (f' (oo,oo')); simpl. - * elim_comp. - destruct o; destruct o'; simpl in *; try discriminate; auto. - * destruct (IHm0 H0) as (H2,_); apply H2; auto. - rewrite <- H. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - -- red; auto. - -- destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)). - exists p; apply find_2; auto. - + (* x = k *) - assert (at_least_one_then_f o o' = f oo oo'). - * destruct o; destruct o'; simpl in *; inversion_clear H; auto. - * rewrite H2. - unfold f'; simpl. - destruct (f oo oo'); simpl. - -- elim_comp; auto. - -- destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - ++ red; auto with ordered_type. - ++ destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). - exists p; apply find_2; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * elim_comp; auto. - destruct (IHm0 H0) as (H3,_); apply H3; auto. - * destruct (IHm0 H0) as (H3,_); apply H3; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.compare x k) as [Hlt|Heq|Hlt]. - + (* x < k *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * elim_comp; auto. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - -- red; auto. - -- destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_2; auto. - + (* x = k *) - discriminate. - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * elim_comp; auto. - destruct (IHm0 H0) as (_,H4); apply H4; auto. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. -Qed. - -(** Specification of [map2] *) - -Lemma map2_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). -Proof. - intros. - rewrite map2_0; auto. - destruct H as [(e,H)|(e,H)]. - - rewrite (find_1 Hm H). - destruct (find x m'); simpl; auto. - - rewrite (find_1 Hm' H). - destruct (find x m); simpl; auto. -Qed. - -Lemma map2_2 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - generalize (map2_0 Hm Hm' x). - rewrite (find_1 (map2_sorted Hm Hm') H). - generalize (@find_2 _ m x). - generalize (@find_2 _ m' x). - destruct (find x m); - destruct (find x m'); simpl; intros. - - left; exists e0; auto. - - left; exists e0; auto. - - right; exists e0; auto. - - discriminate. -Qed. - -End Elt3. + end. + + Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := + List.fold_right (fun p => f (fst p) (snd p)) i l. + + Definition map2_alt m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) m1 nil. + + Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. + Proof. + unfold map2_alt. + induction m. + - simpl; auto; intros. + (* map2_r *) + induction m'; try destruct a; simpl; auto. + rewrite IHm'; auto. + (* fin map2_r *) + - induction m'; destruct a. + + simpl; f_equal. + (* map2_l *) + clear IHm. + induction m; try destruct a; simpl; auto. + rewrite IHm; auto. + (* fin map2_l *) + + destruct a0. + simpl. + destruct (X.compare t0 t1); simpl; f_equal. + * apply IHm. + * apply IHm. + * apply IHm'. + Qed. + + Lemma combine_lelistA : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') m' -> + lelistA (@ltk oee') (x,e'') (combine m m'). + Proof. + induction m. + - intros. + simpl. + exact (map_lelistA _ _ H0). + - induction m'. + + intros. + destruct a. + replace (combine ((t0, e0) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. + exact (map_lelistA _ _ H). + + intros. + simpl. + destruct a as (k,e0); destruct a0 as (k',e0'). + destruct (X.compare k k'). + * inversion_clear H; auto. + * inversion_clear H; auto. + * inversion_clear H0; auto. + Qed. + #[local] + Hint Resolve combine_lelistA : core. + + Lemma combine_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), + sort (@ltk oee') (combine m m'). + Proof. + induction m. + - intros; clear Hm. + simpl. + apply map_sorted; auto. + - induction m'. + + intros; clear Hm'. + destruct a. + replace (combine ((t0, e) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. + apply map_sorted; auto. + + intros. + simpl. + destruct a as (k,e); destruct a0 as (k',e'). + destruct (X.compare k k') as [Hlt|Heq|Hlt]. + * inversion_clear Hm. + constructor; auto. + assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. + exact (combine_lelistA _ H0 H1). + * inversion_clear Hm; inversion_clear Hm'. + constructor; auto. + assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). + exact (combine_lelistA _ H0 H3). + * inversion_clear Hm; inversion_clear Hm'. + constructor; auto. + change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) + (combine ((k,e)::m) m')). + assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto. + exact (combine_lelistA _ H3 H2). + Qed. + + Lemma map2_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), + sort (@ltk elt'') (map2 m m'). + Proof. + intros. + rewrite <- map2_alt_equiv. + unfold map2_alt. + assert (H0:=combine_sorted Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun p : oee' => f (fst p) (snd p)). + assert (H1:=map_sorted (elt' := option elt'') H0 f'). + set (l1:=map f' l0) in *; clearbody l1. + clear f' f H0 l0 Hm Hm' m m'. + induction l1. + - simpl; auto. + - inversion_clear H1. + destruct a; destruct o; auto. + simpl. + constructor; auto. + clear IHl1. + induction l1. + + simpl; auto. + + destruct a; destruct o; simpl; auto. + * inversion_clear H0; auto. + * inversion_clear H0. + red in H1; simpl in H1. + inversion_clear H. + apply IHl1; auto. + apply Inf_lt with (t1, None (A:=elt'')); auto. + Qed. + + Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + + Lemma combine_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). + Proof. + induction m. + - intros. + simpl. + induction m'. + + intros; simpl; auto. + + simpl; destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + inversion_clear Hm'; auto. + - induction m'. + + (* m' = nil *) + intros; destruct a; simpl. + destruct (X.compare x t0) as [Hlt| |Hlt]; simpl; auto. + inversion_clear Hm; clear H0 Hlt Hm' IHm t0. + induction m; simpl; auto. + inversion_clear H. + destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + + (* m' <> nil *) + intros. + destruct a as (k,e); destruct a0 as (k',e'); simpl. + inversion Hm; inversion Hm'; subst. + destruct (X.compare k k'); simpl; + destruct (X.compare x k); + elim_comp || destruct (X.compare x k'); simpl; auto. + * rewrite IHm; auto; simpl; elim_comp; auto. + * rewrite IHm; auto; simpl; elim_comp; auto. + * rewrite IHm; auto; simpl; elim_comp; auto. + * change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + * change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + * change (find x (combine ((k, e) :: m) m') = + at_least_one (find x m) (find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + Qed. + + Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f o o' + end. + + Lemma map2_0 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). + Proof. + intros. + rewrite <- map2_alt_equiv. + unfold map2_alt. + assert (H:=combine_1 Hm Hm' x). + assert (H2:=combine_sorted Hm Hm'). + set (f':= fun p : oee' => f (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. + generalize H; clear H. + match goal with |- ?m=?n -> ?p=?q => + assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. + induction m0; simpl in *; intuition. + - destruct o; destruct o'; simpl in *; try discriminate; auto. + - destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *. + + (* x < k *) + destruct (f' (oo,oo')); simpl. + * elim_comp. + destruct o; destruct o'; simpl in *; try discriminate; auto. + * destruct (IHm0 H0) as (H2,_); apply H2; auto. + rewrite <- H. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + -- red; auto. + -- destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)). + exists p; apply find_2; auto. + + (* x = k *) + assert (at_least_one_then_f o o' = f oo oo'). + * destruct o; destruct o'; simpl in *; inversion_clear H; auto. + * rewrite H2. + unfold f'; simpl. + destruct (f oo oo'); simpl. + -- elim_comp; auto. + -- destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). + ++ red; auto with ordered_type. + ++ destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). + exists p; apply find_2; auto. + + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + * elim_comp; auto. + destruct (IHm0 H0) as (H3,_); apply H3; auto. + * destruct (IHm0 H0) as (H3,_); apply H3; auto. + + - (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.compare x k) as [Hlt|Heq|Hlt]. + + (* x < k *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + * elim_comp; auto. + * destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + -- red; auto. + -- destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). + exists p; apply find_2; auto. + + (* x = k *) + discriminate. + + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + * elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + * destruct (IHm0 H0) as (_,H4); apply H4; auto. + Qed. + + (** Specification of [map2] *) + + Lemma map2_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). + Proof. + intros. + rewrite map2_0; auto. + destruct H as [(e,H)|(e,H)]. + - rewrite (find_1 Hm H). + destruct (find x m'); simpl; auto. + - rewrite (find_1 Hm' H). + destruct (find x m); simpl; auto. + Qed. + + Lemma map2_2 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. + Proof. + intros. + destruct H as (e,H). + generalize (map2_0 Hm Hm' x). + rewrite (find_1 (map2_sorted Hm Hm') H). + generalize (@find_2 _ m x). + generalize (@find_2 _ m' x). + destruct (find x m); + destruct (find x m'); simpl; intros. + - left; exists e0; auto. + - left; exists e0; auto. + - right; exists e0; auto. + - discriminate. + Qed. + + End Elt3. End Raw. Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. -Module E := X. - -Definition key := E.t. - -Record slist (elt:Type) := - {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. -Definition t (elt:Type) : Type := slist elt. - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Build_slist (Raw.empty_sorted elt). - Definition is_empty m : bool := Raw.is_empty (this m). - Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e). - Definition find x m : option elt := Raw.find x (this m). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x). - Definition mem x m : bool := Raw.mem x (this m). - Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f). - Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_sorted f (sorted m) (sorted m')). - Definition elements m : list (key*elt) := @Raw.elements elt (this m). - Definition cardinal m := length (this m). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). - - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). - Definition In x m : Prop := Raw.PX.In x (this m). - Definition Empty m : Prop := Raw.Empty (this m). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. - - Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact (@Raw.empty_1 elt). Qed. - - Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. - Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. - - Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. - Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. - Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. - - Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed. - Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed. - Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed. - - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed. - Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. - - Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. - Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intros; reflexivity. Qed. - - Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. - - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed. - Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed. - - End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. - - Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. - Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). - Qed. - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). - Qed. + Module Raw := Raw X. + Module E := X. + + Definition key := E.t. + + Record slist (elt:Type) := + {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. + Definition t (elt:Type) : Type := slist elt. + + Section Elt. + Variable elt elt' elt'':Type. + + Implicit Types m : t elt. + Implicit Types x y : key. + Implicit Types e : elt. + + Definition empty : t elt := Build_slist (Raw.empty_sorted elt). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e). + Definition find x m : option elt := Raw.find x (this m). + Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x). + Definition mem x m : bool := Raw.mem x (this m). + Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f). + Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f). + Definition map2 f m (m':t elt') : t elt'' := + Build_slist (Raw.map2_sorted f (sorted m) (sorted m')). + Definition elements m : list (key*elt) := @Raw.elements elt (this m). + Definition cardinal m := length (this m). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. + Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). + + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). + Definition In x m : Prop := Raw.PX.In x (this m). + Definition Empty m : Prop := Raw.Empty (this m). + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). + + Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. + Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. + Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. + + Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. + Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. + + Lemma mem_1 : forall m x, In x m -> mem x m = true. + Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed. + Lemma mem_2 : forall m x, mem x m = true -> In x m. + Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed. + + Lemma empty_1 : Empty empty. + Proof. exact (@Raw.empty_1 elt). Qed. + + Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. + Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. + Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. + Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. + + Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). + Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. + Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. + Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. + + Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). + Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed. + Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed. + Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. + Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed. + + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed. + Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. + Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. + + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. + Lemma elements_3 : forall m, sort lt_key (elements m). + Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed. + Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed. + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). + Proof. intros; reflexivity. Qed. + + Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. + + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed. + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. + Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed. + + End Elt. + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). + Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. + Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. + + Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) + (f:key->elt->elt'), MapsTo x e m -> + exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). + Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. + Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) + (f:key->elt->elt'), In x (mapi f m) -> In x m. + Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. + + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; + exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). + Qed. + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x (map2 f m m') -> In x m \/ In x m'. + Proof. + intros elt elt' elt'' m m' x f; + exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). + Qed. End Make. Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D - with Module MapS.E := X. - -Module Data := D. -Module MapS := Make(X). -Import MapS. - -Module MD := OrderedTypeFacts(D). -Import MD. - -Definition t := MapS.t D.t. - -Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. - -Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | EQ _ => D.eq e e' /\ eq_list l l' - | _ => False - end - | _, _ => False - end. - -Definition eq m m' := eq_list (this m) (this m'). - -Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => False - | nil, _ => True - | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | LT _ => True - | GT _ => False - | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') - end - end. - -Definition lt m m' := lt_list (this m) (this m'). - -Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. -Proof. - intros (l,Hl); induction l. - - intros (l',Hl'); unfold eq; simpl. - destruct l'; unfold equal; simpl; intuition auto with bool. - - intros (l',Hl'); unfold eq. - destruct l'. - + destruct a; unfold equal; simpl; intuition auto with bool. - + destruct a as (x,e). - destruct p as (x',e'). - unfold equal; simpl. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition auto with bool. - * unfold cmp at 1. - MD.elim_comp; clear H; simpl. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Build_slist H3)). - unfold equal, eq in H5; simpl in H5; auto. - * destruct (andb_prop _ _ H); clear H. - generalize H0; unfold cmp. - MD.elim_comp; auto; intro; discriminate. - * destruct (andb_prop _ _ H); clear H. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Build_slist H3)). - unfold equal, eq in H6; simpl in H6; auto. -Qed. - -Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'. -Proof. - intros. - generalize (@equal_1 D.t m m' cmp). - generalize (@eq_equal m m'). - intuition. -Qed. - -Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. -Proof. - intros. - generalize (@equal_2 D.t m m' cmp). - generalize (@eq_equal m m'). - intuition. -Qed. - -Lemma eq_refl : forall m : t, eq m m. -Proof. - intros (m,Hm); induction m; unfold eq; simpl; auto. - destruct a. - destruct (X.compare t0 t0) as [Hlt|Heq|Hlt]; auto. - - apply (MapS.Raw.MX.lt_antirefl Hlt); auto. - - split. - + apply D.eq_refl. - + inversion_clear Hm. - apply (IHm H). - - apply (MapS.Raw.MX.lt_antirefl Hlt); auto. -Qed. - -Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. -Proof. - intros (m,Hm); induction m; - intros (m', Hm'); destruct m'; unfold eq; simpl; - try destruct a as (x,e); try destruct p as (x',e'); auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition auto with ordered_type. - inversion_clear Hm; inversion_clear Hm'. - apply (IHm H0 (Build_slist H4)); auto. -Qed. - -Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; - destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt']; - MapS.Raw.MX.elim_comp; intuition. - - apply D.eq_trans with e'; auto. - - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. -Qed. - -Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; - destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt']; - MapS.Raw.MX.elim_comp; intuition. - - left; apply D.lt_trans with e'; auto. - - left; apply lt_eq with e'; auto. - - left; apply eq_lt with e'; auto. - - right. - split. - + apply D.eq_trans with e'; auto. - + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition. -Qed. - -Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); try contradiction; auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; auto. - intuition. - - exact (D.lt_not_eq H0 H1). - - inversion_clear Hm1; inversion_clear Hm2. - apply (IHm1 H0 (Build_slist H5)); intuition. -Qed. - -Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto with ordered_type. - -Definition compare : forall m1 m2, Compare lt eq m1 m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - [ apply EQ | apply LT | apply GT | ]; cmp_solve. - destruct a as (x,e); destruct p as (x',e'). - destruct (X.compare x x'); - [ apply LT | | apply GT ]; cmp_solve. - destruct (D.compare e e'); - [ apply LT | | apply GT ]; cmp_solve. - assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). - - inversion_clear Hm1; auto. - - assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). - { inversion_clear Hm2; auto. } - destruct (IHm1 Hm11 (Build_slist Hm22)); - [ apply LT | apply EQ | apply GT ]; cmp_solve. -Qed. + Sord with Module Data := D + with Module MapS.E := X. + + Module Data := D. + Module MapS := Make(X). + Import MapS. + + Module MD := OrderedTypeFacts(D). + Import MD. + + Definition t := MapS.t D.t. + + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. + + Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := + match m, m' with + | nil, nil => True + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | EQ _ => D.eq e e' /\ eq_list l l' + | _ => False + end + | _, _ => False + end. + + Definition eq m m' := eq_list (this m) (this m'). + + Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := + match m, m' with + | nil, nil => False + | nil, _ => True + | _, nil => False + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | LT _ => True + | GT _ => False + | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') + end + end. + + Definition lt m m' := lt_list (this m) (this m'). + + Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. + Proof. + intros (l,Hl); induction l. + - intros (l',Hl'); unfold eq; simpl. + destruct l'; unfold equal; simpl; intuition auto with bool. + - intros (l',Hl'); unfold eq. + destruct l'. + + destruct a; unfold equal; simpl; intuition auto with bool. + + destruct a as (x,e). + destruct p as (x',e'). + unfold equal; simpl. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition auto with bool. + * unfold cmp at 1. + MD.elim_comp; clear H; simpl. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Build_slist H3)). + unfold equal, eq in H5; simpl in H5; auto. + * destruct (andb_prop _ _ H); clear H. + generalize H0; unfold cmp. + MD.elim_comp; auto; intro; discriminate. + * destruct (andb_prop _ _ H); clear H. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Build_slist H3)). + unfold equal, eq in H6; simpl in H6; auto. + Qed. + + Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'. + Proof. + intros. + generalize (@equal_1 D.t m m' cmp). + generalize (@eq_equal m m'). + intuition. + Qed. + + Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. + Proof. + intros. + generalize (@equal_2 D.t m m' cmp). + generalize (@eq_equal m m'). + intuition. + Qed. + + Lemma eq_refl : forall m : t, eq m m. + Proof. + intros (m,Hm); induction m; unfold eq; simpl; auto. + destruct a. + destruct (X.compare t0 t0) as [Hlt|Heq|Hlt]; auto. + - apply (MapS.Raw.MX.lt_antirefl Hlt); auto. + - split. + + apply D.eq_refl. + + inversion_clear Hm. + apply (IHm H). + - apply (MapS.Raw.MX.lt_antirefl Hlt); auto. + Qed. + + Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. + Proof. + intros (m,Hm); induction m; + intros (m', Hm'); destruct m'; unfold eq; simpl; + try destruct a as (x,e); try destruct p as (x',e'); auto. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition auto with ordered_type. + inversion_clear Hm; inversion_clear Hm'. + apply (IHm H0 (Build_slist H4)); auto. + Qed. + + Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. + Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; + destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt']; + MapS.Raw.MX.elim_comp; intuition. + - apply D.eq_trans with e'; auto. + - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. + Qed. + + Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. + Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; + destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt']; + MapS.Raw.MX.elim_comp; intuition. + - left; apply D.lt_trans with e'; auto. + - left; apply lt_eq with e'; auto. + - left; apply eq_lt with e'; auto. + - right. + split. + + apply D.eq_trans with e'; auto. + + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition. + Qed. + + Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. + Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try contradiction; auto. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; auto. + intuition. + - exact (D.lt_not_eq H0 H1). + - inversion_clear Hm1; inversion_clear Hm2. + apply (IHm1 H0 (Build_slist H5)); intuition. + Qed. + + Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto with ordered_type. + + Definition compare : forall m1 m2, Compare lt eq m1 m2. + Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + [ apply EQ | apply LT | apply GT | ]; cmp_solve. + destruct a as (x,e); destruct p as (x',e'). + destruct (X.compare x x'); + [ apply LT | | apply GT ]; cmp_solve. + destruct (D.compare e e'); + [ apply LT | | apply GT ]; cmp_solve. + assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). + - inversion_clear Hm1; auto. + - assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). + { inversion_clear Hm2; auto. } + destruct (IHm1 Hm11 (Build_slist Hm22)); + [ apply LT | apply EQ | apply GT ]; cmp_solve. + Qed. End Make_ord. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 479a5e25a4..bb1d2fa806 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -36,31 +36,31 @@ Fixpoint append (i j : positive) : positive := Lemma append_assoc_0 : forall (i j : positive), append i (xO j) = append (append i (xO xH)) j. Proof. - induction i; intros; destruct j; simpl; - try rewrite (IHi (xI j)); - try rewrite (IHi (xO j)); - try rewrite <- (IHi xH); - auto. + induction i; intros; destruct j; simpl; + try rewrite (IHi (xI j)); + try rewrite (IHi (xO j)); + try rewrite <- (IHi xH); + auto. Qed. Lemma append_assoc_1 : forall (i j : positive), append i (xI j) = append (append i (xI xH)) j. Proof. - induction i; intros; destruct j; simpl; - try rewrite (IHi (xI j)); - try rewrite (IHi (xO j)); - try rewrite <- (IHi xH); - auto. + induction i; intros; destruct j; simpl; + try rewrite (IHi (xI j)); + try rewrite (IHi (xO j)); + try rewrite <- (IHi xH); + auto. Qed. Lemma append_neutral_r : forall (i : positive), append i xH = i. Proof. - induction i; simpl; congruence. + induction i; simpl; congruence. Qed. Lemma append_neutral_l : forall (i : positive), append xH i = i. Proof. - simpl; auto. + simpl; auto. Qed. @@ -83,669 +83,669 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition t := tree. Section A. - Variable A:Type. - - Arguments Leaf {A}. - - Definition empty : t A := Leaf. - - Fixpoint is_empty (m : t A) : bool := - match m with - | Leaf => true - | Node l None r => (is_empty l) && (is_empty r) - | _ => false - end. - - Fixpoint find (i : key) (m : t A) : option A := - match m with - | Leaf => None - | Node l o r => - match i with - | xH => o - | xO ii => find ii l - | xI ii => find ii r - end - end. - - Fixpoint mem (i : key) (m : t A) : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | xH => match o with None => false | _ => true end - | xO ii => mem ii l - | xI ii => mem ii r - end - end. + Variable A:Type. - Fixpoint add (i : key) (v : A) (m : t A) : t A := - match m with - | Leaf => - match i with - | xH => Node Leaf (Some v) Leaf - | xO ii => Node (add ii v Leaf) None Leaf - | xI ii => Node Leaf None (add ii v Leaf) - end - | Node l o r => - match i with - | xH => Node l (Some v) r - | xO ii => Node (add ii v l) o r - | xI ii => Node l o (add ii v r) - end - end. + Arguments Leaf {A}. - Fixpoint remove (i : key) (m : t A) : t A := - match i with - | xH => - match m with - | Leaf => Leaf - | Node Leaf _ Leaf => Leaf - | Node l _ r => Node l None r - end - | xO ii => - match m with - | Leaf => Leaf - | Node l None Leaf => - match remove ii l with - | Leaf => Leaf - | mm => Node mm None Leaf - end - | Node l o r => Node (remove ii l) o r - end - | xI ii => - match m with - | Leaf => Leaf - | Node Leaf None r => - match remove ii r with - | Leaf => Leaf - | mm => Node Leaf None mm - end - | Node l o r => Node l o (remove ii r) - end - end. + Definition empty : t A := Leaf. - (** [elements] *) + Fixpoint is_empty (m : t A) : bool := + match m with + | Leaf => true + | Node l None r => (is_empty l) && (is_empty r) + | _ => false + end. - Fixpoint xelements (m : t A) (i : key) : list (key * A) := + Fixpoint find (i : key) (m : t A) : option A := match m with - | Leaf => nil - | Node l None r => - (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH))) - | Node l (Some x) r => - (xelements l (append i (xO xH))) - ++ ((i, x) :: xelements r (append i (xI xH))) + | Leaf => None + | Node l o r => + match i with + | xH => o + | xO ii => find ii l + | xI ii => find ii r + end end. - (* Note: function [xelements] above is inefficient. We should apply - deforestation to it, but that makes the proofs even harder. *) - - Definition elements (m : t A) := xelements m xH. - - (** [cardinal] *) - - Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat - | Node l None r => (cardinal l + cardinal r)%nat - | Node l (Some _) r => S (cardinal l + cardinal r) - end. - - Section CompcertSpec. - - Theorem gempty: - forall (i: key), find i empty = None. - Proof. - destruct i; simpl; auto. - Qed. - - Theorem gss: - forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x. - Proof. - induction i; destruct m; simpl; auto. - Qed. - - Lemma gleaf : forall (i : key), find i (Leaf : t A) = None. - Proof. exact gempty. Qed. - - Theorem gso: - forall (i j: key) (x: A) (m: t A), - i <> j -> find i (add j x m) = find i m. - Proof. - induction i; intros; destruct j; destruct m; simpl; - try rewrite <- (gleaf i); auto; try apply IHi; congruence. - Qed. - - Lemma rleaf : forall (i : key), remove i Leaf = Leaf. - Proof. destruct i; simpl; auto. Qed. - - Theorem grs: - forall (i: key) (m: t A), find i (remove i m) = None. - Proof. - induction i; destruct m. - - simpl; auto. - - destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto. - + rewrite (rleaf i); auto. - + cut (find i (remove i (Node ll oo rr)) = None). - * destruct (remove i (Node ll oo rr)); auto; apply IHi. - * apply IHi. - - simpl; auto. - - destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto. - + rewrite (rleaf i); auto. - + cut (find i (remove i (Node ll oo rr)) = None). - * destruct (remove i (Node ll oo rr)); auto; apply IHi. - * apply IHi. - - simpl; auto. - - destruct m1; destruct m2; simpl; auto. - Qed. - - Theorem gro: - forall (i j: key) (m: t A), - i <> j -> find i (remove j m) = find i m. - Proof. - induction i; intros; destruct j; destruct m; - try rewrite (rleaf (xI j)); - try rewrite (rleaf (xO j)); - try rewrite (rleaf 1); auto; - destruct m1; destruct o; destruct m2; - simpl; - try apply IHi; try congruence; - try rewrite (rleaf j); auto; - try rewrite (gleaf i); auto. - - cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2)); - [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto - | apply IHi; congruence ]. - - destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); - auto. - - destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); - auto. - - cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2)); - [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto - | apply IHi; congruence ]. - - destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); - auto. - - destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); - auto. - Qed. - - Lemma xelements_correct: - forall (m: t A) (i j : key) (v: A), - find i m = Some v -> List.In (append j i, v) (xelements m j). - Proof. - induction m; intros. - - rewrite (gleaf i) in H; discriminate. - - destruct o; destruct i; simpl; simpl in H. - + rewrite append_assoc_1; apply in_or_app; right; apply in_cons; - apply IHm2; auto. - + rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. - + rewrite append_neutral_r; apply in_or_app; injection H as [= ->]; - right; apply in_eq. - + rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto. - + rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. - + congruence. - Qed. - - Theorem elements_correct: - forall (m: t A) (i: key) (v: A), - find i m = Some v -> List.In (i, v) (elements m). - Proof. - intros m i v H. - exact (xelements_correct m i xH H). - Qed. - - Fixpoint xfind (i j : key) (m : t A) : option A := - match i, j with - | _, xH => find i m - | xO ii, xO jj => xfind ii jj m - | xI ii, xI jj => xfind ii jj m - | _, _ => None + Fixpoint mem (i : key) (m : t A) : bool := + match m with + | Leaf => false + | Node l o r => + match i with + | xH => match o with None => false | _ => true end + | xO ii => mem ii l + | xI ii => mem ii r + end end. - Lemma xfind_left : - forall (j i : key) (m1 m2 : t A) (o : option A) (v : A), - xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. - Proof. - induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. - destruct i; simpl in *; auto. - Qed. + Fixpoint add (i : key) (v : A) (m : t A) : t A := + match m with + | Leaf => + match i with + | xH => Node Leaf (Some v) Leaf + | xO ii => Node (add ii v Leaf) None Leaf + | xI ii => Node Leaf None (add ii v Leaf) + end + | Node l o r => + match i with + | xH => Node l (Some v) r + | xO ii => Node (add ii v l) o r + | xI ii => Node l o (add ii v r) + end + end. - Lemma xelements_ii : - forall (m: t A) (i j : key) (v: A), - List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); - apply in_or_app. - + left; apply IHm1; auto. - + right; destruct (in_inv H0). - * injection H1 as [= -> ->]; apply in_eq. - * apply in_cons; apply IHm2; auto. - + left; apply IHm1; auto. - + right; apply IHm2; auto. - Qed. + Fixpoint remove (i : key) (m : t A) : t A := + match i with + | xH => + match m with + | Leaf => Leaf + | Node Leaf _ Leaf => Leaf + | Node l _ r => Node l None r + end + | xO ii => + match m with + | Leaf => Leaf + | Node l None Leaf => + match remove ii l with + | Leaf => Leaf + | mm => Node mm None Leaf + end + | Node l o r => Node (remove ii l) o r + end + | xI ii => + match m with + | Leaf => Leaf + | Node Leaf None r => + match remove ii r with + | Leaf => Leaf + | mm => Node Leaf None mm + end + | Node l o r => Node l o (remove ii r) + end + end. - Lemma xelements_io : - forall (m: t A) (i j : key) (v: A), - ~List.In (xI i, v) (xelements m (xO j)). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + apply (IHm1 _ _ _ H0). - + destruct (in_inv H0). - * congruence. - * apply (IHm2 _ _ _ H1). - + apply (IHm1 _ _ _ H0). - + apply (IHm2 _ _ _ H0). - Qed. + (** [elements] *) - Lemma xelements_oo : - forall (m: t A) (i j : key) (v: A), - List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); - apply in_or_app. - + left; apply IHm1; auto. - + right; destruct (in_inv H0). - * injection H1 as [= -> ->]; apply in_eq. - * apply in_cons; apply IHm2; auto. - + left; apply IHm1; auto. - + right; apply IHm2; auto. - Qed. + Fixpoint xelements (m : t A) (i : key) : list (key * A) := + match m with + | Leaf => nil + | Node l None r => + (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH))) + | Node l (Some x) r => + (xelements l (append i (xO xH))) + ++ ((i, x) :: xelements r (append i (xI xH))) + end. - Lemma xelements_oi : - forall (m: t A) (i j : key) (v: A), - ~List.In (xO i, v) (xelements m (xI j)). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + apply (IHm1 _ _ _ H0). - + destruct (in_inv H0). - * congruence. - * apply (IHm2 _ _ _ H1). - + apply (IHm1 _ _ _ H0). - + apply (IHm2 _ _ _ H0). - Qed. + (* Note: function [xelements] above is inefficient. We should apply + deforestation to it, but that makes the proofs even harder. *) - Lemma xelements_ih : - forall (m1 m2: t A) (o: option A) (i : key) (v: A), - List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH). - Proof. - destruct o; simpl; intros; destruct (in_app_or _ _ _ H). - - absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. - - destruct (in_inv H0). - + congruence. - + apply xelements_ii; auto. - - absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. - - apply xelements_ii; auto. - Qed. + Definition elements (m : t A) := xelements m xH. - Lemma xelements_oh : - forall (m1 m2: t A) (o: option A) (i : key) (v: A), - List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH). - Proof. - destruct o; simpl; intros; destruct (in_app_or _ _ _ H). - - apply xelements_oo; auto. - - destruct (in_inv H0). - + congruence. - + absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. - - apply xelements_oo; auto. - - absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. - Qed. + (** [cardinal] *) - Lemma xelements_hi : - forall (m: t A) (i : key) (v: A), - ~List.In (xH, v) (xelements m (xI i)). - Proof. - induction m; intros. - - simpl; auto. - - destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + generalize H0; apply IHm1; auto. - + destruct (in_inv H0). - * congruence. - * generalize H1; apply IHm2; auto. - + generalize H0; apply IHm1; auto. - + generalize H0; apply IHm2; auto. - Qed. + Fixpoint cardinal (m : t A) : nat := + match m with + | Leaf => 0%nat + | Node l None r => (cardinal l + cardinal r)%nat + | Node l (Some _) r => S (cardinal l + cardinal r) + end. - Lemma xelements_ho : - forall (m: t A) (i : key) (v: A), - ~List.In (xH, v) (xelements m (xO i)). + Section CompcertSpec. + + Theorem gempty: + forall (i: key), find i empty = None. + Proof. + destruct i; simpl; auto. + Qed. + + Theorem gss: + forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x. + Proof. + induction i; destruct m; simpl; auto. + Qed. + + Lemma gleaf : forall (i : key), find i (Leaf : t A) = None. + Proof. exact gempty. Qed. + + Theorem gso: + forall (i j: key) (x: A) (m: t A), + i <> j -> find i (add j x m) = find i m. + Proof. + induction i; intros; destruct j; destruct m; simpl; + try rewrite <- (gleaf i); auto; try apply IHi; congruence. + Qed. + + Lemma rleaf : forall (i : key), remove i Leaf = Leaf. + Proof. destruct i; simpl; auto. Qed. + + Theorem grs: + forall (i: key) (m: t A), find i (remove i m) = None. + Proof. + induction i; destruct m. + - simpl; auto. + - destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto. + + rewrite (rleaf i); auto. + + cut (find i (remove i (Node ll oo rr)) = None). + * destruct (remove i (Node ll oo rr)); auto; apply IHi. + * apply IHi. + - simpl; auto. + - destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto. + + rewrite (rleaf i); auto. + + cut (find i (remove i (Node ll oo rr)) = None). + * destruct (remove i (Node ll oo rr)); auto; apply IHi. + * apply IHi. + - simpl; auto. + - destruct m1; destruct m2; simpl; auto. + Qed. + + Theorem gro: + forall (i j: key) (m: t A), + i <> j -> find i (remove j m) = find i m. + Proof. + induction i; intros; destruct j; destruct m; + try rewrite (rleaf (xI j)); + try rewrite (rleaf (xO j)); + try rewrite (rleaf 1); auto; + destruct m1; destruct o; destruct m2; + simpl; + try apply IHi; try congruence; + try rewrite (rleaf j); auto; + try rewrite (gleaf i); auto. + - cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2)); + [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto + | apply IHi; congruence ]. + - destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); + auto. + - destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); + auto. + - cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2)); + [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto + | apply IHi; congruence ]. + - destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); + auto. + - destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); + auto. + Qed. + + Lemma xelements_correct: + forall (m: t A) (i j : key) (v: A), + find i m = Some v -> List.In (append j i, v) (xelements m j). + Proof. + induction m; intros. + - rewrite (gleaf i) in H; discriminate. + - destruct o; destruct i; simpl; simpl in H. + + rewrite append_assoc_1; apply in_or_app; right; apply in_cons; + apply IHm2; auto. + + rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. + + rewrite append_neutral_r; apply in_or_app; injection H as [= ->]; + right; apply in_eq. + + rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto. + + rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. + + congruence. + Qed. + + Theorem elements_correct: + forall (m: t A) (i: key) (v: A), + find i m = Some v -> List.In (i, v) (elements m). + Proof. + intros m i v H. + exact (xelements_correct m i xH H). + Qed. + + Fixpoint xfind (i j : key) (m : t A) : option A := + match i, j with + | _, xH => find i m + | xO ii, xO jj => xfind ii jj m + | xI ii, xI jj => xfind ii jj m + | _, _ => None + end. + + Lemma xfind_left : + forall (j i : key) (m1 m2 : t A) (o : option A) (v : A), + xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. + Proof. + induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. + destruct i; simpl in *; auto. + Qed. + + Lemma xelements_ii : + forall (m: t A) (i j : key) (v: A), + List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j). + Proof. + induction m. + - simpl; auto. + - intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); + apply in_or_app. + + left; apply IHm1; auto. + + right; destruct (in_inv H0). + * injection H1 as [= -> ->]; apply in_eq. + * apply in_cons; apply IHm2; auto. + + left; apply IHm1; auto. + + right; apply IHm2; auto. + Qed. + + Lemma xelements_io : + forall (m: t A) (i j : key) (v: A), + ~List.In (xI i, v) (xelements m (xO j)). + Proof. + induction m. + - simpl; auto. + - intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). + + apply (IHm1 _ _ _ H0). + + destruct (in_inv H0). + * congruence. + * apply (IHm2 _ _ _ H1). + + apply (IHm1 _ _ _ H0). + + apply (IHm2 _ _ _ H0). + Qed. + + Lemma xelements_oo : + forall (m: t A) (i j : key) (v: A), + List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j). + Proof. + induction m. + - simpl; auto. + - intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); + apply in_or_app. + + left; apply IHm1; auto. + + right; destruct (in_inv H0). + * injection H1 as [= -> ->]; apply in_eq. + * apply in_cons; apply IHm2; auto. + + left; apply IHm1; auto. + + right; apply IHm2; auto. + Qed. + + Lemma xelements_oi : + forall (m: t A) (i j : key) (v: A), + ~List.In (xO i, v) (xelements m (xI j)). + Proof. + induction m. + - simpl; auto. + - intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). + + apply (IHm1 _ _ _ H0). + + destruct (in_inv H0). + * congruence. + * apply (IHm2 _ _ _ H1). + + apply (IHm1 _ _ _ H0). + + apply (IHm2 _ _ _ H0). + Qed. + + Lemma xelements_ih : + forall (m1 m2: t A) (o: option A) (i : key) (v: A), + List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH). + Proof. + destruct o; simpl; intros; destruct (in_app_or _ _ _ H). + - absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. + - destruct (in_inv H0). + + congruence. + + apply xelements_ii; auto. + - absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. + - apply xelements_ii; auto. + Qed. + + Lemma xelements_oh : + forall (m1 m2: t A) (o: option A) (i : key) (v: A), + List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH). + Proof. + destruct o; simpl; intros; destruct (in_app_or _ _ _ H). + - apply xelements_oo; auto. + - destruct (in_inv H0). + + congruence. + + absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. + - apply xelements_oo; auto. + - absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. + Qed. + + Lemma xelements_hi : + forall (m: t A) (i : key) (v: A), + ~List.In (xH, v) (xelements m (xI i)). + Proof. + induction m; intros. + - simpl; auto. + - destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). + + generalize H0; apply IHm1; auto. + + destruct (in_inv H0). + * congruence. + * generalize H1; apply IHm2; auto. + + generalize H0; apply IHm1; auto. + + generalize H0; apply IHm2; auto. + Qed. + + Lemma xelements_ho : + forall (m: t A) (i : key) (v: A), + ~List.In (xH, v) (xelements m (xO i)). + Proof. + induction m; intros. + - simpl; auto. + - destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). + + generalize H0; apply IHm1; auto. + + destruct (in_inv H0). + * congruence. + * generalize H1; apply IHm2; auto. + + generalize H0; apply IHm1; auto. + + generalize H0; apply IHm2; auto. + Qed. + + Lemma find_xfind_h : + forall (m: t A) (i: key), find i m = xfind i xH m. + Proof. + destruct i; simpl; auto. + Qed. + + Lemma xelements_complete: + forall (i j : key) (m: t A) (v: A), + List.In (i, v) (xelements m j) -> xfind i j m = Some v. + Proof. + induction i; simpl; intros; destruct j; simpl. + - apply IHi; apply xelements_ii; auto. + - absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io. + - destruct m. + + simpl in H; tauto. + + rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H). + - absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi. + - apply IHi; apply xelements_oo; auto. + - destruct m. + + simpl in H; tauto. + + rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H). + - absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi. + - absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho. + - destruct m. + + simpl in H; tauto. + + destruct o; simpl in H; destruct (in_app_or _ _ _ H). + * absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. + * destruct (in_inv H0). + -- congruence. + -- absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. + * absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. + * absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. + Qed. + + Theorem elements_complete: + forall (m: t A) (i: key) (v: A), + List.In (i, v) (elements m) -> find i m = Some v. + Proof. + intros m i v H. + unfold elements in H. + rewrite find_xfind_h. + exact (xelements_complete i xH m v H). + Qed. + + Lemma cardinal_1 : + forall (m: t A), cardinal m = length (elements m). + Proof. + unfold elements. + intros m; set (p:=1); clearbody p; revert m p. + induction m; simpl; auto; intros. + rewrite (IHm1 (append p 2)), (IHm2 (append p 3)). + destruct o; rewrite length_app; simpl; auto. + Qed. + + End CompcertSpec. + + Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. + + Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. + + Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. + + Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). + + Definition eq_key_elt (p p':key*A) := + E.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). + + #[global] Instance eqk_equiv : Equivalence eq_key := _. + #[global] Instance eqke_equiv : Equivalence eq_key_elt := _. + #[global] Instance ltk_strorder : StrictOrder lt_key := _. + + Lemma mem_find : + forall m x, mem x m = match find x m with None => false | _ => true end. Proof. - induction m; intros. - - simpl; auto. - - destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + generalize H0; apply IHm1; auto. - + destruct (in_inv H0). - * congruence. - * generalize H1; apply IHm2; auto. - + generalize H0; apply IHm1; auto. - + generalize H0; apply IHm2; auto. + induction m; destruct x; simpl; auto. Qed. - Lemma find_xfind_h : - forall (m: t A) (i: key), find i m = xfind i xH m. + Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None. Proof. - destruct i; simpl; auto. + unfold Empty, MapsTo. + intuition. + - generalize (H a). + destruct (find a m); intuition. + elim (H0 a0); auto. + - rewrite H in H0; discriminate. Qed. - Lemma xelements_complete: - forall (i j : key) (m: t A) (v: A), - List.In (i, v) (xelements m j) -> xfind i j m = Some v. + Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r. Proof. - induction i; simpl; intros; destruct j; simpl. - - apply IHi; apply xelements_ii; auto. - - absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io. - - destruct m. - + simpl in H; tauto. - + rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H). - - absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi. - - apply IHi; apply xelements_oo; auto. - - destruct m. - + simpl in H; tauto. - + rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H). - - absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi. - - absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho. - - destruct m. - + simpl in H; tauto. - + destruct o; simpl in H; destruct (in_app_or _ _ _ H). - * absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. - * destruct (in_inv H0). - -- congruence. - -- absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. - * absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. - * absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. + intros l o r. + split. + - rewrite Empty_alt. + split. + + destruct o; auto. + generalize (H 1); simpl; auto. + + split; rewrite Empty_alt; intros. + * generalize (H (xO a)); auto. + * generalize (H (xI a)); auto. + - intros (H,(H0,H1)). + subst. + rewrite Empty_alt; intros. + destruct a; auto. + + simpl; generalize H1; rewrite Empty_alt; auto. + + simpl; generalize H0; rewrite Empty_alt; auto. Qed. - Theorem elements_complete: - forall (m: t A) (i: key) (v: A), - List.In (i, v) (elements m) -> find i m = Some v. - Proof. - intros m i v H. - unfold elements in H. - rewrite find_xfind_h. - exact (xelements_complete i xH m v H). - Qed. - - Lemma cardinal_1 : - forall (m: t A), cardinal m = length (elements m). - Proof. - unfold elements. - intros m; set (p:=1); clearbody p; revert m p. - induction m; simpl; auto; intros. - rewrite (IHm1 (append p 2)), (IHm2 (append p 3)). - destruct o; rewrite length_app; simpl; auto. - Qed. - - End CompcertSpec. - - Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - - Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - - Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. - - Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*A) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). - - #[global] Instance eqk_equiv : Equivalence eq_key := _. - #[global] Instance eqke_equiv : Equivalence eq_key_elt := _. - #[global] Instance ltk_strorder : StrictOrder lt_key := _. - - Lemma mem_find : - forall m x, mem x m = match find x m with None => false | _ => true end. - Proof. - induction m; destruct x; simpl; auto. - Qed. - - Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None. - Proof. - unfold Empty, MapsTo. - intuition. - - generalize (H a). - destruct (find a m); intuition. - elim (H0 a0); auto. - - rewrite H in H0; discriminate. - Qed. - - Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r. - Proof. - intros l o r. - split. - - rewrite Empty_alt. - split. - + destruct o; auto. - generalize (H 1); simpl; auto. - + split; rewrite Empty_alt; intros. - * generalize (H (xO a)); auto. - * generalize (H (xI a)); auto. - - intros (H,(H0,H1)). - subst. - rewrite Empty_alt; intros. - destruct a; auto. - + simpl; generalize H1; rewrite Empty_alt; auto. - + simpl; generalize H0; rewrite Empty_alt; auto. - Qed. - - Section FMapSpec. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - destruct 1 as (e0,H0); rewrite H0; auto. - Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - destruct (find x m). - - exists a; auto. - - intros; discriminate. - Qed. - - Variable m m' m'' : t A. - Variable x y z : key. - Variable e e' : A. - - Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros; rewrite <- H; auto. Qed. - - Lemma find_1 : MapsTo x e m -> find x m = Some e. - Proof. unfold MapsTo; auto. Qed. - - Lemma find_2 : find x m = Some e -> MapsTo x e m. - Proof. red; auto. Qed. - - Lemma empty_1 : Empty empty. - Proof. - rewrite Empty_alt; apply gempty. - Qed. - - Lemma is_empty_1 : Empty m -> is_empty m = true. - Proof. - induction m; simpl; auto. - rewrite Empty_Node. - intros (H,(H0,H1)). - subst; simpl. - rewrite IHt0_1; simpl; auto. - Qed. - - Lemma is_empty_2 : is_empty m = true -> Empty m. - Proof. - induction m; simpl; auto. - - rewrite Empty_alt. - intros _; exact gempty. - - rewrite Empty_Node. - destruct o. - + intros; discriminate. - + intro H; destruct (andb_prop _ _ H); intuition. - Qed. - - Lemma add_1 : E.eq x y -> MapsTo y e (add x e m). - Proof. - unfold MapsTo. - intro H; rewrite H; clear H. - apply gss. - Qed. - - Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. - unfold MapsTo. - intros; rewrite gso; auto. - Qed. - - Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. - unfold MapsTo. - intro H; rewrite gso; auto. - Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x m). - Proof. - intros; intro. - generalize (mem_1 H0). - rewrite mem_find. - red in H. - rewrite H. - rewrite grs. - intros; discriminate. - Qed. - - Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. - unfold MapsTo. - intro H; rewrite gro; auto. - Qed. - - Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - Proof. - unfold MapsTo. - destruct (E.eq_dec x y). - - subst. - rewrite grs; intros; discriminate. - - rewrite gro; auto. - Qed. - - Lemma elements_1 : - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. - unfold MapsTo. - rewrite InA_alt. - intro H. - exists (x,e). - split. - - red; simpl; unfold E.eq; auto. - - apply elements_correct; auto. - Qed. - - Lemma elements_2 : - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. - unfold MapsTo. - rewrite InA_alt. - intros ((e0,a),(H,H0)). - red in H; simpl in H; unfold E.eq in H; destruct H; subst. - apply elements_complete; auto. - Qed. - - Lemma xelements_bits_lt_1 : forall p p0 q m v, - List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. - Proof using. - intros. - generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 H. - induction p; destruct p0; simpl; intros; eauto; try discriminate. - Qed. - - Lemma xelements_bits_lt_2 : forall p p0 q m v, - List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. - Proof using. - intros. - generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 H. - induction p; destruct p0; simpl; intros; eauto; try discriminate. - Qed. - - Lemma xelements_sort : forall p, sort lt_key (xelements m p). - Proof. - induction m. - - simpl; auto. - - destruct o; simpl; intros. - + (* Some *) - apply (SortA_app (eqA:=eq_key_elt)). 1-2: auto with typeclass_instances. - * constructor; auto. - apply In_InfA; intros. - destruct y0. - red; red; simpl. - eapply xelements_bits_lt_2; eauto. - * intros x0 y0. - do 2 rewrite InA_alt. - intros (y1,(Hy1,H)) (y2,(Hy2,H0)). - destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. - destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. - red; red; simpl. - destruct H0. - -- injection H0 as [= H0 _]; subst. - eapply xelements_bits_lt_1; eauto. - -- apply E.bits_lt_trans with p. - ++ eapply xelements_bits_lt_1; eauto. - ++ eapply xelements_bits_lt_2; eauto. - + (* None *) - apply (SortA_app (eqA:=eq_key_elt)). - { auto with typeclass_instances. } 1-2: auto. - intros x0 y0. - do 2 rewrite InA_alt. - intros (y1,(Hy1,H)) (y2,(Hy2,H0)). - destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. - destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. - red; red; simpl. - apply E.bits_lt_trans with p. - * eapply xelements_bits_lt_1; eauto. - * eapply xelements_bits_lt_2; eauto. - Qed. - - Lemma elements_3 : sort lt_key (elements m). - Proof. - unfold elements. - apply xelements_sort; auto. - Qed. - - Lemma elements_3w : NoDupA eq_key (elements m). - Proof. - apply ME.Sort_NoDupA. - apply elements_3. - Qed. - - End FMapSpec. - - (** [map] and [mapi] *) - - Variable B : Type. - - Section Mapi. - - Variable f : key -> A -> B. - - Fixpoint xmapi (m : t A) (i : key) : t B := - match m with - | Leaf => @Leaf B - | Node l o r => Node (xmapi l (append i (xO xH))) - (option_map (f i) o) - (xmapi r (append i (xI xH))) - end. - - Definition mapi m := xmapi m xH. - - End Mapi. - - Definition map (f : A -> B) m := mapi (fun _ => f) m. + Section FMapSpec. + + Lemma mem_1 : forall m x, In x m -> mem x m = true. + Proof. + unfold In, MapsTo; intros m x; rewrite mem_find. + destruct 1 as (e0,H0); rewrite H0; auto. + Qed. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. + Proof. + unfold In, MapsTo; intros m x; rewrite mem_find. + destruct (find x m). + - exists a; auto. + - intros; discriminate. + Qed. + + Variable m m' m'' : t A. + Variable x y z : key. + Variable e e' : A. + + Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. + Proof. intros; rewrite <- H; auto. Qed. + + Lemma find_1 : MapsTo x e m -> find x m = Some e. + Proof. unfold MapsTo; auto. Qed. + + Lemma find_2 : find x m = Some e -> MapsTo x e m. + Proof. red; auto. Qed. + + Lemma empty_1 : Empty empty. + Proof. + rewrite Empty_alt; apply gempty. + Qed. + + Lemma is_empty_1 : Empty m -> is_empty m = true. + Proof. + induction m; simpl; auto. + rewrite Empty_Node. + intros (H,(H0,H1)). + subst; simpl. + rewrite IHt0_1; simpl; auto. + Qed. + + Lemma is_empty_2 : is_empty m = true -> Empty m. + Proof. + induction m; simpl; auto. + - rewrite Empty_alt. + intros _; exact gempty. + - rewrite Empty_Node. + destruct o. + + intros; discriminate. + + intro H; destruct (andb_prop _ _ H); intuition. + Qed. + + Lemma add_1 : E.eq x y -> MapsTo y e (add x e m). + Proof. + unfold MapsTo. + intro H; rewrite H; clear H. + apply gss. + Qed. + + Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Proof. + unfold MapsTo. + intros; rewrite gso; auto. + Qed. + + Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + Proof. + unfold MapsTo. + intro H; rewrite gso; auto. + Qed. + + Lemma remove_1 : E.eq x y -> ~ In y (remove x m). + Proof. + intros; intro. + generalize (mem_1 H0). + rewrite mem_find. + red in H. + rewrite H. + rewrite grs. + intros; discriminate. + Qed. + + Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Proof. + unfold MapsTo. + intro H; rewrite gro; auto. + Qed. + + Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. + Proof. + unfold MapsTo. + destruct (E.eq_dec x y). + - subst. + rewrite grs; intros; discriminate. + - rewrite gro; auto. + Qed. + + Lemma elements_1 : + MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Proof. + unfold MapsTo. + rewrite InA_alt. + intro H. + exists (x,e). + split. + - red; simpl; unfold E.eq; auto. + - apply elements_correct; auto. + Qed. + + Lemma elements_2 : + InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + Proof. + unfold MapsTo. + rewrite InA_alt. + intros ((e0,a),(H,H0)). + red in H; simpl in H; unfold E.eq in H; destruct H; subst. + apply elements_complete; auto. + Qed. + + Lemma xelements_bits_lt_1 : forall p p0 q m v, + List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. + Proof using. + intros. + generalize (xelements_complete _ _ _ _ H); clear H; intros. + revert p0 H. + induction p; destruct p0; simpl; intros; eauto; try discriminate. + Qed. + + Lemma xelements_bits_lt_2 : forall p p0 q m v, + List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. + Proof using. + intros. + generalize (xelements_complete _ _ _ _ H); clear H; intros. + revert p0 H. + induction p; destruct p0; simpl; intros; eauto; try discriminate. + Qed. + + Lemma xelements_sort : forall p, sort lt_key (xelements m p). + Proof. + induction m. + - simpl; auto. + - destruct o; simpl; intros. + + (* Some *) + apply (SortA_app (eqA:=eq_key_elt)). 1-2: auto with typeclass_instances. + * constructor; auto. + apply In_InfA; intros. + destruct y0. + red; red; simpl. + eapply xelements_bits_lt_2; eauto. + * intros x0 y0. + do 2 rewrite InA_alt. + intros (y1,(Hy1,H)) (y2,(Hy2,H0)). + destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. + destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. + red; red; simpl. + destruct H0. + -- injection H0 as [= H0 _]; subst. + eapply xelements_bits_lt_1; eauto. + -- apply E.bits_lt_trans with p. + ++ eapply xelements_bits_lt_1; eauto. + ++ eapply xelements_bits_lt_2; eauto. + + (* None *) + apply (SortA_app (eqA:=eq_key_elt)). + { auto with typeclass_instances. } 1-2: auto. + intros x0 y0. + do 2 rewrite InA_alt. + intros (y1,(Hy1,H)) (y2,(Hy2,H0)). + destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. + destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. + red; red; simpl. + apply E.bits_lt_trans with p. + * eapply xelements_bits_lt_1; eauto. + * eapply xelements_bits_lt_2; eauto. + Qed. + + Lemma elements_3 : sort lt_key (elements m). + Proof. + unfold elements. + apply xelements_sort; auto. + Qed. + + Lemma elements_3w : NoDupA eq_key (elements m). + Proof. + apply ME.Sort_NoDupA. + apply elements_3. + Qed. + + End FMapSpec. + + (** [map] and [mapi] *) + + Variable B : Type. + + Section Mapi. + + Variable f : key -> A -> B. + + Fixpoint xmapi (m : t A) (i : key) : t B := + match m with + | Leaf => @Leaf B + | Node l o r => Node (xmapi l (append i (xO xH))) + (option_map (f i) o) + (xmapi r (append i (xI xH))) + end. + + Definition mapi m := xmapi m xH. + + End Mapi. + + Definition map (f : A -> B) m := mapi (fun _ => f) m. End A. @@ -753,21 +753,21 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A), find i (xmapi f m j) = option_map (f (append j i)) (find i m). Proof. - induction i; intros; destruct m; simpl; auto. - - rewrite (append_assoc_1 j i); apply IHi. - - rewrite (append_assoc_0 j i); apply IHi. - - rewrite (append_neutral_r j); auto. + induction i; intros; destruct m; simpl; auto. + - rewrite (append_assoc_1 j i); apply IHi. + - rewrite (append_assoc_0 j i); apply IHi. + - rewrite (append_neutral_r j); auto. Qed. Theorem gmapi: forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), find i (mapi f m) = option_map (f i) (find i m). Proof. - intros. - unfold mapi. - replace (f i) with (f (append xH i)). - - apply xgmapi. - - rewrite append_neutral_l; auto. + intros. + unfold mapi. + replace (f i) with (f (append xH i)). + - apply xgmapi. + - rewrite append_neutral_l; auto. Qed. Lemma mapi_1 : @@ -775,90 +775,90 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. - intros. - exists x. - split; [red; auto|]. - apply find_2. - generalize (find_1 H); clear H; intros. - rewrite gmapi. - rewrite H. - simpl; auto. + intros. + exists x. + split; [red; auto|]. + apply find_2. + generalize (find_1 H); clear H; intros. + rewrite gmapi. + rewrite H. + simpl; auto. Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros. - apply mem_2. - rewrite mem_find. - destruct H as (v,H). - generalize (find_1 H); clear H; intros. - rewrite gmapi in H. - destruct (find x m); auto. - simpl in *; discriminate. + intros. + apply mem_2. + rewrite mem_find. + destruct H as (v,H). + generalize (find_1 H); clear H; intros. + rewrite gmapi in H. + destruct (find x m); auto. + simpl in *; discriminate. Qed. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. - intros; unfold map. - destruct (mapi_1 (fun _ => f) H); intuition. + intros; unfold map. + destruct (mapi_1 (fun _ => f) H); intuition. Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros; unfold map in *; eapply mapi_2; eauto. + intros; unfold map in *; eapply mapi_2; eauto. Qed. Section map2. - Variable A B C : Type. - Variable f : option A -> option B -> option C. + Variable A B C : Type. + Variable f : option A -> option B -> option C. - Arguments Leaf {A}. + Arguments Leaf {A}. - Fixpoint xmap2_l (m : t A) : t C := - match m with - | Leaf => Leaf - | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) - end. + Fixpoint xmap2_l (m : t A) : t C := + match m with + | Leaf => Leaf + | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) + end. - Lemma xgmap2_l : forall (i : key) (m : t A), - f None None = None -> find i (xmap2_l m) = f (find i m) None. - Proof. - induction i; intros; destruct m; simpl; auto. - Qed. + Lemma xgmap2_l : forall (i : key) (m : t A), + f None None = None -> find i (xmap2_l m) = f (find i m) None. + Proof. + induction i; intros; destruct m; simpl; auto. + Qed. - Fixpoint xmap2_r (m : t B) : t C := - match m with - | Leaf => Leaf - | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) + Fixpoint xmap2_r (m : t B) : t C := + match m with + | Leaf => Leaf + | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) + end. + + Lemma xgmap2_r : forall (i : key) (m : t B), + f None None = None -> find i (xmap2_r m) = f None (find i m). + Proof. + induction i; intros; destruct m; simpl; auto. + Qed. + + Fixpoint _map2 (m1 : t A)(m2 : t B) : t C := + match m1 with + | Leaf => xmap2_r m2 + | Node l1 o1 r1 => + match m2 with + | Leaf => xmap2_l m1 + | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2) + end end. - Lemma xgmap2_r : forall (i : key) (m : t B), - f None None = None -> find i (xmap2_r m) = f None (find i m). - Proof. - induction i; intros; destruct m; simpl; auto. - Qed. - - Fixpoint _map2 (m1 : t A)(m2 : t B) : t C := - match m1 with - | Leaf => xmap2_r m2 - | Node l1 o1 r1 => - match m2 with - | Leaf => xmap2_l m1 - | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2) - end - end. - - Lemma gmap2: forall (i: key)(m1:t A)(m2: t B), - f None None = None -> - find i (_map2 m1 m2) = f (find i m1) (find i m2). - Proof. - induction i; intros; destruct m1; destruct m2; simpl; auto; - try apply xgmap2_r; try apply xgmap2_l; auto. - Qed. + Lemma gmap2: forall (i: key)(m1:t A)(m2: t B), + f None None = None -> + find i (_map2 m1 m2) = f (find i m1) (find i m2). + Proof. + induction i; intros; destruct m1; destruct m2; simpl; auto; + try apply xgmap2_r; try apply xgmap2_l; auto. + Qed. End map2. @@ -870,30 +870,30 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. - intros. - unfold map2. - rewrite gmap2; auto. - generalize (@mem_1 _ m x) (@mem_1 _ m' x). - do 2 rewrite mem_find. - destruct (find x m); simpl; auto. - destruct (find x m'); simpl; auto. - intros. - destruct H; intuition; try discriminate. + intros. + unfold map2. + rewrite gmap2; auto. + generalize (@mem_1 _ m x) (@mem_1 _ m' x). + do 2 rewrite mem_find. + destruct (find x m); simpl; auto. + destruct (find x m'); simpl; auto. + intros. + destruct H; intuition; try discriminate. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. - intros. - generalize (mem_1 H); clear H; intros. - rewrite mem_find in H. - unfold map2 in H. - rewrite gmap2 in H; auto. - generalize (@mem_2 _ m x) (@mem_2 _ m' x). - do 2 rewrite mem_find. - destruct (find x m); simpl in *; auto. - destruct (find x m'); simpl in *; auto. + intros. + generalize (mem_1 H); clear H; intros. + rewrite mem_find in H. + unfold map2 in H. + rewrite gmap2 in H; auto. + generalize (@mem_2 _ m x) (@mem_2 _ m' x). + do 2 rewrite mem_find. + destruct (find x m); simpl in *; auto. + destruct (find x m'); simpl in *; auto. Qed. @@ -963,108 +963,108 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), Equivb cmp m m' -> equal cmp m m' = true. Proof. - induction m. - - (* m = Leaf *) - destruct 1. - simpl. - apply is_empty_1. - red; red; intros. - assert (In a (Leaf A)). - + rewrite H. - exists e; auto. - + destruct H2; red in H2. - destruct a; simpl in *; discriminate. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) + induction m. + - (* m = Leaf *) destruct 1. simpl. - destruct o. - * assert (In xH (Leaf A)). - { rewrite <- H. - exists a; red; auto. } - destruct H1; red in H1; simpl in H1; discriminate. - * apply andb_true_intro; split; apply is_empty_1; red; red; intros. - -- assert (In (xO a) (Leaf A)). { - rewrite <- H. - exists e; auto. - } - destruct H2; red in H2; simpl in H2; discriminate. - -- assert (In (xI a) (Leaf A)). { - rewrite <- H. - exists e; auto. - } - destruct H2; red in H2; simpl in H2; discriminate. - + (* m' = Node *) - destruct 1. - assert (Equivb cmp m1 m'1). { - split. - - intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. - - intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. - } - assert (Equivb cmp m2 m'2). { - split. - - intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. - - intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. - } - simpl. - destruct o; destruct o0; simpl. - * repeat (apply andb_true_intro; split); auto. - apply (H0 xH); red; auto. - * generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H4; try discriminate; eauto. - * generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H5; try discriminate; eauto. - * apply andb_true_intro; split; auto. + apply is_empty_1. + red; red; intros. + assert (In a (Leaf A)). + + rewrite H. + exists e; auto. + + destruct H2; red in H2. + destruct a; simpl in *; discriminate. + - (* m = Node *) + destruct m'. + + (* m' = Leaf *) + destruct 1. + simpl. + destruct o. + * assert (In xH (Leaf A)). + { rewrite <- H. + exists a; red; auto. } + destruct H1; red in H1; simpl in H1; discriminate. + * apply andb_true_intro; split; apply is_empty_1; red; red; intros. + -- assert (In (xO a) (Leaf A)). { + rewrite <- H. + exists e; auto. + } + destruct H2; red in H2; simpl in H2; discriminate. + -- assert (In (xI a) (Leaf A)). { + rewrite <- H. + exists e; auto. + } + destruct H2; red in H2; simpl in H2; discriminate. + + (* m' = Node *) + destruct 1. + assert (Equivb cmp m1 m'1). { + split. + - intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. + - intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. + } + assert (Equivb cmp m2 m'2). { + split. + - intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. + - intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. + } + simpl. + destruct o; destruct o0; simpl. + * repeat (apply andb_true_intro; split); auto. + apply (H0 xH); red; auto. + * generalize (H xH); unfold In, MapsTo; simpl; intuition. + destruct H4; try discriminate; eauto. + * generalize (H xH); unfold In, MapsTo; simpl; intuition. + destruct H5; try discriminate; eauto. + * apply andb_true_intro; split; auto. Qed. Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), equal cmp m m' = true -> Equivb cmp m m'. Proof. - induction m. - - (* m = Leaf *) - simpl. - split; intros. - + split. - * destruct 1; red in H0; destruct k; discriminate. - * destruct 1; elim (is_empty_2 H H0). - + red in H0; destruct k; discriminate. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) + induction m. + - (* m = Leaf *) simpl. - destruct o; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. split; intros. - * split; unfold In, MapsTo; destruct 1. - -- destruct k; simpl in *; try discriminate. - ++ destruct (is_empty_2 H1 (find_2 _ _ H)). - ++ destruct (is_empty_2 H0 (find_2 _ _ H)). - -- destruct k; simpl in *; discriminate. - * unfold In, MapsTo; destruct k; simpl in *; discriminate. - + (* m' = Node *) - destruct o; destruct o0; simpl; intros; try discriminate. - * destruct (andb_prop _ _ H); clear H. - destruct (andb_prop _ _ H0); clear H0. - destruct (IHm1 _ _ H2); clear H2 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - -- destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - -- destruct k; unfold In, MapsTo in *; simpl in *. - ++ eapply H4; eauto. - ++ eapply H3; eauto. - ++ congruence. - * destruct (andb_prop _ _ H); clear H. - destruct (IHm1 _ _ H0); clear H0 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. + + split. + * destruct 1; red in H0; destruct k; discriminate. + * destruct 1; elim (is_empty_2 H H0). + + red in H0; destruct k; discriminate. + - (* m = Node *) + destruct m'. + + (* m' = Leaf *) + simpl. + destruct o; intros; try discriminate. + destruct (andb_prop _ _ H); clear H. split; intros. - -- destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - -- destruct k; unfold In, MapsTo in *; simpl in *. - ++ eapply H3; eauto. - ++ eapply H2; eauto. - ++ try discriminate. + * split; unfold In, MapsTo; destruct 1. + -- destruct k; simpl in *; try discriminate. + ++ destruct (is_empty_2 H1 (find_2 _ _ H)). + ++ destruct (is_empty_2 H0 (find_2 _ _ H)). + -- destruct k; simpl in *; discriminate. + * unfold In, MapsTo; destruct k; simpl in *; discriminate. + + (* m' = Node *) + destruct o; destruct o0; simpl; intros; try discriminate. + * destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H0); clear H0. + destruct (IHm1 _ _ H2); clear H2 IHm1. + destruct (IHm2 _ _ H1); clear H1 IHm2. + split; intros. + -- destruct k; unfold In, MapsTo in *; simpl; auto. + split; eauto. + -- destruct k; unfold In, MapsTo in *; simpl in *. + ++ eapply H4; eauto. + ++ eapply H3; eauto. + ++ congruence. + * destruct (andb_prop _ _ H); clear H. + destruct (IHm1 _ _ H0); clear H0 IHm1. + destruct (IHm2 _ _ H1); clear H1 IHm2. + split; intros. + -- destruct k; unfold In, MapsTo in *; simpl; auto. + split; eauto. + -- destruct k; unfold In, MapsTo in *; simpl in *. + ++ eapply H3; eauto. + ++ eapply H2; eauto. + ++ try discriminate. Qed. End PositiveMap. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index e15686715f..6e30459b21 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -20,989 +20,989 @@ Unset Strict Implicit. Module Raw (X:DecidableType). -Module Import PX := KeyDecidableType X. - -Definition key := X.t. -Definition t (elt:Type) := list (X.t * elt). - -Section Elt. - -Variable elt : Type. - -Notation eqk := (eqk (elt:=elt)). -Notation eqke := (eqke (elt:=elt)). -Notation MapsTo := (MapsTo (elt:=elt)). -Notation In := (In (elt:=elt)). -Notation NoDupA := (NoDupA eqk). - -(** * [empty] *) - -Definition empty : t elt := nil. - -Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m. - -Lemma empty_1 : Empty empty. -Proof. - unfold Empty,empty. - intros a e. - intro abs. - inversion abs. -Qed. - -#[local] -Hint Resolve empty_1 : core. - -Lemma empty_NoDup : NoDupA empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. -Proof. - unfold Empty, PX.MapsTo. - intros m. - case m;auto. - intros p l inlist. - destruct p. - absurd (InA eqke (t0, e) ((t0, e) :: l));auto. -Qed. - -Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. - intros m. - case m;auto. - intros p l abs. - inversion abs. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) {struct s} : bool := - match s with - | nil => false - | (k',_) :: l => if X.eq_dec k k' then true else mem k l - end. - -Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. -Proof. - intros m Hm x; generalize Hm; clear Hm. - induction m; simpl; intros NoDup belong1. - - inversion belong1. inversion H. - - destruct a; destruct X.eq_dec; [reflexivity|]; apply IHm. - + inversion_clear NoDup; assumption. - + inversion_clear belong1; inversion_clear H; [elim n; apply H0|exists x0; auto]. -Qed. - -Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. -Proof. - intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. - induction m; intros NoDup hyp; try discriminate; simpl in *. - destruct a, X.eq_dec. - + exists e; constructor; split; [assumption|reflexivity]. - + destruct IHm as [e' He']. - - inversion_clear NoDup; assumption. - - assumption. - - exists e'; auto. -Qed. - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) {struct s} : option elt := - match s with - | nil => None - | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' - end. - -Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. - intros m x. unfold PX.MapsTo. - induction m; simpl;intros e' eqfind; inversion eqfind; auto. - destruct a, X.eq_dec. - + constructor; split; simpl; congruence. - + constructor 2; apply IHm; assumption. -Qed. - -Lemma find_1 : forall m (Hm:NoDupA m) x e, - MapsTo x e m -> find x m = Some e. -Proof. - intros m; induction m as [|[a e]]; simpl; intros Hdup x e' Hm. - - inversion Hm. - - inversion_clear Hdup. - inversion_clear Hm; destruct X.eq_dec. - + destruct H1; simpl in *; congruence. - + elim n; apply H1. - + elim H; apply InA_eqk with (x,e'); auto. - + apply IHm; auto. -Qed. - -(* Not part of the exported specifications, used later for [combine]. *) - -Lemma find_eq : forall m (Hm:NoDupA m) x x', - X.eq x x' -> find x m = find x' m. -Proof. - induction m; simpl; auto; destruct a; intros. - inversion_clear Hm. - rewrite (IHm H1 x x'); auto. - destruct (X.eq_dec x t0) as [|Hneq]; destruct (X.eq_dec x' t0) as [|?Hneq']; - trivial. - - elim Hneq'; apply X.eq_trans with x; auto. - - elim Hneq; apply X.eq_trans with x'; auto. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l - end. - -Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. - induction m as [|[a m]]; intros x y e He; simpl in *; auto. - destruct X.eq_dec; [now auto|]. - apply InA_cons_tl, IHm, He. -Qed. - -Lemma add_2 : forall m x y e e', - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. - induction m as [|[a m]]; intros x y e e' H Hm; simpl in *. - - inversion_clear Hm. - - inversion_clear Hm; destruct X.eq_dec. - + elim H; apply X.eq_trans with a; [auto|apply X.eq_sym; apply H0]. - + apply InA_cons_hd; apply H0. - + apply InA_cons_tl; assumption. - + apply InA_cons_tl; apply IHm; auto. -Qed. - -Lemma add_3 : forall m x y e e', - ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. - induction m as [|[a m]]; intros x y e e' H Hm. - - exfalso; inversion_clear Hm. - + elim H; apply X.eq_sym; apply H0. - + inversion_clear H0. - - simpl in Hm; destruct X.eq_dec. - + apply InA_cons_tl; apply InA_cons in Hm; destruct Hm; [|now auto]. - elim H; apply X.eq_sym; apply H0. - + apply InA_cons in Hm; destruct Hm. - * apply InA_cons_hd; auto. - * apply InA_cons_tl; eapply IHm; eauto. -Qed. - -Lemma add_3' : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. -Proof. - induction m as [|[a m]]; intros x y e e' H Hm; simpl in *. - - inversion_clear Hm; [|now auto]. - compute in H0; elim H; auto. - - destruct X.eq_dec; simpl in *. - + apply InA_cons in Hm; destruct Hm; [elim H; apply X.eq_sym; apply H0|]. - apply InA_cons_tl; auto. - + apply InA_cons in Hm; destruct Hm; [apply InA_cons_hd; auto|]. - apply InA_cons_tl; eapply IHm; eauto. -Qed. - -Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). -Proof. - induction m. - - simpl; constructor; auto; red; inversion 1. - - intros. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. - + constructor; auto. - contradict H. - apply InA_eqk with (x,e); auto. - + constructor; auto. - contradict H; apply add_3' with x e; auto. -Qed. - -(* Not part of the exported specifications, used later for [combine]. *) - -Lemma add_eq : forall m (Hm:NoDupA m) x a e, - X.eq x a -> find x (add a e m) = Some e. -Proof. - intros. - apply find_1; auto. - - apply add_NoDup; auto. - - apply add_1; auto. -Qed. - -Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, - ~X.eq x a -> find x (add a e m) = find x m. -Proof. - intros. - case_eq (find x m); intros. - - apply find_1; auto. - + apply add_NoDup; auto. - + apply add_2; auto. - apply find_2; auto. - - case_eq (find x (add a e m)); intros; auto. - rewrite <- H0; symmetry. - apply find_1; auto. - apply add_3 with a e; auto. - apply find_2; auto. -Qed. - - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := - match s with - | nil => nil - | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. - -Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). -Proof. - induction m as [|[a m]]; intros Hm x y H; simpl in *. - - - inversion 1; inversion H1. - - - inversion_clear Hm. - destruct X.eq_dec. - + intros [e' ?]; elim H0. - apply InA_eqk with (y, e'). - * apply X.eq_trans with x; [|auto]. - apply X.eq_sym; auto. - * apply InA_eqke_eqk; auto. - + intros [e' H2]; apply InA_cons in H2; destruct H2. - * elim n; apply X.eq_trans with y; [auto|apply H2]. - * elim IHm with x y; auto. - exists e'; auto. -Qed. - -Lemma remove_2 : forall m (Hm:NoDupA m) x y e, - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. - induction m as [|[a m]]; intros Hm x y e H He; simpl in *. - + inversion_clear He. - + apply InA_cons in He; destruct He, X.eq_dec. - - elim H; apply X.eq_trans with a; [auto|]; apply X.eq_sym; apply H0. - - inversion_clear Hm; apply InA_cons_hd; assumption. - - apply H0. - - inversion_clear Hm. - apply InA_cons; destruct (X.eq_dec y a). - * elim H1; apply InA_eqk with (y, e); [assumption|]; apply InA_eqke_eqk; auto. - * right; apply IHm; auto. -Qed. - -Lemma remove_3 : forall m (Hm:NoDupA m) x y e, - MapsTo y e (remove x m) -> MapsTo y e m. -Proof. - induction m as [|[a m]]; intros Hm x y e H; unfold PX.MapsTo; simpl in *; auto. - destruct X.eq_dec. - - apply InA_cons_tl; apply H. - - inversion_clear Hm; apply InA_cons in H; destruct H; [apply InA_cons_hd; auto|]. - apply InA_cons_tl; apply IHm with x; auto. -Qed. - -Lemma remove_3' : forall m (Hm:NoDupA m) x y e, - InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. -Proof. - induction m as [|[a m]]; intros Hm x y e H; unfold PX.MapsTo; simpl in *. - - inversion_clear H. - - destruct X.eq_dec. - + apply InA_cons_tl; auto. - + apply InA_cons in H; destruct H; [apply InA_cons_hd; auto|]. - inversion_clear Hm; apply InA_cons_tl; apply IHm with x; auto. -Qed. - -Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). -Proof. - induction m. - - simpl; intuition. - - intros. - inversion_clear Hm. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); auto. - constructor; auto. - contradict H; apply remove_3' with x; auto. -Qed. - -(** * [elements] *) - -Definition elements (m: t elt) := m. - -Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). -Proof. - auto. -Qed. - -Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. -auto. -Qed. - -Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). -Proof. - auto. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. - induction m as [|[a m]]; intros A i f; simpl; auto. -Qed. - -(** * [equal] *) - -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with - | None => false - | Some e' => cmp e e' - end. - -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - -Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). - -Definition Submap cmp m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. -Proof. - unfold Submap, submap. - induction m. - - simpl; auto. - - destruct a; simpl; intros. - destruct H. - inversion_clear Hm. - assert (H3 : In t0 m'). - + apply H; exists e; auto. - + destruct H3 as (e', H3). - unfold check at 2; rewrite (find_1 Hm' H3). - rewrite (H0 t0); simpl; auto. - eapply IHm; auto. - split; intuition. - * apply H. - destruct H5 as (e'',H5); exists e''; auto. - * apply H0 with k; auto. -Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. -Proof. - unfold Submap, submap. - induction m. - - simpl; auto. - intuition. - + destruct H0; inversion H0. - + inversion H0. - - - destruct a; simpl; intros. - inversion_clear Hm. - rewrite andb_b_true in H. - assert (check cmp t0 e m' = true). - + clear H1 H0 Hm' IHm. - set (b:=check cmp t0 e m') in *. - generalize H; clear H; generalize b; clear b. - induction m; simpl; auto; intros. - destruct a; simpl in *. - destruct (andb_prop _ _ (IHm _ H)); auto. - + rewrite H2 in H. - destruct (IHm H1 m' Hm' cmp H); auto. - unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; - rewrite H5 in H2; try discriminate. - split; intros. - * destruct H6 as (e0,H6); inversion_clear H6. - -- compute in H7; destruct H7; subst. - exists e'. - apply PX.MapsTo_eq with t0; auto. + Module Import PX := KeyDecidableType X. + + Definition key := X.t. + Definition t (elt:Type) := list (X.t * elt). + + Section Elt. + + Variable elt : Type. + + Notation eqk := (eqk (elt:=elt)). + Notation eqke := (eqke (elt:=elt)). + Notation MapsTo := (MapsTo (elt:=elt)). + Notation In := (In (elt:=elt)). + Notation NoDupA := (NoDupA eqk). + + (** * [empty] *) + + Definition empty : t elt := nil. + + Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m. + + Lemma empty_1 : Empty empty. + Proof. + unfold Empty,empty. + intros a e. + intro abs. + inversion abs. + Qed. + + #[local] + Hint Resolve empty_1 : core. + + Lemma empty_NoDup : NoDupA empty. + Proof. + unfold empty; auto. + Qed. + + (** * [is_empty] *) + + Definition is_empty (l : t elt) : bool := if l then true else false. + + Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. + Proof. + unfold Empty, PX.MapsTo. + intros m. + case m;auto. + intros p l inlist. + destruct p. + absurd (InA eqke (t0, e) ((t0, e) :: l));auto. + Qed. + + Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. + Proof. + intros m. + case m;auto. + intros p l abs. + inversion abs. + Qed. + + (** * [mem] *) + + Fixpoint mem (k : key) (s : t elt) {struct s} : bool := + match s with + | nil => false + | (k',_) :: l => if X.eq_dec k k' then true else mem k l + end. + + Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. + Proof. + intros m Hm x; generalize Hm; clear Hm. + induction m; simpl; intros NoDup belong1. + - inversion belong1. inversion H. + - destruct a; destruct X.eq_dec; [reflexivity|]; apply IHm. + + inversion_clear NoDup; assumption. + + inversion_clear belong1; inversion_clear H; [elim n; apply H0|exists x0; auto]. + Qed. + + Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. + Proof. + intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. + induction m; intros NoDup hyp; try discriminate; simpl in *. + destruct a, X.eq_dec. + + exists e; constructor; split; [assumption|reflexivity]. + + destruct IHm as [e' He']. + - inversion_clear NoDup; assumption. + - assumption. + - exists e'; auto. + Qed. + + (** * [find] *) + + Fixpoint find (k:key) (s: t elt) {struct s} : option elt := + match s with + | nil => None + | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' + end. + + Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. + Proof. + intros m x. unfold PX.MapsTo. + induction m; simpl;intros e' eqfind; inversion eqfind; auto. + destruct a, X.eq_dec. + + constructor; split; simpl; congruence. + + constructor 2; apply IHm; assumption. + Qed. + + Lemma find_1 : forall m (Hm:NoDupA m) x e, + MapsTo x e m -> find x m = Some e. + Proof. + intros m; induction m as [|[a e]]; simpl; intros Hdup x e' Hm. + - inversion Hm. + - inversion_clear Hdup. + inversion_clear Hm; destruct X.eq_dec. + + destruct H1; simpl in *; congruence. + + elim n; apply H1. + + elim H; apply InA_eqk with (x,e'); auto. + + apply IHm; auto. + Qed. + + (* Not part of the exported specifications, used later for [combine]. *) + + Lemma find_eq : forall m (Hm:NoDupA m) x x', + X.eq x x' -> find x m = find x' m. + Proof. + induction m; simpl; auto; destruct a; intros. + inversion_clear Hm. + rewrite (IHm H1 x x'); auto. + destruct (X.eq_dec x t0) as [|Hneq]; destruct (X.eq_dec x' t0) as [|?Hneq']; + trivial. + - elim Hneq'; apply X.eq_trans with x; auto. + - elim Hneq; apply X.eq_trans with x'; auto. + Qed. + + (** * [add] *) + + Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l + end. + + Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). + Proof. + induction m as [|[a m]]; intros x y e He; simpl in *; auto. + destruct X.eq_dec; [now auto|]. + apply InA_cons_tl, IHm, He. + Qed. + + Lemma add_2 : forall m x y e e', + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Proof. + induction m as [|[a m]]; intros x y e e' H Hm; simpl in *. + - inversion_clear Hm. + - inversion_clear Hm; destruct X.eq_dec. + + elim H; apply X.eq_trans with a; [auto|apply X.eq_sym; apply H0]. + + apply InA_cons_hd; apply H0. + + apply InA_cons_tl; assumption. + + apply InA_cons_tl; apply IHm; auto. + Qed. + + Lemma add_3 : forall m x y e e', + ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + Proof. + induction m as [|[a m]]; intros x y e e' H Hm. + - exfalso; inversion_clear Hm. + + elim H; apply X.eq_sym; apply H0. + + inversion_clear H0. + - simpl in Hm; destruct X.eq_dec. + + apply InA_cons_tl; apply InA_cons in Hm; destruct Hm; [|now auto]. + elim H; apply X.eq_sym; apply H0. + + apply InA_cons in Hm; destruct Hm. + * apply InA_cons_hd; auto. + * apply InA_cons_tl; eapply IHm; eauto. + Qed. + + Lemma add_3' : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. + Proof. + induction m as [|[a m]]; intros x y e e' H Hm; simpl in *. + - inversion_clear Hm; [|now auto]. + compute in H0; elim H; auto. + - destruct X.eq_dec; simpl in *. + + apply InA_cons in Hm; destruct Hm; [elim H; apply X.eq_sym; apply H0|]. + apply InA_cons_tl; auto. + + apply InA_cons in Hm; destruct Hm; [apply InA_cons_hd; auto|]. + apply InA_cons_tl; eapply IHm; eauto. + Qed. + + Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). + Proof. + induction m. + - simpl; constructor; auto; red; inversion 1. + - intros. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. + + constructor; auto. + contradict H. + apply InA_eqk with (x,e); auto. + + constructor; auto. + contradict H; apply add_3' with x e; auto. + Qed. + + (* Not part of the exported specifications, used later for [combine]. *) + + Lemma add_eq : forall m (Hm:NoDupA m) x a e, + X.eq x a -> find x (add a e m) = Some e. + Proof. + intros. + apply find_1; auto. + - apply add_NoDup; auto. + - apply add_1; auto. + Qed. + + Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, + ~X.eq x a -> find x (add a e m) = find x m. + Proof. + intros. + case_eq (find x m); intros. + - apply find_1; auto. + + apply add_NoDup; auto. + + apply add_2; auto. apply find_2; auto. - -- apply H3. - exists e0; auto. - * inversion_clear H6. - -- compute in H8; destruct H8; subst. - rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence. - -- apply H4 with k; auto. -Qed. - -(** Specification of [equal] *) - -Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. - unfold Equivb, equal. - intuition. - apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. -Qed. - -Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, - equal cmp m m' = true -> Equivb cmp m m'. -Proof. - unfold Equivb, equal. - intros. - destruct (andb_prop _ _ H); clear H. - generalize (submap_2 Hm Hm' H0). - generalize (submap_2 Hm' Hm H1). - firstorder. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work + - case_eq (find x (add a e m)); intros; auto. + rewrite <- H0; symmetry. + apply find_1; auto. + apply add_3 with a e; auto. + apply find_2; auto. + Qed. + + + (** * [remove] *) + + Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := + match s with + | nil => nil + | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l + end. + + Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). + Proof. + induction m as [|[a m]]; intros Hm x y H; simpl in *. + + - inversion 1; inversion H1. + + - inversion_clear Hm. + destruct X.eq_dec. + + intros [e' ?]; elim H0. + apply InA_eqk with (y, e'). + * apply X.eq_trans with x; [|auto]. + apply X.eq_sym; auto. + * apply InA_eqke_eqk; auto. + + intros [e' H2]; apply InA_cons in H2; destruct H2. + * elim n; apply X.eq_trans with y; [auto|apply H2]. + * elim IHm with x y; auto. + exists e'; auto. + Qed. + + Lemma remove_2 : forall m (Hm:NoDupA m) x y e, + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Proof. + induction m as [|[a m]]; intros Hm x y e H He; simpl in *. + + inversion_clear He. + + apply InA_cons in He; destruct He, X.eq_dec. + - elim H; apply X.eq_trans with a; [auto|]; apply X.eq_sym; apply H0. + - inversion_clear Hm; apply InA_cons_hd; assumption. + - apply H0. + - inversion_clear Hm. + apply InA_cons; destruct (X.eq_dec y a). + * elim H1; apply InA_eqk with (y, e); [assumption|]; apply InA_eqke_eqk; auto. + * right; apply IHm; auto. + Qed. + + Lemma remove_3 : forall m (Hm:NoDupA m) x y e, + MapsTo y e (remove x m) -> MapsTo y e m. + Proof. + induction m as [|[a m]]; intros Hm x y e H; unfold PX.MapsTo; simpl in *; auto. + destruct X.eq_dec. + - apply InA_cons_tl; apply H. + - inversion_clear Hm; apply InA_cons in H; destruct H; [apply InA_cons_hd; auto|]. + apply InA_cons_tl; apply IHm with x; auto. + Qed. + + Lemma remove_3' : forall m (Hm:NoDupA m) x y e, + InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. + Proof. + induction m as [|[a m]]; intros Hm x y e H; unfold PX.MapsTo; simpl in *. + - inversion_clear H. + - destruct X.eq_dec. + + apply InA_cons_tl; auto. + + apply InA_cons in H; destruct H; [apply InA_cons_hd; auto|]. + inversion_clear Hm; apply InA_cons_tl; apply IHm with x; auto. + Qed. + + Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). + Proof. + induction m. + - simpl; intuition. + - intros. + inversion_clear Hm. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); auto. + constructor; auto. + contradict H; apply remove_3' with x; auto. + Qed. + + (** * [elements] *) + + Definition elements (m: t elt) := m. + + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). + Proof. + auto. + Qed. + + Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. + Proof. + auto. + Qed. + + Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). + Proof. + auto. + Qed. + + (** * [fold] *) + + Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := + match m with + | nil => acc + | (k,e)::m' => fold f m' (f k e acc) + end. + + Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + Proof. + induction m as [|[a m]]; intros A i f; simpl; auto. + Qed. + + (** * [equal] *) + + Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := + match find k m' with + | None => false + | Some e' => cmp e e' + end. + + Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + + Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). + + Definition Submap cmp m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + + Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + + Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Submap cmp m m' -> submap cmp m m' = true. + Proof. + unfold Submap, submap. + induction m. + - simpl; auto. + - destruct a; simpl; intros. + destruct H. + inversion_clear Hm. + assert (H3 : In t0 m'). + + apply H; exists e; auto. + + destruct H3 as (e', H3). + unfold check at 2; rewrite (find_1 Hm' H3). + rewrite (H0 t0); simpl; auto. + eapply IHm; auto. + split; intuition. + * apply H. + destruct H5 as (e'',H5); exists e''; auto. + * apply H0 with k; auto. + Qed. + + Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + submap cmp m m' = true -> Submap cmp m m'. + Proof. + unfold Submap, submap. + induction m. + - simpl; auto. + intuition. + + destruct H0; inversion H0. + + inversion H0. + + - destruct a; simpl; intros. + inversion_clear Hm. + rewrite andb_b_true in H. + assert (check cmp t0 e m' = true). + + clear H1 H0 Hm' IHm. + set (b:=check cmp t0 e m') in *. + generalize H; clear H; generalize b; clear b. + induction m; simpl; auto; intros. + destruct a; simpl in *. + destruct (andb_prop _ _ (IHm _ H)); auto. + + rewrite H2 in H. + destruct (IHm H1 m' Hm' cmp H); auto. + unfold check in H2. + case_eq (find t0 m'); [intros e' H5 | intros H5]; + rewrite H5 in H2; try discriminate. + split; intros. + * destruct H6 as (e0,H6); inversion_clear H6. + -- compute in H7; destruct H7; subst. + exists e'. + apply PX.MapsTo_eq with t0; auto. + apply find_2; auto. + -- apply H3. + exists e0; auto. + * inversion_clear H6. + -- compute in H8; destruct H8; subst. + rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence. + -- apply H4 with k; auto. + Qed. + + (** Specification of [equal] *) + + Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold Equivb, equal. + intuition. + apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. + Qed. + + Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, + equal cmp m m' = true -> Equivb cmp m m'. + Proof. + unfold Equivb, equal. + intros. + destruct (andb_prop _ _ H); clear H. + generalize (submap_2 Hm Hm' H0). + generalize (submap_2 Hm' Hm H1). + firstorder. + Qed. + + Variable elt':Type. + + (** * [map] and [mapi] *) + + Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f e) :: map f m' + end. + + Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + + End Elt. + Section Elt2. + (* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - intros m x e f. - (* functional induction map elt elt' f m. *) (* Marche pas ??? *) - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + constructor 2. - unfold MapsTo in *; auto. -Qed. - -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. -Proof. - intros m x f. - (* functional induction map elt elt' f m. *) (* Marche pas ??? *) - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), - NoDupA (@eqk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - contradict H. - (* il faut un map_1 avec eqk au lieu de eqke *) - clear IHm H0. - induction m; simpl in *; auto. - - inversion H. - - destruct a; inversion H; auto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> - exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - intros m x e f. - (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + exists x'. - destruct H0; simpl in *. - split; auto. - constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + destruct IHm as (y, hyp); auto. - exists y; intuition. -Qed. - -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), - In x (mapi f m) -> In x m. -Proof. - intros m x f. - (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), - NoDupA (@eqk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - - inversion_clear H. - - destruct a; inversion_clear H; auto. -Qed. - -End Elt2. -Section Elt3. - -Variable elt elt' elt'' : Type. - -Notation oee' := (option elt * option elt')%type. - -Definition combine_l (m:t elt)(m':t elt') : t oee' := - mapi (fun k e => (Some e, find k m')) m. - -Definition combine_r (m:t elt)(m':t elt') : t oee' := - mapi (fun k e' => (find k m, Some e')) m'. - -Definition fold_right_pair (A B C:Type)(f:A->B->C->C) := - List.fold_right (fun p => f (fst p) (snd p)). - -Definition combine (m:t elt)(m':t elt') : t oee' := - let l := combine_l m m' in - let r := combine_r m m' in - fold_right_pair (add (elt:=oee')) r l. - -Lemma fold_right_pair_NoDup : - forall l r (Hl: NoDupA (eqk (elt:=oee')) l) - (Hl: NoDupA (eqk (elt:=oee')) r), - NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) r l). -Proof. - induction l; simpl; auto. - destruct a; simpl; auto. - inversion_clear 1. - intros; apply add_NoDup; auto. -Qed. -#[local] -Hint Resolve fold_right_pair_NoDup : core. - -Lemma combine_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), - NoDupA (@eqk oee') (combine m m'). -Proof. - unfold combine, combine_r, combine_l. - intros. - set (f1 := fun (k : key) (e : elt) => (Some e, find k m')). - set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')). - generalize (mapi_NoDup Hm f1). - generalize (mapi_NoDup Hm' f2). - set (l := mapi f1 m); clearbody l. - set (r := mapi f2 m'); clearbody r. - auto. -Qed. - -Definition at_least_left (o:option elt)(o':option elt') := - match o with - | None => None - | _ => Some (o,o') - end. - -Definition at_least_right (o:option elt)(o':option elt') := - match o' with - | None => None - | _ => Some (o,o') - end. - -Lemma combine_l_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_l m m') = at_least_left (find x m) (find x m'). -Proof. - unfold combine_l. - intros. - case_eq (find x m); intros. - - simpl. - apply find_1. - + apply mapi_NoDup; auto. - + destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)). - rewrite (find_eq Hm' (X.eq_sym H0)); auto. - - simpl. - case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto. - destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))). - + exists p; apply find_2; auto. - + rewrite (find_1 Hm H1) in H; discriminate. -Qed. - -Lemma combine_r_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_r m m') = at_least_right (find x m) (find x m'). -Proof. - unfold combine_r. - intros. - case_eq (find x m'); intros. - - simpl. - apply find_1. - + apply mapi_NoDup; auto. - + destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)). - rewrite (find_eq Hm (X.eq_sym H0)); auto. - - simpl. - case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto. - destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))). - + exists p; apply find_2; auto. - + rewrite (find_1 Hm' H1) in H; discriminate. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - unfold combine. - intros. - generalize (combine_r_1 Hm Hm' x). - generalize (combine_l_1 Hm Hm' x). - assert (NoDupA (eqk (elt:=oee')) (combine_l m m')). { - unfold combine_l; apply mapi_NoDup; auto. - } - assert (NoDupA (eqk (elt:=oee')) (combine_r m m')). { - unfold combine_r; apply mapi_NoDup; auto. - } - set (l := combine_l m m') in *; clearbody l. - set (r := combine_r m m') in *; clearbody r. - set (o := find x m); clearbody o. - set (o' := find x m'); clearbody o'. - clear Hm' Hm m m'. - induction l. - - destruct o; destruct o'; simpl; intros; discriminate || auto. - - destruct a; simpl in *; intros. - destruct (X.eq_dec x t0); simpl in *. - + unfold at_least_left in H1. - destruct o; simpl in *; try discriminate. - inversion H1; subst. - apply add_eq; auto. - inversion_clear H; auto. - + inversion_clear H. - rewrite <- IHl; auto. - apply add_not_eq; auto. -Qed. - -Variable f : option elt -> option elt' -> option elt''. - -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Definition map2 m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) nil m1. - -Lemma map2_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), - NoDupA (@eqk elt'') (map2 m m'). -Proof. - intros. - unfold map2. - assert (H0:=combine_NoDup Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun p : oee' => f (fst p) (snd p)). - assert (H1:=map_NoDup (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. - clear f' f H0 l0 Hm Hm' m m'. - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; simpl; auto. - constructor; auto. - contradict H. - clear IHl1. - induction l1. - + inversion H. - + inversion_clear H0. - destruct a; destruct o; simpl in *; auto. - inversion_clear H; auto. -Qed. - -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f o o' - end. - -Lemma map2_0 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). -Proof. - intros. - unfold map2. - assert (H:=combine_1 Hm Hm' x). - assert (H2:=combine_NoDup Hm Hm'). - set (f':= fun p : oee' => f (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. - generalize H; clear H. - match goal with |- ?m=?n -> ?p=?q => - assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. - induction m0; simpl in *; intuition. - - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.eq_dec x k) as [|Hneq]; simpl in *. - + (* x = k *) - assert (at_least_one_then_f o o' = f oo oo'). - * destruct o; destruct o'; simpl in *; inversion_clear H; auto. - * rewrite H2. - unfold f'; simpl. - destruct (f oo oo'); simpl. - -- destruct (X.eq_dec x k) as [|Hneq]; try contradict Hneq; auto. - -- destruct (IHm0 H1) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - elim H0. - apply InA_eqk with (x,p); auto. - apply InA_eqke_eqk. - exact (find_2 H3). - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * destruct (X.eq_dec x k); [ contradict Hneq; auto | auto]. - destruct (IHm0 H1) as (H3,_); apply H3; auto. - * destruct (IHm0 H1) as (H3,_); apply H3; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.eq_dec x k) as [|Hneq]. - + (* x = k *) - discriminate. - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * destruct (X.eq_dec x k); [ contradict Hneq; auto | auto]. - destruct (IHm0 H1) as (_,H4); apply H4; auto. - * destruct (IHm0 H1) as (_,H4); apply H4; auto. -Qed. - -(** Specification of [map2] *) -Lemma map2_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). -Proof. - intros. - rewrite map2_0; auto. - destruct H as [(e,H)|(e,H)]. - - rewrite (find_1 Hm H). - destruct (find x m'); simpl; auto. - - rewrite (find_1 Hm' H). - destruct (find x m); simpl; auto. -Qed. - -Lemma map2_2 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - generalize (map2_0 Hm Hm' x). - rewrite (find_1 (map2_NoDup Hm Hm') H). - generalize (@find_2 _ m x). - generalize (@find_2 _ m' x). - destruct (find x m); - destruct (find x m'); simpl; intros. - - left; exists e0; auto. - - left; exists e0; auto. - - right; exists e0; auto. - - discriminate. -Qed. - -End Elt3. + Variable elt elt' : Type. + + (** Specification of [map] *) + + Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). + Proof. + intros m x e f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m. + - inversion 1. + + - destruct a as (x',e'). + simpl. + inversion_clear 1. + + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + + constructor 2. + unfold MapsTo in *; auto. + Qed. + + Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. + Proof. + intros m x f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + - intros (e,abs). + inversion abs. + + - destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + + destruct IHm as (e'',hyp). + * exists e'; auto. + * exists e''. + constructor 2; auto. + Qed. + + Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), + NoDupA (@eqk elt') (map f m). + Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + contradict H. + (* il faut un map_1 avec eqk au lieu de eqke *) + clear IHm H0. + induction m; simpl in *; auto. + - inversion H. + - destruct a; inversion H; auto. + Qed. + + (** Specification of [mapi] *) + + Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> + exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). + Proof. + intros m x e f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m. + - inversion 1. + + - destruct a as (x',e'). + simpl. + inversion_clear 1. + + exists x'. + destruct H0; simpl in *. + split; auto. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + + destruct IHm as (y, hyp); auto. + exists y; intuition. + Qed. + + Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), + In x (mapi f m) -> In x m. + Proof. + intros m x f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + - intros (e,abs). + inversion abs. + + - destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + + destruct IHm as (e'',hyp). + * exists e'; auto. + * exists e''. + constructor 2; auto. + Qed. + + Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), + NoDupA (@eqk elt') (mapi f m). + Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. + constructor; auto. + contradict H. + clear IHm H0. + induction m; simpl in *; auto. + - inversion_clear H. + - destruct a; inversion_clear H; auto. + Qed. + + End Elt2. + Section Elt3. + + Variable elt elt' elt'' : Type. + + Notation oee' := (option elt * option elt')%type. + + Definition combine_l (m:t elt)(m':t elt') : t oee' := + mapi (fun k e => (Some e, find k m')) m. + + Definition combine_r (m:t elt)(m':t elt') : t oee' := + mapi (fun k e' => (find k m, Some e')) m'. + + Definition fold_right_pair (A B C:Type)(f:A->B->C->C) := + List.fold_right (fun p => f (fst p) (snd p)). + + Definition combine (m:t elt)(m':t elt') : t oee' := + let l := combine_l m m' in + let r := combine_r m m' in + fold_right_pair (add (elt:=oee')) r l. + + Lemma fold_right_pair_NoDup : + forall l r (Hl: NoDupA (eqk (elt:=oee')) l) + (Hl: NoDupA (eqk (elt:=oee')) r), + NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) r l). + Proof. + induction l; simpl; auto. + destruct a; simpl; auto. + inversion_clear 1. + intros; apply add_NoDup; auto. + Qed. + #[local] + Hint Resolve fold_right_pair_NoDup : core. + + Lemma combine_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), + NoDupA (@eqk oee') (combine m m'). + Proof. + unfold combine, combine_r, combine_l. + intros. + set (f1 := fun (k : key) (e : elt) => (Some e, find k m')). + set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')). + generalize (mapi_NoDup Hm f1). + generalize (mapi_NoDup Hm' f2). + set (l := mapi f1 m); clearbody l. + set (r := mapi f2 m'); clearbody r. + auto. + Qed. + + Definition at_least_left (o:option elt)(o':option elt') := + match o with + | None => None + | _ => Some (o,o') + end. + + Definition at_least_right (o:option elt)(o':option elt') := + match o' with + | None => None + | _ => Some (o,o') + end. + + Lemma combine_l_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_l m m') = at_least_left (find x m) (find x m'). + Proof. + unfold combine_l. + intros. + case_eq (find x m); intros. + - simpl. + apply find_1. + + apply mapi_NoDup; auto. + + destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)). + rewrite (find_eq Hm' (X.eq_sym H0)); auto. + - simpl. + case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto. + destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))). + + exists p; apply find_2; auto. + + rewrite (find_1 Hm H1) in H; discriminate. + Qed. + + Lemma combine_r_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_r m m') = at_least_right (find x m) (find x m'). + Proof. + unfold combine_r. + intros. + case_eq (find x m'); intros. + - simpl. + apply find_1. + + apply mapi_NoDup; auto. + + destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)). + rewrite (find_eq Hm (X.eq_sym H0)); auto. + - simpl. + case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto. + destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))). + + exists p; apply find_2; auto. + + rewrite (find_1 Hm' H1) in H; discriminate. + Qed. + + Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + + Lemma combine_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). + Proof. + unfold combine. + intros. + generalize (combine_r_1 Hm Hm' x). + generalize (combine_l_1 Hm Hm' x). + assert (NoDupA (eqk (elt:=oee')) (combine_l m m')). { + unfold combine_l; apply mapi_NoDup; auto. + } + assert (NoDupA (eqk (elt:=oee')) (combine_r m m')). { + unfold combine_r; apply mapi_NoDup; auto. + } + set (l := combine_l m m') in *; clearbody l. + set (r := combine_r m m') in *; clearbody r. + set (o := find x m); clearbody o. + set (o' := find x m'); clearbody o'. + clear Hm' Hm m m'. + induction l. + - destruct o; destruct o'; simpl; intros; discriminate || auto. + - destruct a; simpl in *; intros. + destruct (X.eq_dec x t0); simpl in *. + + unfold at_least_left in H1. + destruct o; simpl in *; try discriminate. + inversion H1; subst. + apply add_eq; auto. + inversion_clear H; auto. + + inversion_clear H. + rewrite <- IHl; auto. + apply add_not_eq; auto. + Qed. + + Variable f : option elt -> option elt' -> option elt''. + + Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + + Definition map2 m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) nil m1. + + Lemma map2_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), + NoDupA (@eqk elt'') (map2 m m'). + Proof. + intros. + unfold map2. + assert (H0:=combine_NoDup Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun p : oee' => f (fst p) (snd p)). + assert (H1:=map_NoDup (elt' := option elt'') H0 f'). + set (l1:=map f' l0) in *; clearbody l1. + clear f' f H0 l0 Hm Hm' m m'. + induction l1. + - simpl; auto. + - inversion_clear H1. + destruct a; destruct o; simpl; auto. + constructor; auto. + contradict H. + clear IHl1. + induction l1. + + inversion H. + + inversion_clear H0. + destruct a; destruct o; simpl in *; auto. + inversion_clear H; auto. + Qed. + + Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f o o' + end. + + Lemma map2_0 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). + Proof. + intros. + unfold map2. + assert (H:=combine_1 Hm Hm' x). + assert (H2:=combine_NoDup Hm Hm'). + set (f':= fun p : oee' => f (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. + generalize H; clear H. + match goal with |- ?m=?n -> ?p=?q => + assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. + induction m0; simpl in *; intuition. + - destruct o; destruct o'; simpl in *; try discriminate; auto. + - destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.eq_dec x k) as [|Hneq]; simpl in *. + + (* x = k *) + assert (at_least_one_then_f o o' = f oo oo'). + * destruct o; destruct o'; simpl in *; inversion_clear H; auto. + * rewrite H2. + unfold f'; simpl. + destruct (f oo oo'); simpl. + -- destruct (X.eq_dec x k) as [|Hneq]; try contradict Hneq; auto. + -- destruct (IHm0 H1) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + elim H0. + apply InA_eqk with (x,p); auto. + apply InA_eqke_eqk. + exact (find_2 H3). + + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + * destruct (X.eq_dec x k); [ contradict Hneq; auto | auto]. + destruct (IHm0 H1) as (H3,_); apply H3; auto. + * destruct (IHm0 H1) as (H3,_); apply H3; auto. + + - (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.eq_dec x k) as [|Hneq]. + + (* x = k *) + discriminate. + + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + * destruct (X.eq_dec x k); [ contradict Hneq; auto | auto]. + destruct (IHm0 H1) as (_,H4); apply H4; auto. + * destruct (IHm0 H1) as (_,H4); apply H4; auto. + Qed. + + (** Specification of [map2] *) + Lemma map2_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). + Proof. + intros. + rewrite map2_0; auto. + destruct H as [(e,H)|(e,H)]. + - rewrite (find_1 Hm H). + destruct (find x m'); simpl; auto. + - rewrite (find_1 Hm' H). + destruct (find x m); simpl; auto. + Qed. + + Lemma map2_2 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. + Proof. + intros. + destruct H as (e,H). + generalize (map2_0 Hm Hm' x). + rewrite (find_1 (map2_NoDup Hm Hm') H). + generalize (@find_2 _ m x). + generalize (@find_2 _ m' x). + destruct (find x m); + destruct (find x m'); simpl; intros. + - left; exists e0; auto. + - left; exists e0; auto. + - right; exists e0; auto. + - discriminate. + Qed. + + End Elt3. End Raw. Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. - - Module E := X. - Definition key := E.t. - Record slist (elt:Type) := - {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. - Definition t (elt:Type) := slist elt. - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). - Definition is_empty m : bool := Raw.is_empty (this m). - Definition add x e m : t elt := Build_slist (Raw.add_NoDup (NoDup m) x e). - Definition find x m : option elt := Raw.find x (this m). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup (NoDup m) x). - Definition mem x m : bool := Raw.mem x (this m). - Definition map f m : t elt' := Build_slist (Raw.map_NoDup (NoDup m) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup (NoDup m) f). - Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_NoDup f (NoDup m) (NoDup m')). - Definition elements m : list (key*elt) := @Raw.elements elt (this m). - Definition cardinal m := length (this m). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). - Definition In x m : Prop := Raw.PX.In x (this m). - Definition Empty m : Prop := Raw.Empty (this m). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. - - Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt (this m) (NoDup m)). Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt (this m) (NoDup m)). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact (@Raw.empty_1 elt). Qed. - - Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. - Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. - - Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. - Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. - Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. - - Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt (this m) (NoDup m)). Qed. - Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt (this m) (NoDup m)). Qed. - Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt (this m) (NoDup m)). Qed. - - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt (this m) (NoDup m)). Qed. - Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. - - Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. - Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt (this m) (NoDup m)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intros; reflexivity. Qed. - - Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. - - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. - Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. - - End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. - - Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. - Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). - Qed. - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). - Qed. + Module Raw := Raw X. + + Module E := X. + Definition key := E.t. + Record slist (elt:Type) := + {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. + Definition t (elt:Type) := slist elt. + + Section Elt. + Variable elt elt' elt'':Type. + + Implicit Types m : t elt. + Implicit Types x y : key. + Implicit Types e : elt. + + Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Build_slist (Raw.add_NoDup (NoDup m) x e). + Definition find x m : option elt := Raw.find x (this m). + Definition remove x m : t elt := Build_slist (Raw.remove_NoDup (NoDup m) x). + Definition mem x m : bool := Raw.mem x (this m). + Definition map f m : t elt' := Build_slist (Raw.map_NoDup (NoDup m) f). + Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup (NoDup m) f). + Definition map2 f m (m':t elt') : t elt'' := + Build_slist (Raw.map2_NoDup f (NoDup m) (NoDup m')). + Definition elements m : list (key*elt) := @Raw.elements elt (this m). + Definition cardinal m := length (this m). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. + Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). + Definition In x m : Prop := Raw.PX.In x (this m). + Definition Empty m : Prop := Raw.Empty (this m). + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). + + Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. + Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. + + Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. + Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. + + Lemma mem_1 : forall m x, In x m -> mem x m = true. + Proof. intros m; exact (@Raw.mem_1 elt (this m) (NoDup m)). Qed. + Lemma mem_2 : forall m x, mem x m = true -> In x m. + Proof. intros m; exact (@Raw.mem_2 elt (this m) (NoDup m)). Qed. + + Lemma empty_1 : Empty empty. + Proof. exact (@Raw.empty_1 elt). Qed. + + Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. + Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. + Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. + Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. + + Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). + Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. + Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. + Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. + + Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). + Proof. intros m; exact (@Raw.remove_1 elt (this m) (NoDup m)). Qed. + Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Proof. intros m; exact (@Raw.remove_2 elt (this m) (NoDup m)). Qed. + Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. + Proof. intros m; exact (@Raw.remove_3 elt (this m) (NoDup m)). Qed. + + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Proof. intros m; exact (@Raw.find_1 elt (this m) (NoDup m)). Qed. + Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. + Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. + + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. + Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Proof. intros m; exact (@Raw.elements_3w elt (this m) (NoDup m)). Qed. + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). + Proof. intros; reflexivity. Qed. + + Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. + + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. + Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. + + End Elt. + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). + Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. + Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. + + Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) + (f:key->elt->elt'), MapsTo x e m -> + exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). + Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. + Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) + (f:key->elt->elt'), In x (mapi f m) -> In x m. + Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. + + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; + exact (@Raw.map2_1 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). + Qed. + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x (map2 f m m') -> In x m \/ In x m'. + Proof. + intros elt elt' elt'' m m' x f; + exact (@Raw.map2_2 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). + Qed. End Make. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 525a76febd..f66c206c4d 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -117,7 +117,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Proof. - intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). + intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). Qed. Definition cardinal : @@ -250,16 +250,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition choose_aux: forall s : t, { x : elt | M.choose s = Some x } + { M.choose s = None }. Proof. - intros. - destruct (M.choose s); [left | right]; auto. - exists e; auto. + intros. + destruct (M.choose s); [left | right]; auto. + exists e; auto. Qed. Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. Proof. - intros; destruct (choose_aux s) as [(x,Hx)|H]. - - left; exists x; apply choose_1; auto. - - right; apply choose_2; auto. + intros; destruct (choose_aux s) as [(x,Hx)|H]. + - left; exists x; apply choose_1; auto. + - right; apply choose_2; auto. Defined. Lemma choose_ok1 : @@ -294,16 +294,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. | _, _ => False end. Proof. - intros. - generalize (@M.choose_1 s)(@M.choose_2 s) - (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s') - (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s'). - destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros. - - apply H4; auto. - + rewrite H5; exists Hx; auto. - + rewrite H7; exists Hx'; auto. - - apply Hx' with x; unfold Equal in H; rewrite <-H; auto. - - apply Hx with x'; unfold Equal in H; rewrite H; auto. + intros. + generalize (@M.choose_1 s)(@M.choose_2 s) + (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s') + (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s'). + destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros. + - apply H4; auto. + + rewrite H5; exists Hx; auto. + + rewrite H7; exists Hx'; auto. + - apply Hx' with x; unfold Equal in H; rewrite <-H; auto. + - apply Hx with x'; unfold Equal in H; rewrite H; auto. Qed. Definition min_elt : @@ -448,10 +448,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma choose_3 : forall s s' x x', choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. Proof. - unfold choose; intros. - generalize (M.choose_equal H1); clear H1. - destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; - simpl; auto; congruence. + unfold choose; intros. + generalize (M.choose_equal H1); clear H1. + destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; + simpl; auto; congruence. Qed. Definition elements (s : t) : list elt := let (l, _) := elements s in l. diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v index 944770d1bb..fbcb7e7068 100644 --- a/theories/FSets/FSetCompat.v +++ b/theories/FSets/FSetCompat.v @@ -19,149 +19,149 @@ Unset Strict Implicit. (** * From new Weak Sets to old ones *) Module Backport_WSets - (E:DecidableType.DecidableType) - (M:MSetInterface.WSets with Definition E.t := E.t - with Definition E.eq := E.eq) - <: FSetInterface.WSfun E. - - Definition elt := E.t. - Definition t := M.t. - - Implicit Type s : t. - Implicit Type x y : elt. - Implicit Type f : elt -> bool. - - Definition In : elt -> t -> Prop := M.In. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - Definition empty : t := M.empty. - Definition is_empty : t -> bool := M.is_empty. - Definition mem : elt -> t -> bool := M.mem. - Definition add : elt -> t -> t := M.add. - Definition singleton : elt -> t := M.singleton. - Definition remove : elt -> t -> t := M.remove. - Definition union : t -> t -> t := M.union. - Definition inter : t -> t -> t := M.inter. - Definition diff : t -> t -> t := M.diff. - Definition eq : t -> t -> Prop := M.eq. - Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. - Definition equal : t -> t -> bool := M.equal. - Definition subset : t -> t -> bool := M.subset. - Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. - Definition for_all : (elt -> bool) -> t -> bool := M.for_all. - Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. - Definition filter : (elt -> bool) -> t -> t := M.filter. - Definition partition : (elt -> bool) -> t -> t * t:= M.partition. - Definition cardinal : t -> nat := M.cardinal. - Definition elements : t -> list elt := M.elements. - Definition choose : t -> option elt := M.choose. - - Module MF := MSetFacts.WFacts M. - - Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s - := MF.In_1. - Definition eq_refl : forall s, eq s s - := @Equivalence_Reflexive _ _ M.eq_equiv. - Definition eq_sym : forall s s', eq s s' -> eq s' s - := @Equivalence_Symmetric _ _ M.eq_equiv. - Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s'' - := @Equivalence_Transitive _ _ M.eq_equiv. - Definition mem_1 : forall s x, In x s -> mem x s = true - := MF.mem_1. - Definition mem_2 : forall s x, mem x s = true -> In x s - := MF.mem_2. - Definition equal_1 : forall s s', Equal s s' -> equal s s' = true - := MF.equal_1. - Definition equal_2 : forall s s', equal s s' = true -> Equal s s' - := MF.equal_2. - Definition subset_1 : forall s s', Subset s s' -> subset s s' = true - := MF.subset_1. - Definition subset_2 : forall s s', subset s s' = true -> Subset s s' - := MF.subset_2. - Definition empty_1 : Empty empty := MF.empty_1. - Definition is_empty_1 : forall s, Empty s -> is_empty s = true - := MF.is_empty_1. - Definition is_empty_2 : forall s, is_empty s = true -> Empty s - := MF.is_empty_2. - Definition add_1 : forall s x y, E.eq x y -> In y (add x s) - := MF.add_1. - Definition add_2 : forall s x y, In y s -> In y (add x s) - := MF.add_2. - Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s - := MF.add_3. - Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s) - := MF.remove_1. - Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s) - := MF.remove_2. - Definition remove_3 : forall s x y, In y (remove x s) -> In y s - := MF.remove_3. - Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s' - := MF.union_1. - Definition union_2 : forall s s' x, In x s -> In x (union s s') - := MF.union_2. - Definition union_3 : forall s s' x, In x s' -> In x (union s s') - := MF.union_3. - Definition inter_1 : forall s s' x, In x (inter s s') -> In x s - := MF.inter_1. - Definition inter_2 : forall s s' x, In x (inter s s') -> In x s' - := MF.inter_2. - Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s') - := MF.inter_3. - Definition diff_1 : forall s s' x, In x (diff s s') -> In x s - := MF.diff_1. - Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s' - := MF.diff_2. - Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s') - := MF.diff_3. - Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y - := MF.singleton_1. - Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x) - := MF.singleton_2. - Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i - := MF.fold_1. - Definition cardinal_1 : forall s, cardinal s = length (elements s) - := MF.cardinal_1. - Definition filter_1 : forall s x f, compat_bool E.eq f -> - In x (filter f s) -> In x s - := MF.filter_1. - Definition filter_2 : forall s x f, compat_bool E.eq f -> - In x (filter f s) -> f x = true - := MF.filter_2. - Definition filter_3 : forall s x f, compat_bool E.eq f -> - In x s -> f x = true -> In x (filter f s) - := MF.filter_3. - Definition for_all_1 : forall s f, compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true - := MF.for_all_1. - Definition for_all_2 : forall s f, compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s - := MF.for_all_2. - Definition exists_1 : forall s f, compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true - := MF.exists_1. - Definition exists_2 : forall s f, compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s - := MF.exists_2. - Definition partition_1 : forall s f, compat_bool E.eq f -> - Equal (fst (partition f s)) (filter f s) - := MF.partition_1. - Definition partition_2 : forall s f, compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) - := MF.partition_2. - Definition choose_1 : forall s x, choose s = Some x -> In x s - := MF.choose_1. - Definition choose_2 : forall s, choose s = None -> Empty s - := MF.choose_2. - Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s) - := MF.elements_1. - Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s - := MF.elements_2. - Definition elements_3w : forall s, NoDupA E.eq (elements s) - := MF.elements_3w. + (E:DecidableType.DecidableType) + (M:MSetInterface.WSets with Definition E.t := E.t + with Definition E.eq := E.eq) + <: FSetInterface.WSfun E. + + Definition elt := E.t. + Definition t := M.t. + + Implicit Type s : t. + Implicit Type x y : elt. + Implicit Type f : elt -> bool. + + Definition In : elt -> t -> Prop := M.In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + Definition empty : t := M.empty. + Definition is_empty : t -> bool := M.is_empty. + Definition mem : elt -> t -> bool := M.mem. + Definition add : elt -> t -> t := M.add. + Definition singleton : elt -> t := M.singleton. + Definition remove : elt -> t -> t := M.remove. + Definition union : t -> t -> t := M.union. + Definition inter : t -> t -> t := M.inter. + Definition diff : t -> t -> t := M.diff. + Definition eq : t -> t -> Prop := M.eq. + Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. + Definition equal : t -> t -> bool := M.equal. + Definition subset : t -> t -> bool := M.subset. + Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. + Definition for_all : (elt -> bool) -> t -> bool := M.for_all. + Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. + Definition filter : (elt -> bool) -> t -> t := M.filter. + Definition partition : (elt -> bool) -> t -> t * t:= M.partition. + Definition cardinal : t -> nat := M.cardinal. + Definition elements : t -> list elt := M.elements. + Definition choose : t -> option elt := M.choose. + + Module MF := MSetFacts.WFacts M. + + Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s + := MF.In_1. + Definition eq_refl : forall s, eq s s + := @Equivalence_Reflexive _ _ M.eq_equiv. + Definition eq_sym : forall s s', eq s s' -> eq s' s + := @Equivalence_Symmetric _ _ M.eq_equiv. + Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s'' + := @Equivalence_Transitive _ _ M.eq_equiv. + Definition mem_1 : forall s x, In x s -> mem x s = true + := MF.mem_1. + Definition mem_2 : forall s x, mem x s = true -> In x s + := MF.mem_2. + Definition equal_1 : forall s s', Equal s s' -> equal s s' = true + := MF.equal_1. + Definition equal_2 : forall s s', equal s s' = true -> Equal s s' + := MF.equal_2. + Definition subset_1 : forall s s', Subset s s' -> subset s s' = true + := MF.subset_1. + Definition subset_2 : forall s s', subset s s' = true -> Subset s s' + := MF.subset_2. + Definition empty_1 : Empty empty := MF.empty_1. + Definition is_empty_1 : forall s, Empty s -> is_empty s = true + := MF.is_empty_1. + Definition is_empty_2 : forall s, is_empty s = true -> Empty s + := MF.is_empty_2. + Definition add_1 : forall s x y, E.eq x y -> In y (add x s) + := MF.add_1. + Definition add_2 : forall s x y, In y s -> In y (add x s) + := MF.add_2. + Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s + := MF.add_3. + Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s) + := MF.remove_1. + Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s) + := MF.remove_2. + Definition remove_3 : forall s x y, In y (remove x s) -> In y s + := MF.remove_3. + Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s' + := MF.union_1. + Definition union_2 : forall s s' x, In x s -> In x (union s s') + := MF.union_2. + Definition union_3 : forall s s' x, In x s' -> In x (union s s') + := MF.union_3. + Definition inter_1 : forall s s' x, In x (inter s s') -> In x s + := MF.inter_1. + Definition inter_2 : forall s s' x, In x (inter s s') -> In x s' + := MF.inter_2. + Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s') + := MF.inter_3. + Definition diff_1 : forall s s' x, In x (diff s s') -> In x s + := MF.diff_1. + Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s' + := MF.diff_2. + Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s') + := MF.diff_3. + Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y + := MF.singleton_1. + Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x) + := MF.singleton_2. + Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i + := MF.fold_1. + Definition cardinal_1 : forall s, cardinal s = length (elements s) + := MF.cardinal_1. + Definition filter_1 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> In x s + := MF.filter_1. + Definition filter_2 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> f x = true + := MF.filter_2. + Definition filter_3 : forall s x f, compat_bool E.eq f -> + In x s -> f x = true -> In x (filter f s) + := MF.filter_3. + Definition for_all_1 : forall s f, compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true + := MF.for_all_1. + Definition for_all_2 : forall s f, compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s + := MF.for_all_2. + Definition exists_1 : forall s f, compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true + := MF.exists_1. + Definition exists_2 : forall s f, compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s + := MF.exists_2. + Definition partition_1 : forall s f, compat_bool E.eq f -> + Equal (fst (partition f s)) (filter f s) + := MF.partition_1. + Definition partition_2 : forall s f, compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) + := MF.partition_2. + Definition choose_1 : forall s x, choose s = Some x -> In x s + := MF.choose_1. + Definition choose_2 : forall s, choose s = None -> Empty s + := MF.choose_2. + Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s) + := MF.elements_1. + Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s + := MF.elements_2. + Definition elements_3w : forall s, NoDupA E.eq (elements s) + := MF.elements_3w. End Backport_WSets. @@ -169,53 +169,53 @@ End Backport_WSets. (** * From new Sets to new ones *) Module Backport_Sets - (O:OrderedType.OrderedType) - (M:MSetInterface.Sets with Definition E.t := O.t - with Definition E.eq := O.eq - with Definition E.lt := O.lt) - <: FSetInterface.S with Module E:=O. - - Include Backport_WSets O M. - - Implicit Type s : t. - Implicit Type x y : elt. - - Definition lt : t -> t -> Prop := M.lt. - Definition min_elt : t -> option elt := M.min_elt. - Definition max_elt : t -> option elt := M.max_elt. - Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s - := M.min_elt_spec1. - Definition min_elt_2 : forall s x y, - min_elt s = Some x -> In y s -> ~ O.lt y x - := M.min_elt_spec2. - Definition min_elt_3 : forall s, min_elt s = None -> Empty s - := M.min_elt_spec3. - Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s - := M.max_elt_spec1. - Definition max_elt_2 : forall s x y, - max_elt s = Some x -> In y s -> ~ O.lt x y - := M.max_elt_spec2. - Definition max_elt_3 : forall s, max_elt s = None -> Empty s - := M.max_elt_spec3. - Definition elements_3 : forall s, sort O.lt (elements s) - := M.elements_spec2. - Definition choose_3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y - := M.choose_spec3. - Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' - := @StrictOrder_Transitive _ _ M.lt_strorder. - Lemma lt_not_eq : forall s s', lt s s' -> ~ eq s s'. - Proof. - unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt. - apply (StrictOrder_Irreflexive s'); auto. - Qed. - Definition compare : forall s s', Compare lt eq s s'. - Proof. - intros s s'; destruct (CompSpec2Type (M.compare_spec s s')); - [ apply EQ | apply LT | apply GT ]; auto. - Defined. - - Module E := O. + (O:OrderedType.OrderedType) + (M:MSetInterface.Sets with Definition E.t := O.t + with Definition E.eq := O.eq + with Definition E.lt := O.lt) + <: FSetInterface.S with Module E:=O. + + Include Backport_WSets O M. + + Implicit Type s : t. + Implicit Type x y : elt. + + Definition lt : t -> t -> Prop := M.lt. + Definition min_elt : t -> option elt := M.min_elt. + Definition max_elt : t -> option elt := M.max_elt. + Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s + := M.min_elt_spec1. + Definition min_elt_2 : forall s x y, + min_elt s = Some x -> In y s -> ~ O.lt y x + := M.min_elt_spec2. + Definition min_elt_3 : forall s, min_elt s = None -> Empty s + := M.min_elt_spec3. + Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s + := M.max_elt_spec1. + Definition max_elt_2 : forall s x y, + max_elt s = Some x -> In y s -> ~ O.lt x y + := M.max_elt_spec2. + Definition max_elt_3 : forall s, max_elt s = None -> Empty s + := M.max_elt_spec3. + Definition elements_3 : forall s, sort O.lt (elements s) + := M.elements_spec2. + Definition choose_3 : forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y + := M.choose_spec3. + Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' + := @StrictOrder_Transitive _ _ M.lt_strorder. + Lemma lt_not_eq : forall s s', lt s s' -> ~ eq s s'. + Proof. + unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt. + apply (StrictOrder_Irreflexive s'); auto. + Qed. + Definition compare : forall s s', Compare lt eq s s'. + Proof. + intros s s'; destruct (CompSpec2Type (M.compare_spec s s')); + [ apply EQ | apply LT | apply GT ]; auto. + Defined. + + Module E := O. End Backport_Sets. @@ -223,124 +223,124 @@ End Backport_Sets. (** * From old Weak Sets to new ones. *) Module Update_WSets - (E:Equalities.DecidableType) - (M:FSetInterface.WS with Definition E.t := E.t - with Definition E.eq := E.eq) - <: MSetInterface.WSetsOn E. - - Definition elt := E.t. - Definition t := M.t. - - Implicit Type s : t. - Implicit Type x y : elt. - Implicit Type f : elt -> bool. - - Definition In : elt -> t -> Prop := M.In. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - Definition empty : t := M.empty. - Definition is_empty : t -> bool := M.is_empty. - Definition mem : elt -> t -> bool := M.mem. - Definition add : elt -> t -> t := M.add. - Definition singleton : elt -> t := M.singleton. - Definition remove : elt -> t -> t := M.remove. - Definition union : t -> t -> t := M.union. - Definition inter : t -> t -> t := M.inter. - Definition diff : t -> t -> t := M.diff. - Definition eq : t -> t -> Prop := M.eq. - Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. - Definition equal : t -> t -> bool := M.equal. - Definition subset : t -> t -> bool := M.subset. - Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. - Definition for_all : (elt -> bool) -> t -> bool := M.for_all. - Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. - Definition filter : (elt -> bool) -> t -> t := M.filter. - Definition partition : (elt -> bool) -> t -> t * t:= M.partition. - Definition cardinal : t -> nat := M.cardinal. - Definition elements : t -> list elt := M.elements. - Definition choose : t -> option elt := M.choose. - - Module MF := FSetFacts.WFacts M. - -#[global] - Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. - Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed. - -#[global] - Instance eq_equiv : Equivalence eq := _. - - Section Spec. - Variable s s': t. - Variable x y : elt. - - Lemma mem_spec : mem x s = true <-> In x s. - Proof. intros; symmetry; apply MF.mem_iff. Qed. - - Lemma equal_spec : equal s s' = true <-> Equal s s'. - Proof. intros; symmetry; apply MF.equal_iff. Qed. - - Lemma subset_spec : subset s s' = true <-> Subset s s'. - Proof. intros; symmetry; apply MF.subset_iff. Qed. - - Definition empty_spec : Empty empty := M.empty_1. - - Lemma is_empty_spec : is_empty s = true <-> Empty s. - Proof. intros; symmetry; apply MF.is_empty_iff. Qed. - - Declare Equivalent Keys In M.In. - - Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. - Proof. intros. rewrite MF.add_iff. intuition. Qed. - - Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. - Proof. intros. rewrite MF.remove_iff. intuition. Qed. - - Lemma singleton_spec : In y (singleton x) <-> E.eq y x. - Proof. intros; rewrite MF.singleton_iff. intuition. Qed. - - Definition union_spec : In x (union s s') <-> In x s \/ In x s' - := @MF.union_iff s s' x. - Definition inter_spec : In x (inter s s') <-> In x s /\ In x s' - := @MF.inter_iff s s' x. - Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s' - := @MF.diff_iff s s' x. - Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i - := @M.fold_1 s. - Definition cardinal_spec : cardinal s = length (elements s) - := @M.cardinal_1 s. - - Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. - Proof. intros; symmetry; apply MF.elements_iff. Qed. - - Definition elements_spec2w : NoDupA E.eq (elements s) - := @M.elements_3w s. - Definition choose_spec1 : choose s = Some x -> In x s - := @M.choose_1 s x. - Definition choose_spec2 : choose s = None -> Empty s - := @M.choose_2 s. - Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f -> - (In x (filter f s) <-> In x s /\ f x = true) - := @MF.filter_iff s x. - Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f -> - Equal (fst (partition f s)) (filter f s) - := @M.partition_1 s. - Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) - := @M.partition_2 s. - - Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed. - - Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. intros; symmetry; apply MF.exists_iff; auto. Qed. - - End Spec. + (E:Equalities.DecidableType) + (M:FSetInterface.WS with Definition E.t := E.t + with Definition E.eq := E.eq) + <: MSetInterface.WSetsOn E. + + Definition elt := E.t. + Definition t := M.t. + + Implicit Type s : t. + Implicit Type x y : elt. + Implicit Type f : elt -> bool. + + Definition In : elt -> t -> Prop := M.In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + Definition empty : t := M.empty. + Definition is_empty : t -> bool := M.is_empty. + Definition mem : elt -> t -> bool := M.mem. + Definition add : elt -> t -> t := M.add. + Definition singleton : elt -> t := M.singleton. + Definition remove : elt -> t -> t := M.remove. + Definition union : t -> t -> t := M.union. + Definition inter : t -> t -> t := M.inter. + Definition diff : t -> t -> t := M.diff. + Definition eq : t -> t -> Prop := M.eq. + Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. + Definition equal : t -> t -> bool := M.equal. + Definition subset : t -> t -> bool := M.subset. + Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. + Definition for_all : (elt -> bool) -> t -> bool := M.for_all. + Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. + Definition filter : (elt -> bool) -> t -> t := M.filter. + Definition partition : (elt -> bool) -> t -> t * t:= M.partition. + Definition cardinal : t -> nat := M.cardinal. + Definition elements : t -> list elt := M.elements. + Definition choose : t -> option elt := M.choose. + + Module MF := FSetFacts.WFacts M. + + #[global] + Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. + Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed. + + #[global] + Instance eq_equiv : Equivalence eq := _. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + Lemma mem_spec : mem x s = true <-> In x s. + Proof. intros; symmetry; apply MF.mem_iff. Qed. + + Lemma equal_spec : equal s s' = true <-> Equal s s'. + Proof. intros; symmetry; apply MF.equal_iff. Qed. + + Lemma subset_spec : subset s s' = true <-> Subset s s'. + Proof. intros; symmetry; apply MF.subset_iff. Qed. + + Definition empty_spec : Empty empty := M.empty_1. + + Lemma is_empty_spec : is_empty s = true <-> Empty s. + Proof. intros; symmetry; apply MF.is_empty_iff. Qed. + + Declare Equivalent Keys In M.In. + + Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Proof. intros. rewrite MF.add_iff. intuition. Qed. + + Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Proof. intros. rewrite MF.remove_iff. intuition. Qed. + + Lemma singleton_spec : In y (singleton x) <-> E.eq y x. + Proof. intros; rewrite MF.singleton_iff. intuition. Qed. + + Definition union_spec : In x (union s s') <-> In x s \/ In x s' + := @MF.union_iff s s' x. + Definition inter_spec : In x (inter s s') <-> In x s /\ In x s' + := @MF.inter_iff s s' x. + Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s' + := @MF.diff_iff s s' x. + Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i + := @M.fold_1 s. + Definition cardinal_spec : cardinal s = length (elements s) + := @M.cardinal_1 s. + + Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. + Proof. intros; symmetry; apply MF.elements_iff. Qed. + + Definition elements_spec2w : NoDupA E.eq (elements s) + := @M.elements_3w s. + Definition choose_spec1 : choose s = Some x -> In x s + := @M.choose_1 s x. + Definition choose_spec2 : choose s = None -> Empty s + := @M.choose_2 s. + Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (In x (filter f s) <-> In x s /\ f x = true) + := @MF.filter_iff s x. + Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f -> + Equal (fst (partition f s)) (filter f s) + := @M.partition_1 s. + Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) + := @M.partition_2 s. + + Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed. + + Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. intros; symmetry; apply MF.exists_iff; auto. Qed. + + End Spec. End Update_WSets. @@ -348,74 +348,74 @@ End Update_WSets. (** * From old Sets to new ones. *) Module Update_Sets - (O:Orders.OrderedType) - (M:FSetInterface.S with Definition E.t := O.t - with Definition E.eq := O.eq - with Definition E.lt := O.lt) - <: MSetInterface.Sets with Module E:=O. - - Include Update_WSets O M. - - Implicit Type s : t. - Implicit Type x y : elt. - - Definition lt : t -> t -> Prop := M.lt. - Definition min_elt : t -> option elt := M.min_elt. - Definition max_elt : t -> option elt := M.max_elt. - Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s - := M.min_elt_1. - Definition min_elt_spec2 : forall s x y, - min_elt s = Some x -> In y s -> ~ O.lt y x - := M.min_elt_2. - Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s - := M.min_elt_3. - Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s - := M.max_elt_1. - Definition max_elt_spec2 : forall s x y, - max_elt s = Some x -> In y s -> ~ O.lt x y - := M.max_elt_2. - Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s - := M.max_elt_3. - Definition elements_spec2 : forall s, sort O.lt (elements s) - := M.elements_3. - Definition choose_spec3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y - := M.choose_3. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros x Hx. apply (M.lt_not_eq Hx). auto with crelations. - - exact M.lt_trans. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2. 1-2: auto with crelations. - intros s s' Hs u u' Hu H. - assert (H0 : lt s' u). { - destruct (M.compare s' u) as [H'|H'|H']; auto. - - elim (M.lt_not_eq H). transitivity s'; auto. - - elim (M.lt_not_eq (M.lt_trans H H')); auto. - } - destruct (M.compare s' u') as [H'|H'|H']; auto. - - elim (M.lt_not_eq H). - transitivity u'. 2: auto with crelations. transitivity s'; auto. - - elim (M.lt_not_eq (M.lt_trans H' H0)); auto with crelations. - Qed. - - Definition compare s s' := - match M.compare s s' with - | EQ _ => Eq - | LT _ => Lt - | GT _ => Gt - end. - - Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). - Proof. intros; unfold compare; destruct M.compare; auto. Qed. - - Module E := O. + (O:Orders.OrderedType) + (M:FSetInterface.S with Definition E.t := O.t + with Definition E.eq := O.eq + with Definition E.lt := O.lt) + <: MSetInterface.Sets with Module E:=O. + + Include Update_WSets O M. + + Implicit Type s : t. + Implicit Type x y : elt. + + Definition lt : t -> t -> Prop := M.lt. + Definition min_elt : t -> option elt := M.min_elt. + Definition max_elt : t -> option elt := M.max_elt. + Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s + := M.min_elt_1. + Definition min_elt_spec2 : forall s x y, + min_elt s = Some x -> In y s -> ~ O.lt y x + := M.min_elt_2. + Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s + := M.min_elt_3. + Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s + := M.max_elt_1. + Definition max_elt_spec2 : forall s x y, + max_elt s = Some x -> In y s -> ~ O.lt x y + := M.max_elt_2. + Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s + := M.max_elt_3. + Definition elements_spec2 : forall s, sort O.lt (elements s) + := M.elements_3. + Definition choose_spec3 : forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y + := M.choose_3. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - intros x Hx. apply (M.lt_not_eq Hx). auto with crelations. + - exact M.lt_trans. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2. 1-2: auto with crelations. + intros s s' Hs u u' Hu H. + assert (H0 : lt s' u). { + destruct (M.compare s' u) as [H'|H'|H']; auto. + - elim (M.lt_not_eq H). transitivity s'; auto. + - elim (M.lt_not_eq (M.lt_trans H H')); auto. + } + destruct (M.compare s' u') as [H'|H'|H']; auto. + - elim (M.lt_not_eq H). + transitivity u'. 2: auto with crelations. transitivity s'; auto. + - elim (M.lt_not_eq (M.lt_trans H' H0)); auto with crelations. + Qed. + + Definition compare s s' := + match M.compare s s' with + | EQ _ => Eq + | LT _ => Lt + | GT _ => Gt + end. + + Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). + Proof. intros; unfold compare; destruct M.compare; auto. Qed. + + Module E := O. End Update_Sets. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 33c706c4cf..946d8b35bb 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -22,9 +22,9 @@ From Stdlib Require Import Decidable Setoid DecidableTypeEx FSetFacts. (** First, a version for Weak Sets in functorial presentation *) Module WDecide_fun (E : DecidableType)(Import M : WSfun E). - Module F := FSetFacts.WFacts_fun E M. + Module F := FSetFacts.WFacts_fun E M. -(** * Overview + (** * Overview This functor defines the tactic [fsetdec], which will solve any valid goal of the form << @@ -112,33 +112,33 @@ the above form: >> *) - (** * Facts and Tactics for Propositional Logic + (** * Facts and Tactics for Propositional Logic These lemmas and tactics are in a module so that they do not affect the namespace if you import the enclosing module [Decide]. *) - Module FSetLogicalFacts. - Export Decidable. - Export Setoid. + Module FSetLogicalFacts. + Export Decidable. + Export Setoid. - (** ** Lemmas and Tactics About Decidable Propositions *) + (** ** Lemmas and Tactics About Decidable Propositions *) - (** ** Propositional Equivalences Involving Negation + (** ** Propositional Equivalences Involving Negation These are all written with the unfolded form of negation, since I am not sure if setoid rewriting will always perform conversion. *) - (** ** Tactics for Negations *) + (** ** Tactics for Negations *) - Tactic Notation "fold" "any" "not" := - repeat ( - match goal with - | H: context [?P -> False] |- _ => - fold (~ P) in H - | |- context [?P -> False] => - fold (~ P) - end). + Tactic Notation "fold" "any" "not" := + repeat ( + match goal with + | H: context [?P -> False] |- _ => + fold (~ P) in H + | |- context [?P -> False] => + fold (~ P) + end). - (** [push not using db] will pushes all negations to the + (** [push not using db] will pushes all negations to the leaves of propositions in the goal, using the lemmas in [db] to assist in checking the decidability of the propositions involved. If [using db] is omitted, then @@ -152,99 +152,99 @@ the above form: done more cleverly with the following explicit analysis of goals. *) - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || - (rewrite (or_not_l_iff_2 P Q) by tac). - - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || - (rewrite (or_not_r_iff_2 P Q) by tac). - - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || - (rewrite (or_not_l_iff_2 P Q) in H by tac). - - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || - (rewrite (or_not_r_iff_2 P Q) in H by tac). - - Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) - | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) - | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec - end); - fold any not. - - Tactic Notation "push" "not" := - push not using core. - - Tactic Notation - "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H - | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => - rewrite (not_imp_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "push" "not" "in" "*" "|-" := - push not in * |- using core. - - Tactic Notation "push" "not" "in" "*" "using" ident(db) := - push not using db; push not in * |- using db. - Tactic Notation "push" "not" "in" "*" := - push not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_push : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ ((R -> P) \/ (Q -> R))) -> - (~ (P /\ R)) -> - (~ (P -> R)) -> - True. - Proof. - intros. push not in *. - (* note that ~(R->P) remains (since R isn't decidable) *) - tauto. - Qed. - - (** [pull not using db] will pull as many negations as + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || + (rewrite (or_not_l_iff_2 P Q) by tac). + + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || + (rewrite (or_not_r_iff_2 P Q) by tac). + + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || + (rewrite (or_not_l_iff_2 P Q) in H by tac). + + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || + (rewrite (or_not_r_iff_2 P Q) in H by tac). + + Tactic Notation "push" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) + | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) + | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec + end); + fold any not. + + Tactic Notation "push" "not" := + push not using core. + + Tactic Notation + "push" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H + | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H + | H: context [(?P -> ?Q) -> False] |- _ => + rewrite (not_imp_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "push" "not" "in" "*" "|-" := + push not in * |- using core. + + Tactic Notation "push" "not" "in" "*" "using" ident(db) := + push not using db; push not in * |- using db. + Tactic Notation "push" "not" "in" "*" := + push not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_push : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ ((R -> P) \/ (Q -> R))) -> + (~ (P /\ R)) -> + (~ (P -> R)) -> + True. + Proof. + intros. push not in *. + (* note that ~(R->P) remains (since R isn't decidable) *) + tauto. + Qed. + + (** [pull not using db] will pull as many negations as possible toward the top of the propositions in the goal, using the lemmas in [db] to assist in checking the decidability of the propositions involved. If [using @@ -252,148 +252,148 @@ the above form: versions are provided to manipulate the hypotheses or the hypotheses and goal together. *) - Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [(?P -> False) /\ (?Q -> False)] => - rewrite <- (not_or_iff P Q) - | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) - | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => - rewrite <- (not_imp_rev_iff P Q) by dec - end); - fold any not. - - Tactic Notation "pull" "not" := - pull not using core. - - Tactic Notation - "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => - rewrite <- (not_and_iff P Q) in H - | H: context [?P /\ (?Q -> False)] |- _ => - rewrite <- (not_imp_iff P Q) in H by dec - | H: context [(?Q -> False) /\ ?P] |- _ => - rewrite <- (not_imp_rev_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "pull" "not" "in" "*" "|-" := - pull not in * |- using core. - - Tactic Notation "pull" "not" "in" "*" "using" ident(db) := - pull not using db; pull not in * |- using db. - Tactic Notation "pull" "not" "in" "*" := - pull not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_pull : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ (R -> P) /\ ~ (Q -> R)) -> - (~ P \/ ~ R) -> - (P /\ ~ R) -> - (~ R /\ P) -> - True. - Proof. - intros. pull not in *. tauto. - Qed. - - End FSetLogicalFacts. - Import FSetLogicalFacts. - - (** * Auxiliary Tactics + Tactic Notation "pull" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [(?P -> False) /\ (?Q -> False)] => + rewrite <- (not_or_iff P Q) + | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) + | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec + | |- context [(?Q -> False) /\ ?P] => + rewrite <- (not_imp_rev_iff P Q) by dec + end); + fold any not. + + Tactic Notation "pull" "not" := + pull not using core. + + Tactic Notation + "pull" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [(?P -> False) /\ (?Q -> False)] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_and_iff P Q) in H + | H: context [?P /\ (?Q -> False)] |- _ => + rewrite <- (not_imp_iff P Q) in H by dec + | H: context [(?Q -> False) /\ ?P] |- _ => + rewrite <- (not_imp_rev_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "pull" "not" "in" "*" "|-" := + pull not in * |- using core. + + Tactic Notation "pull" "not" "in" "*" "using" ident(db) := + pull not using db; pull not in * |- using db. + Tactic Notation "pull" "not" "in" "*" := + pull not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_pull : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ (R -> P) /\ ~ (Q -> R)) -> + (~ P \/ ~ R) -> + (P /\ ~ R) -> + (~ R /\ P) -> + True. + Proof. + intros. pull not in *. tauto. + Qed. + + End FSetLogicalFacts. + Import FSetLogicalFacts. + + (** * Auxiliary Tactics Again, these lemmas and tactics are in a module so that they do not affect the namespace if you import the enclosing module [Decide]. *) - Module FSetDecideAuxiliary. + Module FSetDecideAuxiliary. - (** ** Generic Tactics + (** ** Generic Tactics We begin by defining a few generic, useful tactics. *) - (** remove logical hypothesis inter-dependencies (fix #2136). *) - - Ltac no_logical_interdep := - match goal with - | H : ?P |- _ => - match type of P with - | Prop => - match goal with H' : context [ H ] |- _ => clear dependent H' end - | _ => fail - end; no_logical_interdep - | _ => idtac - end. - - Ltac abstract_term t := - tryif (is_var t) then fail "no need to abstract a variable" - else (let x := fresh "x" in set (x := t) in *; try clearbody x). - - Ltac abstract_elements := - repeat - (match goal with - | |- context [ singleton ?t ] => abstract_term t - | _ : context [ singleton ?t ] |- _ => abstract_term t - | |- context [ add ?t _ ] => abstract_term t - | _ : context [ add ?t _ ] |- _ => abstract_term t - | |- context [ remove ?t _ ] => abstract_term t - | _ : context [ remove ?t _ ] |- _ => abstract_term t - | |- context [ In ?t _ ] => abstract_term t - | _ : context [ In ?t _ ] |- _ => abstract_term t - end). - - (** [prop P holds by t] succeeds (but does not modify the + (** remove logical hypothesis inter-dependencies (fix #2136). *) + + Ltac no_logical_interdep := + match goal with + | H : ?P |- _ => + match type of P with + | Prop => + match goal with H' : context [ H ] |- _ => clear dependent H' end + | _ => fail + end; no_logical_interdep + | _ => idtac + end. + + Ltac abstract_term t := + tryif (is_var t) then fail "no need to abstract a variable" + else (let x := fresh "x" in set (x := t) in *; try clearbody x). + + Ltac abstract_elements := + repeat + (match goal with + | |- context [ singleton ?t ] => abstract_term t + | _ : context [ singleton ?t ] |- _ => abstract_term t + | |- context [ add ?t _ ] => abstract_term t + | _ : context [ add ?t _ ] |- _ => abstract_term t + | |- context [ remove ?t _ ] => abstract_term t + | _ : context [ remove ?t _ ] |- _ => abstract_term t + | |- context [ In ?t _ ] => abstract_term t + | _ : context [ In ?t _ ] |- _ => abstract_term t + end). + + (** [prop P holds by t] succeeds (but does not modify the goal or context) if the proposition [P] can be proved by [t] in the current context. Otherwise, the tactic fails. *) - Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := - let H := fresh in - assert P as H by t; - clear H. + Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := + let H := fresh in + assert P as H by t; + clear H. - (** This tactic acts just like [assert ... by ...] but will + (** This tactic acts just like [assert ... by ...] but will fail if the context already contains the proposition. *) - Tactic Notation "assert" "new" constr(e) "by" tactic(t) := - match goal with - | H: e |- _ => fail 1 - | _ => assert e by t - end. + Tactic Notation "assert" "new" constr(e) "by" tactic(t) := + match goal with + | H: e |- _ => fail 1 + | _ => assert e by t + end. - (** [subst++] is similar to [subst] except that + (** [subst++] is similar to [subst] except that - it never fails (as [subst] does on recursive equations), - it substitutes locally defined variable for their @@ -402,22 +402,22 @@ the above form: arise after substituting a locally defined function for its definition. *) - Tactic Notation "subst" "++" := - repeat ( - match goal with - | x : _ |- _ => subst x - end); - cbv zeta beta in *. - - (** [decompose records] calls [decompose record H] on every + Tactic Notation "subst" "++" := + repeat ( + match goal with + | x : _ |- _ => subst x + end); + cbv zeta beta in *. + + (** [decompose records] calls [decompose record H] on every relevant hypothesis [H]. *) - Tactic Notation "decompose" "records" := - repeat ( - match goal with - | H: _ |- _ => progress (decompose record H); clear H - end). + Tactic Notation "decompose" "records" := + repeat ( + match goal with + | H: _ |- _ => progress (decompose record H); clear H + end). - (** ** Discarding Irrelevant Hypotheses + (** ** Discarding Irrelevant Hypotheses We will want to clear the context of any non-FSet-related hypotheses in order to increase the speed of the tactic. To do this, we will need to be @@ -425,165 +425,165 @@ the above form: a simple inductive definition classifying the propositions of interest. *) - Inductive FSet_elt_Prop : Prop -> Prop := - | eq_Prop : forall (S : Type) (x y : S), - FSet_elt_Prop (x = y) - | eq_elt_prop : forall x y, - FSet_elt_Prop (E.eq x y) - | In_elt_prop : forall x s, - FSet_elt_Prop (In x s) - | True_elt_prop : - FSet_elt_Prop True - | False_elt_prop : - FSet_elt_Prop False - | conj_elt_prop : forall P Q, - FSet_elt_Prop P -> - FSet_elt_Prop Q -> - FSet_elt_Prop (P /\ Q) - | disj_elt_prop : forall P Q, - FSet_elt_Prop P -> - FSet_elt_Prop Q -> - FSet_elt_Prop (P \/ Q) - | impl_elt_prop : forall P Q, - FSet_elt_Prop P -> - FSet_elt_Prop Q -> - FSet_elt_Prop (P -> Q) - | not_elt_prop : forall P, - FSet_elt_Prop P -> - FSet_elt_Prop (~ P). - - Inductive FSet_Prop : Prop -> Prop := - | elt_FSet_Prop : forall P, - FSet_elt_Prop P -> - FSet_Prop P - | Empty_FSet_Prop : forall s, - FSet_Prop (Empty s) - | Subset_FSet_Prop : forall s1 s2, - FSet_Prop (Subset s1 s2) - | Equal_FSet_Prop : forall s1 s2, - FSet_Prop (Equal s1 s2). - - (** Here is the tactic that will throw away hypotheses that + Inductive FSet_elt_Prop : Prop -> Prop := + | eq_Prop : forall (S : Type) (x y : S), + FSet_elt_Prop (x = y) + | eq_elt_prop : forall x y, + FSet_elt_Prop (E.eq x y) + | In_elt_prop : forall x s, + FSet_elt_Prop (In x s) + | True_elt_prop : + FSet_elt_Prop True + | False_elt_prop : + FSet_elt_Prop False + | conj_elt_prop : forall P Q, + FSet_elt_Prop P -> + FSet_elt_Prop Q -> + FSet_elt_Prop (P /\ Q) + | disj_elt_prop : forall P Q, + FSet_elt_Prop P -> + FSet_elt_Prop Q -> + FSet_elt_Prop (P \/ Q) + | impl_elt_prop : forall P Q, + FSet_elt_Prop P -> + FSet_elt_Prop Q -> + FSet_elt_Prop (P -> Q) + | not_elt_prop : forall P, + FSet_elt_Prop P -> + FSet_elt_Prop (~ P). + + Inductive FSet_Prop : Prop -> Prop := + | elt_FSet_Prop : forall P, + FSet_elt_Prop P -> + FSet_Prop P + | Empty_FSet_Prop : forall s, + FSet_Prop (Empty s) + | Subset_FSet_Prop : forall s1 s2, + FSet_Prop (Subset s1 s2) + | Equal_FSet_Prop : forall s1 s2, + FSet_Prop (Equal s1 s2). + + (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) - #[global] - Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. - Ltac discard_nonFSet := - repeat ( - match goal with - | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - tryif (change T with E.t in H) then fail - else tryif (change T with t in H) then fail - else clear H - | H : ?P |- _ => - tryif prop (FSet_Prop P) holds by - (auto 100 with FSet_Prop) - then fail - else clear H - end). + #[global] + Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. + Ltac discard_nonFSet := + repeat ( + match goal with + | H : context [ @Logic.eq ?T ?x ?y ] |- _ => + tryif (change T with E.t in H) then fail + else tryif (change T with t in H) then fail + else clear H + | H : ?P |- _ => + tryif prop (FSet_Prop P) holds by + (auto 100 with FSet_Prop) + then fail + else clear H + end). - (** ** Turning Set Operators into Propositional Connectives + (** ** Turning Set Operators into Propositional Connectives The lemmas from [FSetFacts] will be used to break down set operations into propositional formulas built over the predicates [In] and [E.eq] applied only to variables. We are going to use them with [autorewrite]. *) - #[global] Hint Rewrite - F.empty_iff F.singleton_iff F.add_iff F.remove_iff - F.union_iff F.inter_iff F.diff_iff - : set_simpl. + #[global] Hint Rewrite + F.empty_iff F.singleton_iff F.add_iff F.remove_iff + F.union_iff F.inter_iff F.diff_iff + : set_simpl. - Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. - Proof. - now split. - Qed. + Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. + Proof. + now split. + Qed. - #[global] Hint Rewrite eq_refl_iff : set_eq_simpl. + #[global] Hint Rewrite eq_refl_iff : set_eq_simpl. - (** ** Decidability of FSet Propositions *) + (** ** Decidability of FSet Propositions *) - (** [In] is decidable. *) - Lemma dec_In : forall x s, - decidable (In x s). - Proof. - red; intros; generalize (F.mem_iff s x); case (mem x s); intuition auto with bool. - Qed. + (** [In] is decidable. *) + Lemma dec_In : forall x s, + decidable (In x s). + Proof. + red; intros; generalize (F.mem_iff s x); case (mem x s); intuition auto with bool. + Qed. - (** [E.eq] is decidable. *) - Lemma dec_eq : forall (x y : E.t), - decidable (E.eq x y). - Proof. - red; intros x y; destruct (E.eq_dec x y); auto. - Qed. + (** [E.eq] is decidable. *) + Lemma dec_eq : forall (x y : E.t), + decidable (E.eq x y). + Proof. + red; intros x y; destruct (E.eq_dec x y); auto. + Qed. - (** The hint database [FSet_decidability] will be given to + (** The hint database [FSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) - #[global] - Hint Resolve dec_In dec_eq : FSet_decidability. + #[global] + Hint Resolve dec_In dec_eq : FSet_decidability. - (** ** Normalizing Propositions About Equality + (** ** Normalizing Propositions About Equality We have to deal with the fact that [E.eq] may be convertible with Coq's equality. Thus, we will find the following tactics useful to replace one form with the other everywhere. *) - (** The next tactic, [Logic_eq_to_E_eq], mentions the term + (** The next tactic, [Logic_eq_to_E_eq], mentions the term [E.t]; thus, we must ensure that [E.t] is used in favor of any other convertible but syntactically distinct term. *) - Ltac change_to_E_t := - repeat ( - match goal with - | H : ?T |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - | H : forall x : ?T, _ |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - end). - - (** These two tactics take us from Coq's built-in equality + Ltac change_to_E_t := + repeat ( + match goal with + | H : ?T |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + | H : forall x : ?T, _ |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). + + (** These two tactics take us from Coq's built-in equality to [E.eq] (and vice versa) when possible. *) - Ltac Logic_eq_to_E_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change (@Logic.eq E.t) with E.eq in H) - | |- _ => - progress (change (@Logic.eq E.t) with E.eq) - end). + Ltac Logic_eq_to_E_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change (@Logic.eq E.t) with E.eq in H) + | |- _ => + progress (change (@Logic.eq E.t) with E.eq) + end). - Ltac E_eq_to_Logic_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change E.eq with (@Logic.eq E.t) in H) - | |- _ => - progress (change E.eq with (@Logic.eq E.t)) - end). + Ltac E_eq_to_Logic_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change E.eq with (@Logic.eq E.t) in H) + | |- _ => + progress (change E.eq with (@Logic.eq E.t)) + end). - (** This tactic works like the built-in tactic [subst], but + (** This tactic works like the built-in tactic [subst], but at the level of set element equality (which may not be the convertible with Coq's equality). *) - Ltac substFSet := - repeat ( - match goal with - | H: E.eq ?x ?x |- _ => clear H - | H: E.eq ?x ?y |- _ => rewrite H in *; clear H - end); - autorewrite with set_eq_simpl in *. - - (** ** Considering Decidability of Base Propositions + Ltac substFSet := + repeat ( + match goal with + | H: E.eq ?x ?x |- _ => clear H + | H: E.eq ?x ?y |- _ => rewrite H in *; clear H + end); + autorewrite with set_eq_simpl in *. + + (** ** Considering Decidability of Base Propositions This tactic adds assertions about the decidability of [E.eq] and [In] to the context. This is necessary for the completeness of the [fsetdec] tactic. However, in @@ -592,125 +592,125 @@ the above form: have been pushed to the leaves of the propositions, we only need to worry about decidability for those base propositions that appear in a negated form. *) - Ltac assert_decidability := - (** We actually don't want these rules to fire if the + Ltac assert_decidability := + (** We actually don't want these rules to fire if the syntactic context in the patterns below is trivially empty, but we'll just do some clean-up at the afterward. *) - repeat ( - match goal with - | H: context [~ E.eq ?x ?y] |- _ => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | H: context [~ In ?x ?s] |- _ => - assert new (In x s \/ ~ In x s) by (apply dec_In) - | |- context [~ E.eq ?x ?y] => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | |- context [~ In ?x ?s] => - assert new (In x s \/ ~ In x s) by (apply dec_In) - end); - (** Now we eliminate the useless facts we added (because + repeat ( + match goal with + | H: context [~ E.eq ?x ?y] |- _ => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | H: context [~ In ?x ?s] |- _ => + assert new (In x s \/ ~ In x s) by (apply dec_In) + | |- context [~ E.eq ?x ?y] => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | |- context [~ In ?x ?s] => + assert new (In x s \/ ~ In x s) by (apply dec_In) + end); + (** Now we eliminate the useless facts we added (because they would likely be very harmful to performance). *) - repeat ( - match goal with - | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H - end). + repeat ( + match goal with + | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H + end). - (** ** Handling [Empty], [Subset], and [Equal] + (** ** Handling [Empty], [Subset], and [Equal] This tactic instantiates universally quantified hypotheses (which arise from the unfolding of [Empty], [Subset], and [Equal]) for each of the set element expressions that is involved in some membership or equality fact. Then it throws away those hypotheses, which should no longer be needed. *) - Ltac inst_FSet_hypotheses := - repeat ( - match goal with - | H : forall a : E.t, _, - _ : context [ In ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ In ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq _ ?x ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq _ ?x ] => - let P := type of (H x) in - assert new P by (exact (H x)) - end); - repeat ( - match goal with - | H : forall a : E.t, _ |- _ => - clear H - end). + Ltac inst_FSet_hypotheses := + repeat ( + match goal with + | H : forall a : E.t, _, + _ : context [ In ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ In ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq _ ?x ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq _ ?x ] => + let P := type of (H x) in + assert new P by (exact (H x)) + end); + repeat ( + match goal with + | H : forall a : E.t, _ |- _ => + clear H + end). - (** ** The Core [fsetdec] Auxiliary Tactics *) + (** ** The Core [fsetdec] Auxiliary Tactics *) - (** Here is the crux of the proof search. Recursion through + (** Here is the crux of the proof search. Recursion through [intuition]! (This will terminate if I correctly understand the behavior of [intuition].) *) - Ltac fsetdec_rec := progress substFSet; intuition fsetdec_rec. + Ltac fsetdec_rec := progress substFSet; intuition fsetdec_rec. - (** If we add [unfold Empty, Subset, Equal in *; intros;] to + (** If we add [unfold Empty, Subset, Equal in *; intros;] to the beginning of this tactic, it will satisfy the same specification as the [fsetdec] tactic; however, it will be much slower than necessary without the pre-processing done by the wrapper tactic [fsetdec]. *) - Ltac fsetdec_body := - autorewrite with set_eq_simpl in *; - inst_FSet_hypotheses; - autorewrite with set_simpl set_eq_simpl in *; - push not in * using FSet_decidability; - substFSet; - assert_decidability; - auto; - (intuition fsetdec_rec) || - fail 1 - "because the goal is beyond the scope of this tactic". - - End FSetDecideAuxiliary. - Import FSetDecideAuxiliary. - - (** * The [fsetdec] Tactic + Ltac fsetdec_body := + autorewrite with set_eq_simpl in *; + inst_FSet_hypotheses; + autorewrite with set_simpl set_eq_simpl in *; + push not in * using FSet_decidability; + substFSet; + assert_decidability; + auto; + (intuition fsetdec_rec) || + fail 1 + "because the goal is beyond the scope of this tactic". + + End FSetDecideAuxiliary. + Import FSetDecideAuxiliary. + + (** * The [fsetdec] Tactic Here is the top-level tactic (the only one intended for clients of this library). It's specification is given at the top of the file. *) - Ltac fsetdec := - (** We first unfold any occurrences of [iff]. *) - unfold iff in *; - (** We fold occurrences of [not] because it is better for + Ltac fsetdec := + (** We first unfold any occurrences of [iff]. *) + unfold iff in *; + (** We fold occurrences of [not] because it is better for [intros] to leave us with a goal of [~ P] than a goal of [False]. *) - fold any not; intros; - (** We don't care about the value of elements : complex ones are + fold any not; intros; + (** We don't care about the value of elements : complex ones are abstracted as new variables (avoiding potential dependencies, see bug #2464) *) - abstract_elements; - (** We remove dependencies to logical hypothesis. This way, + abstract_elements; + (** We remove dependencies to logical hypothesis. This way, later "clear" will work nicely (see bug #2136) *) - no_logical_interdep; - (** Now we decompose conjunctions, which will allow the + no_logical_interdep; + (** Now we decompose conjunctions, which will allow the [discard_nonFSet] and [assert_decidability] tactics to do a much better job. *) - decompose records; - discard_nonFSet; - (** We unfold these defined propositions on finite sets. If + decompose records; + discard_nonFSet; + (** We unfold these defined propositions on finite sets. If our goal was one of them, then have one more item to introduce now. *) - unfold Empty, Subset, Equal in *; intros; - (** We now want to get rid of all uses of [=] in favor of + unfold Empty, Subset, Equal in *; intros; + (** We now want to get rid of all uses of [=] in favor of [E.eq]. However, the best way to eliminate a [=] is in the context is with [subst], so we will try that first. In fact, we may as well convert uses of [E.eq] into [=] @@ -720,8 +720,8 @@ the above form: use [change_to_E_t] to ensure that we have a canonical name for set elements, so that [Logic_eq_to_E_eq] will work properly. *) - change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; - (** The next optimization is to swap a negated goal with a + change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; + (** The next optimization is to swap a negated goal with a negated hypothesis when possible. Any swap will improve performance by eliminating the total number of negations, but we will get the maximum benefit if we @@ -732,161 +732,161 @@ the above form: swap with a decidable proposition; hence, we first test whether the hypothesis is an [FSet_elt_Prop], noting that any [FSet_elt_Prop] is decidable. *) - pull not using FSet_decidability; - unfold not in *; - match goal with - | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => - contradict H; fsetdec_body - | H: ?P -> False |- ?Q -> False => - tryif prop (FSet_elt_Prop P) holds by - (auto 100 with FSet_Prop) - then (contradict H; fsetdec_body) - else fsetdec_body - | |- _ => - fsetdec_body - end. - - (** * Examples *) - - Module FSetDecideTestCases. - - Lemma test_eq_trans_1 : forall x y z s, - E.eq x y -> - ~ ~ E.eq z y -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_trans_2 : forall x y z r s, - In x (singleton y) -> - ~ In z r -> - ~ ~ In z (add y r) -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_1 : forall w x y z s, - E.eq x w -> - ~ ~ E.eq x y -> - ~ E.eq y z -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, - In x (singleton w) -> - ~ In x r1 -> - In x (add y r1) -> - In y r2 -> - In y (remove z r2) -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_In_singleton : forall x, - In x (singleton x). - Proof. fsetdec. Qed. - - Lemma test_add_In : forall x y s, - In x (add y s) -> - ~ E.eq x y -> - In x s. - Proof. fsetdec. Qed. - - Lemma test_Subset_add_remove : forall x s, - s [<=] (add x (remove x s)). - Proof. fsetdec. Qed. - - Lemma test_eq_disjunction : forall w x y z, - In w (add x (add y (singleton z))) -> - E.eq w x \/ E.eq w y \/ E.eq w z. - Proof. fsetdec. Qed. - - Lemma test_not_In_disj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ (In x s1 \/ In x s4 \/ E.eq y x). - Proof. fsetdec. Qed. - - Lemma test_not_In_conj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. - Proof. fsetdec. Qed. - - Lemma test_iff_conj : forall a x s s', - (In a s' <-> E.eq x a \/ In a s) -> - (In a s' <-> In a (add x s)). - Proof. fsetdec. Qed. - - Lemma test_set_ops_1 : forall x q r s, - (singleton x) [<=] s -> - Empty (union q r) -> - Empty (inter (diff s q) (diff s r)) -> - ~ In x s. - Proof. fsetdec. Qed. - - Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, - Empty s1 -> - In x2 (add x1 s1) -> - In x3 s2 -> - ~ In x3 (remove x2 s2) -> - ~ In x4 s3 -> - In x4 (add x3 s3) -> - In x1 s4 -> - Subset (add x4 s4) s4. - Proof. fsetdec. Qed. - - Lemma test_too_complex : forall x y z r s, - E.eq x y -> - (In x (singleton y) -> r [<=] s) -> - In z r -> - In z s. - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until s; intros Heq H Hr; lapply H; fsetdec. - Qed. - - Lemma function_test_1 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g (g x2)) -> - In x1 s1 -> - In (g (g x2)) (f s2). - Proof. fsetdec. Qed. - - Lemma function_test_2 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g x2) -> - In x1 s1 -> - g x2 = g (g x2) -> - In (g (g x2)) (f s2). - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. - Qed. - - Lemma test_baydemir : - forall (f : t -> t), - forall (s : t), - forall (x y : elt), - In x (add y (f s)) -> - ~ E.eq x y -> - In x (f s). - Proof. - fsetdec. - Qed. - - End FSetDecideTestCases. + pull not using FSet_decidability; + unfold not in *; + match goal with + | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => + contradict H; fsetdec_body + | H: ?P -> False |- ?Q -> False => + tryif prop (FSet_elt_Prop P) holds by + (auto 100 with FSet_Prop) + then (contradict H; fsetdec_body) + else fsetdec_body + | |- _ => + fsetdec_body + end. + + (** * Examples *) + + Module FSetDecideTestCases. + + Lemma test_eq_trans_1 : forall x y z s, + E.eq x y -> + ~ ~ E.eq z y -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_trans_2 : forall x y z r s, + In x (singleton y) -> + ~ In z r -> + ~ ~ In z (add y r) -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_1 : forall w x y z s, + E.eq x w -> + ~ ~ E.eq x y -> + ~ E.eq y z -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, + In x (singleton w) -> + ~ In x r1 -> + In x (add y r1) -> + In y r2 -> + In y (remove z r2) -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_In_singleton : forall x, + In x (singleton x). + Proof. fsetdec. Qed. + + Lemma test_add_In : forall x y s, + In x (add y s) -> + ~ E.eq x y -> + In x s. + Proof. fsetdec. Qed. + + Lemma test_Subset_add_remove : forall x s, + s [<=] (add x (remove x s)). + Proof. fsetdec. Qed. + + Lemma test_eq_disjunction : forall w x y z, + In w (add x (add y (singleton z))) -> + E.eq w x \/ E.eq w y \/ E.eq w z. + Proof. fsetdec. Qed. + + Lemma test_not_In_disj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ (In x s1 \/ In x s4 \/ E.eq y x). + Proof. fsetdec. Qed. + + Lemma test_not_In_conj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. + Proof. fsetdec. Qed. + + Lemma test_iff_conj : forall a x s s', + (In a s' <-> E.eq x a \/ In a s) -> + (In a s' <-> In a (add x s)). + Proof. fsetdec. Qed. + + Lemma test_set_ops_1 : forall x q r s, + (singleton x) [<=] s -> + Empty (union q r) -> + Empty (inter (diff s q) (diff s r)) -> + ~ In x s. + Proof. fsetdec. Qed. + + Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, + Empty s1 -> + In x2 (add x1 s1) -> + In x3 s2 -> + ~ In x3 (remove x2 s2) -> + ~ In x4 s3 -> + In x4 (add x3 s3) -> + In x1 s4 -> + Subset (add x4 s4) s4. + Proof. fsetdec. Qed. + + Lemma test_too_complex : forall x y z r s, + E.eq x y -> + (In x (singleton y) -> r [<=] s) -> + In z r -> + In z s. + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until s; intros Heq H Hr; lapply H; fsetdec. + Qed. + + Lemma function_test_1 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2). + Proof. fsetdec. Qed. + + Lemma function_test_2 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2). + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. + Qed. + + Lemma test_baydemir : + forall (f : t -> t), + forall (s : t), + forall (x y : elt), + In x (add y (f s)) -> + ~ E.eq x y -> + In x (f s). + Proof. + fsetdec. + Qed. + + End FSetDecideTestCases. End WDecide_fun. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 3dc83c1ca3..0dcf336ef2 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -20,932 +20,933 @@ From Stdlib Require Import FSetProperties Zerob Sumbool DecidableTypeEx. Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E). -Module Import MP := WProperties_fun E M. -Import FM Dec.F. -Import M. - -Definition Add := MP.Add. - -Section BasicProperties. - -(** Some old specifications written with boolean equalities. *) - -Variable s s' s'': t. -Variable x y z : elt. - -Lemma mem_eq: - E.eq x y -> mem x s=mem y s. -Proof. -intro H; rewrite H; auto. -Qed. - -Lemma equal_mem_1: - (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. -intros; apply equal_1; unfold Equal; intros. -do 2 rewrite mem_iff; rewrite H; tauto. -Qed. - -Lemma equal_mem_2: - equal s s'=true -> forall a, mem a s=mem a s'. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma subset_mem_1: - (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. -intros; apply subset_1; unfold Subset; intros a. -do 2 rewrite mem_iff; auto. -Qed. - -Lemma subset_mem_2: - subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. -intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. -Qed. - -Lemma empty_mem: mem x empty=false. -Proof. -rewrite <- not_mem_iff; auto with set. -Qed. - -Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. -apply bool_1; split; intros. -- auto with set. -- rewrite <- is_empty_iff; auto with set. -Qed. - -Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. -auto with set. -Qed. - -Lemma choose_mem_2: choose s=None -> is_empty s=true. -Proof. -auto with set. -Qed. - -Lemma add_mem_1: mem x (add x s)=true. -Proof. -auto with set. -Qed. - -Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. -apply add_neq_b. -Qed. - -Lemma remove_mem_1: mem x (remove x s)=false. -Proof. -rewrite <- not_mem_iff; auto with set. -Qed. - -Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. -apply remove_neq_b. -Qed. - -Lemma singleton_equal_add: - equal (singleton x) (add x empty)=true. -Proof. -rewrite (singleton_equal_add x); auto with set. -Qed. - -Lemma union_mem: - mem x (union s s')=mem x s || mem x s'. -Proof. -apply union_b. -Qed. - -Lemma inter_mem: - mem x (inter s s')=mem x s && mem x s'. -Proof. -apply inter_b. -Qed. - -Lemma diff_mem: - mem x (diff s s')=mem x s && negb (mem x s'). -Proof. -apply diff_b. -Qed. - -(** properties of [mem] *) - -Lemma mem_3 : ~In x s -> mem x s=false. -Proof. -intros; rewrite <- not_mem_iff; auto. -Qed. - -Lemma mem_4 : mem x s=false -> ~In x s. -Proof. -intros; rewrite not_mem_iff; auto. -Qed. - -(** Properties of [equal] *) - -Lemma equal_refl: equal s s=true. -Proof. -auto with set. -Qed. - -Lemma equal_sym: equal s s'=equal s' s. -Proof. -intros; apply bool_1; do 2 rewrite <- equal_iff; intuition auto with relations. -Qed. - -Lemma equal_trans: - equal s s'=true -> equal s' s''=true -> equal s s''=true. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_equal: - equal s s'=true -> equal s s''=equal s' s''. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_cardinal: - equal s s'=true -> cardinal s=cardinal s'. -Proof. -auto with set fset. -Qed. - -(* Properties of [subset] *) - -Lemma subset_refl: subset s s=true. -Proof. -auto with set. -Qed. - -Lemma subset_antisym: - subset s s'=true -> subset s' s=true -> equal s s'=true. -Proof. -auto with set. -Qed. - -Lemma subset_trans: - subset s s'=true -> subset s' s''=true -> subset s s''=true. -Proof. -do 3 rewrite <- subset_iff; intros. -apply subset_trans with s'; auto. -Qed. - -Lemma subset_equal: - equal s s'=true -> subset s s'=true. -Proof. -auto with set. -Qed. - -(** Properties of [choose] *) - -Lemma choose_mem_3: - is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. -Proof. -intros. -generalize (@choose_1 s) (@choose_2 s). -destruct (choose s);intros. -- exists e;auto with set. -- generalize (H1 Logic.eq_refl); clear H1. - intros; rewrite (is_empty_1 H1) in H; discriminate. -Qed. - -Lemma choose_mem_4: choose empty=None. -Proof. -generalize (@choose_1 empty). -case (@choose empty);intros;auto. -elim (@empty_1 e); auto. -Qed. - -(** Properties of [add] *) - -Lemma add_mem_3: - mem y s=true -> mem y (add x s)=true. -Proof. -auto with set. -Qed. - -Lemma add_equal: - mem x s=true -> equal (add x s) s=true. -Proof. -auto with set. -Qed. - -(** Properties of [remove] *) - -Lemma remove_mem_3: - mem y (remove x s)=true -> mem y s=true. -Proof. -rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. -Qed. - -Lemma remove_equal: - mem x s=false -> equal (remove x s) s=true. -Proof. -intros; apply equal_1; apply remove_equal. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_remove: - mem x s=true -> equal (add x (remove x s)) s=true. -Proof. -intros; apply equal_1; apply add_remove; auto with set. -Qed. - -Lemma remove_add: - mem x s=false -> equal (remove x (add x s)) s=true. -Proof. -intros; apply equal_1; apply remove_add; auto. -rewrite not_mem_iff; auto. -Qed. - -(** Properties of [is_empty] *) - -Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). -Proof. -intros; apply bool_1; split; intros. -- rewrite MP.cardinal_1; simpl; auto with set. -- assert (cardinal s = 0) by (apply zerob_true_elim; auto). - auto with set fset. -Qed. - -(** Properties of [singleton] *) - -Lemma singleton_mem_1: mem x (singleton x)=true. -Proof. -auto with set. -Qed. - -Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. -Proof. -intros; rewrite singleton_b. -unfold eqb; destruct (E.eq_dec x y); intuition. -Qed. - -Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. -Proof. -intros; apply singleton_1; auto with set. -Qed. - -(** Properties of [union] *) - -Lemma union_sym: - equal (union s s') (union s' s)=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_equal: - subset s s'=true -> equal (union s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_1: - equal s s'=true-> equal (union s s'') (union s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_2: - equal s' s''=true-> equal (union s s') (union s s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_assoc: - equal (union (union s s') s'') (union s (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma add_union_singleton: - equal (add x s) (union (singleton x) s)=true. -Proof. -auto with set. -Qed. - -Lemma union_add: - equal (union (add x s) s') (add x (union s s'))=true. -Proof. -auto with set. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma union_subset_1: subset s (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_2: subset s' (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> - subset (union s s') s''=true. -Proof. -intros; apply subset_1; apply union_subset_3; auto with set. -Qed. - -(** Properties of [inter] *) - -Lemma inter_sym: equal (inter s s') (inter s' s)=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_equal: - subset s s'=true -> equal (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_1: - equal s s'=true -> equal (inter s s'') (inter s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_2: - equal s' s''=true -> equal (inter s s') (inter s s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_assoc: - equal (inter (inter s s') s'') (inter s (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_1: - equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_2: - equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_1: mem x s'=true -> - equal (inter (add x s) s') (add x (inter s s'))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_2: mem x s'=false -> - equal (inter (add x s) s') (inter s s')=true. -Proof. -intros; apply equal_1; apply inter_add_2. -rewrite not_mem_iff; auto. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma inter_subset_1: subset (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_2: subset (inter s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> - subset s'' (inter s s')=true. -Proof. -intros; apply subset_1; apply inter_subset_3; auto with set. -Qed. - -(** Properties of [diff] *) - -Lemma diff_subset: subset (diff s s') s=true. -Proof. -auto with set. -Qed. - -Lemma diff_subset_equal: - subset s s'=true -> equal (diff s s') empty=true. -Proof. -auto with set. -Qed. - -Lemma remove_inter_singleton: - equal (remove x s) (diff s (singleton x))=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_all: - equal (union (diff s s') (inter s s')) s=true. -Proof. -auto with set. -Qed. - -End BasicProperties. - -#[global] -Hint Immediate empty_mem is_empty_equal_empty add_mem_1 - remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. -#[global] -Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 - choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal - subset_refl subset_equal subset_antisym - add_mem_3 add_equal remove_mem_3 remove_equal : set. - - -(** General recursion principle *) - -Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> - P empty -> forall s, P s. -Proof. -intros. -apply set_induction; auto; intros. -- apply X with empty; auto with set. -- apply X with (add x s0); auto with set. - + apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. - + apply X0; auto with set; apply mem_3; auto. -Qed. - -(** Properties of [fold] *) - -Lemma exclusive_set : forall s s' x, - ~(In x s/\In x s') <-> mem x s && mem x s'=false. -Proof. -intros; do 2 rewrite mem_iff. -destruct (mem x s); destruct (mem x s'); intuition auto with bool. -Qed. - -Section Fold. -Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). -Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). -Variables (i:A). -Variables (s s':t)(x:elt). - -Lemma fold_empty: (fold f empty i) = i. -Proof. -apply fold_empty; auto. -Qed. - -Lemma fold_equal: - equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. -intros; apply fold_equal with (eqA:=eqA); auto with set. -Qed. - -Lemma fold_add: - mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. -intros; apply fold_add with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_fold: - mem x s=true -> eqA (fold f (add x s) i) (fold f s i). -Proof. -intros; apply add_fold with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_1: - mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). -Proof. -intros; apply remove_fold_1 with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_2: - mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). -Proof. -intros; apply remove_fold_2 with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). -Proof. -intros; apply fold_union with (eqA:=eqA); auto. -intros; rewrite exclusive_set; auto. -Qed. - -End Fold. - -(** Properties of [cardinal] *) - -Lemma add_cardinal_1: - forall s x, mem x s=true -> cardinal (add x s)=cardinal s. -Proof. -auto with set fset. -Qed. - -Lemma add_cardinal_2: - forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). -Proof. -intros; apply add_cardinal_2; auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma remove_cardinal_1: - forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. -Proof. -intros; apply remove_cardinal_1; auto with set. -Qed. - -Lemma remove_cardinal_2: - forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. -Proof. -intros; apply Equal_cardinal; apply equal_2; auto with set. -Qed. - -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> - cardinal (union s s')=cardinal s+cardinal s'. -Proof. -intros; apply union_cardinal; auto; intros. -rewrite exclusive_set; auto. -Qed. - -Lemma subset_cardinal: - forall s s', subset s s'=true -> cardinal s<=cardinal s'. -Proof. -intros; apply subset_cardinal; auto with set. -Qed. - -Section Bool. - -(** Properties of [filter] *) - -Variable f:elt->bool. -Variable Comp: Proper (E.eq==>Logic.eq) f. - -#[local] Definition Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). -Proof. -repeat red; intros; f_equal; auto. -Defined. - -#[local] Hint Resolve Comp' : core. -#[local] Hint Unfold compat_bool : core. - -Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. -intros; apply filter_b; auto. -Qed. - -Lemma for_all_filter: - forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. -intros; apply bool_1; split; intros. -- apply is_empty_1. - unfold Empty; intros. - rewrite filter_iff; auto. - red; destruct 1. - rewrite <- (@for_all_iff s f) in H; auto. - rewrite (H a H0) in H1; discriminate. -- apply for_all_1; auto; red; intros. - revert H; rewrite <- is_empty_iff. - unfold Empty; intro H; generalize (H x); clear H. - rewrite filter_iff; auto. - destruct (f x); auto. -Qed. - -Lemma exists_filter : - forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. -- destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). - apply bool_6. - red; intros; apply (@is_empty_2 _ H0 a); auto with set. -- generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). - destruct (choose (filter f s)). - + intros H0 _; apply exists_1; auto. - exists e; generalize (H0 e); rewrite filter_iff; auto. - + intros _ H0. - rewrite (is_empty_1 (H0 Logic.eq_refl)) in H; auto; discriminate. -Qed. - -Lemma partition_filter_1: - forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. -auto with set. -Qed. - -Lemma partition_filter_2: - forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. -auto with set. -Qed. - -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). -Proof. -red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -rewrite <- H; apply Comp; auto. -Qed. - -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. -Proof. -red; intros; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -assert (f x = f a) by (apply Comp; auto). -rewrite H in H1; rewrite H2 in H1; discriminate. -Qed. - -Lemma add_filter_1 : forall s s' x, - f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). -Proof. -unfold Add, MP.Add; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -assert (E.eq x y -> f y = true) by - (intro H0; rewrite <- (Comp _ _ H0); auto). -tauto. -Qed. - -Lemma add_filter_2 : forall s s' x, - f x=false -> (Add x s s') -> filter f s [=] filter f s'. -Proof. -unfold Add, MP.Add, Equal; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -assert (f a = true -> ~E.eq x a). -- intros H0 H1. - rewrite (Comp _ _ H1) in H. - rewrite H in H0; discriminate. -- tauto. -Qed. - -Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> - forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. -Proof. -clear Comp f. -intros. -assert (compat_bool E.eq (fun x => orb (f x) (g x))). -- unfold compat_bool, Proper, respectful; intros. - rewrite (H x y H1); rewrite (H0 x y H1); auto. -- unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. - assert (f a || g a = true <-> f a = true \/ g a = true). - + split; auto with bool. - intro H3; destruct (orb_prop _ _ H3); auto. - + tauto. -Qed. - -Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). -Proof. -unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. -Qed. - -(** Properties of [for_all] *) - -Lemma for_all_mem_1: forall s, - (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. -Proof. -intros. -rewrite for_all_filter; auto. -rewrite is_empty_equal_empty. -apply equal_mem_1;intros. -rewrite filter_b; auto. -rewrite empty_mem. -generalize (H a); case (mem a s);intros;auto. -rewrite H0;auto. -Qed. - -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. -Proof. -intros. -rewrite for_all_filter in H; auto. -rewrite is_empty_equal_empty in H. -generalize (equal_mem_2 _ _ H x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H0; simpl;intros. -rewrite <- negb_false_iff; auto. -Qed. - -Lemma for_all_mem_3: - forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. -Proof. -intros. -apply (bool_eq_ind (for_all f s));intros;auto. -rewrite for_all_filter in H1; auto. -rewrite is_empty_equal_empty in H1. -generalize (equal_mem_2 _ _ H1 x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H. -rewrite H0. -simpl;auto. -Qed. - -Lemma for_all_mem_4: - forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. -Proof. -intros. -rewrite for_all_filter in H; auto. -destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. -exists x. -rewrite filter_b in H1; auto. -elim (andb_prop _ _ H1). -split;auto. -rewrite <- negb_true_iff; auto. -Qed. - -(** Properties of [exists] *) - -Lemma for_all_exists: - forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). -Proof. -intros. -rewrite for_all_b; auto. -rewrite exists_b; auto. -induction (elements s); simpl; auto. -destruct (f a); simpl; auto. -Qed. - -End Bool. -Section Bool'. - -Variable f:elt->bool. -Variable Comp: compat_bool E.eq f. - -Hint Resolve Comp' : core. - -Lemma exists_mem_1: - forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite for_all_mem_1;auto with bool. -intros;generalize (H x H0);intros. -rewrite negb_true_iff; auto. -Qed. - -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_false_iff in H. -rewrite <- negb_true_iff. -apply for_all_mem_2 with (2:=H); auto. -Qed. - -Lemma exists_mem_3: - forall s x, mem x s=true -> f x=true -> exists_ f s=true. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite negb_true_iff. -apply for_all_mem_3 with x;auto. -rewrite negb_false_iff; auto. -Qed. - -Lemma exists_mem_4: - forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_true_iff in H. -destruct (for_all_mem_4 (fun x =>negb (f x)) (Comp' f Comp) s) as (x,p); auto. -elim p;intros. -exists x;split;auto. -rewrite <-negb_false_iff; auto. -Qed. - -End Bool'. - -Section Sum. - -(** Adding a valuation function on all elements of a set. *) - -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. -Notation compat_opL := (compat_op E.eq Logic.eq). -Notation transposeL := (transpose Logic.eq). - -Lemma sum_plus : - forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. -Proof. -unfold sum. -intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))). { red; auto with fset. } -assert (ft : transposeL (fun x:elt =>plus (f x))). { red; intros x y z. - rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (f x) (f y)); reflexivity. } -assert (gc : compat_opL (fun x:elt => plus (g x))). { red; auto with fset. } -assert (gt : transposeL (fun x:elt =>plus (g x))). { red; intros x y z. - rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (g x) (g y)); reflexivity. } -assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). { repeat red; auto. } -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). { red; intros x y z. - set (u := (f x + g x)); set (v := (f y + g y)). - rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm u). - reflexivity. -} -assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -intros s;pattern s; apply set_rec. -- intros. - rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). - rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). - rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. -- intros; do 3 (rewrite (fold_add _ _ st);auto). - rewrite H0;simpl. - rewrite <- !(PeanoNat.Nat.add_assoc (f x)); f_equal. - rewrite !PeanoNat.Nat.add_assoc. f_equal. - apply PeanoNat.Nat.add_comm. -- do 3 rewrite fold_empty;auto. -Qed. - -Lemma sum_filter : forall f, (compat_bool E.eq f) -> - forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). -Proof. -unfold sum; intros f Hf. -assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). { - repeat red; intros. - rewrite (Hf _ _ H); auto. -} -assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). { - red; intros. - set (a := if f x then _ else _). - rewrite PeanoNat.Nat.add_comm. - rewrite <- !PeanoNat.Nat.add_assoc. f_equal. - apply PeanoNat.Nat.add_comm. -} -intros s;pattern s; apply set_rec. -- intros. - change elt with E.t. - rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). - rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto. -- intros; rewrite (fold_add _ _ st _ cc ct); auto. - generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . - assert (~ In x (filter f s0)). - + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. - + case (f x); simpl; intros. - * rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto. - * rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (MP.Add_add s0 x))); auto. -- intros; rewrite fold_empty;auto. - rewrite MP.cardinal_1; auto. - unfold Empty; intros. - rewrite filter_iff; auto; set_iff; tauto. -Qed. - -Lemma fold_compat : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f g:elt->A->A), - (compat_op E.eq eqA f) -> (transpose eqA f) -> - (compat_op E.eq eqA g) -> (transpose eqA g) -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> - (eqA (fold f s i) (fold g s i)). -Proof. -intros A eqA st f g fc ft gc gt i. -intro s; pattern s; apply set_rec; intros. -- transitivity (fold f s0 i). - + apply fold_equal with (eqA:=eqA); auto. - rewrite equal_sym; auto. - + transitivity (fold g s0 i). - * apply H0; intros; apply H1; auto with set. - elim (equal_2 H x); auto with set; intros. - * apply fold_equal with (eqA:=eqA); auto with set. -- transitivity (f x (fold f s0 i)). - + apply fold_add with (eqA:=eqA); auto with set. - + transitivity (g x (fold f s0 i)); auto with set. - transitivity (g x (fold g s0 i)); auto with set. - * apply gc; auto with set. - * symmetry; apply fold_add with (eqA:=eqA); auto. -- do 2 rewrite fold_empty; reflexivity. -Qed. - -Lemma sum_compat : - forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. -intros. -unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with fset. -- intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. -- intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. -- intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. -- intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. -Qed. - -End Sum. + Module Import MP := WProperties_fun E M. + Import FM Dec.F. + Import M. + + Definition Add := MP.Add. + + Section BasicProperties. + + (** Some old specifications written with boolean equalities. *) + + Variable s s' s'': t. + Variable x y z : elt. + + Lemma mem_eq: + E.eq x y -> mem x s=mem y s. + Proof. + intro H; rewrite H; auto. + Qed. + + Lemma equal_mem_1: + (forall a, mem a s=mem a s') -> equal s s'=true. + Proof. + intros; apply equal_1; unfold Equal; intros. + do 2 rewrite mem_iff; rewrite H; tauto. + Qed. + + Lemma equal_mem_2: + equal s s'=true -> forall a, mem a s=mem a s'. + Proof. + intros; rewrite (equal_2 H); auto. + Qed. + + Lemma subset_mem_1: + (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. + Proof. + intros; apply subset_1; unfold Subset; intros a. + do 2 rewrite mem_iff; auto. + Qed. + + Lemma subset_mem_2: + subset s s'=true -> forall a, mem a s=true -> mem a s'=true. + Proof. + intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. + Qed. + + Lemma empty_mem: mem x empty=false. + Proof. + rewrite <- not_mem_iff; auto with set. + Qed. + + Lemma is_empty_equal_empty: is_empty s = equal s empty. + Proof. + apply bool_1; split; intros. + - auto with set. + - rewrite <- is_empty_iff; auto with set. + Qed. + + Lemma choose_mem_1: choose s=Some x -> mem x s=true. + Proof. + auto with set. + Qed. + + Lemma choose_mem_2: choose s=None -> is_empty s=true. + Proof. + auto with set. + Qed. + + Lemma add_mem_1: mem x (add x s)=true. + Proof. + auto with set. + Qed. + + Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. + Proof. + apply add_neq_b. + Qed. + + Lemma remove_mem_1: mem x (remove x s)=false. + Proof. + rewrite <- not_mem_iff; auto with set. + Qed. + + Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. + Proof. + apply remove_neq_b. + Qed. + + Lemma singleton_equal_add: + equal (singleton x) (add x empty)=true. + Proof. + rewrite (singleton_equal_add x); auto with set. + Qed. + + Lemma union_mem: + mem x (union s s')=mem x s || mem x s'. + Proof. + apply union_b. + Qed. + + Lemma inter_mem: + mem x (inter s s')=mem x s && mem x s'. + Proof. + apply inter_b. + Qed. + + Lemma diff_mem: + mem x (diff s s')=mem x s && negb (mem x s'). + Proof. + apply diff_b. + Qed. + + (** properties of [mem] *) + + Lemma mem_3 : ~In x s -> mem x s=false. + Proof. + intros; rewrite <- not_mem_iff; auto. + Qed. + + Lemma mem_4 : mem x s=false -> ~In x s. + Proof. + intros; rewrite not_mem_iff; auto. + Qed. + + (** Properties of [equal] *) + + Lemma equal_refl: equal s s=true. + Proof. + auto with set. + Qed. + + Lemma equal_sym: equal s s'=equal s' s. + Proof. + intros; apply bool_1; do 2 rewrite <- equal_iff; intuition auto with relations. + Qed. + + Lemma equal_trans: + equal s s'=true -> equal s' s''=true -> equal s s''=true. + Proof. + intros; rewrite (equal_2 H); auto. + Qed. + + Lemma equal_equal: + equal s s'=true -> equal s s''=equal s' s''. + Proof. + intros; rewrite (equal_2 H); auto. + Qed. + + Lemma equal_cardinal: + equal s s'=true -> cardinal s=cardinal s'. + Proof. + auto with set fset. + Qed. + + (* Properties of [subset] *) + + Lemma subset_refl: subset s s=true. + Proof. + auto with set. + Qed. + + Lemma subset_antisym: + subset s s'=true -> subset s' s=true -> equal s s'=true. + Proof. + auto with set. + Qed. + + Lemma subset_trans: + subset s s'=true -> subset s' s''=true -> subset s s''=true. + Proof. + do 3 rewrite <- subset_iff; intros. + apply subset_trans with s'; auto. + Qed. + + Lemma subset_equal: + equal s s'=true -> subset s s'=true. + Proof. + auto with set. + Qed. + + (** Properties of [choose] *) + + Lemma choose_mem_3: + is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. + Proof. + intros. + generalize (@choose_1 s) (@choose_2 s). + destruct (choose s);intros. + - exists e;auto with set. + - generalize (H1 Logic.eq_refl); clear H1. + intros; rewrite (is_empty_1 H1) in H; discriminate. + Qed. + + Lemma choose_mem_4: choose empty=None. + Proof. + generalize (@choose_1 empty). + case (@choose empty);intros;auto. + elim (@empty_1 e); auto. + Qed. + + (** Properties of [add] *) + + Lemma add_mem_3: + mem y s=true -> mem y (add x s)=true. + Proof. + auto with set. + Qed. + + Lemma add_equal: + mem x s=true -> equal (add x s) s=true. + Proof. + auto with set. + Qed. + + (** Properties of [remove] *) + + Lemma remove_mem_3: + mem y (remove x s)=true -> mem y s=true. + Proof. + rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. + Qed. + + Lemma remove_equal: + mem x s=false -> equal (remove x s) s=true. + Proof. + intros; apply equal_1; apply remove_equal. + rewrite not_mem_iff; auto. + Qed. + + Lemma add_remove: + mem x s=true -> equal (add x (remove x s)) s=true. + Proof. + intros; apply equal_1; apply add_remove; auto with set. + Qed. + + Lemma remove_add: + mem x s=false -> equal (remove x (add x s)) s=true. + Proof. + intros; apply equal_1; apply remove_add; auto. + rewrite not_mem_iff; auto. + Qed. + + (** Properties of [is_empty] *) + + Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). + Proof. + intros; apply bool_1; split; intros. + - rewrite MP.cardinal_1; simpl; auto with set. + - assert (cardinal s = 0) by (apply zerob_true_elim; auto). + auto with set fset. + Qed. + + (** Properties of [singleton] *) + + Lemma singleton_mem_1: mem x (singleton x)=true. + Proof. + auto with set. + Qed. + + Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. + Proof. + intros; rewrite singleton_b. + unfold eqb; destruct (E.eq_dec x y); intuition. + Qed. + + Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. + Proof. + intros; apply singleton_1; auto with set. + Qed. + + (** Properties of [union] *) + + Lemma union_sym: + equal (union s s') (union s' s)=true. + Proof. + auto with set. + Qed. + + Lemma union_subset_equal: + subset s s'=true -> equal (union s s') s'=true. + Proof. + auto with set. + Qed. + + Lemma union_equal_1: + equal s s'=true-> equal (union s s'') (union s' s'')=true. + Proof. + auto with set. + Qed. + + Lemma union_equal_2: + equal s' s''=true-> equal (union s s') (union s s'')=true. + Proof. + auto with set. + Qed. + + Lemma union_assoc: + equal (union (union s s') s'') (union s (union s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma add_union_singleton: + equal (add x s) (union (singleton x) s)=true. + Proof. + auto with set. + Qed. + + Lemma union_add: + equal (union (add x s) s') (add x (union s s'))=true. + Proof. + auto with set. + Qed. + + (* characterisation of [union] via [subset] *) + + Lemma union_subset_1: subset s (union s s')=true. + Proof. + auto with set. + Qed. + + Lemma union_subset_2: subset s' (union s s')=true. + Proof. + auto with set. + Qed. + + Lemma union_subset_3: + subset s s''=true -> subset s' s''=true -> + subset (union s s') s''=true. + Proof. + intros; apply subset_1; apply union_subset_3; auto with set. + Qed. + + (** Properties of [inter] *) + + Lemma inter_sym: equal (inter s s') (inter s' s)=true. + Proof. + auto with set. + Qed. + + Lemma inter_subset_equal: + subset s s'=true -> equal (inter s s') s=true. + Proof. + auto with set. + Qed. + + Lemma inter_equal_1: + equal s s'=true -> equal (inter s s'') (inter s' s'')=true. + Proof. + auto with set. + Qed. + + Lemma inter_equal_2: + equal s' s''=true -> equal (inter s s') (inter s s'')=true. + Proof. + auto with set. + Qed. + + Lemma inter_assoc: + equal (inter (inter s s') s'') (inter s (inter s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma union_inter_1: + equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma union_inter_2: + equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma inter_add_1: mem x s'=true -> + equal (inter (add x s) s') (add x (inter s s'))=true. + Proof. + auto with set. + Qed. + + Lemma inter_add_2: mem x s'=false -> + equal (inter (add x s) s') (inter s s')=true. + Proof. + intros; apply equal_1; apply inter_add_2. + rewrite not_mem_iff; auto. + Qed. + + (* characterisation of [union] via [subset] *) + + Lemma inter_subset_1: subset (inter s s') s=true. + Proof. + auto with set. + Qed. + + Lemma inter_subset_2: subset (inter s s') s'=true. + Proof. + auto with set. + Qed. + + Lemma inter_subset_3: + subset s'' s=true -> subset s'' s'=true -> + subset s'' (inter s s')=true. + Proof. + intros; apply subset_1; apply inter_subset_3; auto with set. + Qed. + + (** Properties of [diff] *) + + Lemma diff_subset: subset (diff s s') s=true. + Proof. + auto with set. + Qed. + + Lemma diff_subset_equal: + subset s s'=true -> equal (diff s s') empty=true. + Proof. + auto with set. + Qed. + + Lemma remove_inter_singleton: + equal (remove x s) (diff s (singleton x))=true. + Proof. + auto with set. + Qed. + + Lemma diff_inter_empty: + equal (inter (diff s s') (inter s s')) empty=true. + Proof. + auto with set. + Qed. + + Lemma diff_inter_all: + equal (union (diff s s') (inter s s')) s=true. + Proof. + auto with set. + Qed. + + End BasicProperties. + + #[global] + Hint Immediate empty_mem is_empty_equal_empty add_mem_1 + remove_mem_1 singleton_equal_add union_mem inter_mem + diff_mem equal_sym add_remove remove_add : set. + #[global] + Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 + choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal + subset_refl subset_equal subset_antisym + add_mem_3 add_equal remove_mem_3 remove_equal : set. + + + (** General recursion principle *) + + Lemma set_rec: forall (P:t->Type), + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> + P empty -> forall s, P s. + Proof. + intros. + apply set_induction; auto; intros. + - apply X with empty; auto with set. + - apply X with (add x s0); auto with set. + + apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. + + apply X0; auto with set; apply mem_3; auto. + Qed. + + (** Properties of [fold] *) + + Lemma exclusive_set : forall s s' x, + ~(In x s/\In x s') <-> mem x s && mem x s'=false. + Proof. + intros; do 2 rewrite mem_iff. + destruct (mem x s); destruct (mem x s'); intuition auto with bool. + Qed. + + Section Fold. + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). + Variables (i:A). + Variables (s s':t)(x:elt). + + Lemma fold_empty: (fold f empty i) = i. + Proof. + apply fold_empty; auto. + Qed. + + Lemma fold_equal: + equal s s'=true -> eqA (fold f s i) (fold f s' i). + Proof. + intros; apply fold_equal with (eqA:=eqA); auto with set. + Qed. + + Lemma fold_add: + mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_add with (eqA:=eqA); auto. + rewrite not_mem_iff; auto. + Qed. + + Lemma add_fold: + mem x s=true -> eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply add_fold with (eqA:=eqA); auto with set. + Qed. + + Lemma remove_fold_1: + mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros; apply remove_fold_1 with (eqA:=eqA); auto with set. + Qed. + + Lemma remove_fold_2: + mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros; apply remove_fold_2 with (eqA:=eqA); auto. + rewrite not_mem_iff; auto. + Qed. + + Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros; apply fold_union with (eqA:=eqA); auto. + intros; rewrite exclusive_set; auto. + Qed. + + End Fold. + + (** Properties of [cardinal] *) + + Lemma add_cardinal_1: + forall s x, mem x s=true -> cardinal (add x s)=cardinal s. + Proof. + auto with set fset. + Qed. + + Lemma add_cardinal_2: + forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). + Proof. + intros; apply add_cardinal_2; auto. + rewrite not_mem_iff; auto. + Qed. + + Lemma remove_cardinal_1: + forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. + Proof. + intros; apply remove_cardinal_1; auto with set. + Qed. + + Lemma remove_cardinal_2: + forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. + Proof. + intros; apply Equal_cardinal; apply equal_2; auto with set. + Qed. + + Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> + cardinal (union s s')=cardinal s+cardinal s'. + Proof. + intros; apply union_cardinal; auto; intros. + rewrite exclusive_set; auto. + Qed. + + Lemma subset_cardinal: + forall s s', subset s s'=true -> cardinal s<=cardinal s'. + Proof. + intros; apply subset_cardinal; auto with set. + Qed. + + Section Bool. + + (** Properties of [filter] *) + + Variable f:elt->bool. + Variable Comp: Proper (E.eq==>Logic.eq) f. + + #[local] Definition Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). + Proof. + repeat red; intros; f_equal; auto. + Defined. + + #[local] Hint Resolve Comp' : core. + #[local] Hint Unfold compat_bool : core. + + Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. + Proof. + intros; apply filter_b; auto. + Qed. + + Lemma for_all_filter: + forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). + Proof. + intros; apply bool_1; split; intros. + - apply is_empty_1. + unfold Empty; intros. + rewrite filter_iff; auto. + red; destruct 1. + rewrite <- (@for_all_iff s f) in H; auto. + rewrite (H a H0) in H1; discriminate. + - apply for_all_1; auto; red; intros. + revert H; rewrite <- is_empty_iff. + unfold Empty; intro H; generalize (H x); clear H. + rewrite filter_iff; auto. + destruct (f x); auto. + Qed. + + Lemma exists_filter : + forall s, exists_ f s=negb (is_empty (filter f s)). + Proof. + intros; apply bool_1; split; intros. + - destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). + apply bool_6. + red; intros; apply (@is_empty_2 _ H0 a); auto with set. + - generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). + destruct (choose (filter f s)). + + intros H0 _; apply exists_1; auto. + exists e; generalize (H0 e); rewrite filter_iff; auto. + + intros _ H0. + rewrite (is_empty_1 (H0 Logic.eq_refl)) in H; auto; discriminate. + Qed. + + Lemma partition_filter_1: + forall s, equal (fst (partition f s)) (filter f s)=true. + Proof. + auto with set. + Qed. + + Lemma partition_filter_2: + forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. + Proof. + auto with set. + Qed. + + Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). + Proof. + red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. + intuition. + rewrite <- H; apply Comp; auto. + Qed. + + Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. + Proof. + red; intros; do 2 (rewrite filter_iff; auto); set_iff. + intuition. + assert (f x = f a) by (apply Comp; auto). + rewrite H in H1; rewrite H2 in H1; discriminate. + Qed. + + Lemma add_filter_1 : forall s s' x, + f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). + Proof. + unfold Add, MP.Add; intros. + repeat rewrite filter_iff; auto. + rewrite H0; clear H0. + assert (E.eq x y -> f y = true) by + (intro H0; rewrite <- (Comp _ _ H0); auto). + tauto. + Qed. + + Lemma add_filter_2 : forall s s' x, + f x=false -> (Add x s s') -> filter f s [=] filter f s'. + Proof. + unfold Add, MP.Add, Equal; intros. + repeat rewrite filter_iff; auto. + rewrite H0; clear H0. + assert (f a = true -> ~E.eq x a). + - intros H0 H1. + rewrite (Comp _ _ H1) in H. + rewrite H in H0; discriminate. + - tauto. + Qed. + + Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> + forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. + Proof. + clear Comp f. + intros. + assert (compat_bool E.eq (fun x => orb (f x) (g x))). + - unfold compat_bool, Proper, respectful; intros. + rewrite (H x y H1); rewrite (H0 x y H1); auto. + - unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. + assert (f a || g a = true <-> f a = true \/ g a = true). + + split; auto with bool. + intro H3; destruct (orb_prop _ _ H3); auto. + + tauto. + Qed. + + Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). + Proof. + unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. + Qed. + + (** Properties of [for_all] *) + + Lemma for_all_mem_1: forall s, + (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. + Proof. + intros. + rewrite for_all_filter; auto. + rewrite is_empty_equal_empty. + apply equal_mem_1;intros. + rewrite filter_b; auto. + rewrite empty_mem. + generalize (H a); case (mem a s);intros;auto. + rewrite H0;auto. + Qed. + + Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. + Proof. + intros. + rewrite for_all_filter in H; auto. + rewrite is_empty_equal_empty in H. + generalize (equal_mem_2 _ _ H x). + rewrite filter_b; auto. + rewrite empty_mem. + rewrite H0; simpl;intros. + rewrite <- negb_false_iff; auto. + Qed. + + Lemma for_all_mem_3: + forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. + Proof. + intros. + apply (bool_eq_ind (for_all f s));intros;auto. + rewrite for_all_filter in H1; auto. + rewrite is_empty_equal_empty in H1. + generalize (equal_mem_2 _ _ H1 x). + rewrite filter_b; auto. + rewrite empty_mem. + rewrite H. + rewrite H0. + simpl;auto. + Qed. + + Lemma for_all_mem_4: + forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. + Proof. + intros. + rewrite for_all_filter in H; auto. + destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. + exists x. + rewrite filter_b in H1; auto. + elim (andb_prop _ _ H1). + split;auto. + rewrite <- negb_true_iff; auto. + Qed. + + (** Properties of [exists] *) + + Lemma for_all_exists: + forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). + Proof. + intros. + rewrite for_all_b; auto. + rewrite exists_b; auto. + induction (elements s); simpl; auto. + destruct (f a); simpl; auto. + Qed. + + End Bool. + Section Bool'. + + Variable f:elt->bool. + Variable Comp: compat_bool E.eq f. + + Hint Resolve Comp' : core. + + Lemma exists_mem_1: + forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. + Proof. + intros. + rewrite for_all_exists; auto. + rewrite for_all_mem_1;auto with bool. + intros;generalize (H x H0);intros. + rewrite negb_true_iff; auto. + Qed. + + Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. + Proof. + intros. + rewrite for_all_exists in H; auto. + rewrite negb_false_iff in H. + rewrite <- negb_true_iff. + apply for_all_mem_2 with (2:=H); auto. + Qed. + + Lemma exists_mem_3: + forall s x, mem x s=true -> f x=true -> exists_ f s=true. + Proof. + intros. + rewrite for_all_exists; auto. + rewrite negb_true_iff. + apply for_all_mem_3 with x;auto. + rewrite negb_false_iff; auto. + Qed. + + Lemma exists_mem_4: + forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. + Proof. + intros. + rewrite for_all_exists in H; auto. + rewrite negb_true_iff in H. + destruct (for_all_mem_4 (fun x =>negb (f x)) (Comp' f Comp) s) as (x,p); auto. + elim p;intros. + exists x;split;auto. + rewrite <-negb_false_iff; auto. + Qed. + + End Bool'. + + Section Sum. + + (** Adding a valuation function on all elements of a set. *) + + Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. + Notation compat_opL := (compat_op E.eq Logic.eq). + Notation transposeL := (transpose Logic.eq). + + Lemma sum_plus : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. + Proof. + unfold sum. + intros f g Hf Hg. + assert (fc : compat_opL (fun x:elt =>plus (f x))). { red; auto with fset. } + assert (ft : transposeL (fun x:elt =>plus (f x))). { red; intros x y z. + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (f x) (f y)); reflexivity. } + assert (gc : compat_opL (fun x:elt => plus (g x))). { red; auto with fset. } + assert (gt : transposeL (fun x:elt =>plus (g x))). { red; intros x y z. + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (g x) (g y)); reflexivity. } + assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). { repeat red; auto. } + assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). { red; intros x y z. + set (u := (f x + g x)); set (v := (f y + g y)). + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm u). + reflexivity. + } + assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). + intros s;pattern s; apply set_rec. + - intros. + rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). + rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). + rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. + - intros; do 3 (rewrite (fold_add _ _ st);auto). + rewrite H0;simpl. + rewrite <- !(PeanoNat.Nat.add_assoc (f x)); f_equal. + rewrite !PeanoNat.Nat.add_assoc. f_equal. + apply PeanoNat.Nat.add_comm. + - do 3 rewrite fold_empty;auto. + Qed. + + Lemma sum_filter : forall f, (compat_bool E.eq f) -> + forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). + Proof. + unfold sum; intros f Hf. + assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). + assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). { + repeat red; intros. + rewrite (Hf _ _ H); auto. + } + assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). { + red; intros. + set (a := if f x then _ else _). + rewrite PeanoNat.Nat.add_comm. + rewrite <- !PeanoNat.Nat.add_assoc. f_equal. + apply PeanoNat.Nat.add_comm. + } + intros s;pattern s; apply set_rec. + - intros. + change elt with E.t. + rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). + rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto. + - intros; rewrite (fold_add _ _ st _ cc ct); auto. + generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . + assert (~ In x (filter f s0)). + + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. + + case (f x); simpl; intros. + * rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto. + * rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (MP.Add_add s0 x))); auto. + - intros; rewrite fold_empty;auto. + rewrite MP.cardinal_1; auto. + unfold Empty; intros. + rewrite filter_iff; auto; set_iff; tauto. + Qed. + + Lemma fold_compat : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f g:elt->A->A), + (compat_op E.eq eqA f) -> (transpose eqA f) -> + (compat_op E.eq eqA g) -> (transpose eqA g) -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (eqA (fold f s i) (fold g s i)). + Proof. + intros A eqA st f g fc ft gc gt i. + intro s; pattern s; apply set_rec; intros. + - transitivity (fold f s0 i). + + apply fold_equal with (eqA:=eqA); auto. + rewrite equal_sym; auto. + + transitivity (fold g s0 i). + * apply H0; intros; apply H1; auto with set. + elim (equal_2 H x); auto with set; intros. + * apply fold_equal with (eqA:=eqA); auto with set. + - transitivity (f x (fold f s0 i)). + + apply fold_add with (eqA:=eqA); auto with set. + + transitivity (g x (fold f s0 i)); auto with set. + transitivity (g x (fold g s0 i)); auto with set. + * apply gc; auto with set. + * symmetry; apply fold_add with (eqA:=eqA); auto. + - do 2 rewrite fold_empty; reflexivity. + Qed. + + Lemma sum_compat : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. + Proof. + intros. + unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with fset. + - intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. + - intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. + - intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. + - intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. + Qed. + + End Sum. End WEqProperties_fun. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index d68cfc7935..2c986e26b1 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -25,476 +25,476 @@ Unset Strict Implicit. Module WFacts_fun (Import E : DecidableType)(Import M : WSfun E). -Notation eq_dec := E.eq_dec. -Definition eqb x y := if eq_dec x y then true else false. - -(** * Specifications written using equivalences *) - -Section IffSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). -Proof. -split; apply In_1; auto. -Qed. - -Lemma mem_iff : In x s <-> mem x s = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_iff : ~In x s <-> mem x s = false. -Proof. -rewrite mem_iff; destruct (mem x s); intuition auto with bool. -Qed. - -Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. -split; [apply equal_1|apply equal_2]. -Qed. - -Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. -split; [apply subset_1|apply subset_2]. -Qed. - -Lemma empty_iff : In x empty <-> False. -Proof. -intuition; apply (empty_1 H). -Qed. - -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. -split; [apply is_empty_1|apply is_empty_2]. -Qed. - -Lemma singleton_iff : In y (singleton x) <-> E.eq x y. -Proof. -split; [apply singleton_1|apply singleton_2]. -Qed. - -Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. -split; [ | destruct 1; [apply add_1|apply add_2]]; auto. -destruct (eq_dec x y) as [E|E]; auto. -intro H; right; exact (add_3 E H). -Qed. - -Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. -Proof. -split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. -intro. -apply (remove_1 H0 H). -Qed. - -Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. -Proof. -split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. -Qed. - -Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. -Proof. -split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. -Qed. - -Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. -Proof. -split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. -Qed. - -Variable f : elt->bool. - -Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). -Proof. -split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. -Qed. - -Lemma for_all_iff : compat_bool E.eq f -> - (For_all (fun x => f x = true) s <-> for_all f s = true). -Proof. -split; [apply for_all_1 | apply for_all_2]; auto. -Qed. - -Lemma exists_iff : compat_bool E.eq f -> - (Exists (fun x => f x = true) s <-> exists_ f s = true). -Proof. -split; [apply exists_1 | apply exists_2]; auto. -Qed. - -Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. -split; [apply elements_1 | apply elements_2]. -Qed. - -End IffSpec. - -(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := - repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff - || rewrite union_iff || rewrite inter_iff || rewrite diff_iff - || rewrite empty_iff)). - -(** * Specifications written using boolean predicates *) - -Section BoolSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. -intros. -generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). -destruct (mem x s); destruct (mem y s); intuition. -Qed. - -Lemma empty_b : mem y empty = false. -Proof. -generalize (empty_iff y)(mem_iff empty y). -destruct (mem y empty); intuition. -Qed. - -Lemma add_b : mem y (add x s) = eqb x y || mem y s. -Proof. -generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. -Proof. -intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). -destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). -Proof. -generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. -Qed. - -Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. -Proof. -intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). -destruct (mem y s); destruct (mem y (remove x s)); intuition. -Qed. - -Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. -generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. -Qed. - -Lemma union_b : mem x (union s s') = mem x s || mem x s'. -Proof. -generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. -Qed. - -Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. -Proof. -generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. -Qed. - -Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). -Proof. -generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. -Qed. - -Lemma elements_b : mem x s = existsb (eqb x) (elements s). -Proof. -generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). -rewrite InA_alt. -destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. -- symmetry. - rewrite H1. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. - exists a; intuition. - unfold eqb; destruct (eq_dec x a); auto. -- rewrite <- H. - rewrite H0. - destruct H1 as (H1,_). - destruct H1 as (a,(Ha1,Ha2)); [intuition|]. - exists a; intuition. - unfold eqb in *; destruct (eq_dec x a); auto; discriminate. -Qed. - -Variable f : elt->bool. - -Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. -Proof. -intros. -generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). -destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. -Qed. - -Lemma for_all_b : compat_bool E.eq f -> - for_all f s = forallb f (elements s). -Proof. -intros. -generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). -unfold For_all. -destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - rewrite (H2 x0) in H3. - rewrite (InA_alt E.eq x0 (elements s)) in H3. - destruct H3 as (a,(Ha1,Ha2)). - rewrite (H _ _ Ha1). - apply H0; auto. -- symmetry. - rewrite H0; intros. - destruct H1 as (_,H1). - apply H1; auto. - rewrite H2. - rewrite InA_alt; eauto. -Qed. - -Lemma exists_b : compat_bool E.eq f -> - exists_ f s = existsb f (elements s). -Proof. -intros. -generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). -unfold Exists. -destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); auto. - exists a; split; auto. - rewrite H2; rewrite InA_alt; eauto. -- symmetry. - rewrite H0. - destruct H1 as (_,H1). - destruct H1 as (a,(Ha1,Ha2)); auto. - rewrite (H2 a) in Ha1. - rewrite (InA_alt E.eq a (elements s)) in Ha1. - destruct Ha1 as (b,(Hb1,Hb2)). - exists b; auto. - rewrite <- (H _ _ Hb1); auto. -Qed. - -End BoolSpec. - -(** * [E.eq] and [Equal] are setoid equalities *) - -#[global] -Instance E_ST : Equivalence E.eq. -Proof. -constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. -Qed. - -#[global] -Instance Equal_ST : Equivalence Equal. -Proof. -constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. -Qed. - -#[global] -Instance In_m : Proper (E.eq ==> Equal ==> iff) In. -Proof. -unfold Equal; intros x y H s s' H0. -rewrite (In_eq_iff s H); auto. -Qed. - -#[global] -Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty. -Proof. -unfold Equal; intros s s' H. -generalize (is_empty_iff s)(is_empty_iff s'). -destruct (is_empty s); destruct (is_empty s'); - unfold Empty; auto; intros. -- symmetry. - rewrite <- H1; intros a Ha. - rewrite <- (H a) in Ha. - destruct H0 as (_,H0). - exact (H0 Logic.eq_refl _ Ha). -- rewrite <- H0; intros a Ha. - rewrite (H a) in Ha. - destruct H1 as (_,H1). - exact (H1 Logic.eq_refl _ Ha). -Qed. - -#[global] -Instance Empty_m : Proper (Equal ==> iff) Empty. -Proof. -repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition. -Qed. - -#[global] -Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem. -Proof. -unfold Equal; intros x y H s s' H0. -generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). -generalize (mem_iff s x)(mem_iff s' y). -destruct (mem x s); destruct (mem y s'); intuition. -Qed. - -#[global] -Instance singleton_m : Proper (E.eq ==> Equal) singleton. -Proof. -unfold Equal; intros x y H a. -do 2 rewrite singleton_iff; split; intros. -- apply E.eq_trans with x; auto. -- apply E.eq_trans with y; auto. -Qed. - -#[global] -Instance add_m : Proper (E.eq==>Equal==>Equal) add. -Proof. -unfold Equal; intros x y H s s' H0 a. -do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. -Proof. -unfold Equal; intros x y H s s' H0 a. -do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance union_m : Proper (Equal==>Equal==>Equal) union. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance inter_m : Proper (Equal==>Equal==>Equal) inter. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance diff_m : Proper (Equal==>Equal==>Equal) diff. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. -Proof. -unfold Equal, Subset; firstorder. -Qed. - -#[global] -Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset. -Proof. -intros s s' H s'' s''' H0. -generalize (subset_iff s s'') (subset_iff s' s'''). -destruct (subset s s''); destruct (subset s' s'''); auto; intros. -- rewrite H in H1; rewrite H0 in H1; intuition. -- rewrite H in H1; rewrite H0 in H1; intuition. -Qed. - -#[global] -Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal. -Proof. -intros s s' H s'' s''' H0. -generalize (equal_iff s s'') (equal_iff s' s'''). -destruct (equal s s''); destruct (equal s' s'''); auto; intros. -- rewrite H in H1; rewrite H0 in H1; intuition. -- rewrite H in H1; rewrite H0 in H1; intuition. -Qed. - - -(* [Subset] is a setoid order *) - -Lemma Subset_refl : forall s, s[<=]s. -Proof. red; auto. Qed. - -Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. -Proof. unfold Subset; eauto. Qed. - -Add Relation t Subset - reflexivity proved by Subset_refl - transitivity proved by Subset_trans - as SubsetSetoid. - -#[global] -Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1. -Proof. - simpl_relation. eauto with set. -Qed. - -Add Morphism Empty with signature Subset --> Basics.impl as Empty_s_m. -Proof. -unfold Subset, Empty, Basics.impl; firstorder. -Qed. - -Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m. -Proof. -unfold Subset; intros x y H s s' H0 a. -do 2 rewrite add_iff; rewrite H; intuition. -Qed. - -Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m. -Proof. -unfold Subset; intros x y H s s' H0 a. -do 2 rewrite remove_iff; rewrite H; intuition. -Qed. - -Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite union_iff; intuition. -Qed. - -Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite inter_iff; intuition. -Qed. - -Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m. -Proof. -unfold Subset; intros s s' H s'' s''' H0 a. -do 2 rewrite diff_iff; intuition. -Qed. - -(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism + Notation eq_dec := E.eq_dec. + Definition eqb x y := if eq_dec x y then true else false. + + (** * Specifications written using equivalences *) + + Section IffSpec. + Variable s s' s'' : t. + Variable x y z : elt. + + Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). + Proof. + split; apply In_1; auto. + Qed. + + Lemma mem_iff : In x s <-> mem x s = true. + Proof. + split; [apply mem_1|apply mem_2]. + Qed. + + Lemma not_mem_iff : ~In x s <-> mem x s = false. + Proof. + rewrite mem_iff; destruct (mem x s); intuition auto with bool. + Qed. + + Lemma equal_iff : s[=]s' <-> equal s s' = true. + Proof. + split; [apply equal_1|apply equal_2]. + Qed. + + Lemma subset_iff : s[<=]s' <-> subset s s' = true. + Proof. + split; [apply subset_1|apply subset_2]. + Qed. + + Lemma empty_iff : In x empty <-> False. + Proof. + intuition; apply (empty_1 H). + Qed. + + Lemma is_empty_iff : Empty s <-> is_empty s = true. + Proof. + split; [apply is_empty_1|apply is_empty_2]. + Qed. + + Lemma singleton_iff : In y (singleton x) <-> E.eq x y. + Proof. + split; [apply singleton_1|apply singleton_2]. + Qed. + + Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. + Proof. + split; [ | destruct 1; [apply add_1|apply add_2]]; auto. + destruct (eq_dec x y) as [E|E]; auto. + intro H; right; exact (add_3 E H). + Qed. + + Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). + Proof. + split; [apply add_3|apply add_2]; auto. + Qed. + + Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. + Proof. + split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. + intro. + apply (remove_1 H0 H). + Qed. + + Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). + Proof. + split; [apply remove_3|apply remove_2]; auto. + Qed. + + Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. + Proof. + split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. + Qed. + + Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. + Proof. + split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. + Qed. + + Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. + Proof. + split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. + Qed. + + Variable f : elt->bool. + + Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). + Proof. + split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. + Qed. + + Lemma for_all_iff : compat_bool E.eq f -> + (For_all (fun x => f x = true) s <-> for_all f s = true). + Proof. + split; [apply for_all_1 | apply for_all_2]; auto. + Qed. + + Lemma exists_iff : compat_bool E.eq f -> + (Exists (fun x => f x = true) s <-> exists_ f s = true). + Proof. + split; [apply exists_1 | apply exists_2]; auto. + Qed. + + Lemma elements_iff : In x s <-> InA E.eq x (elements s). + Proof. + split; [apply elements_1 | apply elements_2]. + Qed. + + End IffSpec. + + (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + + Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + + (** * Specifications written using boolean predicates *) + + Section BoolSpec. + Variable s s' s'' : t. + Variable x y z : elt. + + Lemma mem_b : E.eq x y -> mem x s = mem y s. + Proof. + intros. + generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). + destruct (mem x s); destruct (mem y s); intuition. + Qed. + + Lemma empty_b : mem y empty = false. + Proof. + generalize (empty_iff y)(mem_iff empty y). + destruct (mem y empty); intuition. + Qed. + + Lemma add_b : mem y (add x s) = eqb x y || mem y s. + Proof. + generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. + destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. + Qed. + + Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. + Proof. + intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). + destruct (mem y s); destruct (mem y (add x s)); intuition. + Qed. + + Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). + Proof. + generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. + destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. + Qed. + + Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. + Proof. + intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). + destruct (mem y s); destruct (mem y (remove x s)); intuition. + Qed. + + Lemma singleton_b : mem y (singleton x) = eqb x y. + Proof. + generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. + destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. + Qed. + + Lemma union_b : mem x (union s s') = mem x s || mem x s'. + Proof. + generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). + destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. + Qed. + + Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. + Proof. + generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). + destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. + Qed. + + Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). + Proof. + generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). + destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. + Qed. + + Lemma elements_b : mem x s = existsb (eqb x) (elements s). + Proof. + generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). + rewrite InA_alt. + destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. + - symmetry. + rewrite H1. + destruct H0 as (H0,_). + destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. + exists a; intuition. + unfold eqb; destruct (eq_dec x a); auto. + - rewrite <- H. + rewrite H0. + destruct H1 as (H1,_). + destruct H1 as (a,(Ha1,Ha2)); [intuition|]. + exists a; intuition. + unfold eqb in *; destruct (eq_dec x a); auto; discriminate. + Qed. + + Variable f : elt->bool. + + Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. + Proof. + intros. + generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). + destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. + Qed. + + Lemma for_all_b : compat_bool E.eq f -> + for_all f s = forallb f (elements s). + Proof. + intros. + generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). + unfold For_all. + destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. + - rewrite <- H1; intros. + destruct H0 as (H0,_). + rewrite (H2 x0) in H3. + rewrite (InA_alt E.eq x0 (elements s)) in H3. + destruct H3 as (a,(Ha1,Ha2)). + rewrite (H _ _ Ha1). + apply H0; auto. + - symmetry. + rewrite H0; intros. + destruct H1 as (_,H1). + apply H1; auto. + rewrite H2. + rewrite InA_alt; eauto. + Qed. + + Lemma exists_b : compat_bool E.eq f -> + exists_ f s = existsb f (elements s). + Proof. + intros. + generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). + unfold Exists. + destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. + - rewrite <- H1; intros. + destruct H0 as (H0,_). + destruct H0 as (a,(Ha1,Ha2)); auto. + exists a; split; auto. + rewrite H2; rewrite InA_alt; eauto. + - symmetry. + rewrite H0. + destruct H1 as (_,H1). + destruct H1 as (a,(Ha1,Ha2)); auto. + rewrite (H2 a) in Ha1. + rewrite (InA_alt E.eq a (elements s)) in Ha1. + destruct Ha1 as (b,(Hb1,Hb2)). + exists b; auto. + rewrite <- (H _ _ Hb1); auto. + Qed. + + End BoolSpec. + + (** * [E.eq] and [Equal] are setoid equalities *) + + #[global] + Instance E_ST : Equivalence E.eq. + Proof. + constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. + Qed. + + #[global] + Instance Equal_ST : Equivalence Equal. + Proof. + constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. + Qed. + + #[global] + Instance In_m : Proper (E.eq ==> Equal ==> iff) In. + Proof. + unfold Equal; intros x y H s s' H0. + rewrite (In_eq_iff s H); auto. + Qed. + + #[global] + Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty. + Proof. + unfold Equal; intros s s' H. + generalize (is_empty_iff s)(is_empty_iff s'). + destruct (is_empty s); destruct (is_empty s'); + unfold Empty; auto; intros. + - symmetry. + rewrite <- H1; intros a Ha. + rewrite <- (H a) in Ha. + destruct H0 as (_,H0). + exact (H0 Logic.eq_refl _ Ha). + - rewrite <- H0; intros a Ha. + rewrite (H a) in Ha. + destruct H1 as (_,H1). + exact (H1 Logic.eq_refl _ Ha). + Qed. + + #[global] + Instance Empty_m : Proper (Equal ==> iff) Empty. + Proof. + repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition. + Qed. + + #[global] + Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem. + Proof. + unfold Equal; intros x y H s s' H0. + generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). + generalize (mem_iff s x)(mem_iff s' y). + destruct (mem x s); destruct (mem y s'); intuition. + Qed. + + #[global] + Instance singleton_m : Proper (E.eq ==> Equal) singleton. + Proof. + unfold Equal; intros x y H a. + do 2 rewrite singleton_iff; split; intros. + - apply E.eq_trans with x; auto. + - apply E.eq_trans with y; auto. + Qed. + + #[global] + Instance add_m : Proper (E.eq==>Equal==>Equal) add. + Proof. + unfold Equal; intros x y H s s' H0 a. + do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. + Qed. + + #[global] + Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. + Proof. + unfold Equal; intros x y H s s' H0 a. + do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. + Qed. + + #[global] + Instance union_m : Proper (Equal==>Equal==>Equal) union. + Proof. + unfold Equal; intros s s' H s'' s''' H0 a. + do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. + Qed. + + #[global] + Instance inter_m : Proper (Equal==>Equal==>Equal) inter. + Proof. + unfold Equal; intros s s' H s'' s''' H0 a. + do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. + Qed. + + #[global] + Instance diff_m : Proper (Equal==>Equal==>Equal) diff. + Proof. + unfold Equal; intros s s' H s'' s''' H0 a. + do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. + Qed. + + #[global] + Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. + Proof. + unfold Equal, Subset; firstorder. + Qed. + + #[global] + Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset. + Proof. + intros s s' H s'' s''' H0. + generalize (subset_iff s s'') (subset_iff s' s'''). + destruct (subset s s''); destruct (subset s' s'''); auto; intros. + - rewrite H in H1; rewrite H0 in H1; intuition. + - rewrite H in H1; rewrite H0 in H1; intuition. + Qed. + + #[global] + Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal. + Proof. + intros s s' H s'' s''' H0. + generalize (equal_iff s s'') (equal_iff s' s'''). + destruct (equal s s''); destruct (equal s' s'''); auto; intros. + - rewrite H in H1; rewrite H0 in H1; intuition. + - rewrite H in H1; rewrite H0 in H1; intuition. + Qed. + + + (* [Subset] is a setoid order *) + + Lemma Subset_refl : forall s, s[<=]s. + Proof. red; auto. Qed. + + Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. + Proof. unfold Subset; eauto. Qed. + + Add Relation t Subset + reflexivity proved by Subset_refl + transitivity proved by Subset_trans + as SubsetSetoid. + + #[global] + Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1. + Proof. + simpl_relation. eauto with set. + Qed. + + Add Morphism Empty with signature Subset --> Basics.impl as Empty_s_m. + Proof. + unfold Subset, Empty, Basics.impl; firstorder. + Qed. + + Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m. + Proof. + unfold Subset; intros x y H s s' H0 a. + do 2 rewrite add_iff; rewrite H; intuition. + Qed. + + Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m. + Proof. + unfold Subset; intros x y H s s' H0 a. + do 2 rewrite remove_iff; rewrite H; intuition. + Qed. + + Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m. + Proof. + unfold Equal; intros s s' H s'' s''' H0 a. + do 2 rewrite union_iff; intuition. + Qed. + + Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m. + Proof. + unfold Equal; intros s s' H s'' s''' H0 a. + do 2 rewrite inter_iff; intuition. + Qed. + + Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m. + Proof. + unfold Subset; intros s s' H s'' s''' H0 a. + do 2 rewrite diff_iff; intuition. + Qed. + + (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism without additional hypothesis on [f]. For instance: *) -Lemma filter_equal : forall f, compat_bool E.eq f -> - forall s s', s[=]s' -> filter f s [=] filter f s'. -Proof. -unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. -Qed. - -Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> - forall s s', s[=]s' -> filter f s [=] filter f' s'. -Proof. -intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). -- rewrite Hff', Hss'; intuition. -- repeat red; intros; rewrite <- 2 Hff'; auto. -Qed. - -Lemma filter_subset : forall f, compat_bool E.eq f -> - forall s s', s[<=]s' -> filter f s [<=] filter f s'. -Proof. -unfold Subset; intros; rewrite filter_iff in *; intuition. -Qed. - -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid + Lemma filter_equal : forall f, compat_bool E.eq f -> + forall s s', s[=]s' -> filter f s [=] filter f s'. + Proof. + unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. + Qed. + + Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> + forall s s', s[=]s' -> filter f s [=] filter f' s'. + Proof. + intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). + - rewrite Hff', Hss'; intuition. + - repeat red; intros; rewrite <- 2 Hff'; auto. + Qed. + + Lemma filter_subset : forall f, compat_bool E.eq f -> + forall s s', s[<=]s' -> filter f s [<=] filter f s'. + Proof. + unfold Subset; intros; rewrite filter_iff in *; intuition. + Qed. + + (* For [elements], [min_elt], [max_elt] and [choose], we would need setoid structures on [list elt] and [option elt]. *) -(* Later: + (* Later: Add Morphism cardinal ; cardinal_m. *) diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 89c84bf3fd..063bdda3cd 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -139,117 +139,117 @@ Module Type WSfun (E : DecidableType). Section Spec. - Variable s s' s'': t. - Variable x y : elt. - - (** Specification of [In] *) - Parameter In_1 : E.eq x y -> In x s -> In y s. - - (** Specification of [eq] *) - Parameter eq_refl : eq s s. - Parameter eq_sym : eq s s' -> eq s' s. - Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. - - (** Specification of [mem] *) - Parameter mem_1 : In x s -> mem x s = true. - Parameter mem_2 : mem x s = true -> In x s. - - (** Specification of [equal] *) - Parameter equal_1 : Equal s s' -> equal s s' = true. - Parameter equal_2 : equal s s' = true -> Equal s s'. - - (** Specification of [subset] *) - Parameter subset_1 : Subset s s' -> subset s s' = true. - Parameter subset_2 : subset s s' = true -> Subset s s'. - - (** Specification of [empty] *) - Parameter empty_1 : Empty empty. - - (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty s -> is_empty s = true. - Parameter is_empty_2 : is_empty s = true -> Empty s. - - (** Specification of [add] *) - Parameter add_1 : E.eq x y -> In y (add x s). - Parameter add_2 : In y s -> In y (add x s). - Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - - (** Specification of [remove] *) - Parameter remove_1 : E.eq x y -> ~ In y (remove x s). - Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Parameter remove_3 : In y (remove x s) -> In y s. - - (** Specification of [singleton] *) - Parameter singleton_1 : In y (singleton x) -> E.eq x y. - Parameter singleton_2 : E.eq x y -> In y (singleton x). - - (** Specification of [union] *) - Parameter union_1 : In x (union s s') -> In x s \/ In x s'. - Parameter union_2 : In x s -> In x (union s s'). - Parameter union_3 : In x s' -> In x (union s s'). - - (** Specification of [inter] *) - Parameter inter_1 : In x (inter s s') -> In x s. - Parameter inter_2 : In x (inter s s') -> In x s'. - Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). - - (** Specification of [diff] *) - Parameter diff_1 : In x (diff s s') -> In x s. - Parameter diff_2 : In x (diff s s') -> ~ In x s'. - Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - - (** Specification of [fold] *) - Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - - (** Specification of [cardinal] *) - Parameter cardinal_1 : cardinal s = length (elements s). - - Section Filter. - - Variable f : elt -> bool. - - (** Specification of [filter] *) - Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Parameter filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - - (** Specification of [for_all] *) - Parameter for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Parameter for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - - (** Specification of [exists] *) - Parameter exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Parameter exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - - (** Specification of [partition] *) - Parameter partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Parameter partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - - End Filter. - - (** Specification of [elements] *) - Parameter elements_1 : In x s -> InA E.eq x (elements s). - Parameter elements_2 : InA E.eq x (elements s) -> In x s. - (** When compared with ordered sets, here comes the only + Variable s s' s'': t. + Variable x y : elt. + + (** Specification of [In] *) + Parameter In_1 : E.eq x y -> In x s -> In y s. + + (** Specification of [eq] *) + Parameter eq_refl : eq s s. + Parameter eq_sym : eq s s' -> eq s' s. + Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. + + (** Specification of [mem] *) + Parameter mem_1 : In x s -> mem x s = true. + Parameter mem_2 : mem x s = true -> In x s. + + (** Specification of [equal] *) + Parameter equal_1 : Equal s s' -> equal s s' = true. + Parameter equal_2 : equal s s' = true -> Equal s s'. + + (** Specification of [subset] *) + Parameter subset_1 : Subset s s' -> subset s s' = true. + Parameter subset_2 : subset s s' = true -> Subset s s'. + + (** Specification of [empty] *) + Parameter empty_1 : Empty empty. + + (** Specification of [is_empty] *) + Parameter is_empty_1 : Empty s -> is_empty s = true. + Parameter is_empty_2 : is_empty s = true -> Empty s. + + (** Specification of [add] *) + Parameter add_1 : E.eq x y -> In y (add x s). + Parameter add_2 : In y s -> In y (add x s). + Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + + (** Specification of [remove] *) + Parameter remove_1 : E.eq x y -> ~ In y (remove x s). + Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). + Parameter remove_3 : In y (remove x s) -> In y s. + + (** Specification of [singleton] *) + Parameter singleton_1 : In y (singleton x) -> E.eq x y. + Parameter singleton_2 : E.eq x y -> In y (singleton x). + + (** Specification of [union] *) + Parameter union_1 : In x (union s s') -> In x s \/ In x s'. + Parameter union_2 : In x s -> In x (union s s'). + Parameter union_3 : In x s' -> In x (union s s'). + + (** Specification of [inter] *) + Parameter inter_1 : In x (inter s s') -> In x s. + Parameter inter_2 : In x (inter s s') -> In x s'. + Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). + + (** Specification of [diff] *) + Parameter diff_1 : In x (diff s s') -> In x s. + Parameter diff_2 : In x (diff s s') -> ~ In x s'. + Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). + + (** Specification of [fold] *) + Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + + (** Specification of [cardinal] *) + Parameter cardinal_1 : cardinal s = length (elements s). + + Section Filter. + + Variable f : elt -> bool. + + (** Specification of [filter] *) + Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Parameter filter_3 : + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + + (** Specification of [for_all] *) + Parameter for_all_1 : + compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Parameter for_all_2 : + compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + + (** Specification of [exists] *) + Parameter exists_1 : + compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true. + Parameter exists_2 : + compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s. + + (** Specification of [partition] *) + Parameter partition_1 : + compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). + Parameter partition_2 : + compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + + End Filter. + + (** Specification of [elements] *) + Parameter elements_1 : In x s -> InA E.eq x (elements s). + Parameter elements_2 : InA E.eq x (elements s) -> In x s. + (** When compared with ordered sets, here comes the only property that is really weaker: *) - Parameter elements_3w : NoDupA E.eq (elements s). + Parameter elements_3w : NoDupA E.eq (elements s). - (** Specification of [choose] *) - Parameter choose_1 : choose s = Some x -> In x s. - Parameter choose_2 : choose s = None -> Empty s. + (** Specification of [choose] *) + Parameter choose_1 : choose s = Some x -> In x s. + Parameter choose_2 : choose s = None -> Empty s. End Spec. @@ -308,34 +308,34 @@ Module Type Sfun (E : OrderedType). Section Spec. - Variable s s' s'' : t. - Variable x y : elt. + Variable s s' s'' : t. + Variable x y : elt. - (** Specification of [lt] *) - Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Parameter lt_not_eq : lt s s' -> ~ eq s s'. + (** Specification of [lt] *) + Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. + Parameter lt_not_eq : lt s s' -> ~ eq s s'. - (** Additional specification of [elements] *) - Parameter elements_3 : sort E.lt (elements s). + (** Additional specification of [elements] *) + Parameter elements_3 : sort E.lt (elements s). - (** Remark: since [fold] is specified via [elements], this stronger + (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) - (** Specification of [min_elt] *) - Parameter min_elt_1 : min_elt s = Some x -> In x s. - Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Parameter min_elt_3 : min_elt s = None -> Empty s. + (** Specification of [min_elt] *) + Parameter min_elt_1 : min_elt s = Some x -> In x s. + Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_3 : min_elt s = None -> Empty s. - (** Specification of [max_elt] *) - Parameter max_elt_1 : max_elt s = Some x -> In x s. - Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Parameter max_elt_3 : max_elt s = None -> Empty s. + (** Specification of [max_elt] *) + Parameter max_elt_1 : max_elt s = Some x -> In x s. + Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_3 : max_elt s = None -> Empty s. - (** Additional specification of [choose] *) - Parameter choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. + (** Additional specification of [choose] *) + Parameter choose_3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. End Spec. diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index a18f4aaf1a..a9b379be74 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -23,7 +23,7 @@ Unset Strict Implicit. From Stdlib Require FSetCompat MSetList Orders OrdersAlt. Module Make (X: OrderedType) <: S with Module E := X. - Module X' := OrdersAlt.Update_OT X. - Module MSet := MSetList.Make X'. - Include FSetCompat.Backport_Sets X MSet. + Module X' := OrdersAlt.Update_OT X. + Module MSet := MSetList.Make X'. + Include FSetCompat.Backport_Sets X MSet. End Make. diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v index b27162c62f..82136d2fa6 100644 --- a/theories/FSets/FSetPositive.v +++ b/theories/FSets/FSetPositive.v @@ -545,107 +545,107 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section lt_spec. - Inductive ct: comparison -> comparison -> comparison -> Prop := - | ct_xxx: forall x, ct x x x - | ct_xex: forall x, ct x Eq x - | ct_exx: forall x, ct Eq x x - | ct_glx: forall x, ct Gt Lt x - | ct_lgx: forall x, ct Lt Gt x. - - Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_xce: forall x, ct x (CompOpp x) Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_lxl: forall x, ct Lt x Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_gxg: forall x, ct Gt x Gt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xll: forall x, ct x Lt Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xgg: forall x, ct x Gt Gt. - Proof. destruct x; constructor. Qed. - - #[local] Hint Constructors ct: ct. - #[local] Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. - Ltac ct := trivial with ct. - - Lemma ct_lex: forall u v w u' v' w', - ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). - Proof. - intros u v w u' v' w' H H'. - inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. - Qed. - - Lemma ct_compare_bool: - forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). - Proof. - intros [|] [|] [|]; constructor. - Qed. - - Lemma compare_x_Leaf: forall s, - compare_fun s Leaf = if is_empty s then Eq else Gt. - Proof. - intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. - Qed. - - Lemma compare_empty_x: forall a, is_empty a = true -> - forall b, compare_fun a b = if is_empty b then Eq else Lt. - Proof. - induction a as [|l IHl o r IHr]; trivial. - destruct o. - - intro; discriminate. - - simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. - intros [Hl Hr]. - destruct b as [|l' [|] r']; simpl compare_fun; trivial. - + rewrite Hl, Hr. trivial. - + rewrite (IHl Hl), (IHr Hr). simpl. - case (is_empty l'); case (is_empty r'); trivial. - Qed. - - Lemma compare_x_empty: forall a, is_empty a = true -> - forall b, compare_fun b a = if is_empty b then Eq else Gt. - Proof. - setoid_rewrite <- compare_x_Leaf. - intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. - Qed. - - Lemma ct_compare_fun: - forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c). - Proof. - induction a as [|l IHl o r IHr]; intros s' s''. - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. - + rewrite compare_inv. ct. - + unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'. - * rewrite (compare_empty_x _ H'). ct. - * unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H'. ct. - -- ct. - - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. - + ct. - + unfold compare_fun at 2. rewrite compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite (compare_empty_x _ H). ct. - * case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H. ct. - -- ct. - - + rewrite 2 compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite compare_inv, (compare_x_empty _ H). ct. - * case_eq (is_empty (Node l' o' r')); intro H'. - -- rewrite (compare_x_empty _ H'), H. ct. - -- ct. - - + simpl compare_fun. apply ct_lex. - * apply ct_compare_bool. - * apply ct_lex; trivial. - Qed. + Inductive ct: comparison -> comparison -> comparison -> Prop := + | ct_xxx: forall x, ct x x x + | ct_xex: forall x, ct x Eq x + | ct_exx: forall x, ct Eq x x + | ct_glx: forall x, ct Gt Lt x + | ct_lgx: forall x, ct Lt Gt x. + + Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_xce: forall x, ct x (CompOpp x) Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_lxl: forall x, ct Lt x Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_gxg: forall x, ct Gt x Gt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xll: forall x, ct x Lt Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xgg: forall x, ct x Gt Gt. + Proof. destruct x; constructor. Qed. + + #[local] Hint Constructors ct: ct. + #[local] Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. + Ltac ct := trivial with ct. + + Lemma ct_lex: forall u v w u' v' w', + ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). + Proof. + intros u v w u' v' w' H H'. + inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. + Qed. + + Lemma ct_compare_bool: + forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). + Proof. + intros [|] [|] [|]; constructor. + Qed. + + Lemma compare_x_Leaf: forall s, + compare_fun s Leaf = if is_empty s then Eq else Gt. + Proof. + intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. + Qed. + + Lemma compare_empty_x: forall a, is_empty a = true -> + forall b, compare_fun a b = if is_empty b then Eq else Lt. + Proof. + induction a as [|l IHl o r IHr]; trivial. + destruct o. + - intro; discriminate. + - simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. + intros [Hl Hr]. + destruct b as [|l' [|] r']; simpl compare_fun; trivial. + + rewrite Hl, Hr. trivial. + + rewrite (IHl Hl), (IHr Hr). simpl. + case (is_empty l'); case (is_empty r'); trivial. + Qed. + + Lemma compare_x_empty: forall a, is_empty a = true -> + forall b, compare_fun b a = if is_empty b then Eq else Gt. + Proof. + setoid_rewrite <- compare_x_Leaf. + intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. + Qed. + + Lemma ct_compare_fun: + forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c). + Proof. + induction a as [|l IHl o r IHr]; intros s' s''. + - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. + + rewrite compare_inv. ct. + + unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'. + * rewrite (compare_empty_x _ H'). ct. + * unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. + -- rewrite (compare_x_empty _ H''), H'. ct. + -- ct. + + - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. + + ct. + + unfold compare_fun at 2. rewrite compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + * rewrite (compare_empty_x _ H). ct. + * case_eq (is_empty (Node l'' o'' r'')); intro H''. + -- rewrite (compare_x_empty _ H''), H. ct. + -- ct. + + + rewrite 2 compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + * rewrite compare_inv, (compare_x_empty _ H). ct. + * case_eq (is_empty (Node l' o' r')); intro H'. + -- rewrite (compare_x_empty _ H'), H. ct. + -- ct. + + + simpl compare_fun. apply ct_lex. + * apply ct_compare_bool. + * apply ct_lex; trivial. + Qed. End lt_spec. @@ -1093,16 +1093,16 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s. Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (min_elt l); intros. - + injection H as [= <-]. apply IHl. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (min_elt r); simpl in *. - -- injection H as [= <-]. apply IHr. reflexivity. - -- discriminate. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + - intros. discriminate. + - intros x. destruct (min_elt l); intros. + + injection H as [= <-]. apply IHl. reflexivity. + + destruct o; simpl. + * injection H as [= <-]. reflexivity. + * destruct (min_elt r); simpl in *. + -- injection H as [= <-]. apply IHr. reflexivity. + -- discriminate. Qed. Lemma min_elt_3: forall s, min_elt s = None -> Empty s. @@ -1146,16 +1146,16 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s. Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (max_elt r); intros. - + injection H as [= <-]. apply IHr. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (max_elt l); simpl in *. - -- injection H as [= <-]. apply IHl. reflexivity. - -- discriminate. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + - intros. discriminate. + - intros x. destruct (max_elt r); intros. + + injection H as [= <-]. apply IHr. reflexivity. + + destruct o; simpl. + * injection H as [= <-]. reflexivity. + * destruct (max_elt l); simpl in *. + -- injection H as [= <-]. apply IHl. reflexivity. + -- discriminate. Qed. Lemma max_elt_3: forall s, max_elt s = None -> Empty s. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 1bbce8aade..9d86f733c5 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -35,239 +35,239 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma In_dec : forall x s, {In x s} + {~ In x s}. Proof. - intros; generalize (mem_iff s x); case (mem x s); intuition auto with bool. + intros; generalize (mem_iff s x); case (mem x s); intuition auto with bool. Qed. Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. Proof. - unfold Add. - split; intros. - - red; intros. - rewrite H; clear H. - fsetdec. - - fsetdec. + unfold Add. + split; intros. + - red; intros. + rewrite H; clear H. + fsetdec. + - fsetdec. Qed. Ltac expAdd := repeat rewrite Add_Equal. Section BasicProperties. - Variable s s' s'' s1 s2 s3 : t. - Variable x x' : elt. + Variable s s' s'' s1 s2 s3 : t. + Variable x x' : elt. - Lemma equal_refl : s[=]s. - Proof. fsetdec. Qed. + Lemma equal_refl : s[=]s. + Proof. fsetdec. Qed. - Lemma equal_sym : s[=]s' -> s'[=]s. - Proof. fsetdec. Qed. + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. fsetdec. Qed. - Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. - Proof. fsetdec. Qed. + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. fsetdec. Qed. - Lemma subset_refl : s[<=]s. - Proof. fsetdec. Qed. + Lemma subset_refl : s[<=]s. + Proof. fsetdec. Qed. - Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. - Proof. fsetdec. Qed. + Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. + Proof. fsetdec. Qed. - Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. - Proof. fsetdec. Qed. + Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. + Proof. fsetdec. Qed. - Lemma subset_equal : s[=]s' -> s[<=]s'. - Proof. fsetdec. Qed. + Lemma subset_equal : s[=]s' -> s[<=]s'. + Proof. fsetdec. Qed. - Lemma subset_empty : empty[<=]s. - Proof. fsetdec. Qed. + Lemma subset_empty : empty[<=]s. + Proof. fsetdec. Qed. - Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. - Proof. fsetdec. Qed. + Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. + Proof. fsetdec. Qed. - Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. - Proof. fsetdec. Qed. + Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. + Proof. fsetdec. Qed. - Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. - Proof. fsetdec. Qed. + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. + Proof. fsetdec. Qed. - Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. - Proof. fsetdec. Qed. + Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. + Proof. fsetdec. Qed. - Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. - Proof. fsetdec. Qed. + Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. + Proof. fsetdec. Qed. - Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. - Proof. intuition fsetdec. Qed. + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. + Proof. intuition fsetdec. Qed. - Lemma empty_is_empty_1 : Empty s -> s[=]empty. - Proof. fsetdec. Qed. + Lemma empty_is_empty_1 : Empty s -> s[=]empty. + Proof. fsetdec. Qed. - Lemma empty_is_empty_2 : s[=]empty -> Empty s. - Proof. fsetdec. Qed. + Lemma empty_is_empty_2 : s[=]empty -> Empty s. + Proof. fsetdec. Qed. - Lemma add_equal : In x s -> add x s [=] s. - Proof. fsetdec. Qed. + Lemma add_equal : In x s -> add x s [=] s. + Proof. fsetdec. Qed. - Lemma add_add : add x (add x' s) [=] add x' (add x s). - Proof. fsetdec. Qed. + Lemma add_add : add x (add x' s) [=] add x' (add x s). + Proof. fsetdec. Qed. - Lemma remove_equal : ~ In x s -> remove x s [=] s. - Proof. fsetdec. Qed. + Lemma remove_equal : ~ In x s -> remove x s [=] s. + Proof. fsetdec. Qed. - Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. - Proof. fsetdec. Qed. + Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. + Proof. fsetdec. Qed. - Lemma add_remove : In x s -> add x (remove x s) [=] s. - Proof. fsetdec. Qed. + Lemma add_remove : In x s -> add x (remove x s) [=] s. + Proof. fsetdec. Qed. - Lemma remove_add : ~In x s -> remove x (add x s) [=] s. - Proof. fsetdec. Qed. + Lemma remove_add : ~In x s -> remove x (add x s) [=] s. + Proof. fsetdec. Qed. - Lemma singleton_equal_add : singleton x [=] add x empty. - Proof. fsetdec. Qed. + Lemma singleton_equal_add : singleton x [=] add x empty. + Proof. fsetdec. Qed. - Lemma remove_singleton_empty : - In x s -> remove x s [=] empty -> singleton x [=] s. - Proof. fsetdec. Qed. + Lemma remove_singleton_empty : + In x s -> remove x s [=] empty -> singleton x [=] s. + Proof. fsetdec. Qed. - Lemma union_sym : union s s' [=] union s' s. - Proof. fsetdec. Qed. + Lemma union_sym : union s s' [=] union s' s. + Proof. fsetdec. Qed. - Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. - Proof. fsetdec. Qed. + Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. + Proof. fsetdec. Qed. - Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. - Proof. fsetdec. Qed. + Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. + Proof. fsetdec. Qed. - Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. - Proof. fsetdec. Qed. + Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. + Proof. fsetdec. Qed. - Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). - Proof. fsetdec. Qed. + Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). + Proof. fsetdec. Qed. - Lemma add_union_singleton : add x s [=] union (singleton x) s. - Proof. fsetdec. Qed. + Lemma add_union_singleton : add x s [=] union (singleton x) s. + Proof. fsetdec. Qed. - Lemma union_add : union (add x s) s' [=] add x (union s s'). - Proof. fsetdec. Qed. + Lemma union_add : union (add x s) s' [=] add x (union s s'). + Proof. fsetdec. Qed. - Lemma union_remove_add_1 : - union (remove x s) (add x s') [=] union (add x s) (remove x s'). - Proof. fsetdec. Qed. + Lemma union_remove_add_1 : + union (remove x s) (add x s') [=] union (add x s) (remove x s'). + Proof. fsetdec. Qed. - Lemma union_remove_add_2 : In x s -> - union (remove x s) (add x s') [=] union s s'. - Proof. fsetdec. Qed. + Lemma union_remove_add_2 : In x s -> + union (remove x s) (add x s') [=] union s s'. + Proof. fsetdec. Qed. - Lemma union_subset_1 : s [<=] union s s'. - Proof. fsetdec. Qed. + Lemma union_subset_1 : s [<=] union s s'. + Proof. fsetdec. Qed. - Lemma union_subset_2 : s' [<=] union s s'. - Proof. fsetdec. Qed. + Lemma union_subset_2 : s' [<=] union s s'. + Proof. fsetdec. Qed. - Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. - Proof. fsetdec. Qed. + Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. + Proof. fsetdec. Qed. - Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. + Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. + Proof. fsetdec. Qed. - Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. + Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. + Proof. fsetdec. Qed. - Lemma empty_union_1 : Empty s -> union s s' [=] s'. - Proof. fsetdec. Qed. + Lemma empty_union_1 : Empty s -> union s s' [=] s'. + Proof. fsetdec. Qed. - Lemma empty_union_2 : Empty s -> union s' s [=] s'. - Proof. fsetdec. Qed. + Lemma empty_union_2 : Empty s -> union s' s [=] s'. + Proof. fsetdec. Qed. - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). - Proof. fsetdec. Qed. + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Proof. fsetdec. Qed. - Lemma inter_sym : inter s s' [=] inter s' s. - Proof. fsetdec. Qed. + Lemma inter_sym : inter s s' [=] inter s' s. + Proof. fsetdec. Qed. - Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. - Proof. fsetdec. Qed. + Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. + Proof. fsetdec. Qed. - Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. - Proof. fsetdec. Qed. + Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. + Proof. fsetdec. Qed. - Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. - Proof. fsetdec. Qed. + Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. + Proof. fsetdec. Qed. - Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). - Proof. fsetdec. Qed. + Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). + Proof. fsetdec. Qed. - Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). - Proof. fsetdec. Qed. + Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). + Proof. fsetdec. Qed. - Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). - Proof. fsetdec. Qed. + Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). + Proof. fsetdec. Qed. - Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). - Proof. fsetdec. Qed. + Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). + Proof. fsetdec. Qed. - Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. - Proof. fsetdec. Qed. + Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. + Proof. fsetdec. Qed. - Lemma empty_inter_1 : Empty s -> Empty (inter s s'). - Proof. fsetdec. Qed. + Lemma empty_inter_1 : Empty s -> Empty (inter s s'). + Proof. fsetdec. Qed. - Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). - Proof. fsetdec. Qed. + Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). + Proof. fsetdec. Qed. - Lemma inter_subset_1 : inter s s' [<=] s. - Proof. fsetdec. Qed. + Lemma inter_subset_1 : inter s s' [<=] s. + Proof. fsetdec. Qed. - Lemma inter_subset_2 : inter s s' [<=] s'. - Proof. fsetdec. Qed. + Lemma inter_subset_2 : inter s s' [<=] s'. + Proof. fsetdec. Qed. - Lemma inter_subset_3 : - s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. - Proof. fsetdec. Qed. + Lemma inter_subset_3 : + s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. + Proof. fsetdec. Qed. - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). - Proof. fsetdec. Qed. + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Proof. fsetdec. Qed. - Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. - Proof. fsetdec. Qed. + Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. + Proof. fsetdec. Qed. - Lemma diff_subset : diff s s' [<=] s. - Proof. fsetdec. Qed. + Lemma diff_subset : diff s s' [<=] s. + Proof. fsetdec. Qed. - Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. - Proof. fsetdec. Qed. + Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. + Proof. fsetdec. Qed. - Lemma remove_diff_singleton : - remove x s [=] diff s (singleton x). - Proof. fsetdec. Qed. + Lemma remove_diff_singleton : + remove x s [=] diff s (singleton x). + Proof. fsetdec. Qed. - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. - Proof. fsetdec. Qed. + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Proof. fsetdec. Qed. - Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. - Proof. fsetdec. Qed. + Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. + Proof. fsetdec. Qed. - Lemma Add_add : Add x s (add x s). - Proof. expAdd; fsetdec. Qed. + Lemma Add_add : Add x s (add x s). + Proof. expAdd; fsetdec. Qed. - Lemma Add_remove : In x s -> Add x (remove x s) s. - Proof. expAdd; fsetdec. Qed. + Lemma Add_remove : In x s -> Add x (remove x s) s. + Proof. expAdd; fsetdec. Qed. - Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. + Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). + Proof. expAdd; fsetdec. Qed. - Lemma inter_Add : - In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. + Lemma inter_Add : + In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). + Proof. expAdd; fsetdec. Qed. - Lemma union_Equal : - In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. + Lemma union_Equal : + In x s'' -> Add x s s' -> union s s'' [=] union s' s''. + Proof. expAdd; fsetdec. Qed. - Lemma inter_Add_2 : - ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. - Proof. expAdd; fsetdec. Qed. + Lemma inter_Add_2 : + ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. + Proof. expAdd; fsetdec. Qed. End BasicProperties. @@ -291,26 +291,26 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma elements_Empty : forall s, Empty s <-> elements s = nil. Proof. - intros. - unfold Empty. - split; intros. - - assert (forall a, ~ List.In a (elements s)). { - red; intros. - apply (H a). - rewrite elements_iff. - rewrite InA_alt; exists a; auto. - } - destruct (elements s); auto. - elim (H0 e); simpl; auto. - - red; intros. - rewrite elements_iff in H0. - rewrite InA_alt in H0; destruct H0. - rewrite H in H0; destruct H0 as (_,H0); inversion H0. + intros. + unfold Empty. + split; intros. + - assert (forall a, ~ List.In a (elements s)). { + red; intros. + apply (H a). + rewrite elements_iff. + rewrite InA_alt; exists a; auto. + } + destruct (elements s); auto. + elim (H0 e); simpl; auto. + - red; intros. + rewrite elements_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. Qed. Lemma elements_empty : elements empty = nil. Proof. - rewrite <-elements_Empty; auto with set. + rewrite <-elements_Empty; auto with set. Qed. (** * Conversions between lists and sets *) @@ -321,375 +321,375 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. Proof. - induction l; simpl; intro x. - - rewrite empty_iff, InA_nil. intuition. - - rewrite add_iff, InA_cons, IHl. intuition. + induction l; simpl; intro x. + - rewrite empty_iff, InA_nil. intuition. + - rewrite add_iff, InA_cons, IHl. intuition. Qed. Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. Proof. - unfold to_list; red; intros. - rewrite <- elements_iff; apply of_list_1. + unfold to_list; red; intros. + rewrite <- elements_iff; apply of_list_1. Qed. Lemma of_list_3 : forall s, of_list (to_list s) [=] s. Proof. - unfold to_list; red; intros. - rewrite of_list_1; symmetry; apply elements_iff. + unfold to_list; red; intros. + rewrite of_list_1; symmetry; apply elements_iff. Qed. (** * Fold *) Section Fold. - (** Alternative specification via [fold_right] *) + (** Alternative specification via [fold_right] *) - Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : - fold f s i = List.fold_right f i (rev (elements s)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. + Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : + fold f s i = List.fold_right f i (rev (elements s)). + Proof. + rewrite fold_1. symmetry. apply fold_left_rev_right. + Qed. - Notation NoDup := (NoDupA E.eq). - Notation InA := (InA E.eq). + Notation NoDup := (NoDupA E.eq). + Notation InA := (InA E.eq). - (** ** Induction principles for fold (contributed by S. Lescuyer) *) + (** ** Induction principles for fold (contributed by S. Lescuyer) *) - (** In the following lemma, the step hypothesis is deliberately restricted + (** In the following lemma, the step hypothesis is deliberately restricted to the precise set s we are considering. *) - Theorem fold_rec : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s', Empty s' -> P s' i) -> - (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> - P s' a -> P s'' (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pempty Pstep. - rewrite fold_spec_right. set (l:=rev (elements s)). - assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> - P s' a -> P s'' (f x a)). { - intros; eapply Pstep; eauto. - rewrite elements_iff, <- InA_rev; auto. - } - assert (Hdup : NoDup l) by - (unfold l; eauto using elements_3w, NoDupA_rev with * ). - assert (Hsame : forall x, In x s <-> InA x l) by - (unfold l; intros; rewrite elements_iff, InA_rev; intuition). - clear Pstep; clearbody l; revert s Hsame; induction l. - - (* empty *) - intros s Hsame; simpl. - apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. - - (* step *) - intros s Hsame; simpl. - apply Pstep' with (of_list l); auto. - + inversion_clear Hdup; rewrite of_list_1; auto. - + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. - + apply IHl. - * intros; eapply Pstep'; eauto. - * inversion_clear Hdup; auto. - * exact (of_list_1 l). - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + Theorem fold_rec : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s', Empty s' -> P s' i) -> + (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pempty Pstep. + rewrite fold_spec_right. set (l:=rev (elements s)). + assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)). { + intros; eapply Pstep; eauto. + rewrite elements_iff, <- InA_rev; auto. + } + assert (Hdup : NoDup l) by + (unfold l; eauto using elements_3w, NoDupA_rev with * ). + assert (Hsame : forall x, In x s <-> InA x l) by + (unfold l; intros; rewrite elements_iff, InA_rev; intuition). + clear Pstep; clearbody l; revert s Hsame; induction l. + - (* empty *) + intros s Hsame; simpl. + apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. + - (* step *) + intros s Hsame; simpl. + apply Pstep' with (of_list l); auto. + + inversion_clear Hdup; rewrite of_list_1; auto. + + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. + + apply IHl. + * intros; eapply Pstep'; eauto. + * inversion_clear Hdup; auto. + * exact (of_list_1 l). + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this case, [P] must be compatible with equality of sets *) - Theorem fold_rec_bis : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - (P empty i) -> - (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pmorphism Pempty Pstep. - apply fold_rec; intros. - - apply Pmorphism with empty; auto with set. - - rewrite Add_Equal in H1; auto with set. - apply Pmorphism with (add x s'); auto with set. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), - P i -> (forall x a, In x s -> P a -> P (f x a)) -> - P (fold f s i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + Theorem fold_rec_bis : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + (P empty i) -> + (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pmorphism Pempty Pstep. + apply fold_rec; intros. + - apply Pmorphism with empty; auto with set. + - rewrite Add_Equal in H1; auto with set. + apply Pmorphism with (add x s'); auto with set. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), + P i -> (forall x a, In x s -> P a -> P (f x a)) -> + P (fold f s i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : the step hypothesis must here be applicable to any [x]. At the same time, it looks more like an induction principle, and hence can be easier to use. *) - Lemma fold_rec_weak : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - P empty i -> - (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> - forall s, P s (fold f s i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), - R i j -> - (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> - R (fold f s i) (fold g s j). - Proof. - intros A B R f g i j s Rempty Rstep. - rewrite 2 fold_spec_right. set (l:=rev (elements s)). - assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by - (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). - clearbody l; clear Rstep s. - induction l; simpl; auto. - Qed. - - (** From the induction principle on [fold], we can deduce some general + Lemma fold_rec_weak : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + P empty i -> + (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> + forall s, P s (fold f s i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), + R i j -> + (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> + R (fold f s i) (fold g s j). + Proof. + intros A B R f g i j s Rempty Rstep. + rewrite 2 fold_spec_right. set (l:=rev (elements s)). + assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). + clearbody l; clear Rstep s. + induction l; simpl; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general induction principles on sets. *) - Lemma set_induction : - forall P : t -> Type, - (forall s, Empty s -> P s) -> - (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> - forall s, P s. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - Lemma set_induction_bis : - forall P : t -> Type, - (forall s s', s [=] s' -> P s -> P s') -> - P empty -> - (forall x s, ~In x s -> P s -> P (add x s)) -> - forall s, P s. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall s, fold add s empty [=] s. - Proof. - intros. - apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. - intros. rewrite H2; rewrite Add_Equal in H1; auto with set. - Qed. - - (** ** Alternative (weaker) specifications for [fold] *) - - (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] + Lemma set_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall s, P s. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + Lemma set_induction_bis : + forall P : t -> Type, + (forall s s', s [=] s' -> P s -> P s') -> + P empty -> + (forall x s, ~In x s -> P s -> P (add x s)) -> + forall s, P s. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall s, fold add s empty [=] s. + Proof. + intros. + apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. + intros. rewrite H2; rewrite Add_Equal in H1; auto with set. + Qed. + + (** ** Alternative (weaker) specifications for [fold] *) + + (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] takes the set elements was unspecified. This specification reflects this fact: *) - Lemma fold_0 : - forall s (A : Type) (i : A) (f : elt -> A -> A), - exists l : list elt, - NoDup l /\ - (forall x : elt, In x s <-> InA x l) /\ - fold f s i = fold_right f i l. - Proof. - intros; exists (rev (elements s)); split. - - apply NoDupA_rev. - + auto with typeclass_instances. - + auto with set. - - split; intros. - + rewrite elements_iff; do 2 rewrite InA_alt. - split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. - + apply fold_spec_right. - Qed. - - (** An alternate (and previous) specification for [fold] was based on + Lemma fold_0 : + forall s (A : Type) (i : A) (f : elt -> A -> A), + exists l : list elt, + NoDup l /\ + (forall x : elt, In x s <-> InA x l) /\ + fold f s i = fold_right f i l. + Proof. + intros; exists (rev (elements s)); split. + - apply NoDupA_rev. + + auto with typeclass_instances. + + auto with set. + - split; intros. + + rewrite elements_iff; do 2 rewrite InA_alt. + split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. + + apply fold_spec_right. + Qed. + + (** An alternate (and previous) specification for [fold] was based on the recursive structure of a set. It is now lemmas [fold_1] and [fold_2]. *) - Lemma fold_1 : - forall s (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Empty s -> eqA (fold f s i) i. - Proof. - unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). - rewrite H3; clear H3. - generalize H H2; clear H H2; case l; simpl; intros. - - reflexivity. - - elim (H e). - elim (H2 e); intuition. - Qed. - - Lemma fold_2 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - compat_op E.eq eqA f -> - transpose eqA f -> - ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); - destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). - rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. - apply fold_right_add with (eqA:=E.eq)(eqB:=eqA). { auto with typeclass_instances. } 1-5: auto. - - rewrite <- Hl1; auto. - - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; - rewrite (H2 a); intuition. - Qed. - - (** In fact, [fold] on empty sets is more than equivalent to + Lemma fold_1 : + forall s (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Empty s -> eqA (fold f s i) i. + Proof. + unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). + rewrite H3; clear H3. + generalize H H2; clear H H2; case l; simpl; intros. + - reflexivity. + - elim (H e). + elim (H2 e); intuition. + Qed. + + Lemma fold_2 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + compat_op E.eq eqA f -> + transpose eqA f -> + ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). + rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA). { auto with typeclass_instances. } 1-5: auto. + - rewrite <- Hl1; auto. + - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + rewrite (H2 a); intuition. + Qed. + + (** In fact, [fold] on empty sets is more than equivalent to the initial element, it is Leibniz-equal to it. *) - Lemma fold_1b : - forall s (A : Type)(i : A) (f : elt -> A -> A), - Empty s -> (fold f s i) = i. - Proof. - intros. - rewrite M.fold_1. - rewrite elements_Empty in H; rewrite H; simpl; auto. - Qed. - - Section Fold_More. - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). + Lemma fold_1b : + forall s (A : Type)(i : A) (f : elt -> A -> A), + Empty s -> (fold f s i) = i. + Proof. + intros. + rewrite M.fold_1. + rewrite elements_Empty in H; rewrite H; simpl; auto. + Qed. - Lemma fold_commutes : forall i s x, - eqA (fold f s (f x i)) (f x (fold f s i)). - Proof. - intros. - apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. - - reflexivity. - - transitivity (f x0 (f x b)); auto. apply Comp; auto. - Qed. + Section Fold_More. - (** ** Fold is a morphism *) + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - Lemma fold_init : forall i i' s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros. apply fold_rel with (R:=eqA); auto. - intros; apply Comp; auto. - Qed. - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros i s; pattern s; apply set_induction; clear s; intros. - - transitivity i. - + apply fold_1; auto. - + symmetry; apply fold_1; auto. - rewrite <- H0; auto. - - transitivity (f x (fold f s i)). - + apply fold_2 with (eqA := eqA); auto. - + symmetry; apply fold_2 with (eqA := eqA); auto. - unfold Add in *; intros. - rewrite <- H2; auto. - Qed. - - (** ** Fold and other set operators *) - - Lemma fold_empty : forall i, fold f empty i = i. - Proof. - intros i; apply fold_1b; auto with set. - Qed. - - Lemma fold_add : forall i s x, ~In x s -> - eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. - intros; apply fold_2 with (eqA := eqA); auto with set. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_1: forall i s x, In x s -> - eqA (f x (fold f (remove x s) i)) (fold f s i). - Proof. - intros. - symmetry. - apply fold_2 with (eqA:=eqA); auto with set. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - Lemma fold_union_inter : forall i s s', - eqA (fold f (union s s') (fold f (inter s s') i)) - (fold f s (fold f s' i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - - transitivity (fold f s' (fold f (inter s s') i)). - { apply fold_equal; auto with set. } - transitivity (fold f s' i). - + apply fold_init; auto. - apply fold_1; auto with set. - + symmetry; apply fold_1; auto. - - rename s'0 into s''. - destruct (In_dec x s'). - + (* In x s' *) - transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. - * apply fold_init; auto. + Lemma fold_commutes : forall i s x, + eqA (fold f s (f x i)) (f x (fold f s i)). + Proof. + intros. + apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. + - reflexivity. + - transitivity (f x0 (f x b)); auto. apply Comp; auto. + Qed. + + (** ** Fold is a morphism *) + + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros; apply Comp; auto. + Qed. + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros i s; pattern s; apply set_induction; clear s; intros. + - transitivity i. + + apply fold_1; auto. + + symmetry; apply fold_1; auto. + rewrite <- H0; auto. + - transitivity (f x (fold f s i)). + + apply fold_2 with (eqA := eqA); auto. + + symmetry; apply fold_2 with (eqA := eqA); auto. + unfold Add in *; intros. + rewrite <- H2; auto. + Qed. + + (** ** Fold and other set operators *) + + Lemma fold_empty : forall i, fold f empty i = i. + Proof. + intros i; apply fold_1b; auto with set. + Qed. + + Lemma fold_add : forall i s x, ~In x s -> + eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_2 with (eqA := eqA); auto with set. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_1: forall i s x, In x s -> + eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros. + symmetry. apply fold_2 with (eqA:=eqA); auto with set. - rewrite inter_iff; intuition. - * transitivity (f x (fold f s (fold f s' i))). - 1:transitivity (fold f (union s s') (f x (fold f (inter s s') i))). - -- apply fold_equal; auto. - apply equal_sym; apply union_Equal with x; auto with set. - -- transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - { apply fold_commutes; auto. } - apply Comp; auto. - -- symmetry; apply fold_2 with (eqA:=eqA); auto. - + (* ~(In x s') *) - transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). - { apply fold_2 with (eqA:=eqA); auto with set. } - transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - * apply Comp;auto. - apply fold_init;auto. - apply fold_equal;auto. - apply equal_sym; apply inter_Add_2 with x; auto with set. - * transitivity (f x (fold f s (fold f s' i))). - -- apply Comp; auto. - -- symmetry; apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma fold_diff_inter : forall i s s', - eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). - Proof. - intros. - transitivity (fold f (union (diff s s') (inter s s')) - (fold f (inter (diff s s') (inter s s')) i)). - { symmetry; apply fold_union_inter; auto. } - transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). - { apply fold_equal; auto with set. } - apply fold_init; auto. - apply fold_1; auto with set. - Qed. + Qed. - Lemma fold_union: forall i s s', - (forall x, ~(In x s/\In x s')) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). - Proof. - intros. - transitivity (fold f (union s s') (fold f (inter s s') i)). - { apply fold_init; auto. - symmetry; apply fold_1; auto with set. - unfold Empty; intro a; generalize (H a); set_iff; tauto. } - apply fold_union_inter; auto. - Qed. + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + Lemma fold_union_inter : forall i s s', + eqA (fold f (union s s') (fold f (inter s s') i)) + (fold f s (fold f s' i)). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + - transitivity (fold f s' (fold f (inter s s') i)). + { apply fold_equal; auto with set. } + transitivity (fold f s' i). + + apply fold_init; auto. + apply fold_1; auto with set. + + symmetry; apply fold_1; auto. + - rename s'0 into s''. + destruct (In_dec x s'). + + (* In x s' *) + transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. + * apply fold_init; auto. + apply fold_2 with (eqA:=eqA); auto with set. + rewrite inter_iff; intuition. + * transitivity (f x (fold f s (fold f s' i))). + 1:transitivity (fold f (union s s') (f x (fold f (inter s s') i))). + -- apply fold_equal; auto. + apply equal_sym; apply union_Equal with x; auto with set. + -- transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + { apply fold_commutes; auto. } + apply Comp; auto. + -- symmetry; apply fold_2 with (eqA:=eqA); auto. + + (* ~(In x s') *) + transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). + { apply fold_2 with (eqA:=eqA); auto with set. } + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + * apply Comp;auto. + apply fold_init;auto. + apply fold_equal;auto. + apply equal_sym; apply inter_Add_2 with x; auto with set. + * transitivity (f x (fold f s (fold f s' i))). + -- apply Comp; auto. + -- symmetry; apply fold_2 with (eqA:=eqA); auto. + Qed. + + Lemma fold_diff_inter : forall i s s', + eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). + Proof. + intros. + transitivity (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + { symmetry; apply fold_union_inter; auto. } + transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). + { apply fold_equal; auto with set. } + apply fold_init; auto. + apply fold_1; auto with set. + Qed. + + Lemma fold_union: forall i s s', + (forall x, ~(In x s/\In x s')) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros. + transitivity (fold f (union s s') (fold f (inter s s') i)). + { apply fold_init; auto. + symmetry; apply fold_1; auto with set. + unfold Empty; intro a; generalize (H a); set_iff; tauto. } + apply fold_union_inter; auto. + Qed. - End Fold_More. + End Fold_More. - Lemma fold_plus : - forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. - Proof. - intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. - Qed. + Lemma fold_plus : + forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. + Proof. + intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. + Qed. End Fold. @@ -699,8 +699,8 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. Proof. - intros; rewrite cardinal_1; rewrite M.fold_1. - symmetry; apply fold_left_S_0; auto. + intros; rewrite cardinal_1; rewrite M.fold_1. + symmetry; apply fold_left_S_0; auto. Qed. (** ** Old specifications for [cardinal]. *) @@ -711,34 +711,34 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). (forall x : elt, In x s <-> InA E.eq x l) /\ cardinal s = length l. Proof. - intros; exists (elements s); intuition auto with set; apply cardinal_1. + intros; exists (elements s); intuition auto with set; apply cardinal_1. Qed. Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. Proof. - intros; rewrite cardinal_fold; apply fold_1; auto with fset. + intros; rewrite cardinal_fold; apply fold_1; auto with fset. Qed. Lemma cardinal_2 : forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x). - apply fold_2; auto with fset. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x). + apply fold_2; auto with fset. Qed. (** ** Cardinal and (non-)emptiness *) Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. Proof. - intros. - rewrite elements_Empty, M.cardinal_1. - destruct (elements s); intuition; discriminate. + intros. + rewrite elements_Empty, M.cardinal_1. + destruct (elements s); intuition; discriminate. Qed. Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. Proof. - intros; rewrite cardinal_Empty; auto. + intros; rewrite cardinal_Empty; auto. Qed. #[global] Hint Resolve cardinal_inv_1 : fset. @@ -746,36 +746,36 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. Proof. - intros; rewrite M.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto. + intros; rewrite M.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto. Qed. Lemma cardinal_inv_2b : forall s, cardinal s <> 0 -> { x : elt | In x s }. Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; - [intuition|eauto]. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. Qed. (** ** Cardinal is a morphism *) Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. Proof. - symmetry. - remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. - induction n; intros. - - apply cardinal_1; rewrite <- H; auto with fset. - - destruct (cardinal_inv_2 Heqn) as (x,H2). - revert Heqn. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + - apply cardinal_1; rewrite <- H; auto with fset. + - destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. Qed. Add Morphism cardinal with signature (Equal ==> Logic.eq) as cardinal_m. Proof. - exact Equal_cardinal. + exact Equal_cardinal. Qed. #[global] @@ -785,7 +785,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma empty_cardinal : cardinal empty = 0. Proof. - rewrite cardinal_fold; apply fold_1; auto with set fset. + rewrite cardinal_fold; apply fold_1; auto with set fset. Qed. #[global] @@ -793,10 +793,10 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. Proof. - intros. - rewrite (singleton_equal_add x). - replace 0 with (cardinal empty); auto with set. - apply cardinal_2 with x; auto with set. + intros. + rewrite (singleton_equal_add x). + replace 0 with (cardinal empty); auto with set. + apply cardinal_2 with x; auto with set. Qed. #[global] @@ -805,98 +805,98 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma diff_inter_cardinal : forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with fset. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma union_cardinal: forall s s', (forall x, ~(In x s/\In x s')) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_union; auto with fset. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_union; auto with fset. Qed. Lemma subset_cardinal : forall s s', s[<=]s' -> cardinal s <= cardinal s' . Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - apply Nat.le_add_l. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H). + apply Nat.le_add_l. Qed. Lemma subset_cardinal_lt : forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - generalize (@cardinal_inv_1 (diff s' s)). - destruct (cardinal (diff s' s)). - - intro H2; destruct (H2 Logic.eq_refl x). - set_iff; auto. - - intros _. - change (0 + cardinal s < S n + cardinal s). - apply Nat.add_lt_le_mono; [ apply Nat.lt_0_succ | reflexivity ]. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H). + generalize (@cardinal_inv_1 (diff s' s)). + destruct (cardinal (diff s' s)). + - intro H2; destruct (H2 Logic.eq_refl x). + set_iff; auto. + - intros _. + change (0 + cardinal s < S n + cardinal s). + apply Nat.add_lt_le_mono; [ apply Nat.lt_0_succ | reflexivity ]. Qed. Theorem union_inter_cardinal : forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . Proof. - intros. - do 4 rewrite cardinal_fold. - do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@Logic.eq nat); auto with fset. + intros. + do 4 rewrite cardinal_fold. + do 2 rewrite <- fold_plus. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma union_cardinal_inter : forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). Proof. - intros. - rewrite <- union_inter_cardinal, Nat.add_sub. - reflexivity. + intros. + rewrite <- union_inter_cardinal, Nat.add_sub. + reflexivity. Qed. Lemma union_cardinal_le : forall s s', cardinal (union s s') <= cardinal s + cardinal s'. Proof. - intros; generalize (union_inter_cardinal s s'). - intros; rewrite <- H; auto with arith. + intros; generalize (union_inter_cardinal s s'). + intros; rewrite <- H; auto with arith. Qed. Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. - auto with set fset. + auto with set fset. Qed. Lemma add_cardinal_2 : forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x); - apply fold_add with (eqA:=@Logic.eq nat); auto with fset. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x); + apply fold_add with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma remove_cardinal_1 : forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with fset. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ =>S) x). + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. Proof. - auto with set fset. + auto with set fset. Qed. #[global] @@ -927,7 +927,7 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list elt, sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. Proof. - apply SortA_equivlistA_eqlistA; auto with typeclass_instances. + apply SortA_equivlistA_eqlistA; auto with typeclass_instances. Qed. Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. @@ -938,32 +938,32 @@ Module OrdProperties (M:S). Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. Proof. - intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. + intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. Proof. - intros; unfold leb, gtb; destruct (E.compare x y); intuition try discriminate; ME.order. + intros; unfold leb, gtb; destruct (E.compare x y); intuition try discriminate; ME.order. Qed. Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x). Proof. - red; intros x a b H. - generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. - - intros. - symmetry; rewrite H1. - apply ME.eq_lt with a; auto with ordered_type. - rewrite <- H0; auto. - - intros. - rewrite H0. - apply ME.eq_lt with b; auto. - rewrite <- H1; auto. + red; intros x a b H. + generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. + - intros. + symmetry; rewrite H1. + apply ME.eq_lt with a; auto with ordered_type. + rewrite <- H0; auto. + - intros. + rewrite H0. + apply ME.eq_lt with b; auto. + rewrite <- H1; auto. Qed. Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x). Proof. - red; intros x a b H; unfold leb. - f_equal; apply gtb_compat; auto. + red; intros x a b H; unfold leb. + f_equal; apply gtb_compat; auto. Qed. #[global] Hint Resolve gtb_compat leb_compat : fset. @@ -971,48 +971,48 @@ Module OrdProperties (M:S). Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. Proof. - unfold elements_lt, elements_ge, leb; intros. - eapply (@filter_split _ E.eq _ E.lt). 1-2: auto with typeclass_instances. 2: auto with set. - intros. - rewrite gtb_1 in H. - assert (~E.lt y x). { - unfold gtb in *; destruct (E.compare x y); intuition try discriminate; ME.order. - } - ME.order. + unfold elements_lt, elements_ge, leb; intros. + eapply (@filter_split _ E.eq _ E.lt). 1-2: auto with typeclass_instances. 2: auto with set. + intros. + rewrite gtb_1 in H. + assert (~E.lt y x). { + unfold gtb in *; destruct (E.compare x y); intuition try discriminate; ME.order. + } + ME.order. Qed. Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). Proof. - intros; unfold elements_ge, elements_lt. - apply sort_equivlistA_eqlistA; auto with set. - - apply (@SortA_app _ E.eq). { auto with typeclass_instances. } - + apply (@filter_sort _ E.eq). 1-3: auto with typeclass_instances. auto with set. - + constructor; auto. - * apply (@filter_sort _ E.eq). 1-3: auto with typeclass_instances. auto with set. - * rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); auto with set typeclass_instances). - intros. + intros; unfold elements_ge, elements_lt. + apply sort_equivlistA_eqlistA; auto with set. + - apply (@SortA_app _ E.eq). { auto with typeclass_instances. } + + apply (@filter_sort _ E.eq). 1-3: auto with typeclass_instances. auto with set. + + constructor; auto. + * apply (@filter_sort _ E.eq). 1-3: auto with typeclass_instances. auto with set. + * rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); auto with set typeclass_instances). + intros. + rewrite filter_InA in H1 by auto with fset. destruct H1. + rewrite leb_1 in H2. + rewrite <- elements_iff in H1. + assert (~E.eq x y). { + contradict H; rewrite H; auto. + } + ME.order. + + intros. rewrite filter_InA in H1 by auto with fset. destruct H1. - rewrite leb_1 in H2. - rewrite <- elements_iff in H1. - assert (~E.eq x y). { - contradict H; rewrite H; auto. - } - ME.order. - + intros. - rewrite filter_InA in H1 by auto with fset. destruct H1. - rewrite gtb_1 in H3. - inversion_clear H2. - * ME.order. - * rewrite filter_InA in H4 by auto with fset. destruct H4. - rewrite leb_1 in H4. - ME.order. - - red; intros a. - rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff, - leb_1, gtb_1, (H0 a) by auto with fset. - intuition auto with relations set. - destruct (E.compare a x); intuition auto with set. - fold (~E.lt a x); auto with ordered_type set. + rewrite gtb_1 in H3. + inversion_clear H2. + * ME.order. + * rewrite filter_InA in H4 by auto with fset. destruct H4. + rewrite leb_1 in H4. + ME.order. + - red; intros a. + rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff, + leb_1, gtb_1, (H0 a) by auto with fset. + intuition auto with relations set. + destruct (E.compare a x); intuition auto with set. + fold (~E.lt a x); auto with ordered_type set. Qed. Definition Above x s := forall y, In y s -> E.lt y x. @@ -1022,42 +1022,42 @@ Module OrdProperties (M:S). Above x s -> Add x s s' -> eqlistA E.eq (elements s') (elements s ++ x::nil). Proof. - intros. - apply sort_equivlistA_eqlistA. { auto with set. } - - apply (@SortA_app _ E.eq). - + auto with typeclass_instances. - + auto with set. - + auto. - + intros. - inversion_clear H2. - * rewrite <- elements_iff in H1. - apply ME.lt_eq with x; auto with ordered_type. - * inversion H3. - - red; intros a. - rewrite InA_app_iff, InA_cons, InA_nil. - do 2 rewrite <- elements_iff; rewrite (H0 a); intuition auto with relations. + intros. + apply sort_equivlistA_eqlistA. { auto with set. } + - apply (@SortA_app _ E.eq). + + auto with typeclass_instances. + + auto with set. + + auto. + + intros. + inversion_clear H2. + * rewrite <- elements_iff in H1. + apply ME.lt_eq with x; auto with ordered_type. + * inversion H3. + - red; intros a. + rewrite InA_app_iff, InA_cons, InA_nil. + do 2 rewrite <- elements_iff; rewrite (H0 a); intuition auto with relations. Qed. Lemma elements_Add_Below : forall s s' x, Below x s -> Add x s s' -> eqlistA E.eq (elements s') (x::elements s). Proof. - intros. - apply sort_equivlistA_eqlistA. - - auto with set. - - change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq). - + auto with typeclass_instances. - + auto. - + auto with set. - + intros. - inversion_clear H1. - * rewrite <- elements_iff in H2. - apply ME.eq_lt with x; auto. - * inversion H3. - - red; intros a. - rewrite InA_cons. - do 2 rewrite <- elements_iff; rewrite (H0 a); intuition auto with relations. + intros. + apply sort_equivlistA_eqlistA. + - auto with set. + - change (sort E.lt ((x::nil) ++ elements s)). + apply (@SortA_app _ E.eq). + + auto with typeclass_instances. + + auto. + + auto with set. + + intros. + inversion_clear H1. + * rewrite <- elements_iff in H2. + apply ME.eq_lt with x; auto. + * inversion H3. + - red; intros a. + rewrite InA_cons. + do 2 rewrite <- elements_iff; rewrite (H0 a); intuition auto with relations. Qed. (** Two other induction principles on sets: we can be more restrictive @@ -1069,19 +1069,19 @@ Module OrdProperties (M:S). (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. - case_eq (max_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). - { rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@max_elt_2 s e y H H0); ME.order. - - - assert (H0:=max_elt_3 H). - rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. + case_eq (max_elt s); intros. + - apply X0 with (remove e s) e; auto with set. + + apply IHn. + assert (S n = S (cardinal (remove e s))). + { rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. } + inversion H0; auto. + + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@max_elt_2 s e y H H0); ME.order. + + - assert (H0:=max_elt_3 H). + rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. Qed. Lemma set_induction_min : @@ -1090,19 +1090,19 @@ Module OrdProperties (M:S). (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. - case_eq (min_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). - { rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@min_elt_2 s e y H H0); ME.order. - - - assert (H0:=min_elt_3 H). - rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. + case_eq (min_elt s); intros. + - apply X0 with (remove e s) e; auto with set. + + apply IHn. + assert (S n = S (cardinal (remove e s))). + { rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. } + inversion H0; auto. + + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@min_elt_2 s e y H H0); ME.order. + + - assert (H0:=min_elt_3 H). + rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. Qed. (** More properties of [fold] : behavior with respect to Above/Below *) @@ -1113,14 +1113,14 @@ Module OrdProperties (M:S). compat_op E.eq eqA f -> Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. - intros. - rewrite 2 fold_spec_right. - change (f x (fold_right f i (rev (elements s)))) with - (fold_right f i (rev (x::nil)++rev (elements s))). - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - rewrite <- distr_rev. - apply eqlistA_rev. - apply elements_Add_Above; auto. + intros. + rewrite 2 fold_spec_right. + change (f x (fold_right f i (rev (elements s)))) with + (fold_right f i (rev (x::nil)++rev (elements s))). + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + rewrite <- distr_rev. + apply eqlistA_rev. + apply elements_Add_Above; auto. Qed. Lemma fold_4 : @@ -1129,15 +1129,15 @@ Module OrdProperties (M:S). compat_op E.eq eqA f -> Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). Proof. - intros. - rewrite 2 M.fold_1. - set (g:=fun (a : A) (e : elt) => f e a). - change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)). - unfold g. - rewrite <- 2 fold_left_rev_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply elements_Add_Below; auto. + intros. + rewrite 2 M.fold_1. + set (g:=fun (a : A) (e : elt) => f e a). + change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)). + unfold g. + rewrite <- 2 fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply elements_Add_Below; auto. Qed. (** The following results have already been proved earlier, @@ -1145,31 +1145,31 @@ Module OrdProperties (M:S). no need for [(transpose eqA f)]. *) Section FoldOpt. - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros. rewrite 2 fold_spec_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply sort_equivlistA_eqlistA; auto with set. - red; intro a; do 2 rewrite <- elements_iff; auto. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros. rewrite 2 fold_spec_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply sort_equivlistA_eqlistA; auto with set. + red; intro a; do 2 rewrite <- elements_iff; auto. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. End FoldOpt. @@ -1182,12 +1182,12 @@ Module OrdProperties (M:S). | _, _ => False end. Proof. - intros s s' H; - generalize (@choose_1 s)(@choose_2 s) - (@choose_1 s')(@choose_2 s')(@choose_3 s s'); - destruct (choose s); destruct (choose s'); simpl; intuition. - - apply H5 with e; rewrite <-H; auto. - - apply H5 with e; rewrite H; auto. + intros s s' H; + generalize (@choose_1 s)(@choose_2 s) + (@choose_1 s')(@choose_2 s')(@choose_3 s s'); + destruct (choose s); destruct (choose s'); simpl; intuition. + - apply H5 with e; rewrite <-H; auto. + - apply H5 with e; rewrite H; auto. Qed. End OrdProperties. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 1b5511d21e..6098d95767 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -17,137 +17,137 @@ From Stdlib Require Import FSetInterface FSetProperties OrderedTypeEx DecidableT to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). - Module MP:= WProperties_fun U M. - Import M MP FM Ensembles Finite_sets. - - Definition mkEns : M.t -> Ensemble M.elt := - fun s x => M.In x s. - - Notation " !! " := mkEns. - - Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. - Proof. - unfold In; compute; auto with extcore. - Qed. - - Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). - Proof. - unfold Subset, Included, In, mkEns; intuition. - Qed. - - Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). - - Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. - Proof. - intros. - rewrite double_inclusion. - unfold Subset, Included, Same_set, In, mkEns; intuition. - Qed. - - Lemma empty_Empty_Set : !!M.empty === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1. - Qed. - - Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - destruct(H x H0). - - inversion H0. - Qed. - - Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. - Qed. - - Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - - inversion H0. - constructor 2; constructor. - - constructor 1; auto. - Qed. - - Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - red in H; rewrite H in H0. - destruct H0. - + inversion H0. - constructor 2; constructor. - + constructor 1; auto. - - red in H; rewrite H. - inversion H0; auto. - inversion H1; auto. - Qed. - - Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - split; auto. - contradict H1. - inversion H1; auto. - Qed. - - Lemma mkEns_Finite : forall s, Finite _ (!!s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + constructor 2; auto. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - + rewrite cardinal_1; auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + rewrite (cardinal_2 H0 H1); auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - (** we can even build a function from Finite Ensemble to FSet + Module MP:= WProperties_fun U M. + Import M MP FM Ensembles Finite_sets. + + Definition mkEns : M.t -> Ensemble M.elt := + fun s x => M.In x s. + + Notation " !! " := mkEns. + + Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. + Proof. + unfold In; compute; auto with extcore. + Qed. + + Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). + Proof. + unfold Subset, Included, In, mkEns; intuition. + Qed. + + Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). + + Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. + Proof. + intros. + rewrite double_inclusion. + unfold Subset, Included, Same_set, In, mkEns; intuition. + Qed. + + Lemma empty_Empty_Set : !!M.empty === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1. + Qed. + + Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + - destruct(H x H0). + - inversion H0. + Qed. + + Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. + Qed. + + Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + - inversion H0. + constructor 2; constructor. + - constructor 1; auto. + Qed. + + Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + - red in H; rewrite H in H0. + destruct H0. + + inversion H0. + constructor 2; constructor. + + constructor 1; auto. + - red in H; rewrite H. + inversion H0; auto. + inversion H1; auto. + Qed. + + Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + split; auto. + contradict H1. + inversion H1; auto. + Qed. + + Lemma mkEns_Finite : forall s, Finite _ (!!s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + - intros; replace (!!s) with (Empty_set elt); auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + - replace (!!s') with (Add _ (!!s) x). + + constructor 2; auto. + + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + - intros; replace (!!s) with (Empty_set elt); auto with sets. + + rewrite cardinal_1; auto with sets. + + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + - replace (!!s') with (Add _ (!!s) x). + + rewrite (cardinal_2 H0 H1); auto with sets. + + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + (** we can even build a function from Finite Ensemble to FSet ... at least in Prop. *) - Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> - exists s:M.t, !!s === e. - Proof. - induction 1. - - exists M.empty. - apply empty_Empty_Set. - - destruct IHFinite as (s,Hs). - exists (M.add x s). - apply Extensionality_Ensembles in Hs. - rewrite <- Hs. - apply add_Add. - Qed. + Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> + exists s:M.t, !!s === e. + Proof. + induction 1. + - exists M.empty. + apply empty_Empty_Set. + - destruct IHFinite as (s,Hs). + exists (M.add x s). + apply Extensionality_Ensembles in Hs. + rewrite <- Hs. + apply add_Add. + Qed. End WS_to_Finite_set. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 7007e7e240..14da27414c 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -23,8 +23,8 @@ Unset Strict Implicit. From Stdlib Require Equalities FSetCompat MSetWeakList. Module Make (X: DecidableType) <: WS with Module E := X. - Module E := X. - Module X' := Equalities.Update_DT X. - Module MSet := MSetWeakList.Make X'. - Include FSetCompat.Backport_WSets X MSet. + Module E := X. + Module X' := Equalities.Update_DT X. + Module MSet := MSetWeakList.Make X'. + Include FSetCompat.Backport_WSets X MSet. End Make. diff --git a/theories/Lists/Finite.v b/theories/Lists/Finite.v index 66730b7a65..2f68ae862b 100644 --- a/theories/Lists/Finite.v +++ b/theories/Lists/Finite.v @@ -62,9 +62,9 @@ Qed. (* Finite_alt is a weaker version of Finite_dec and has been deprecated. *) Lemma Finite_alt_deprecated A (d:decidable_eq A) : Finite A <-> Finite' A. Proof. - split. - - intros F. now apply Finite_dec. - - intros (l & _ & F). now exists l. + split. + - intros F. now apply Finite_dec. + - intros (l & _ & F). now exists l. Qed. #[deprecated(since="8.17", note="Use Finite_dec instead.")] Notation Finite_alt := Finite_alt_deprecated. @@ -74,48 +74,48 @@ Notation Finite_alt := Finite_alt_deprecated. Lemma Injective_map_NoDup A B (f:A->B) (l:list A) : Injective f -> NoDup l -> NoDup (map f l). Proof. - intros Ij. induction 1 as [|x l X N IH]; simpl; constructor; trivial. - rewrite in_map_iff. intros (y & E & Y). apply Ij in E. now subst. + intros Ij. induction 1 as [|x l X N IH]; simpl; constructor; trivial. + rewrite in_map_iff. intros (y & E & Y). apply Ij in E. now subst. Qed. Lemma Injective_map_NoDup_in A B (f:A->B) (l:list A) : (forall x y, In x l -> In y l -> f x = f y -> x = y) -> NoDup l -> NoDup (map f l). Proof. - pose proof @in_cons. pose proof @in_eq. - intros Ij N; revert Ij; induction N; cbn [map]; constructor; auto. - rewrite in_map_iff. intros (y & E & Y). apply Ij in E; auto; congruence. + pose proof @in_cons. pose proof @in_eq. + intros Ij N; revert Ij; induction N; cbn [map]; constructor; auto. + rewrite in_map_iff. intros (y & E & Y). apply Ij in E; auto; congruence. Qed. Lemma Injective_list_carac A B (d:decidable_eq A)(f:A->B) : Injective f <-> (forall l, NoDup l -> NoDup (map f l)). Proof. - split. - - intros. now apply Injective_map_NoDup. - - intros H x y E. - destruct (d x y); trivial. - assert (N : NoDup (x::y::nil)). - { repeat constructor; simpl; intuition. } - specialize (H _ N). simpl in H. rewrite E in H. - inversion_clear H; simpl in *; intuition. + split. + - intros. now apply Injective_map_NoDup. + - intros H x y E. + destruct (d x y); trivial. + assert (N : NoDup (x::y::nil)). + { repeat constructor; simpl; intuition. } + specialize (H _ N). simpl in H. rewrite E in H. + inversion_clear H; simpl in *; intuition. Qed. Lemma Injective_carac A B (l:list A) : Listing l -> forall (f:A->B), Injective f <-> NoDup (map f l). Proof. - intros L f. split. - - intros Ij. apply Injective_map_NoDup; trivial. apply L. - - intros N x y E. - assert (X : In x l) by apply L. - assert (Y : In y l) by apply L. - apply In_nth_error in X. destruct X as (i,X). - apply In_nth_error in Y. destruct Y as (j,Y). - assert (X' := map_nth_error f _ _ X). - assert (Y' := map_nth_error f _ _ Y). - assert (i = j). - { rewrite NoDup_nth_error in N. apply N. - - rewrite <- nth_error_Some. now rewrite X'. - - rewrite X', Y'. now f_equal. } - subst j. rewrite Y in X. now injection X. + intros L f. split. + - intros Ij. apply Injective_map_NoDup; trivial. apply L. + - intros N x y E. + assert (X : In x l) by apply L. + assert (Y : In y l) by apply L. + apply In_nth_error in X. destruct X as (i,X). + apply In_nth_error in Y. destruct Y as (j,Y). + assert (X' := map_nth_error f _ _ X). + assert (Y' := map_nth_error f _ _ Y). + assert (i = j). + { rewrite NoDup_nth_error in N. apply N. + - rewrite <- nth_error_Some. now rewrite X'. + - rewrite X', Y'. now f_equal. } + subst j. rewrite Y in X. now injection X. Qed. (** Surjection characterized in term of lists *) @@ -123,33 +123,33 @@ Qed. Lemma Surjective_list_carac A B (f:A->B): Surjective f <-> (forall lB, exists lA, incl lB (map f lA)). Proof. - split. - - intros Su lB. - induction lB as [|b lB IH]. - + now exists nil. - + destruct (Su b) as (a,E). - destruct IH as (lA,IC). - exists (a::lA). simpl. rewrite E. - intros x [X|X]; simpl; intuition. - - intros H y. - destruct (H (y::nil)) as (lA,IC). - assert (IN : In y (map f lA)) by (apply (IC y); now left). - rewrite in_map_iff in IN. destruct IN as (x & E & _). - now exists x. + split. + - intros Su lB. + induction lB as [|b lB IH]. + + now exists nil. + + destruct (Su b) as (a,E). + destruct IH as (lA,IC). + exists (a::lA). simpl. rewrite E. + intros x [X|X]; simpl; intuition. + - intros H y. + destruct (H (y::nil)) as (lA,IC). + assert (IN : In y (map f lA)) by (apply (IC y); now left). + rewrite in_map_iff in IN. destruct IN as (x & E & _). + now exists x. Qed. Lemma Surjective_carac A B : Finite B -> decidable_eq B -> forall f:A->B, Surjective f <-> (exists lA, Listing (map f lA)). Proof. - intros (lB,FB) d f. split. - - rewrite Surjective_list_carac. - intros Su. destruct (Su lB) as (lA,IC). - destruct (uniquify_map d f lA) as (lA' & N & IC'). - exists lA'. split; trivial. - intro x. apply IC', IC, FB. - - intros (lA & N & FA) y. - generalize (FA y). rewrite in_map_iff. intros (x & E & _). - now exists x. + intros (lB,FB) d f. split. + - rewrite Surjective_list_carac. + intros Su. destruct (Su lB) as (lA,IC). + destruct (uniquify_map d f lA) as (lA' & N & IC'). + exists lA'. split; trivial. + intro x. apply IC', IC, FB. + - intros (lA & N & FA) y. + generalize (FA y). rewrite in_map_iff. intros (x & E & _). + now exists x. Qed. (** Main result : *) @@ -158,26 +158,26 @@ Lemma Endo_Injective_Surjective : forall A, Finite A -> decidable_eq A -> forall f:A->A, Injective f <-> Surjective f. Proof. - intros A F d f. rewrite (Surjective_carac F d). split. - - assert (Finite' A) as (l, L) by (now apply Finite_dec); clear F. - rewrite (Injective_carac L); intros. - exists l; split; trivial. - destruct L as (N,F). - assert (I : incl l (map f l)). - { apply NoDup_length_incl; trivial. - - now rewrite length_map. - - intros x _. apply F. } - intros x. apply I, F. - - clear F d. intros (l,L). - assert (N : NoDup l). { apply (NoDup_map_inv f), L. } - assert (I : incl (map f l) l). - { apply NoDup_length_incl; trivial. - - now rewrite length_map. - - intros x _. apply L. } - assert (L' : Listing l). - { split; trivial. - intro x. apply I, L. } - apply (Injective_carac L'), L. + intros A F d f. rewrite (Surjective_carac F d). split. + - assert (Finite' A) as (l, L) by (now apply Finite_dec); clear F. + rewrite (Injective_carac L); intros. + exists l; split; trivial. + destruct L as (N,F). + assert (I : incl l (map f l)). + { apply NoDup_length_incl; trivial. + - now rewrite length_map. + - intros x _. apply F. } + intros x. apply I, F. + - clear F d. intros (l,L). + assert (N : NoDup l). { apply (NoDup_map_inv f), L. } + assert (I : incl (map f l) l). + { apply NoDup_length_incl; trivial. + - now rewrite length_map. + - intros x _. apply L. } + assert (L' : Listing l). + { split; trivial. + intro x. apply I, L. } + apply (Injective_carac L'), L. Qed. (** An injective and surjective function is bijective. @@ -195,10 +195,10 @@ Definition RecEnum A := exists h:nat->A, surjective h. Lemma Finite_Empty_or_not A : Finite A -> (A->False) \/ exists a:A,True. Proof. - intros (l,F). - destruct l as [|a l]. - - left; exact F. - - right; now exists a. + intros (l,F). + destruct l as [|a l]. + - left; exact F. + - right; now exists a. Qed. Lemma Surjective_inverse : @@ -206,25 +206,25 @@ Lemma Surjective_inverse : forall f:A->B, Surjective f -> exists g:B->A, forall x, f (g x) = x. Proof. - intros A B F d f Su. - destruct (Finite_Empty_or_not F) as [noA | (a,_)]. - - (* A is empty : g is obtained via False_rect *) - assert (noB : B -> False). { intros y. now destruct (Su y). } - exists (fun y => False_rect _ (noB y)). - intro y. destruct (noB y). - - (* A is inhabited by a : we use it in Option.get *) - destruct F as (l,F). - set (h := fun x k => if d (f k) x then true else false). - set (get := fun o => match o with Some y => y | None => a end). - exists (fun x => get (List.find (h x) l)). - intros x. - case_eq (find (h x) l); simpl; clear get; [intros y H|intros H]. - * apply find_some in H. destruct H as (_,H). unfold h in H. - now destruct (d (f y) x) in H. - * exfalso. - destruct (Su x) as (y & Y). - generalize (find_none _ l H y (F y)). - unfold h. now destruct (d (f y) x). + intros A B F d f Su. + destruct (Finite_Empty_or_not F) as [noA | (a,_)]. + - (* A is empty : g is obtained via False_rect *) + assert (noB : B -> False). { intros y. now destruct (Su y). } + exists (fun y => False_rect _ (noB y)). + intro y. destruct (noB y). + - (* A is inhabited by a : we use it in Option.get *) + destruct F as (l,F). + set (h := fun x k => if d (f k) x then true else false). + set (get := fun o => match o with Some y => y | None => a end). + exists (fun x => get (List.find (h x) l)). + intros x. + case_eq (find (h x) l); simpl; clear get; [intros y H|intros H]. + * apply find_some in H. destruct H as (_,H). unfold h in H. + now destruct (d (f y) x) in H. + * exfalso. + destruct (Su x) as (y & Y). + generalize (find_none _ l H y (F y)). + unfold h. now destruct (d (f y) x). Qed. (** Same, with more knowledge on the inverse function: g.f = f.g = id *) @@ -233,8 +233,8 @@ Lemma Injective_Surjective_Bijective : forall A B, Finite A -> EqDec B -> forall f:A->B, Injective f -> Surjective f -> Bijective f. Proof. - intros A B F d f Ij Su. - destruct (Surjective_inverse F d Su) as (g, E). - exists g. split; trivial. - intros y. apply Ij. now rewrite E. + intros A B F d f Ij Su. + destruct (Surjective_inverse F d Su) as (g, E). + exists g. split; trivial. + intros y. apply Ij. now rewrite E. Qed. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index e2d092dddf..3d83c7496d 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -28,10 +28,10 @@ Open Scope list_scope. (** Standard notations for lists. In a special module to avoid conflicts. *) Module ListNotations. -Notation "[ ]" := nil (format "[ ]") : list_scope. -Notation "[ x ]" := (cons x nil) : list_scope. -Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) - (format "[ '[' x ; '/' y ; '/' .. ; '/' z ']' ]") : list_scope. + Notation "[ ]" := nil (format "[ ]") : list_scope. + Notation "[ x ]" := (cons x nil) : list_scope. + Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) + (format "[ '[' x ; '/' y ; '/' .. ; '/' z ']' ]") : list_scope. End ListNotations. Import ListNotations. @@ -327,26 +327,26 @@ Section Facts. Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. Proof. - intros x l; induction l as [|a l IHl]; simpl; [destruct 1|destruct 1 as [?|H]]. - - subst a; auto. - exists [], l; auto. - - destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1), l2; simpl. apply f_equal. auto. + intros x l; induction l as [|a l IHl]; simpl; [destruct 1|destruct 1 as [?|H]]. + - subst a; auto. + exists [], l; auto. + - destruct (IHl H) as (l1,(l2,H0)). + exists (a::l1), l2; simpl. apply f_equal. auto. Qed. Lemma in_elt : forall (x:A) l1 l2, In x (l1 ++ x :: l2). Proof. - intros. - apply in_or_app. - right; left; reflexivity. + intros. + apply in_or_app. + right; left; reflexivity. Qed. Lemma in_elt_inv : forall (x y : A) l1 l2, In x (l1 ++ y :: l2) -> x = y \/ In x (l1 ++ l2). Proof. - intros x y l1 l2 Hin. - apply in_app_or in Hin. - destruct Hin as [Hin|[Hin|Hin]]; [right|left|right]; try apply in_or_app; intuition. + intros x y l1 l2 Hin. + apply in_app_or in Hin. + destruct Hin as [Hin|[Hin|Hin]]; [right|left|right]; try apply in_or_app; intuition. Qed. Lemma app_inj_pivot x1 x2 y1 y2 (a : A): x1 ++ a :: x2 = y1 ++ a :: y2 -> @@ -589,11 +589,11 @@ Section Elts. Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. Proof. - revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - - split; [now destruct 1 | inversion 1]. - - split; [now destruct 1 | inversion 1]. - - now split; intros; [apply Nat.lt_0_succ|]. - - now rewrite IHl, Nat.succ_lt_mono. + revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. + - split; [now destruct 1 | inversion 1]. + - split; [now destruct 1 | inversion 1]. + - now split; intros; [apply Nat.lt_0_succ|]. + - now rewrite IHl, Nat.succ_lt_mono. Qed. Lemma nth_error_split l n a : nth_error l n = Some a -> @@ -1104,19 +1104,19 @@ Section ListOps. Lemma concat_nil : concat [] = []. Proof. - reflexivity. + reflexivity. Qed. Lemma concat_cons : forall x l, concat (cons x l) = x ++ concat l. Proof. - reflexivity. + reflexivity. Qed. Lemma concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2. Proof. - intros l1; induction l1 as [|x l1 IH]; intros l2; simpl. - - reflexivity. - - rewrite IH; apply app_assoc. + intros l1; induction l1 as [|x l1 IH]; intros l2; simpl. + - reflexivity. + - rewrite IH; apply app_assoc. Qed. Lemma in_concat : forall l y, @@ -1495,210 +1495,210 @@ End Fold_Right_Recursor. (*************************************) Section Bool. - Variable A : Type. - Variable f : A -> bool. + Variable A : Type. + Variable f : A -> bool. - (** find whether a boolean function can be satisfied by an + (** find whether a boolean function can be satisfied by an elements of the list. *) - Fixpoint existsb (l:list A) : bool := - match l with - | [] => false - | a :: l => f a || existsb l - end. - - Lemma existsb_exists : - forall l, existsb l = true <-> exists x, In x l /\ f x = true. - Proof. - intro l; induction l as [ | a m IH ]; split; simpl. - - easy. - - intros [x [[]]]. - - destruct (f a) eqn:Ha. - + intros _. exists a. tauto. - + intros [x [? ?]] %IH. exists x. tauto. - - intros [ x [ [ Hax | Hxm ] Hfx ] ]. - + now rewrite Hax, Hfx. - + destruct IH as [ _ -> ]; eauto with bool. - Qed. - - Lemma existsb_nth : forall l n d, n < length l -> - existsb l = false -> f (nth n l d) = false. - Proof. - intro l; induction l as [|a ? IHl]; [easy|]. - cbn. intros [|n]; [now destruct (f a)|]. - intros d ? %Nat.succ_lt_mono. - now destruct (f a); [|apply IHl]. - Qed. - - Lemma existsb_app : forall l1 l2, - existsb (l1++l2) = existsb l1 || existsb l2. - Proof. - intro l1; induction l1 as [|a ? ?]; intros l2; simpl. - - auto. - - case (f a); simpl; solve[auto]. - Qed. + Fixpoint existsb (l:list A) : bool := + match l with + | [] => false + | a :: l => f a || existsb l + end. - (** find whether a boolean function is satisfied by + Lemma existsb_exists : + forall l, existsb l = true <-> exists x, In x l /\ f x = true. + Proof. + intro l; induction l as [ | a m IH ]; split; simpl. + - easy. + - intros [x [[]]]. + - destruct (f a) eqn:Ha. + + intros _. exists a. tauto. + + intros [x [? ?]] %IH. exists x. tauto. + - intros [ x [ [ Hax | Hxm ] Hfx ] ]. + + now rewrite Hax, Hfx. + + destruct IH as [ _ -> ]; eauto with bool. + Qed. + + Lemma existsb_nth : forall l n d, n < length l -> + existsb l = false -> f (nth n l d) = false. + Proof. + intro l; induction l as [|a ? IHl]; [easy|]. + cbn. intros [|n]; [now destruct (f a)|]. + intros d ? %Nat.succ_lt_mono. + now destruct (f a); [|apply IHl]. + Qed. + + Lemma existsb_app : forall l1 l2, + existsb (l1++l2) = existsb l1 || existsb l2. + Proof. + intro l1; induction l1 as [|a ? ?]; intros l2; simpl. + - auto. + - case (f a); simpl; solve[auto]. + Qed. + + (** find whether a boolean function is satisfied by all the elements of a list. *) - Fixpoint forallb (l:list A) : bool := - match l with - | [] => true - | a::l => f a && forallb l - end. - - Lemma forallb_forall : - forall l, forallb l = true <-> (forall x, In x l -> f x = true). - Proof. - intro l; induction l as [|a l IHl]; simpl; [ tauto | split; intro H ]. - + destruct (andb_prop _ _ H); intros a' [?|?]. - - congruence. - - apply IHl; assumption. - + apply andb_true_intro; split. - - apply H; left; reflexivity. - - apply IHl; intros; apply H; right; assumption. - Qed. - - Lemma forallb_app : - forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2. - Proof. - intro l1; induction l1 as [|a ? ?]; simpl. - - auto. - - case (f a); simpl; solve[auto]. - Qed. - - (** [filter] *) - - Fixpoint filter (l:list A) : list A := - match l with - | [] => [] - | x :: l => if f x then x::(filter l) else filter l - end. + Fixpoint forallb (l:list A) : bool := + match l with + | [] => true + | a::l => f a && forallb l + end. - Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. - Proof. - intros x l; induction l as [|a ? ?]; simpl. - - tauto. - - intros. - case_eq (f a); intros; simpl; intuition congruence. - Qed. + Lemma forallb_forall : + forall l, forallb l = true <-> (forall x, In x l -> f x = true). + Proof. + intro l; induction l as [|a l IHl]; simpl; [ tauto | split; intro H ]. + + destruct (andb_prop _ _ H); intros a' [?|?]. + - congruence. + - apply IHl; assumption. + + apply andb_true_intro; split. + - apply H; left; reflexivity. + - apply IHl; intros; apply H; right; assumption. + Qed. + + Lemma forallb_app : + forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2. + Proof. + intro l1; induction l1 as [|a ? ?]; simpl. + - auto. + - case (f a); simpl; solve[auto]. + Qed. + + (** [filter] *) + + Fixpoint filter (l:list A) : list A := + match l with + | [] => [] + | x :: l => if f x then x::(filter l) else filter l + end. - Lemma filter_app (l l':list A) : - filter (l ++ l') = filter l ++ filter l'. - Proof. - induction l as [|x l IH]; simpl; trivial. - destruct (f x); simpl; now rewrite IH. - Qed. + Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. + Proof. + intros x l; induction l as [|a ? ?]; simpl. + - tauto. + - intros. + case_eq (f a); intros; simpl; intuition congruence. + Qed. + + Lemma filter_app (l l':list A) : + filter (l ++ l') = filter l ++ filter l'. + Proof. + induction l as [|x l IH]; simpl; trivial. + destruct (f x); simpl; now rewrite IH. + Qed. + + Lemma concat_filter_map : forall (l : list (list A)), + concat (map filter l) = filter (concat l). + Proof. + intro l; induction l as [| v l IHl]; [auto|]. + simpl. rewrite IHl. rewrite filter_app. reflexivity. + Qed. + + Lemma forallb_filter l: forallb (filter l) = true. + Proof. + induction l as [|x l IH]; [reflexivity|]. + cbn. remember (f x) as y. destruct y. + - apply andb_true_intro. auto. + - exact IH. + Qed. + + Lemma forallb_filter_id l: forallb l = true -> filter l = l. + Proof. + induction l as [|x l IH]; [easy|]. + cbn. intro H. destruct (f x). + - f_equal. apply IH, H. + - discriminate H. + Qed. + + (** [find] *) + + Fixpoint find (l:list A) : option A := + match l with + | [] => None + | x :: tl => if f x then Some x else find tl + end. - Lemma concat_filter_map : forall (l : list (list A)), - concat (map filter l) = filter (concat l). - Proof. - intro l; induction l as [| v l IHl]; [auto|]. - simpl. rewrite IHl. rewrite filter_app. reflexivity. - Qed. + Lemma find_some l x : find l = Some x -> In x l /\ f x = true. + Proof. + induction l as [|a l IH]; simpl; [easy| ]. + case_eq (f a); intros Ha Eq. + * injection Eq as [= ->]; auto. + * destruct (IH Eq); auto. + Qed. + + Lemma find_none l : find l = None -> forall x, In x l -> f x = false. + Proof. + induction l as [|a l IH]; simpl; [easy|]. + case_eq (f a); intros Ha Eq x IN; [easy|]. + destruct IN as [<-|IN]; auto. + Qed. + + Lemma filter_rev (l : list A) : filter (rev l) = rev (filter l). + Proof. + induction l; cbn [rev]; trivial. + rewrite filter_app, IHl; cbn [filter]. + case f; cbn [app]; auto using app_nil_r. + Qed. + + (** [partition] *) + + Fixpoint partition (l:list A) : list A * list A := + match l with + | [] => ([], []) + | x :: tl => let (g,d) := partition tl in + if f x then (x::g,d) else (g,x::d) + end. - Lemma forallb_filter l: forallb (filter l) = true. + Theorem partition_cons1 a l l1 l2: + partition l = (l1, l2) -> + f a = true -> + partition (a::l) = (a::l1, l2). Proof. - induction l as [|x l IH]; [reflexivity|]. - cbn. remember (f x) as y. destruct y. - - apply andb_true_intro. auto. - - exact IH. + simpl. now intros -> ->. Qed. - Lemma forallb_filter_id l: forallb l = true -> filter l = l. + Theorem partition_cons2 a l l1 l2: + partition l = (l1, l2) -> + f a=false -> + partition (a::l) = (l1, a::l2). Proof. - induction l as [|x l IH]; [easy|]. - cbn. intro H. destruct (f x). - - f_equal. apply IH, H. - - discriminate H. + simpl. now intros -> ->. Qed. - (** [find] *) - - Fixpoint find (l:list A) : option A := - match l with - | [] => None - | x :: tl => if f x then Some x else find tl - end. - - Lemma find_some l x : find l = Some x -> In x l /\ f x = true. + Theorem partition_length l l1 l2: + partition l = (l1, l2) -> + length l = length l1 + length l2. Proof. - induction l as [|a l IH]; simpl; [easy| ]. - case_eq (f a); intros Ha Eq. - * injection Eq as [= ->]; auto. - * destruct (IH Eq); auto. + revert l1 l2. induction l as [ | a l' Hrec]; intros l1 l2. + - now intros [= <- <- ]. + - simpl. destruct (f a), (partition l') as (left, right); + intros [= <- <- ]; simpl; rewrite (Hrec left right); auto. Qed. - Lemma find_none l : find l = None -> forall x, In x l -> f x = false. + Theorem partition_inv_nil (l : list A): + partition l = ([], []) <-> l = []. Proof. - induction l as [|a l IH]; simpl; [easy|]. - case_eq (f a); intros Ha Eq x IN; [easy|]. - destruct IN as [<-|IN]; auto. + split. + - destruct l as [|a l']. + * intuition. + * simpl. destruct (f a), (partition l'); now intros [= -> ->]. + - now intros ->. Qed. - Lemma filter_rev (l : list A) : filter (rev l) = rev (filter l). + Theorem elements_in_partition l l1 l2: + partition l = (l1, l2) -> + forall x:A, In x l <-> In x l1 \/ In x l2. Proof. - induction l; cbn [rev]; trivial. - rewrite filter_app, IHl; cbn [filter]. - case f; cbn [app]; auto using app_nil_r. + revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x. + - injection Eq as [= <- <-]. tauto. + - destruct (partition l') as (left, right). + specialize (Hrec left right eq_refl x). + destruct (f a); injection Eq as [= <- <-]; simpl; tauto. Qed. - (** [partition] *) - - Fixpoint partition (l:list A) : list A * list A := - match l with - | [] => ([], []) - | x :: tl => let (g,d) := partition tl in - if f x then (x::g,d) else (g,x::d) - end. - - Theorem partition_cons1 a l l1 l2: - partition l = (l1, l2) -> - f a = true -> - partition (a::l) = (a::l1, l2). - Proof. - simpl. now intros -> ->. - Qed. - - Theorem partition_cons2 a l l1 l2: - partition l = (l1, l2) -> - f a=false -> - partition (a::l) = (l1, a::l2). - Proof. - simpl. now intros -> ->. - Qed. - - Theorem partition_length l l1 l2: - partition l = (l1, l2) -> - length l = length l1 + length l2. - Proof. - revert l1 l2. induction l as [ | a l' Hrec]; intros l1 l2. - - now intros [= <- <- ]. - - simpl. destruct (f a), (partition l') as (left, right); - intros [= <- <- ]; simpl; rewrite (Hrec left right); auto. - Qed. - - Theorem partition_inv_nil (l : list A): - partition l = ([], []) <-> l = []. - Proof. - split. - - destruct l as [|a l']. - * intuition. - * simpl. destruct (f a), (partition l'); now intros [= -> ->]. - - now intros ->. - Qed. - - Theorem elements_in_partition l l1 l2: - partition l = (l1, l2) -> - forall x:A, In x l <-> In x l1 \/ In x l2. - Proof. - revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x. - - injection Eq as [= <- <-]. tauto. - - destruct (partition l') as (left, right). - specialize (Hrec left right eq_refl x). - destruct (f a); injection Eq as [= <- <-]; simpl; tauto. - Qed. - End Bool. @@ -2505,42 +2505,42 @@ Section Add. Lemma Add_app a l1 l2 : Add a (l1++l2) (l1++a::l2). Proof. - induction l1; simpl; now constructor. + induction l1; simpl; now constructor. Qed. Lemma Add_split a l l' : Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2. Proof. - induction 1 as [l|x ? ? ? IHAdd]. - - exists nil; exists l; split; trivial. - - destruct IHAdd as (l1 & l2 & Hl & Hl'). - exists (x::l1); exists l2; split; simpl; f_equal; trivial. + induction 1 as [l|x ? ? ? IHAdd]. + - exists nil; exists l; split; trivial. + - destruct IHAdd as (l1 & l2 & Hl & Hl'). + exists (x::l1); exists l2; split; simpl; f_equal; trivial. Qed. Lemma Add_in a l l' : Add a l l' -> forall x, In x l' <-> In x (a::l). Proof. - induction 1 as [|? ? ? ? IHAdd]; intros; simpl in *; rewrite ?IHAdd; tauto. + induction 1 as [|? ? ? ? IHAdd]; intros; simpl in *; rewrite ?IHAdd; tauto. Qed. Lemma Add_length a l l' : Add a l l' -> length l' = S (length l). Proof. - induction 1; simpl; now auto. + induction 1; simpl; now auto. Qed. Lemma Add_inv a l : In a l -> exists l', Add a l' l. Proof. - intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->). - exists (l1 ++ l2). apply Add_app. + intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->). + exists (l1 ++ l2). apply Add_app. Qed. Lemma incl_Add_inv a l u v : ~In a l -> incl (a::l) v -> Add a u v -> incl l u. Proof. - intros Ha H AD y Hy. - assert (Hy' : In y (a::u)). - { rewrite <- (Add_in AD). apply H; simpl; auto. } - destruct Hy'; [ subst; now elim Ha | trivial ]. + intros Ha H AD y Hy. + assert (Hy' : In y (a::u)). + { rewrite <- (Add_in AD). apply H; simpl; auto. } + destruct Hy'; [ subst; now elim Ha | trivial ]. Qed. End Add. @@ -2559,30 +2559,30 @@ Section ReDun. Lemma NoDup_Add a l l' : Add a l l' -> (NoDup l' <-> NoDup l /\ ~In a l). Proof. - induction 1 as [l|x l l' AD IH]. - - split; [ inversion_clear 1; now split | now constructor ]. - - split. - + inversion_clear 1. rewrite IH in *. rewrite (Add_in AD) in *. - simpl in *; split; try constructor; intuition. - + intros (N,IN). inversion_clear N. constructor. - * rewrite (Add_in AD); simpl in *; intuition. - * apply IH. split; trivial. simpl in *; intuition. + induction 1 as [l|x l l' AD IH]. + - split; [ inversion_clear 1; now split | now constructor ]. + - split. + + inversion_clear 1. rewrite IH in *. rewrite (Add_in AD) in *. + simpl in *; split; try constructor; intuition. + + intros (N,IN). inversion_clear N. constructor. + * rewrite (Add_in AD); simpl in *; intuition. + * apply IH. split; trivial. simpl in *; intuition. Qed. Lemma NoDup_remove l l' a : NoDup (l++a::l') -> NoDup (l++l') /\ ~In a (l++l'). Proof. - apply NoDup_Add. apply Add_app. + apply NoDup_Add. apply Add_app. Qed. Lemma NoDup_remove_1 l l' a : NoDup (l++a::l') -> NoDup (l++l'). Proof. - intros. now apply NoDup_remove with a. + intros. now apply NoDup_remove with a. Qed. Lemma NoDup_remove_2 l l' a : NoDup (l++a::l') -> ~In a (l++l'). Proof. - intros. now apply NoDup_remove. + intros. now apply NoDup_remove. Qed. Theorem NoDup_cons_iff a l: @@ -2609,16 +2609,16 @@ Section ReDun. Lemma NoDup_app_remove_l l l' : NoDup (l++l') -> NoDup l'. Proof. - induction l as [|a l IHl]; intro H. - - exact H. - - apply IHl, (NoDup_remove_1 nil _ _ H). + induction l as [|a l IHl]; intro H. + - exact H. + - apply IHl, (NoDup_remove_1 nil _ _ H). Qed. Lemma NoDup_app_remove_r l l' : NoDup (l++l') -> NoDup l. Proof. - induction l' as [|a l' IHl']; intro H. - - now rewrite app_nil_r in H. - - apply IHl', (NoDup_remove_1 _ _ _ H). + induction l' as [|a l' IHl']; intro H. + - now rewrite app_nil_r in H. + - apply IHl', (NoDup_remove_1 _ _ _ H). Qed. Lemma NoDup_rev l : NoDup l -> NoDup (rev l). @@ -2760,26 +2760,26 @@ Section ReDun. Lemma NoDup_incl_length l l' : NoDup l -> incl l l' -> length l <= length l'. Proof. - intros N. revert l'. induction N as [|a l Hal N IH]; simpl. - - intros. now apply Nat.le_0_l. - - intros l' H. - destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } - rewrite (Add_length AD). apply le_n_S. apply IH. - now apply incl_Add_inv with a l'. + intros N. revert l'. induction N as [|a l Hal N IH]; simpl. + - intros. now apply Nat.le_0_l. + - intros l' H. + destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } + rewrite (Add_length AD). apply le_n_S. apply IH. + now apply incl_Add_inv with a l'. Qed. Lemma NoDup_length_incl l l' : NoDup l -> length l' <= length l -> incl l l' -> incl l' l. Proof. - intros N. revert l'. induction N as [|a l Hal N IH]. - - intro l'; destruct l'; easy. - - intros l' E H x Hx. - destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } - rewrite (Add_in AD) in Hx. simpl in Hx. - destruct Hx as [Hx|Hx]; [left; trivial|right]. - revert x Hx. apply (IH l''); trivial. - * apply Nat.succ_le_mono. now rewrite <- (Add_length AD). - * now apply incl_Add_inv with a l'. + intros N. revert l'. induction N as [|a l Hal N IH]. + - intro l'; destruct l'; easy. + - intros l' E H x Hx. + destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } + rewrite (Add_in AD) in Hx. simpl in Hx. + destruct Hx as [Hx|Hx]; [left; trivial|right]. + revert x Hx. apply (IH l''); trivial. + * apply Nat.succ_le_mono. now rewrite <- (Add_length AD). + * now apply incl_Add_inv with a l'. Qed. Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> @@ -2818,8 +2818,8 @@ End ReDun. Lemma NoDup_map_inv A B (f:A->B) l : NoDup (map f l) -> NoDup l. Proof. - induction l; simpl; inversion_clear 1; subst; constructor; auto. - intro H. now apply (in_map f) in H. + induction l; simpl; inversion_clear 1; subst; constructor; auto. + intro H. now apply (in_map f) in H. Qed. (***********************************) @@ -2875,9 +2875,9 @@ Section NatSeq. Lemma seq_NoDup len start : NoDup (seq start len). Proof. - revert start; induction len as [|len IH]; - intros start; simpl; constructor; trivial. - rewrite in_seq. intros (H,_). now apply (Nat.lt_irrefl start). + revert start; induction len as [|len IH]; + intros start; simpl; constructor; trivial. + rewrite in_seq. intros (H,_). now apply (Nat.lt_irrefl start). Qed. Lemma seq_app : forall len1 len2 start, @@ -2890,10 +2890,10 @@ Section NatSeq. Lemma seq_S : forall len start, seq start (S len) = seq start len ++ [start + len]. Proof. - intros len start. - change [start + len] with (seq (start + len) 1). - rewrite <- seq_app. - rewrite Nat.add_succ_r, Nat.add_0_r; reflexivity. + intros len start. + change [start + len] with (seq (start + len) 1). + rewrite <- seq_app. + rewrite Nat.add_succ_r, Nat.add_0_r; reflexivity. Qed. Lemma skipn_seq n start len : skipn n (seq start len) = seq (start+n) (len-n). @@ -3874,9 +3874,9 @@ Definition list_sum l := fold_right plus 0 l. Lemma list_sum_app : forall l1 l2, list_sum (l1 ++ l2) = list_sum l1 + list_sum l2. Proof. -intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. -simpl; rewrite IHl1. -apply Nat.add_assoc. + intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. + simpl; rewrite IHl1. + apply Nat.add_assoc. Qed. Lemma length_concat A l: @@ -3918,8 +3918,8 @@ Definition list_max l := fold_right max 0 l. Lemma list_max_app : forall l1 l2, list_max (l1 ++ l2) = max (list_max l1) (list_max l2). Proof. -intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. -now simpl; rewrite IHl1, Nat.max_assoc. + intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. + now simpl; rewrite IHl1, Nat.max_assoc. Qed. Lemma list_max_le : forall l n, @@ -3935,17 +3935,17 @@ Qed. Lemma list_max_lt : forall l n, l <> [] -> list_max l < n <-> Forall (fun k => k < n) l. Proof. -intro l; induction l as [|a l IHl]; simpl; intros n Hnil; split; intros H; intuition. -- destruct l. - + repeat constructor. - now simpl in H; rewrite Nat.max_0_r in H. - + apply Nat.max_lub_lt_iff in H. - now constructor; [ | apply IHl ]. -- destruct l; inversion_clear H as [ | ? ? Hlt HF ]. - + now simpl; rewrite Nat.max_0_r. - + apply IHl in HF. - * now apply Nat.max_lub_lt_iff. - * intros Heq; inversion Heq. + intro l; induction l as [|a l IHl]; simpl; intros n Hnil; split; intros H; intuition. + - destruct l. + + repeat constructor. + now simpl in H; rewrite Nat.max_0_r in H. + + apply Nat.max_lub_lt_iff in H. + now constructor; [ | apply IHl ]. + - destruct l; inversion_clear H as [ | ? ? Hlt HF ]. + + now simpl; rewrite Nat.max_0_r. + + apply IHl in HF. + * now apply Nat.max_lub_lt_iff. + * intros Heq; inversion Heq. Qed. diff --git a/theories/Lists/ListDec.v b/theories/Lists/ListDec.v index 3d1638afaa..87cd114ca0 100644 --- a/theories/Lists/ListDec.v +++ b/theories/Lists/ListDec.v @@ -16,86 +16,86 @@ Set Implicit Arguments. Definition decidable_eq A := forall x y:A, decidable (x=y). Section Dec_in_Prop. -Variables (A:Type)(dec:decidable_eq A). - -Lemma In_decidable x (l:list A) : decidable (In x l). -Proof using A dec. - induction l as [|a l IH]. - - now right. - - destruct (dec a x). - + left. now left. - + destruct IH; simpl; [left|right]; tauto. -Qed. - -Lemma incl_decidable (l l':list A) : decidable (incl l l'). -Proof using A dec. - induction l as [|a l IH]. - - left. inversion 1. - - destruct (In_decidable a l') as [IN|IN]. - + destruct IH as [IC|IC]. - * left. destruct 1; subst; auto. - * right. contradict IC. intros x H. apply IC; now right. - + right. contradict IN. apply IN; now left. -Qed. - -Lemma NoDup_decidable (l:list A) : decidable (NoDup l). -Proof using A dec. - induction l as [|a l IH]. - - left; now constructor. - - destruct (In_decidable a l). - + right. inversion_clear 1. tauto. - + destruct IH. - * left. now constructor. - * right. inversion_clear 1. tauto. -Qed. - -Lemma not_NoDup (l: list A): - ~ NoDup l -> exists a l1 l2 l3, l = l1++a::l2++a::l3. -Proof using A dec. -intro H0. induction l as [|a l IHl]. -- contradiction H0; constructor. -- destruct (NoDup_decidable l) as [H1|H1]. - + destruct (In_decidable a l) as [H2|H2]. - * destruct (in_split _ _ H2) as (l1 & l2 & ->). - now exists a, nil, l1, l2. - * now contradiction H0; constructor. - + destruct (IHl H1) as (b & l1 & l2 & l3 & ->). - now exists b, (a::l1), l2, l3. -Qed. - -Lemma NoDup_list_decidable (l:list A) : NoDup l -> forall x y:A, In x l -> In y l -> decidable (x=y). -Proof using A. - clear dec; intros Hl; induction Hl; firstorder congruence. -Qed. + Variables (A:Type)(dec:decidable_eq A). + + Lemma In_decidable x (l:list A) : decidable (In x l). + Proof using A dec. + induction l as [|a l IH]. + - now right. + - destruct (dec a x). + + left. now left. + + destruct IH; simpl; [left|right]; tauto. + Qed. + + Lemma incl_decidable (l l':list A) : decidable (incl l l'). + Proof using A dec. + induction l as [|a l IH]. + - left. inversion 1. + - destruct (In_decidable a l') as [IN|IN]. + + destruct IH as [IC|IC]. + * left. destruct 1; subst; auto. + * right. contradict IC. intros x H. apply IC; now right. + + right. contradict IN. apply IN; now left. + Qed. + + Lemma NoDup_decidable (l:list A) : decidable (NoDup l). + Proof using A dec. + induction l as [|a l IH]. + - left; now constructor. + - destruct (In_decidable a l). + + right. inversion_clear 1. tauto. + + destruct IH. + * left. now constructor. + * right. inversion_clear 1. tauto. + Qed. + + Lemma not_NoDup (l: list A): + ~ NoDup l -> exists a l1 l2 l3, l = l1++a::l2++a::l3. + Proof using A dec. + intro H0. induction l as [|a l IHl]. + - contradiction H0; constructor. + - destruct (NoDup_decidable l) as [H1|H1]. + + destruct (In_decidable a l) as [H2|H2]. + * destruct (in_split _ _ H2) as (l1 & l2 & ->). + now exists a, nil, l1, l2. + * now contradiction H0; constructor. + + destruct (IHl H1) as (b & l1 & l2 & l3 & ->). + now exists b, (a::l1), l2, l3. + Qed. + + Lemma NoDup_list_decidable (l:list A) : NoDup l -> forall x y:A, In x l -> In y l -> decidable (x=y). + Proof using A. + clear dec; intros Hl; induction Hl; firstorder congruence. + Qed. End Dec_in_Prop. Section Dec_in_Type. -Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}). - -Definition In_dec := List.In_dec dec. (* Already in List.v *) - -Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}. -Proof using A dec. - induction l as [|a l IH]. - - left. inversion 1. - - destruct (In_dec a l') as [IN|IN]. - + destruct IH as [IC|IC]. - * left. destruct 1; subst; auto. - * right. contradict IC. intros x H. apply IC; now right. - + right. contradict IN. apply IN; now left. -Qed. - -Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}. -Proof using A dec. - induction l as [|a l IH]. - - left; now constructor. - - destruct (In_dec a l). - + right. inversion_clear 1. tauto. - + destruct IH. - * left. now constructor. - * right. inversion_clear 1. tauto. -Qed. + Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}). + + Definition In_dec := List.In_dec dec. (* Already in List.v *) + + Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}. + Proof using A dec. + induction l as [|a l IH]. + - left. inversion 1. + - destruct (In_dec a l') as [IN|IN]. + + destruct IH as [IC|IC]. + * left. destruct 1; subst; auto. + * right. contradict IC. intros x H. apply IC; now right. + + right. contradict IN. apply IN; now left. + Qed. + + Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}. + Proof using A dec. + induction l as [|a l IH]. + - left; now constructor. + - destruct (In_dec a l). + + right. inversion_clear 1. tauto. + + destruct IH. + * left. now constructor. + * right. inversion_clear 1. tauto. + Qed. End Dec_in_Type. @@ -105,24 +105,24 @@ End Dec_in_Type. Lemma uniquify_map A B (d:decidable_eq B)(f:A->B)(l:list A) : exists l', NoDup (map f l') /\ incl (map f l) (map f l'). Proof. - induction l as [|a l IHl]. - - exists nil. simpl. split; [now constructor | red; trivial]. - - destruct IHl as (l' & N & I). - destruct (In_decidable d (f a) (map f l')). - + exists l'; simpl; split; trivial. - intros x [Hx|Hx]. - * now subst. - * now apply I. - + exists (a::l'); simpl; split. - * now constructor. - * intros x [Hx|Hx]. - -- subst; now left. - -- right; now apply I. + induction l as [|a l IHl]. + - exists nil. simpl. split; [now constructor | red; trivial]. + - destruct IHl as (l' & N & I). + destruct (In_decidable d (f a) (map f l')). + + exists l'; simpl; split; trivial. + intros x [Hx|Hx]. + * now subst. + * now apply I. + + exists (a::l'); simpl; split. + * now constructor. + * intros x [Hx|Hx]. + -- subst; now left. + -- right; now apply I. Qed. Lemma uniquify A (d:decidable_eq A)(l:list A) : exists l', NoDup l' /\ incl l l'. Proof. - destruct (uniquify_map d id l) as (l',H). - exists l'. now rewrite !map_id in H. + destruct (uniquify_map d id l) as (l',H). + exists l'. now rewrite !map_id in H. Qed. diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 979e5535c1..323f022c51 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -22,453 +22,458 @@ Set Implicit Arguments. Section first_definitions. - Variable A : Type. - Hypothesis Aeq_dec : forall x y:A, {x = y} + {x <> y}. - - Definition set := list A. - - Definition empty_set : set := nil. - - Fixpoint set_add (a:A) (x:set) : set := - match x with - | nil => a :: nil - | a1 :: x1 => - match Aeq_dec a a1 with - | left _ => a1 :: x1 - | right _ => a1 :: set_add a x1 - end - end. - - - Fixpoint set_mem (a:A) (x:set) : bool := - match x with - | nil => false - | a1 :: x1 => - match Aeq_dec a a1 with - | left _ => true - | right _ => set_mem a x1 - end - end. - - (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing. + Variable A : Type. + Hypothesis Aeq_dec : forall x y:A, {x = y} + {x <> y}. + + Definition set := list A. + + Definition empty_set : set := nil. + + Fixpoint set_add (a:A) (x:set) : set := + match x with + | nil => a :: nil + | a1 :: x1 => + match Aeq_dec a a1 with + | left _ => a1 :: x1 + | right _ => a1 :: set_add a x1 + end + end. + + + Fixpoint set_mem (a:A) (x:set) : bool := + match x with + | nil => false + | a1 :: x1 => + match Aeq_dec a a1 with + | left _ => true + | right _ => set_mem a x1 + end + end. + + (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing. Invariant: any element should occur at most once in [x], see for instance [set_add]. We hence remove here only the first occurrence of [a] in [x]. *) - Fixpoint set_remove (a:A) (x:set) : set := - match x with - | nil => empty_set - | a1 :: x1 => - match Aeq_dec a a1 with - | left _ => x1 - | right _ => a1 :: set_remove a x1 - end - end. - - Fixpoint set_inter (x:set) : set -> set := - match x with - | nil => fun y => nil - | a1 :: x1 => - fun y => - if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y - end. - - Fixpoint set_union (x y:set) : set := - match y with - | nil => x - | a1 :: y1 => set_add a1 (set_union x y1) - end. - - (** returns the set of all els of [x] that does not belong to [y] *) - Fixpoint set_diff (x y:set) : set := - match x with - | nil => nil - | a1 :: x1 => - if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y) - end. - - - Definition set_In : A -> set -> Prop := In (A:=A). - - Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}. - Proof. exact (List.In_dec Aeq_dec). Qed. - - Lemma set_mem_ind : - forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), - (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z). - - Proof. - simple induction x; simpl; intros. - - assumption. - - elim (Aeq_dec a a0); auto with datatypes. - Qed. - - Lemma set_mem_ind2 : - forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), - (set_In a x -> P y) -> - (~ set_In a x -> P z) -> P (if set_mem a x then y else z). - - Proof. - simple induction x; simpl; intros. - - apply H0; red; trivial. - - case (Aeq_dec a a0); auto with datatypes. - intro Hneg; apply H; intros; auto. - apply H1; red; intro. - case H3; auto. - Qed. - - - Lemma set_mem_correct1 : - forall (a:A) (x:set), set_mem a x = true -> set_In a x. - Proof. - simple induction x; simpl. - - discriminate. - - intros a0 l; elim (Aeq_dec a a0); auto with datatypes. - Qed. - - Lemma set_mem_correct2 : - forall (a:A) (x:set), set_In a x -> set_mem a x = true. - Proof. - simple induction x; simpl. - - intro Ha; elim Ha. - - intros a0 l; elim (Aeq_dec a a0); auto with datatypes. - intros H1 H2 [H3| H4]. - + absurd (a0 = a); auto with datatypes. - + auto with datatypes. - Qed. - - Lemma set_mem_complete1 : - forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x. - Proof. - simple induction x; simpl. - - tauto. - - intros a0 l; elim (Aeq_dec a a0). - + intros _ _ [=]. - + unfold not; intros H H0 H1 [|]; auto with datatypes. - Qed. - - Lemma set_mem_complete2 : - forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false. - Proof. - simple induction x; simpl. - - tauto. - - intros a0 l; elim (Aeq_dec a a0). - + intros H H0 []; auto with datatypes. - + tauto. - Qed. - - Lemma set_add_intro1 : - forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x). - - Proof. - unfold set_In; simple induction x; simpl. - - auto with datatypes. - - intros a0 l H [Ha0a| Hal]. - + elim (Aeq_dec b a0); left; assumption. - + elim (Aeq_dec b a0); right; [ assumption | auto with datatypes ]. - Qed. - - Lemma set_add_intro2 : - forall (a b:A) (x:set), a = b -> set_In a (set_add b x). - - Proof. - unfold set_In; simple induction x; simpl. - - auto with datatypes. - - intros a0 l H Hab. - elim (Aeq_dec b a0); - [ rewrite Hab; intro Hba0; rewrite Hba0; simpl; - auto with datatypes - | auto with datatypes ]. - Qed. - - #[local] - Hint Resolve set_add_intro1 set_add_intro2 : core. - - Lemma set_add_intro : - forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). - - Proof. - intros a b x [H1| H2]; auto with datatypes. - Qed. - - Lemma set_add_elim : - forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x. - - Proof. - unfold set_In. - simple induction x. - - simpl; intros [H1| H2]; auto with datatypes. - - simpl; do 3 intro. - elim (Aeq_dec b a0). - + simpl; tauto. - + simpl; intros H0 [|]. - * trivial with datatypes. - tauto. + Fixpoint set_remove (a:A) (x:set) : set := + match x with + | nil => empty_set + | a1 :: x1 => + match Aeq_dec a a1 with + | left _ => x1 + | right _ => a1 :: set_remove a x1 + end + end. + + Fixpoint set_inter (x:set) : set -> set := + match x with + | nil => fun y => nil + | a1 :: x1 => + fun y => + if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y + end. + + Fixpoint set_union (x y:set) : set := + match y with + | nil => x + | a1 :: y1 => set_add a1 (set_union x y1) + end. + + (** returns the set of all els of [x] that does not belong to [y] *) + Fixpoint set_diff (x y:set) : set := + match x with + | nil => nil + | a1 :: x1 => + if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y) + end. + + + Definition set_In : A -> set -> Prop := In (A:=A). + + Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}. + Proof. exact (List.In_dec Aeq_dec). Qed. + + Lemma set_mem_ind : + forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), + (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z). + + Proof. + simple induction x; simpl; intros. + - assumption. + - elim (Aeq_dec a a0); auto with datatypes. + Qed. + + Lemma set_mem_ind2 : + forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), + (set_In a x -> P y) -> + (~ set_In a x -> P z) -> P (if set_mem a x then y else z). + + Proof. + simple induction x; simpl; intros. + - apply H0; red; trivial. + - case (Aeq_dec a a0); auto with datatypes. + intro Hneg; apply H; intros; auto. + apply H1; red; intro. + case H3; auto. + Qed. + + + Lemma set_mem_correct1 : + forall (a:A) (x:set), set_mem a x = true -> set_In a x. + Proof. + simple induction x; simpl. + - discriminate. + - intros a0 l; elim (Aeq_dec a a0); auto with datatypes. + Qed. + + Lemma set_mem_correct2 : + forall (a:A) (x:set), set_In a x -> set_mem a x = true. + Proof. + simple induction x; simpl. + - intro Ha; elim Ha. + - intros a0 l; elim (Aeq_dec a a0); auto with datatypes. + intros H1 H2 [H3| H4]. + + absurd (a0 = a); auto with datatypes. + + auto with datatypes. + Qed. + + Lemma set_mem_complete1 : + forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x. + Proof. + simple induction x; simpl. + - tauto. + - intros a0 l; elim (Aeq_dec a a0). + + intros _ _ [=]. + + unfold not; intros H H0 H1 [|]; auto with datatypes. + Qed. + + Lemma set_mem_complete2 : + forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false. + Proof. + simple induction x; simpl. + - tauto. + - intros a0 l; elim (Aeq_dec a a0). + + intros H H0 []; auto with datatypes. + + tauto. + Qed. + + Lemma set_add_intro1 : + forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x). + + Proof. + unfold set_In; simple induction x; simpl. + - auto with datatypes. + - intros a0 l H [Ha0a| Hal]. + + elim (Aeq_dec b a0); left; assumption. + + elim (Aeq_dec b a0); right; [ assumption | auto with datatypes ]. + Qed. + + Lemma set_add_intro2 : + forall (a b:A) (x:set), a = b -> set_In a (set_add b x). + + Proof. + unfold set_In; simple induction x; simpl. + - auto with datatypes. + - intros a0 l H Hab. + elim (Aeq_dec b a0); + [ rewrite Hab; intro Hba0; rewrite Hba0; simpl; + auto with datatypes + | auto with datatypes ]. + Qed. + + #[local] + Hint Resolve set_add_intro1 set_add_intro2 : core. + + Lemma set_add_intro : + forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). + + Proof. + intros a b x [H1| H2]; auto with datatypes. + Qed. + + Lemma set_add_elim : + forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x. + + Proof. + unfold set_In. + simple induction x. + - simpl; intros [H1| H2]; auto with datatypes. + - simpl; do 3 intro. + elim (Aeq_dec b a0). + + simpl; tauto. + + simpl; intros H0 [|]. + * trivial with datatypes. + tauto. + * tauto. + Qed. + + Lemma set_add_elim2 : + forall (a b:A) (x:set), set_In a (set_add b x) -> a <> b -> set_In a x. + Proof. + intros a b x H; case (set_add_elim _ _ _ H); intros; trivial. + case H1; trivial. + Qed. + + #[local] + Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. + + Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. + Proof. + simple induction x; simpl. + - discriminate. + - intros; elim (Aeq_dec a a0); intros; discriminate. + Qed. + + Lemma set_add_iff a b l : In a (set_add b l) <-> a = b \/ In a l. + Proof. + split. + - apply set_add_elim. + - apply set_add_intro. + Qed. + + Lemma set_add_nodup a l : NoDup l -> NoDup (set_add a l). + Proof. + induction 1 as [|x l H H' IH]; simpl. + - constructor; [ tauto | constructor ]. + - destruct (Aeq_dec a x) as [<-|Hax]; constructor; trivial. + rewrite set_add_iff. intuition. + Qed. + + Lemma set_remove_1 (a b : A) (l : set) : + In a (set_remove b l) -> In a l. + Proof. + induction l as [|x xs Hrec]. + - intros. auto. + - simpl. destruct (Aeq_dec b x). * tauto. - Qed. - - Lemma set_add_elim2 : - forall (a b:A) (x:set), set_In a (set_add b x) -> a <> b -> set_In a x. - intros a b x H; case (set_add_elim _ _ _ H); intros; trivial. - case H1; trivial. - Qed. - - #[local] - Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. - - Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. - Proof. - simple induction x; simpl. - - discriminate. - - intros; elim (Aeq_dec a a0); intros; discriminate. - Qed. - - Lemma set_add_iff a b l : In a (set_add b l) <-> a = b \/ In a l. - Proof. - split. - - apply set_add_elim. - - apply set_add_intro. - Qed. - - Lemma set_add_nodup a l : NoDup l -> NoDup (set_add a l). - Proof. - induction 1 as [|x l H H' IH]; simpl. - - constructor; [ tauto | constructor ]. - - destruct (Aeq_dec a x) as [<-|Hax]; constructor; trivial. - rewrite set_add_iff. intuition. - Qed. - - Lemma set_remove_1 (a b : A) (l : set) : - In a (set_remove b l) -> In a l. - Proof. - induction l as [|x xs Hrec]. - - intros. auto. - - simpl. destruct (Aeq_dec b x). - * tauto. - * intro H. destruct H. - + rewrite H. apply in_eq. - + apply in_cons. apply Hrec. assumption. - Qed. - - Lemma set_remove_2 (a b:A) (l : set) : - NoDup l -> In a (set_remove b l) -> a <> b. - Proof. - induction l as [|x l IH]; intro ND; simpl. - - tauto. - - inversion_clear ND. - destruct (Aeq_dec b x) as [<-|Hbx]. - + congruence. - + destruct 1; subst; auto. - Qed. - - Lemma set_remove_3 (a b : A) (l : set) : - In a l -> a <> b -> In a (set_remove b l). - Proof. - induction l as [|x xs Hrec]. - - now simpl. - - simpl. destruct (Aeq_dec b x) as [<-|Hbx]; simpl; intuition. - congruence. - Qed. - - Lemma set_remove_iff (a b : A) (l : set) : - NoDup l -> (In a (set_remove b l) <-> In a l /\ a <> b). - Proof. - split; try split. - - eapply set_remove_1; eauto. - - eapply set_remove_2; eauto. - - destruct 1; apply set_remove_3; auto. - Qed. - - Lemma set_remove_nodup a l : NoDup l -> NoDup (set_remove a l). - Proof. - induction 1 as [|x l H H' IH]; simpl. - - constructor. - - destruct (Aeq_dec a x) as [<-|Hax]; trivial. - constructor; trivial. - rewrite set_remove_iff; trivial. intuition. - Qed. - - Lemma set_union_intro1 : - forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y). - Proof. - simple induction y; simpl; auto with datatypes. - Qed. - - Lemma set_union_intro2 : - forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y). - Proof. - simple induction y; simpl. - - tauto. - - intros; elim H0; auto with datatypes. - Qed. - - #[local] - Hint Resolve set_union_intro2 set_union_intro1 : core. - - Lemma set_union_intro : - forall (a:A) (x y:set), - set_In a x \/ set_In a y -> set_In a (set_union x y). - Proof. - intros; elim H; auto with datatypes. - Qed. - - Lemma set_union_elim : - forall (a:A) (x y:set), - set_In a (set_union x y) -> set_In a x \/ set_In a y. - Proof. - simple induction y; simpl. - - auto with datatypes. - - intros. - generalize (set_add_elim _ _ _ H0). - intros [H1| H1]. - + auto with datatypes. - + tauto. - Qed. - - Lemma set_union_iff a l l': In a (set_union l l') <-> In a l \/ In a l'. - Proof. - split. - - apply set_union_elim. - - apply set_union_intro. - Qed. - - Lemma set_union_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_union l l'). - Proof. - induction 2 as [|x' l' ? ? IH]; simpl; trivial. now apply set_add_nodup. - Qed. - - Lemma set_union_emptyL : - forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x. - intros a x H; case (set_union_elim _ _ _ H); auto || contradiction. - Qed. - - Lemma set_union_emptyR : - forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x. - intros a x H; case (set_union_elim _ _ _ H); auto || contradiction. - Qed. - - Lemma set_inter_intro : - forall (a:A) (x y:set), - set_In a x -> set_In a y -> set_In a (set_inter x y). - Proof. - simple induction x. - - auto with datatypes. - - simpl; intros a0 l Hrec y [Ha0a| Hal] Hy. - + simpl; rewrite Ha0a. - generalize (set_mem_correct1 a y). - generalize (set_mem_complete1 a y). - elim (set_mem a y); simpl; intros. - * auto with datatypes. - * absurd (set_In a y); auto with datatypes. - + elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. - Qed. - - Lemma set_inter_elim1 : - forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a x. - Proof. - simple induction x. - - auto with datatypes. - - simpl; intros a0 l Hrec y. - generalize (set_mem_correct1 a0 y). - elim (set_mem a0 y); simpl; intros. - + elim H0; eauto with datatypes. - + eauto with datatypes. - Qed. - - Lemma set_inter_elim2 : - forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y. - Proof. - simple induction x. - - simpl; tauto. - - simpl; intros a0 l Hrec y. - generalize (set_mem_correct1 a0 y). - elim (set_mem a0 y); simpl; intros. - + elim H0; - [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ]. - + eauto with datatypes. - Qed. + * intro H. destruct H. + + rewrite H. apply in_eq. + + apply in_cons. apply Hrec. assumption. + Qed. + + Lemma set_remove_2 (a b:A) (l : set) : + NoDup l -> In a (set_remove b l) -> a <> b. + Proof. + induction l as [|x l IH]; intro ND; simpl. + - tauto. + - inversion_clear ND. + destruct (Aeq_dec b x) as [<-|Hbx]. + + congruence. + + destruct 1; subst; auto. + Qed. + + Lemma set_remove_3 (a b : A) (l : set) : + In a l -> a <> b -> In a (set_remove b l). + Proof. + induction l as [|x xs Hrec]. + - now simpl. + - simpl. destruct (Aeq_dec b x) as [<-|Hbx]; simpl; intuition. + congruence. + Qed. + + Lemma set_remove_iff (a b : A) (l : set) : + NoDup l -> (In a (set_remove b l) <-> In a l /\ a <> b). + Proof. + split; try split. + - eapply set_remove_1; eauto. + - eapply set_remove_2; eauto. + - destruct 1; apply set_remove_3; auto. + Qed. + + Lemma set_remove_nodup a l : NoDup l -> NoDup (set_remove a l). + Proof. + induction 1 as [|x l H H' IH]; simpl. + - constructor. + - destruct (Aeq_dec a x) as [<-|Hax]; trivial. + constructor; trivial. + rewrite set_remove_iff; trivial. intuition. + Qed. + + Lemma set_union_intro1 : + forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y). + Proof. + simple induction y; simpl; auto with datatypes. + Qed. + + Lemma set_union_intro2 : + forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y). + Proof. + simple induction y; simpl. + - tauto. + - intros; elim H0; auto with datatypes. + Qed. + + #[local] + Hint Resolve set_union_intro2 set_union_intro1 : core. + + Lemma set_union_intro : + forall (a:A) (x y:set), + set_In a x \/ set_In a y -> set_In a (set_union x y). + Proof. + intros; elim H; auto with datatypes. + Qed. + + Lemma set_union_elim : + forall (a:A) (x y:set), + set_In a (set_union x y) -> set_In a x \/ set_In a y. + Proof. + simple induction y; simpl. + - auto with datatypes. + - intros. + generalize (set_add_elim _ _ _ H0). + intros [H1| H1]. + + auto with datatypes. + + tauto. + Qed. + + Lemma set_union_iff a l l': In a (set_union l l') <-> In a l \/ In a l'. + Proof. + split. + - apply set_union_elim. + - apply set_union_intro. + Qed. + + Lemma set_union_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_union l l'). + Proof. + induction 2 as [|x' l' ? ? IH]; simpl; trivial. now apply set_add_nodup. + Qed. + + Lemma set_union_emptyL : + forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x. + Proof. + intros a x H; case (set_union_elim _ _ _ H); auto || contradiction. + Qed. + + Lemma set_union_emptyR : + forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x. + Proof. + intros a x H; case (set_union_elim _ _ _ H); auto || contradiction. + Qed. + + Lemma set_inter_intro : + forall (a:A) (x y:set), + set_In a x -> set_In a y -> set_In a (set_inter x y). + Proof. + simple induction x. + - auto with datatypes. + - simpl; intros a0 l Hrec y [Ha0a| Hal] Hy. + + simpl; rewrite Ha0a. + generalize (set_mem_correct1 a y). + generalize (set_mem_complete1 a y). + elim (set_mem a y); simpl; intros. + * auto with datatypes. + * absurd (set_In a y); auto with datatypes. + + elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. + Qed. + + Lemma set_inter_elim1 : + forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a x. + Proof. + simple induction x. + - auto with datatypes. + - simpl; intros a0 l Hrec y. + generalize (set_mem_correct1 a0 y). + elim (set_mem a0 y); simpl; intros. + + elim H0; eauto with datatypes. + + eauto with datatypes. + Qed. + + Lemma set_inter_elim2 : + forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y. + Proof. + simple induction x. + - simpl; tauto. + - simpl; intros a0 l Hrec y. + generalize (set_mem_correct1 a0 y). + elim (set_mem a0 y); simpl; intros. + + elim H0; + [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ]. + + eauto with datatypes. + Qed. + + #[local] + Hint Resolve set_inter_elim1 set_inter_elim2 : core. + + Lemma set_inter_elim : + forall (a:A) (x y:set), + set_In a (set_inter x y) -> set_In a x /\ set_In a y. + Proof. + eauto with datatypes. + Qed. + + Lemma set_inter_iff a l l' : In a (set_inter l l') <-> In a l /\ In a l'. + Proof. + split. + - apply set_inter_elim. + - destruct 1. now apply set_inter_intro. + Qed. + + Lemma set_inter_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_inter l l'). + Proof. + induction 1 as [|x l H H' IH]; intro Hl'; simpl. + - constructor. + - destruct (set_mem x l'); auto. + constructor; auto. rewrite set_inter_iff; tauto. + Qed. + + Lemma set_diff_intro : + forall (a:A) (x y:set), + set_In a x -> ~ set_In a y -> set_In a (set_diff x y). + Proof. + simple induction x. + - simpl; tauto. + - simpl; intros a0 l Hrec y [Ha0a| Hal] Hay. + + rewrite Ha0a; generalize (set_mem_complete2 _ _ Hay). + elim (set_mem a y); + [ intro Habs; discriminate Habs | auto with datatypes ]. + + elim (set_mem a0 y); auto with datatypes. + Qed. + + Lemma set_diff_elim1 : + forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x. + Proof. + simple induction x. + - simpl; tauto. + - simpl; intros a0 l Hrec y; elim (set_mem a0 y). + + eauto with datatypes. + + intro; generalize (set_add_elim _ _ _ H). + intros [H1| H2]; eauto with datatypes. + Qed. + + Lemma set_diff_elim2 : + forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y. + Proof. + intros a x y; elim x; simpl. + - intros; contradiction. + - intros a0 l Hrec. + apply set_mem_ind2; auto. + intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto. + rewrite H; trivial. + Qed. + + Lemma set_diff_iff a l l' : In a (set_diff l l') <-> In a l /\ ~In a l'. + Proof. + split. + - split; [eapply set_diff_elim1 | eapply set_diff_elim2]; eauto. + - destruct 1. now apply set_diff_intro. + Qed. + + Lemma set_diff_nodup l l' : NoDup l -> NoDup (set_diff l l'). + Proof. + induction 1 as [|x l H IH]; simpl. + - constructor. + - destruct (set_mem x l'); auto using set_add_nodup. + Qed. + + Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x). + Proof. + red; intros a x H. + apply (set_diff_elim2 _ _ _ H). + apply (set_diff_elim1 _ _ _ H). + Qed. #[local] - Hint Resolve set_inter_elim1 set_inter_elim2 : core. - - Lemma set_inter_elim : - forall (a:A) (x y:set), - set_In a (set_inter x y) -> set_In a x /\ set_In a y. - Proof. - eauto with datatypes. - Qed. - - Lemma set_inter_iff a l l' : In a (set_inter l l') <-> In a l /\ In a l'. - Proof. - split. - - apply set_inter_elim. - - destruct 1. now apply set_inter_intro. - Qed. - - Lemma set_inter_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_inter l l'). - Proof. - induction 1 as [|x l H H' IH]; intro Hl'; simpl. - - constructor. - - destruct (set_mem x l'); auto. - constructor; auto. rewrite set_inter_iff; tauto. - Qed. - - Lemma set_diff_intro : - forall (a:A) (x y:set), - set_In a x -> ~ set_In a y -> set_In a (set_diff x y). - Proof. - simple induction x. - - simpl; tauto. - - simpl; intros a0 l Hrec y [Ha0a| Hal] Hay. - + rewrite Ha0a; generalize (set_mem_complete2 _ _ Hay). - elim (set_mem a y); - [ intro Habs; discriminate Habs | auto with datatypes ]. - + elim (set_mem a0 y); auto with datatypes. - Qed. - - Lemma set_diff_elim1 : - forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x. - Proof. - simple induction x. - - simpl; tauto. - - simpl; intros a0 l Hrec y; elim (set_mem a0 y). - + eauto with datatypes. - + intro; generalize (set_add_elim _ _ _ H). - intros [H1| H2]; eauto with datatypes. - Qed. - - Lemma set_diff_elim2 : - forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y. - intros a x y; elim x; simpl. - - intros; contradiction. - - intros a0 l Hrec. - apply set_mem_ind2; auto. - intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto. - rewrite H; trivial. - Qed. - - Lemma set_diff_iff a l l' : In a (set_diff l l') <-> In a l /\ ~In a l'. - Proof. - split. - - split; [eapply set_diff_elim1 | eapply set_diff_elim2]; eauto. - - destruct 1. now apply set_diff_intro. - Qed. - - Lemma set_diff_nodup l l' : NoDup l -> NoDup (set_diff l l'). - Proof. - induction 1 as [|x l H IH]; simpl. - - constructor. - - destruct (set_mem x l'); auto using set_add_nodup. - Qed. - - Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x). - red; intros a x H. - apply (set_diff_elim2 _ _ _ H). - apply (set_diff_elim1 _ _ _ H). - Qed. - -#[local] -Hint Resolve set_diff_intro set_diff_trivial : core. + Hint Resolve set_diff_intro set_diff_trivial : core. End first_definitions. diff --git a/theories/Logic/Adjointification.v b/theories/Logic/Adjointification.v index 788a4be4db..6499370d79 100644 --- a/theories/Logic/Adjointification.v +++ b/theories/Logic/Adjointification.v @@ -15,99 +15,99 @@ Module Import lemmas. -(* Lemma 2.4.3 in the HoTT book, specialized to g = id *) -Definition commute_homotopy_id {A} {f : A -> A} - (H : forall a, f a = a) {x y : A} (p : x = y) - : eq_trans (H x) p = eq_trans (f_equal f p) (H y) - := match p in (_ = y) - return eq_trans (H x) p = eq_trans (f_equal f p) (H y) - with eq_refl => eq_sym (eq_trans_refl_l (H x)) end. + (* Lemma 2.4.3 in the HoTT book, specialized to g = id *) + Definition commute_homotopy_id {A} {f : A -> A} + (H : forall a, f a = a) {x y : A} (p : x = y) + : eq_trans (H x) p = eq_trans (f_equal f p) (H y) + := match p in (_ = y) + return eq_trans (H x) p = eq_trans (f_equal f p) (H y) + with eq_refl => eq_sym (eq_trans_refl_l (H x)) end. End lemmas. Section adjointify. -Context {A B} (f : A -> B) (g : B -> A). + Context {A B} (f : A -> B) (g : B -> A). -(** One adjoint equation implies the other *) -Section g_adjoint. -Context - (gf_id : forall a, g (f a) = a) - (fg_id : forall b, f (g b) = b). + (** One adjoint equation implies the other *) + Section g_adjoint. + Context + (gf_id : forall a, g (f a) = a) + (fg_id : forall b, f (g b) = b). -Definition f_adjoint_gives_g_adjoint_pointwise - (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b))) - : gf_id (g b) = f_equal g (fg_id b) - := let precomposed_eq - : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b))) - (gf_id (g b)) = - eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b))) - (f_equal g (fg_id b)) - := eq_trans - (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b)))) - (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _) - (eq_trans (eq_trans - (eq_sym (eq_trans_map_distr g _ _)) - (f_equal (fun p => f_equal g p) - (commute_homotopy_id fg_id (fg_id b)))) - (eq_trans_map_distr g _ _)) _ - (eq_trans (eq_trans - (f_equal (fun p => f_equal g p) f_adjoint_at_gb) - (f_equal_compose f g _)) - (eq_id_comm_r _ gf_id (g b)))) in - match fg_id b as p - return - forall p1 p2, - eq_trans (f_equal _ (f_equal g p)) p1 = - eq_trans (f_equal g (f_equal _ p)) p2 -> - p1 = p2 - with eq_refl => fun p1 p2 eq => - eq_trans (eq_trans - (eq_sym (eq_trans_refl_l _)) - eq) - (eq_trans_refl_l _) - end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq. + Definition f_adjoint_gives_g_adjoint_pointwise + (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b))) + : gf_id (g b) = f_equal g (fg_id b) + := let precomposed_eq + : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b))) + (gf_id (g b)) = + eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b))) + (f_equal g (fg_id b)) + := eq_trans + (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b)))) + (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _) + (eq_trans (eq_trans + (eq_sym (eq_trans_map_distr g _ _)) + (f_equal (fun p => f_equal g p) + (commute_homotopy_id fg_id (fg_id b)))) + (eq_trans_map_distr g _ _)) _ + (eq_trans (eq_trans + (f_equal (fun p => f_equal g p) f_adjoint_at_gb) + (f_equal_compose f g _)) + (eq_id_comm_r _ gf_id (g b)))) in + match fg_id b as p + return + forall p1 p2, + eq_trans (f_equal _ (f_equal g p)) p1 = + eq_trans (f_equal g (f_equal _ p)) p2 -> + p1 = p2 + with eq_refl => fun p1 p2 eq => + eq_trans (eq_trans + (eq_sym (eq_trans_refl_l _)) + eq) + (eq_trans_refl_l _) + end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq. -(** We can flip an adjoint equivalence around without changing the proofs. *) -Definition f_adjoint_gives_g_adjoint - (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a)) - (b : B) : gf_id (g b) = f_equal g (fg_id b) - := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)). -End g_adjoint. + (** We can flip an adjoint equivalence around without changing the proofs. *) + Definition f_adjoint_gives_g_adjoint + (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a)) + (b : B) : gf_id (g b) = f_equal g (fg_id b) + := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)). + End g_adjoint. -Section correction. -Context - (gf_id : forall a, g (f a) = a) - (fg_id : forall b, f (g b) = b). + Section correction. + Context + (gf_id : forall a, g (f a) = a) + (fg_id : forall b, f (g b) = b). -(** Modifies the proof of (f (g b) = b) to be adjoint *) -Definition fg_id' b : f (g b) = b - := eq_trans (eq_sym (fg_id (f (g b)))) - (eq_trans (f_equal f (gf_id (g b))) (fg_id b)). + (** Modifies the proof of (f (g b) = b) to be adjoint *) + Definition fg_id' b : f (g b) = b + := eq_trans (eq_sym (fg_id (f (g b)))) + (eq_trans (f_equal f (gf_id (g b))) (fg_id b)). -(** The main lemma: *) -Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a) - := let symmetric_eq - : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) = - eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a)) - := eq_trans (eq_trans - (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a))) - (eq_sym (eq_id_comm_r _ gf_id a))) - (f_equal (fun p => eq_trans p _) - (eq_trans - (f_equal_compose (fun a => g (f a)) f _) - (eq_sym (f_equal_compose f (fun b => f (g b)) _))))) - (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in - match fg_id (f (g (f a))) as p - return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p' - with eq_refl => fun p' eq => - eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _)) - end _ symmetric_eq. + (** The main lemma: *) + Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a) + := let symmetric_eq + : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) = + eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a)) + := eq_trans (eq_trans + (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a))) + (eq_sym (eq_id_comm_r _ gf_id a))) + (f_equal (fun p => eq_trans p _) + (eq_trans + (f_equal_compose (fun a => g (f a)) f _) + (eq_sym (f_equal_compose f (fun b => f (g b)) _))))) + (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in + match fg_id (f (g (f a))) as p + return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p' + with eq_refl => fun p' eq => + eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _)) + end _ symmetric_eq. -(** And the symmetric version. Note that we use the same proofs of inverse. *) -Definition g_adjoint - : forall b, gf_id (g b) = f_equal g (fg_id' b) - := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint. + (** And the symmetric version. Note that we use the same proofs of inverse. *) + Definition g_adjoint + : forall b, gf_id (g b) = f_equal g (fg_id' b) + := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint. -End correction. + End correction. End adjointify. diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index eb9c02bbd7..2faafd8a08 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -31,126 +31,126 @@ Set Implicit Arguments. Section Berardis_paradox. -(** Excluded middle *) -Hypothesis EM : forall P:Prop, P \/ ~ P. + (** Excluded middle *) + Hypothesis EM : forall P:Prop, P \/ ~ P. -(** Conditional on any proposition. *) -Definition IFProp (P B:Prop) (e1 e2:P) := - match EM B with - | or_introl _ => e1 - | or_intror _ => e2 - end. + (** Conditional on any proposition. *) + Definition IFProp (P B:Prop) (e1 e2:P) := + match EM B with + | or_introl _ => e1 + | or_intror _ => e2 + end. -(** Axiom of choice applied to disjunction. + (** Axiom of choice applied to disjunction. Provable in Coq because of dependent elimination. *) -Lemma AC_IF : - forall (P B:Prop) (e1 e2:P) (Q:P -> Prop), - (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2). -Proof. -intros P B e1 e2 Q p1 p2. -unfold IFProp. -case (EM B); assumption. -Qed. + Lemma AC_IF : + forall (P B:Prop) (e1 e2:P) (Q:P -> Prop), + (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2). + Proof. + intros P B e1 e2 Q p1 p2. + unfold IFProp. + case (EM B); assumption. + Qed. -(** We assume a type with two elements. They play the role of booleans. + (** We assume a type with two elements. They play the role of booleans. The main theorem under the current assumptions is that [T=F] *) -Variable Bool : Prop. -Variable T : Bool. -Variable F : Bool. + Variable Bool : Prop. + Variable T : Bool. + Variable F : Bool. -(** The powerset operator *) -Definition pow (P:Prop) := P -> Bool. + (** The powerset operator *) + Definition pow (P:Prop) := P -> Bool. -(** A piece of theory about retracts *) -Section Retracts. + (** A piece of theory about retracts *) + Section Retracts. -Variables A B : Prop. + Variables A B : Prop. -Record retract : Prop := - {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. -Record retract_cond : Prop := - {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. + Record retract : Prop := + {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. + Record retract_cond : Prop := + {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. -(** The dependent elimination above implies the axiom of choice: *) + (** The dependent elimination above implies the axiom of choice: *) -Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. -Proof. intros r. exact (inv2 r). Qed. + Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. + Proof. intros r. exact (inv2 r). Qed. -End Retracts. + End Retracts. -(** This lemma is basically a commutation of implication and existential + (** This lemma is basically a commutation of implication and existential quantification: (EX x | A -> P(x)) <=> (A -> EX x | P(x)) which is provable in classical logic ( => is already provable in intuitionistic logic). *) -Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). -Proof. -intros A B. -destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. -- exists f0 g0; trivial. -- exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; - destruct hf; auto. -Qed. + Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). + Proof. + intros A B. + destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. + - exists f0 g0; trivial. + - exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; + destruct hf; auto. + Qed. -(** The paradoxical set *) -Definition U := forall P:Prop, pow P. + (** The paradoxical set *) + Definition U := forall P:Prop, pow P. -(** Bijection between [U] and [(pow U)] *) -Definition f (u:U) : pow U := u U. + (** Bijection between [U] and [(pow U)] *) + Definition f (u:U) : pow U := u U. -Definition g (h:pow U) : U := - fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h). + Definition g (h:pow U) : U := + fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h). -(** We deduce that the powerset of [U] is a retract of [U]. + (** We deduce that the powerset of [U] is a retract of [U]. This lemma is stated in Berardi's article, but is not used afterwards. *) -Lemma retract_pow_U_U : retract (pow U) U. -Proof. -exists g f. -intro a. -unfold f, g; simpl. -apply AC. -exists (fun x:pow U => x) (fun x:pow U => x). -trivial. -Qed. - -(** Encoding of Russel's paradox *) - -(** The boolean negation. *) -Definition Not_b (b:Bool) := IFProp (b = T) F T. - -(** the set of elements not belonging to itself *) -Definition R : U := g (fun u:U => Not_b (u U u)). - - -Lemma not_has_fixpoint : R R = Not_b (R R). -Proof. -unfold R at 1. -unfold g. -rewrite AC. -- trivial. -- exists (fun x:pow U => x) (fun x:pow U => x). - trivial. -Qed. - - -Theorem classical_proof_irrelevance : T = F. -Proof. -generalize not_has_fixpoint. -unfold Not_b. -apply AC_IF. -- intros is_true is_false. - elim is_true; elim is_false; trivial. - -- intros not_true is_true. - elim not_true; trivial. -Qed. - - -#[deprecated(since = "8.8", note = "Use classical_proof_irrelevance instead.")] -Notation classical_proof_irrelevence := classical_proof_irrelevance. + Lemma retract_pow_U_U : retract (pow U) U. + Proof. + exists g f. + intro a. + unfold f, g; simpl. + apply AC. + exists (fun x:pow U => x) (fun x:pow U => x). + trivial. + Qed. + + (** Encoding of Russel's paradox *) + + (** The boolean negation. *) + Definition Not_b (b:Bool) := IFProp (b = T) F T. + + (** the set of elements not belonging to itself *) + Definition R : U := g (fun u:U => Not_b (u U u)). + + + Lemma not_has_fixpoint : R R = Not_b (R R). + Proof. + unfold R at 1. + unfold g. + rewrite AC. + - trivial. + - exists (fun x:pow U => x) (fun x:pow U => x). + trivial. + Qed. + + + Theorem classical_proof_irrelevance : T = F. + Proof. + generalize not_has_fixpoint. + unfold Not_b. + apply AC_IF. + - intros is_true is_false. + elim is_true; elim is_false; trivial. + + - intros not_true is_true. + elim not_true; trivial. + Qed. + + + #[deprecated(since = "8.8", note = "Use classical_proof_irrelevance instead.")] + Notation classical_proof_irrelevence := classical_proof_irrelevance. End Berardis_paradox. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 4720a3a608..0c180ab015 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -46,200 +46,200 @@ Set Implicit Arguments. Section ChoiceSchemes. -Variables A B :Type. + Variables A B :Type. -Variable P:A->Prop. + Variable P:A->Prop. -(** ** Constructive choice and description *) + (** ** Constructive choice and description *) -(** AC_rel = relational form of the (non extensional) axiom of choice + (** AC_rel = relational form of the (non extensional) axiom of choice (a "set-theoretic" axiom of choice) *) -Definition RelationalChoice_on := - forall R:A->B->Prop, - (forall x : A, exists y : B, R x y) -> - (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y). + Definition RelationalChoice_on := + forall R:A->B->Prop, + (forall x : A, exists y : B, R x y) -> + (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y). -(** AC_fun = functional form of the (non extensional) axiom of choice + (** AC_fun = functional form of the (non extensional) axiom of choice (a "type-theoretic" axiom of choice) *) -(* Note: This is called Type-Theoretic Description Axiom (TTDA) in + (* Note: This is called Type-Theoretic Description Axiom (TTDA) in [[Werner97]] (using a non-standard meaning of "description"). This is called intensional axiom of choice (AC_int) in [[Carlström04]] *) -Definition FunctionalChoice_on_rel (R:A->B->Prop) := - (forall x:A, exists y : B, R x y) -> - exists f : A -> B, (forall x:A, R x (f x)). + Definition FunctionalChoice_on_rel (R:A->B->Prop) := + (forall x:A, exists y : B, R x y) -> + exists f : A -> B, (forall x:A, R x (f x)). -Definition FunctionalChoice_on := - forall R:A->B->Prop, - (forall x : A, exists y : B, R x y) -> - (exists f : A->B, forall x : A, R x (f x)). + Definition FunctionalChoice_on := + forall R:A->B->Prop, + (forall x : A, exists y : B, R x y) -> + (exists f : A->B, forall x : A, R x (f x)). -(** AC_fun_dep = functional form of the (non extensional) axiom of + (** AC_fun_dep = functional form of the (non extensional) axiom of choice, with dependent functions *) -Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := - forall R:forall x:A, B x -> Prop, - (forall x:A, exists y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). + Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := + forall R:forall x:A, B x -> Prop, + (forall x:A, exists y : B x, R x y) -> + (exists f : (forall x:A, B x), forall x:A, R x (f x)). -(** AC_trunc = axiom of choice for propositional truncations + (** AC_trunc = axiom of choice for propositional truncations (truncation and quantification commute) *) -Definition InhabitedForallCommute_on (A : Type) (B : A -> Type) := - (forall x, inhabited (B x)) -> inhabited (forall x, B x). + Definition InhabitedForallCommute_on (A : Type) (B : A -> Type) := + (forall x, inhabited (B x)) -> inhabited (forall x, B x). -(** DC_fun = functional form of the dependent axiom of choice *) + (** DC_fun = functional form of the dependent axiom of choice *) -Definition FunctionalDependentChoice_on := - forall (R:A->A->Prop), - (forall x, exists y, R x y) -> forall x0, - (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))). + Definition FunctionalDependentChoice_on := + forall (R:A->A->Prop), + (forall x, exists y, R x y) -> forall x0, + (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))). -(** ACw_fun = functional form of the countable axiom of choice *) + (** ACw_fun = functional form of the countable axiom of choice *) -Definition FunctionalCountableChoice_on := - forall (R:nat->A->Prop), - (forall n, exists y, R n y) -> - (exists f : nat -> A, forall n, R n (f n)). + Definition FunctionalCountableChoice_on := + forall (R:nat->A->Prop), + (forall n, exists y, R n y) -> + (exists f : nat -> A, forall n, R n (f n)). -(** AC! = functional relation reification + (** AC! = functional relation reification (known as axiom of unique choice in topos theory, sometimes called principle of definite description in the context of constructive type theory, sometimes called axiom of no choice) *) -Definition FunctionalRelReification_on := - forall R:A->B->Prop, - (forall x : A, exists! y : B, R x y) -> - (exists f : A->B, forall x : A, R x (f x)). + Definition FunctionalRelReification_on := + forall R:A->B->Prop, + (forall x : A, exists! y : B, R x y) -> + (exists f : A->B, forall x : A, R x (f x)). -(** AC_dep! = functional relation reification, with dependent functions + (** AC_dep! = functional relation reification, with dependent functions see AC! *) -Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) := - forall (R:forall x:A, B x -> Prop), - (forall x:A, exists! y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). + Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) := + forall (R:forall x:A, B x -> Prop), + (forall x:A, exists! y : B x, R x y) -> + (exists f : (forall x:A, B x), forall x:A, R x (f x)). -(** AC_fun_repr = functional choice of a representative in an equivalence class *) + (** AC_fun_repr = functional choice of a representative in an equivalence class *) -(* Note: This is called Type-Theoretic Choice Axiom (TTCA) in + (* Note: This is called Type-Theoretic Choice Axiom (TTCA) in [[Werner97]] (by reference to the extensional set-theoretic formulation of choice); Note also a typo in its intended formulation in [[Werner97]]. *) -Definition RepresentativeFunctionalChoice_on := - forall R:A->A->Prop, - (Equivalence R) -> - (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x'). + Definition RepresentativeFunctionalChoice_on := + forall R:A->A->Prop, + (Equivalence R) -> + (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x'). -(** AC_fun_setoid = functional form of the (so-called extensional) axiom of + (** AC_fun_setoid = functional form of the (so-called extensional) axiom of choice from setoids *) -Definition SetoidFunctionalChoice_on := - forall R : A -> A -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - (forall x x' y, R x x' -> T x y -> T x' y) -> - (forall x, exists y, T x y) -> - exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + Definition SetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). -(** AC_fun_setoid_gen = functional form of the general form of the (so-called + (** AC_fun_setoid_gen = functional form of the general form of the (so-called extensional) axiom of choice over setoids *) -(* Note: This is called extensional axiom of choice (AC_ext) in + (* Note: This is called extensional axiom of choice (AC_ext) in [[Carlström04]]. *) -Definition GeneralizedSetoidFunctionalChoice_on := - forall R : A -> A -> Prop, - forall S : B -> B -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - Equivalence S -> - (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> - (forall x, exists y, T x y) -> - exists f : A -> B, - forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')). - -(** AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of + Definition GeneralizedSetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall S : B -> B -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + Equivalence S -> + (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> + (forall x, exists y, T x y) -> + exists f : A -> B, + forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')). + + (** AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of choice from setoids on locally compatible relations *) -Definition SimpleSetoidFunctionalChoice_on A B := - forall R : A -> A -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - (forall x, exists y, forall x', R x x' -> T x' y) -> - exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + Definition SimpleSetoidFunctionalChoice_on A B := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x, exists y, forall x', R x x' -> T x' y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). -(** ID_epsilon = constructive version of indefinite description; + (** ID_epsilon = constructive version of indefinite description; combined with proof-irrelevance, it may be connected to Carlström's type theory with a constructive indefinite description operator *) -Definition ConstructiveIndefiniteDescription_on := - forall P:A->Prop, - (exists x, P x) -> { x:A | P x }. + Definition ConstructiveIndefiniteDescription_on := + forall P:A->Prop, + (exists x, P x) -> { x:A | P x }. -(** ID_iota = constructive version of definite description; + (** ID_iota = constructive version of definite description; combined with proof-irrelevance, it may be connected to Carlström's and Stenlund's type theory with a constructive definite description operator) *) -Definition ConstructiveDefiniteDescription_on := - forall P:A->Prop, - (exists! x, P x) -> { x:A | P x }. + Definition ConstructiveDefiniteDescription_on := + forall P:A->Prop, + (exists! x, P x) -> { x:A | P x }. -(** ** Weakly classical choice and description *) + (** ** Weakly classical choice and description *) -(** GAC_rel = guarded relational form of the (non extensional) axiom of choice *) + (** GAC_rel = guarded relational form of the (non extensional) axiom of choice *) -Definition GuardedRelationalChoice_on := - forall P : A->Prop, forall R : A->B->Prop, - (forall x : A, P x -> exists y : B, R x y) -> - (exists R' : A->B->Prop, - subrelation R' R /\ forall x, P x -> exists! y, R' x y). + Definition GuardedRelationalChoice_on := + forall P : A->Prop, forall R : A->B->Prop, + (forall x : A, P x -> exists y : B, R x y) -> + (exists R' : A->B->Prop, + subrelation R' R /\ forall x, P x -> exists! y, R' x y). -(** GAC_fun = guarded functional form of the (non extensional) axiom of choice *) + (** GAC_fun = guarded functional form of the (non extensional) axiom of choice *) -Definition GuardedFunctionalChoice_on := - forall P : A->Prop, forall R : A->B->Prop, - inhabited B -> - (forall x : A, P x -> exists y : B, R x y) -> - (exists f : A->B, forall x, P x -> R x (f x)). + Definition GuardedFunctionalChoice_on := + forall P : A->Prop, forall R : A->B->Prop, + inhabited B -> + (forall x : A, P x -> exists y : B, R x y) -> + (exists f : A->B, forall x, P x -> R x (f x)). -(** GAC! = guarded functional relation reification *) + (** GAC! = guarded functional relation reification *) -Definition GuardedFunctionalRelReification_on := - forall P : A->Prop, forall R : A->B->Prop, - inhabited B -> - (forall x : A, P x -> exists! y : B, R x y) -> - (exists f : A->B, forall x : A, P x -> R x (f x)). + Definition GuardedFunctionalRelReification_on := + forall P : A->Prop, forall R : A->B->Prop, + inhabited B -> + (forall x : A, P x -> exists! y : B, R x y) -> + (exists f : A->B, forall x : A, P x -> R x (f x)). -(** OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice *) + (** OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice *) -Definition OmniscientRelationalChoice_on := - forall R : A->B->Prop, - exists R' : A->B->Prop, - subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y. + Definition OmniscientRelationalChoice_on := + forall R : A->B->Prop, + exists R' : A->B->Prop, + subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y. -(** OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice + (** OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice (called AC* in Bell [[Bell]]) *) -Definition OmniscientFunctionalChoice_on := - forall R : A->B->Prop, - inhabited B -> - exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x). + Definition OmniscientFunctionalChoice_on := + forall R : A->B->Prop, + inhabited B -> + exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x). -(** D_epsilon = (weakly classical) indefinite description principle *) + (** D_epsilon = (weakly classical) indefinite description principle *) -Definition EpsilonStatement_on := - forall P:A->Prop, - inhabited A -> { x:A | (exists x, P x) -> P x }. + Definition EpsilonStatement_on := + forall P:A->Prop, + inhabited A -> { x:A | (exists x, P x) -> P x }. -(** D_iota = (weakly classical) definite description principle *) + (** D_iota = (weakly classical) definite description principle *) -Definition IotaStatement_on := - forall P:A->Prop, - inhabited A -> { x:A | (exists! x, P x) -> P x }. + Definition IotaStatement_on := + forall P:A->Prop, + inhabited A -> { x:A | (exists! x, P x) -> P x }. End ChoiceSchemes. diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index 5e6c57e8bf..3b154e327e 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -34,9 +34,9 @@ Theorem singleton_choice : forall (A : Type) (P : A->Prop), (exists x : A, P x) -> exists P' : A->Prop, subset P' P /\ exists! x, P' x. Proof. -intros A P H. -destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')). -exists (R' tt); firstorder. + intros A P H. + destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')). + exists (R' tt); firstorder. Qed. Theorem choice : @@ -44,8 +44,8 @@ Theorem choice : (forall x : A, exists y : B, R x y) -> exists f : A->B, (forall x : A, R x (f x)). Proof. -intros A B. -apply description_rel_choice_imp_funct_choice. -- exact (unique_choice A B). -- exact (relational_choice A B). + intros A B. + apply description_rel_choice_imp_funct_choice. + - exact (unique_choice A B). + - exact (relational_choice A B). Qed. diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index 3dac8f0b4b..1149247883 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -28,23 +28,23 @@ From Stdlib Require Import ChoiceFacts. Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. Proof. -apply - (constructive_definite_descr_excluded_middle - constructive_definite_description classic). + apply + (constructive_definite_descr_excluded_middle + constructive_definite_description classic). Qed. Theorem classical_definite_description : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists! x : A, P x) -> P x }. Proof. -intros A P i. -destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP]. -- apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x). - destruct Hex as (x,(Hx,Huni)). - exists x; split. - + intros _; exact Hx. - + firstorder. -- exists i; tauto. + intros A P i. + destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP]. + - apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x). + destruct Hex as (x,(Hx,Huni)). + exists x; split. + + intros _; exact Hx. + + firstorder. + - exists i; tauto. Qed. (** Church's iota operator *) @@ -62,12 +62,12 @@ Theorem dependent_unique_choice : (forall x:A, exists! y : B x, R x y) -> (exists f : (forall x:A, B x), forall x:A, R x (f x)). Proof. -intros A B R H. -assert (Hexuni:forall x, exists! y, R x y). -- intro x. apply H. -- exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))). - intro x. - apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))). + intros A B R H. + assert (Hexuni:forall x, exists! y, R x y). + - intro x. apply H. + - exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))). + intro x. + apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))). Qed. Theorem unique_choice : @@ -75,8 +75,8 @@ Theorem unique_choice : (forall x:A, exists! y : B, R x y) -> (exists f : A -> B, forall x:A, R x (f x)). Proof. -intros A B. -apply dependent_unique_choice with (B:=fun _:A => B). + intros A B. + apply dependent_unique_choice with (B:=fun _:A => B). Qed. (** Compatibility lemmas *) diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index 9f8ebb1342..be24a3b7dd 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -81,9 +81,9 @@ Lemma epsilon_inh_irrelevance : forall (A:Type) (i j : inhabited A) (P:A->Prop), (exists x, P x) -> epsilon i P = epsilon j P. Proof. - intros. - unfold epsilon, classical_indefinite_description. - destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial. + intros. + unfold epsilon, classical_indefinite_description. + destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial. Qed. Opaque epsilon. diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 05d2fca735..a04370b0ab 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -40,8 +40,8 @@ Theorem unique_choice : (forall x:A, exists! y : B, R x y) -> (exists f:A->B, forall x:A, R x (f x)). Proof. -intros A B. -apply (dependent_unique_choice A (fun _ => B)). + intros A B. + apply (dependent_unique_choice A (fun _ => B)). Qed. @@ -51,43 +51,43 @@ From Stdlib Require Import Setoid. Theorem classic_set_in_prop_context : forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. -intros C HnotEM. -set (R := fun A b => A /\ true = b \/ ~ A /\ false = b). -assert (H : exists f : Prop -> bool, (forall A:Prop, R A (f A))). { -apply unique_choice. -intro A. -destruct (classic A) as [Ha| Hnota]. -- exists true; split. - + left; split; [ assumption | reflexivity ]. - + intros y [[_ Hy]| [Hna _]]. - * assumption. - * contradiction. -- exists false; split. - + right; split; [ assumption | reflexivity ]. - + intros y [[Ha _]| [_ Hy]]. - * contradiction. - * assumption. -} -destruct H as [f Hf]. -apply HnotEM. -intro P. -assert (HfP := Hf P). -(* Elimination from Hf to Set is not allowed but from f to Set yes ! *) -destruct (f P). -- left. - destruct HfP as [[Ha _]| [_ Hfalse]]. - + assumption. - + discriminate. -- right. - destruct HfP as [[_ Hfalse]| [Hna _]]. - + discriminate. - + assumption. + intros C HnotEM. + set (R := fun A b => A /\ true = b \/ ~ A /\ false = b). + assert (H : exists f : Prop -> bool, (forall A:Prop, R A (f A))). { + apply unique_choice. + intro A. + destruct (classic A) as [Ha| Hnota]. + - exists true; split. + + left; split; [ assumption | reflexivity ]. + + intros y [[_ Hy]| [Hna _]]. + * assumption. + * contradiction. + - exists false; split. + + right; split; [ assumption | reflexivity ]. + + intros y [[Ha _]| [_ Hy]]. + * contradiction. + * assumption. + } + destruct H as [f Hf]. + apply HnotEM. + intro P. + assert (HfP := Hf P). + (* Elimination from Hf to Set is not allowed but from f to Set yes ! *) + destruct (f P). + - left. + destruct HfP as [[Ha _]| [_ Hfalse]]. + + assumption. + + discriminate. + - right. + destruct HfP as [[_ Hfalse]| [Hna _]]. + + discriminate. + + assumption. Qed. Corollary not_not_classic_set : ((forall P:Prop, {P} + {~ P}) -> False) -> False. Proof. -apply classic_set_in_prop_context. + apply classic_set_in_prop_context. Qed. (* Compatibility *) diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index 9358413511..7266d790fe 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -16,59 +16,59 @@ From Stdlib Require Import Classical_Prop. Section Generic. -Variable U : Type. + Variable U : Type. -(** de Morgan laws for quantifiers *) + (** de Morgan laws for quantifiers *) -Lemma not_all_not_ex : - forall P:U -> Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. -Proof. -intros P notall. -apply NNPP. -intro abs. -apply notall. -intros n H. -apply abs; exists n; exact H. -Qed. + Lemma not_all_not_ex : + forall P:U -> Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. + Proof. + intros P notall. + apply NNPP. + intro abs. + apply notall. + intros n H. + apply abs; exists n; exact H. + Qed. -Lemma not_all_ex_not : - forall P:U -> Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. -Proof. -intros P notall. -apply not_all_not_ex with (P:=fun x => ~ P x). -intro all; apply notall. -intro n; apply NNPP. -apply all. -Qed. + Lemma not_all_ex_not : + forall P:U -> Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. + Proof. + intros P notall. + apply not_all_not_ex with (P:=fun x => ~ P x). + intro all; apply notall. + intro n; apply NNPP. + apply all. + Qed. -Lemma not_ex_all_not : - forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n. -Proof. (* Intuitionistic *) -unfold not; intros P notex n abs. -apply notex. -exists n; trivial. -Qed. + Lemma not_ex_all_not : + forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n. + Proof. (* Intuitionistic *) + unfold not; intros P notex n abs. + apply notex. + exists n; trivial. + Qed. -Lemma not_ex_not_all : - forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. -Proof. -intros P H n. -apply NNPP. -red; intro K; apply H; exists n; trivial. -Qed. + Lemma not_ex_not_all : + forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. + Proof. + intros P H n. + apply NNPP. + red; intro K; apply H; exists n; trivial. + Qed. -Lemma ex_not_not_all : - forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n). -Proof. (* Intuitionistic *) -unfold not; intros P exnot allP. -elim exnot; auto. -Qed. + Lemma ex_not_not_all : + forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n). + Proof. (* Intuitionistic *) + unfold not; intros P exnot allP. + elim exnot; auto. + Qed. -Lemma all_not_not_ex : - forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n). -Proof. (* Intuitionistic *) -unfold not; intros P allnot exP; elim exP; intros n p. -apply allnot with n; auto. -Qed. + Lemma all_not_not_ex : + forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n). + Proof. (* Intuitionistic *) + unfold not; intros P allnot exP; elim exP; intros n p. + apply allnot with n; auto. + Qed. End Generic. diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index 2a0df5d74d..fb1c72209e 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -23,8 +23,8 @@ Axiom classic : forall P:Prop, P \/ ~ P. Lemma NNPP : forall p:Prop, ~ ~ p -> p. Proof. -unfold not; intros; elim (classic p); auto. -intro NP; elim (H NP). + unfold not; intros; elim (classic p); auto. + intro NP; elim (H NP). Qed. Register NNPP as core.nnpp.type. @@ -35,65 +35,65 @@ Register NNPP as core.nnpp.type. Lemma Peirce : forall P:Prop, ((P -> False) -> P) -> P. Proof. -intros P H; destruct (classic P); auto. + intros P H; destruct (classic P); auto. Qed. Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P. Proof. -intros; apply NNPP; red. -intro; apply H; intro; absurd P; trivial. + intros; apply NNPP; red. + intro; apply H; intro; absurd P; trivial. Qed. Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q. Proof. (* Intuitionistic *) -tauto. + tauto. Qed. Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q. Proof. -intros; elim (classic P); auto. + intros; elim (classic P); auto. Qed. Lemma imply_to_and : forall P Q:Prop, ~ (P -> Q) -> P /\ ~ Q. Proof. -intros; split. -- apply not_imply_elim with Q; trivial. -- apply not_imply_elim2 with P; trivial. + intros; split. + - apply not_imply_elim with Q; trivial. + - apply not_imply_elim2 with P; trivial. Qed. Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q. Proof. (* Intuitionistic *) -tauto. + tauto. Qed. Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q. Proof. -intros; elim (classic P); auto. + intros; elim (classic P); auto. Qed. Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q). Proof. -simple induction 1; red; simple induction 2; auto. + simple induction 1; red; simple induction 2; auto. Qed. Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q. Proof. (* Intuitionistic *) -tauto. + tauto. Qed. Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q). Proof. (* Intuitionistic *) -tauto. + tauto. Qed. Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q. Proof. (* Intuitionistic *) -tauto. + tauto. Qed. Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R. Proof. (* Intuitionistic *) -tauto. + tauto. Qed. Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. @@ -116,11 +116,11 @@ From Stdlib Require Export EqdepFacts. Module Eq_rect_eq. -Lemma eq_rect_eq : - forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. -Proof. -intros; rewrite proof_irrelevance with (p1:=h) (p2:=eq_refl p); reflexivity. -Qed. + Lemma eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + Proof. + intros; rewrite proof_irrelevance with (p1:=h) (p2:=eq_refl p); reflexivity. + Qed. End Eq_rect_eq. diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index 6ebe39f327..f534967b0d 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -109,140 +109,142 @@ related to conformity to [rel_ls]. Section ConstructiveIndefiniteGroundDescription_Direct. -Variable P : nat -> Prop. + Variable P : nat -> Prop. -Hypothesis P_dec : forall n, {P n}+{~(P n)}. + Hypothesis P_dec : forall n, {P n}+{~(P n)}. -(** The termination argument is [before_witness n], which says that + (** The termination argument is [before_witness n], which says that any number before any witness (not necessarily the [x] of [exists x :A, P x]) makes the search eventually stops. *) -Inductive before_witness (n:nat) : Prop := - | stop : P n -> before_witness n - | next : before_witness (S n) -> before_witness n. + Inductive before_witness (n:nat) : Prop := + | stop : P n -> before_witness n + | next : before_witness (S n) -> before_witness n. -(* Computation of the initial termination certificate *) -Fixpoint O_witness (n : nat) : before_witness n -> before_witness 0 := - match n return (before_witness n -> before_witness 0) with - | 0 => fun b => b - | S n => fun b => O_witness n (next n b) - end. + (* Computation of the initial termination certificate *) + Fixpoint O_witness (n : nat) : before_witness n -> before_witness 0 := + match n return (before_witness n -> before_witness 0) with + | 0 => fun b => b + | S n => fun b => O_witness n (next n b) + end. -(* Inversion of [inv_before_witness n] in a way such that the result + (* Inversion of [inv_before_witness n] in a way such that the result is structurally smaller even in the [stop] case. *) -Definition inv_before_witness : - forall n, before_witness n -> ~(P n) -> before_witness (S n) := - fun n b not_p => - match b with - | stop _ p => match not_p p with end - | next _ b => b + Definition inv_before_witness : + forall n, before_witness n -> ~(P n) -> before_witness (S n) := + fun n b not_p => + match b with + | stop _ p => match not_p p with end + | next _ b => b + end. + + (** Basic program *) + Fixpoint prog_linear_search start (b : before_witness start) : nat := + match P_dec start with + | left yes => start + | right no => prog_linear_search (S start) (inv_before_witness start b no) end. -(** Basic program *) -Fixpoint prog_linear_search start (b : before_witness start) : nat := - match P_dec start with - | left yes => start - | right no => prog_linear_search (S start) (inv_before_witness start b no) - end. - -(** rel_ls = relational version of linear search *) -Inductive rel_ls : nat -> nat -> Prop := -| Rstop : forall {found}, P found -> rel_ls found found -| Rnext : forall {start found}, ~(P start) -> rel_ls (S start) found -> rel_ls start found. - -(** Following the Braga method, the output is packed with a proof of its conformity wrt rel_ls *) -Definition linear_search_conform start (b : before_witness start) : {n : nat | rel_ls start n}. - revert start b. - refine (fix loop start b := - match P_dec start with - | left yes => exist _ start _ - | right no => - let (n, r) := loop (S start) (inv_before_witness start b no) in - exist _ n _ - end). - - apply (Rstop yes). - - apply (Rnext no r). -Defined. - -(** A variant where the computational contents is closer to [prog_linear_search] + (** rel_ls = relational version of linear search *) + Inductive rel_ls : nat -> nat -> Prop := + | Rstop : forall {found}, P found -> rel_ls found found + | Rnext : forall {start found}, ~(P start) -> rel_ls (S start) found -> rel_ls start found. + + (** Following the Braga method, the output is packed with a proof of its conformity wrt rel_ls *) + Definition linear_search_conform start (b : before_witness start) : {n : nat | rel_ls start n}. + Proof. + revert start b. + refine (fix loop start b := + match P_dec start with + | left yes => exist _ start _ + | right no => + let (n, r) := loop (S start) (inv_before_witness start b no) in + exist _ n _ + end). + - apply (Rstop yes). + - apply (Rnext no r). + Defined. + + (** A variant where the computational contents is closer to [prog_linear_search] (no deconstruction/reconstruction of the result), using a suitable abstraction of the postcondition. The predicate [rel_ls start] is abstracted into [Q], with an additional implication [rq] they are equivalent (but only one direction is needed); and as linear search is tail recursive, [Q] can be fixed (but [rq] varies, behaving like a logical continuation). *) -Definition linear_search_conform_alt start (b : before_witness start) : {n : nat | rel_ls start n}. - refine ((fun Q: nat -> Prop => _ : (forall y, rel_ls start y -> Q y) -> {n | Q n}) - (rel_ls start) (fun y r => r)). - revert start b. - refine (fix loop start b := - fun rq => - match P_dec start with - | left yes => exist _ start _ - | right no => loop (S start) (inv_before_witness start b no) _ - end). - - apply rq, (Rstop yes). - - intros y r. apply rq, (Rnext no r). -Defined. - -(** Start at 0 *) -Definition linear_search_from_0_conform (e : exists n, P n) : {n:nat | rel_ls 0 n} := - let b := let (n, p) := e in O_witness n (stop n p) in - linear_search_conform 0 b. - -(** Partial correctness properties *) - -(** rel_ls entails P on the output *) -Theorem rel_ls_post : forall {start found}, rel_ls start found -> P found. -Proof. - intros * rls. induction rls as [x p | x y b rls IHrls]. - - exact p. - - exact IHrls. -Qed. - -(** rel_ls entails minimality of the output *) -Lemma rel_ls_lower_bound {found start} : - rel_ls start found -> forall {k}, P k -> start <= k -> found <= k. -Proof. - induction 1 as [x p | x y no _ IH]; intros k pk greater. - - exact greater. - - destruct greater as [ | k greater]. - + case (no pk). - + apply (IH _ pk), le_n_S, greater. -Qed. - -(** For compatibility with previous version *) -Definition linear_search start (b : before_witness start) : {n : nat | P n} := - let (n, p) := linear_search_conform start b in exist _ n (rel_ls_post p). - -(** Main definitions *) -Definition constructive_indefinite_ground_description_nat : - (exists n, P n) -> {n:nat | P n}. -Proof. - intro e; destruct (linear_search_from_0_conform e) as [found r]; exists found. - apply (rel_ls_post r). -Defined. - -Lemma le_0_l n : 0 <= n. -Proof. induction n; auto. Qed. - -Definition epsilon_smallest : - (exists n : nat, P n) -> { n : nat | P n /\ forall k, P k -> n <= k }. -Proof. - intro e; destruct (linear_search_from_0_conform e) as [found r]; exists found. - split. - - apply (rel_ls_post r). - - intros k pk. apply (rel_ls_lower_bound r pk), le_0_l. -Defined. - -(** NB. The previous version used a negative formulation: + Definition linear_search_conform_alt start (b : before_witness start) : {n : nat | rel_ls start n}. + Proof. + refine ((fun Q: nat -> Prop => _ : (forall y, rel_ls start y -> Q y) -> {n | Q n}) + (rel_ls start) (fun y r => r)). + revert start b. + refine (fix loop start b := + fun rq => + match P_dec start with + | left yes => exist _ start _ + | right no => loop (S start) (inv_before_witness start b no) _ + end). + - apply rq, (Rstop yes). + - intros y r. apply rq, (Rnext no r). + Defined. + + (** Start at 0 *) + Definition linear_search_from_0_conform (e : exists n, P n) : {n:nat | rel_ls 0 n} := + let b := let (n, p) := e in O_witness n (stop n p) in + linear_search_conform 0 b. + + (** Partial correctness properties *) + + (** rel_ls entails P on the output *) + Theorem rel_ls_post : forall {start found}, rel_ls start found -> P found. + Proof. + intros * rls. induction rls as [x p | x y b rls IHrls]. + - exact p. + - exact IHrls. + Qed. + + (** rel_ls entails minimality of the output *) + Lemma rel_ls_lower_bound {found start} : + rel_ls start found -> forall {k}, P k -> start <= k -> found <= k. + Proof. + induction 1 as [x p | x y no _ IH]; intros k pk greater. + - exact greater. + - destruct greater as [ | k greater]. + + case (no pk). + + apply (IH _ pk), le_n_S, greater. + Qed. + + (** For compatibility with previous version *) + Definition linear_search start (b : before_witness start) : {n : nat | P n} := + let (n, p) := linear_search_conform start b in exist _ n (rel_ls_post p). + + (** Main definitions *) + Definition constructive_indefinite_ground_description_nat : + (exists n, P n) -> {n:nat | P n}. + Proof. + intro e; destruct (linear_search_from_0_conform e) as [found r]; exists found. + apply (rel_ls_post r). + Defined. + + Lemma le_0_l n : 0 <= n. + Proof. induction n; auto. Qed. + + Definition epsilon_smallest : + (exists n : nat, P n) -> { n : nat | P n /\ forall k, P k -> n <= k }. + Proof. + intro e; destruct (linear_search_from_0_conform e) as [found r]; exists found. + split. + - apply (rel_ls_post r). + - intros k pk. apply (rel_ls_lower_bound r pk), le_0_l. + Defined. + + (** NB. The previous version used a negative formulation: [forall k, k < n -> ~P k] Lemmas [le_not_lt] and [lt_not_le] can help if needed. *) -(************************************************************************) + (************************************************************************) -(** In simple situations like here, a direct proof that [prog_linear_search] + (** In simple situations like here, a direct proof that [prog_linear_search] satisfies [rel_ls] can be provided. On the computational side of the proof, the fixpoint (coming from [before_witness_dep_ind]) has to come first, before the pattern matching @@ -251,44 +253,44 @@ Defined. for [Rstop]. *) -Scheme before_witness_dep_ind := Induction for before_witness Sort Prop. - -Lemma linear_search_rel : forall start b, rel_ls start (prog_linear_search start b). -Proof. - intros start b. - induction b as [n p | n b IHb] using before_witness_dep_ind; - unfold prog_linear_search; destruct (P_dec n) as [yes | no]; fold prog_linear_search. - - apply Rstop, yes. - - case (no p). - - apply Rstop, yes. - - apply (Rnext no), IHb. -Qed. - -(** Start at 0 *) -Definition linear_search_from_0 (e : exists n, P n) : nat := - let b := let (n, p) := e in O_witness n (stop n p) in - prog_linear_search 0 b. - -Lemma linear_search_from_0_rel (e : exists n, P n) : - rel_ls 0 (linear_search_from_0 e). -Proof. apply linear_search_rel. Qed. - -(** Main definitions *) -Definition constructive_indefinite_ground_description_nat_direct : - (exists n, P n) -> {n:nat | P n}. -Proof. - intro e. exists (linear_search_from_0 e). - apply (rel_ls_post (linear_search_from_0_rel e)). -Defined. - -Definition epsilon_smallest_direct : - (exists n : nat, P n) -> { n : nat | P n /\ forall k, P k -> n <= k }. -Proof. - intro e. exists (linear_search_from_0 e). split. - - apply (rel_ls_post (linear_search_from_0_rel e)). - - intros k pk. - apply (@rel_ls_lower_bound _ 0 (linear_search_from_0_rel e) k pk), le_0_l. -Defined. + Scheme before_witness_dep_ind := Induction for before_witness Sort Prop. + + Lemma linear_search_rel : forall start b, rel_ls start (prog_linear_search start b). + Proof. + intros start b. + induction b as [n p | n b IHb] using before_witness_dep_ind; + unfold prog_linear_search; destruct (P_dec n) as [yes | no]; fold prog_linear_search. + - apply Rstop, yes. + - case (no p). + - apply Rstop, yes. + - apply (Rnext no), IHb. + Qed. + + (** Start at 0 *) + Definition linear_search_from_0 (e : exists n, P n) : nat := + let b := let (n, p) := e in O_witness n (stop n p) in + prog_linear_search 0 b. + + Lemma linear_search_from_0_rel (e : exists n, P n) : + rel_ls 0 (linear_search_from_0 e). + Proof. apply linear_search_rel. Qed. + + (** Main definitions *) + Definition constructive_indefinite_ground_description_nat_direct : + (exists n, P n) -> {n:nat | P n}. + Proof. + intro e. exists (linear_search_from_0 e). + apply (rel_ls_post (linear_search_from_0_rel e)). + Defined. + + Definition epsilon_smallest_direct : + (exists n : nat, P n) -> { n : nat | P n /\ forall k, P k -> n <= k }. + Proof. + intro e. exists (linear_search_from_0 e). split. + - apply (rel_ls_post (linear_search_from_0_rel e)). + - intros k pk. + apply (@rel_ls_lower_bound _ 0 (linear_search_from_0_rel e) k pk), le_0_l. + Defined. End ConstructiveIndefiniteGroundDescription_Direct. @@ -298,11 +300,11 @@ End ConstructiveIndefiniteGroundDescription_Direct. Section ConstructiveIndefiniteGroundDescription_Acc. -Variable P : nat -> Prop. + Variable P : nat -> Prop. -Hypothesis P_decidable : forall n : nat, {P n} + {~ P n}. + Hypothesis P_decidable : forall n : nat, {P n} + {~ P n}. -(** The predicate [Acc] delineates elements that are accessible via a + (** The predicate [Acc] delineates elements that are accessible via a given relation [R]. An element is accessible if there are no infinite [R]-descending chains starting from it. @@ -316,53 +318,53 @@ numbers we try. Namely, [y] is [R]-less then [x] if we try [y] after infinite [R]-descending chain from 0 is equivalent to the termination of our searching algorithm. *) -Let R (x y : nat) : Prop := x = S y /\ ~ P y. + Let R (x y : nat) : Prop := x = S y /\ ~ P y. -#[local] Notation acc x := (Acc R x). + #[local] Notation acc x := (Acc R x). -Lemma P_implies_acc : forall x : nat, P x -> acc x. -Proof. -intros x H. constructor. -intros y [_ not_Px]. absurd (P x); assumption. -Qed. + Lemma P_implies_acc : forall x : nat, P x -> acc x. + Proof. + intros x H. constructor. + intros y [_ not_Px]. absurd (P x); assumption. + Qed. -Lemma P_eventually_implies_acc : forall (x : nat) (n : nat), P (n + x) -> acc x. -Proof. -intros x n; generalize x; clear x; induction n as [|n IH]; simpl. -- apply P_implies_acc. -- intros x H. constructor. intros y [fxy _]. - apply IH. rewrite fxy. - replace (n + S x) with (S (n + x)); auto. -Defined. + Lemma P_eventually_implies_acc : forall (x : nat) (n : nat), P (n + x) -> acc x. + Proof. + intros x n; generalize x; clear x; induction n as [|n IH]; simpl. + - apply P_implies_acc. + - intros x H. constructor. intros y [fxy _]. + apply IH. rewrite fxy. + replace (n + S x) with (S (n + x)); auto. + Defined. -Corollary P_eventually_implies_acc_ex : (exists n : nat, P n) -> acc 0. -Proof. -intros H; elim H. intros x Px. apply P_eventually_implies_acc with (n := x). -replace (x + 0) with x; auto. -Defined. + Corollary P_eventually_implies_acc_ex : (exists n : nat, P n) -> acc 0. + Proof. + intros H; elim H. intros x Px. apply P_eventually_implies_acc with (n := x). + replace (x + 0) with x; auto. + Defined. -(** In the following statement, we use the trick with recursion on + (** In the following statement, we use the trick with recursion on [Acc]. This is also where decidability of [P] is used. *) -Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}. -Proof. -intros Acc_0. pattern 0. apply Fix_F with (R := R); [| assumption]. -clear Acc_0; intros x IH. -destruct (P_decidable x) as [Px | not_Px]. -- exists x; simpl; assumption. -- set (y := S x). - assert (Ryx : R y x). - + unfold R; split; auto. - + destruct (IH y Ryx) as [n Hn]. - exists n; assumption. -Defined. - -Theorem constructive_indefinite_ground_description_nat_Acc : - (exists n : nat, P n) -> {n : nat | P n}. -Proof. -intros H; apply acc_implies_P_eventually. -apply P_eventually_implies_acc_ex; assumption. -Defined. + Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}. + Proof. + intros Acc_0. pattern 0. apply Fix_F with (R := R); [| assumption]. + clear Acc_0; intros x IH. + destruct (P_decidable x) as [Px | not_Px]. + - exists x; simpl; assumption. + - set (y := S x). + assert (Ryx : R y x). + + unfold R; split; auto. + + destruct (IH y Ryx) as [n Hn]. + exists n; assumption. + Defined. + + Theorem constructive_indefinite_ground_description_nat_Acc : + (exists n : nat, P n) -> {n : nat | P n}. + Proof. + intros H; apply acc_implies_P_eventually. + apply P_eventually_implies_acc_ex; assumption. + Defined. End ConstructiveIndefiniteGroundDescription_Acc. @@ -370,15 +372,15 @@ End ConstructiveIndefiniteGroundDescription_Acc. Section ConstructiveGroundEpsilon_nat. -Variable P : nat -> Prop. + Variable P : nat -> Prop. -Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}. + Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}. -Definition constructive_ground_epsilon_nat (E : exists n : nat, P n) : nat - := proj1_sig (constructive_indefinite_ground_description_nat P P_decidable E). + Definition constructive_ground_epsilon_nat (E : exists n : nat, P n) : nat + := proj1_sig (constructive_indefinite_ground_description_nat P P_decidable E). -Definition constructive_ground_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_ground_epsilon_nat E) - := proj2_sig (constructive_indefinite_ground_description_nat P P_decidable E). + Definition constructive_ground_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_ground_epsilon_nat E) + := proj2_sig (constructive_indefinite_ground_description_nat P P_decidable E). End ConstructiveGroundEpsilon_nat. @@ -386,45 +388,45 @@ End ConstructiveGroundEpsilon_nat. Section ConstructiveGroundEpsilon. -(** For the current purpose, we say that a set [A] is countable if + (** For the current purpose, we say that a set [A] is countable if there are functions [f : A -> nat] and [g : nat -> A] such that [g] is a left inverse of [f]. *) -Variable A : Type. -Variable f : A -> nat. -Variable g : nat -> A. + Variable A : Type. + Variable f : A -> nat. + Variable g : nat -> A. -Hypothesis gof_eq_id : forall x : A, g (f x) = x. + Hypothesis gof_eq_id : forall x : A, g (f x) = x. -Variable P : A -> Prop. + Variable P : A -> Prop. -Hypothesis P_decidable : forall x : A, {P x} + {~ P x}. + Hypothesis P_decidable : forall x : A, {P x} + {~ P x}. -Definition P' (x : nat) : Prop := P (g x). + Definition P' (x : nat) : Prop := P (g x). -Lemma P'_decidable : forall n : nat, {P' n} + {~ P' n}. -Proof. -intro n; unfold P'; destruct (P_decidable (g n)); auto. -Defined. + Lemma P'_decidable : forall n : nat, {P' n} + {~ P' n}. + Proof. + intro n; unfold P'; destruct (P_decidable (g n)); auto. + Defined. -Lemma constructive_indefinite_ground_description : (exists x : A, P x) -> {x : A | P x}. -Proof. -intro H. assert (H1 : exists n : nat, P' n). -{ destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption. } -apply (constructive_indefinite_ground_description_nat P' P'_decidable) in H1. -destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption. -Defined. + Lemma constructive_indefinite_ground_description : (exists x : A, P x) -> {x : A | P x}. + Proof. + intro H. assert (H1 : exists n : nat, P' n). + { destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption. } + apply (constructive_indefinite_ground_description_nat P' P'_decidable) in H1. + destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption. + Defined. -Lemma constructive_definite_ground_description : (exists! x : A, P x) -> {x : A | P x}. -Proof. - intros; apply constructive_indefinite_ground_description; firstorder. -Defined. + Lemma constructive_definite_ground_description : (exists! x : A, P x) -> {x : A | P x}. + Proof. + intros; apply constructive_indefinite_ground_description; firstorder. + Defined. -Definition constructive_ground_epsilon (E : exists x : A, P x) : A - := proj1_sig (constructive_indefinite_ground_description E). + Definition constructive_ground_epsilon (E : exists x : A, P x) : A + := proj1_sig (constructive_indefinite_ground_description E). -Definition constructive_ground_epsilon_spec (E : (exists x, P x)) : P (constructive_ground_epsilon E) - := proj2_sig (constructive_indefinite_ground_description E). + Definition constructive_ground_epsilon_spec (E : (exists x, P x)) : P (constructive_ground_epsilon E) + := proj2_sig (constructive_indefinite_ground_description E). End ConstructiveGroundEpsilon. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 1dba658cf8..81dbf6a7bd 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -25,78 +25,78 @@ Definition decidable (P:Prop) := P \/ ~ P. Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P. Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem dec_True : decidable True. Proof. -unfold decidable; auto. + unfold decidable; auto. Qed. Theorem dec_False : decidable False. Proof. -unfold decidable, not; auto. + unfold decidable, not; auto. Qed. Theorem dec_or : forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem dec_and : forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem dec_imp : forall A B:Prop, decidable A -> decidable B -> decidable (A -> B). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem dec_iff : forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P. Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B. Proof. -tauto. + tauto. Qed. Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B. Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B. Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B. Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem not_iff : forall A B:Prop, decidable A -> decidable B -> ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Register dec_True as core.dec.True. @@ -123,54 +123,54 @@ Register not_iff as core.dec.not_iff. Theorem not_true_iff : (True -> False) <-> False. Proof. -tauto. + tauto. Qed. Theorem not_false_iff : (False -> False) <-> True. Proof. -tauto. + tauto. Qed. Theorem not_not_iff : forall A:Prop, decidable A -> (((A -> False) -> False) <-> A). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Theorem contrapositive : forall A B:Prop, decidable A -> (((A -> False) -> (B -> False)) <-> (B -> A)). Proof. -unfold decidable; tauto. + unfold decidable; tauto. Qed. Lemma or_not_l_iff_1 : forall A B: Prop, decidable A -> ((A -> False) \/ B <-> (A -> B)). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. Lemma or_not_l_iff_2 : forall A B: Prop, decidable B -> ((A -> False) \/ B <-> (A -> B)). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. Lemma or_not_r_iff_1 : forall A B: Prop, decidable A -> (A \/ (B -> False) <-> (B -> A)). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. Lemma or_not_r_iff_2 : forall A B: Prop, decidable B -> (A \/ (B -> False) <-> (B -> A)). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. Lemma imp_not_l : forall A B: Prop, decidable A -> (((A -> False) -> B) <-> (A \/ B)). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. @@ -183,25 +183,25 @@ Qed. Theorem not_or_iff : forall A B:Prop, (A \/ B -> False) <-> (A -> False) /\ (B -> False). Proof. -tauto. + tauto. Qed. Lemma not_and_iff : forall A B:Prop, (A /\ B -> False) <-> (A -> B -> False). Proof. -tauto. + tauto. Qed. Lemma not_imp_iff : forall A B:Prop, decidable A -> (((A -> B) -> False) <-> A /\ (B -> False)). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. Lemma not_imp_rev_iff : forall A B : Prop, decidable A -> (((A -> B) -> False) <-> (B -> False) /\ A). Proof. -unfold decidable. tauto. + unfold decidable. tauto. Qed. (* Functional relations on decidable co-domains are decidable *) @@ -210,9 +210,9 @@ Theorem dec_functional_relation : forall (X Y : Type) (A:X->Y->Prop), (forall y y' : Y, decidable (y=y')) -> (forall x, exists! y, A x y) -> forall x y, decidable (A x y). Proof. -intros X Y A Hdec H x y. -destruct (H x) as (y',(Hex,Huniq)). -destruct (Hdec y y') as [->|Hnot]; firstorder. + intros X Y A Hdec H x y. + destruct (H x) as (y',(Hex,Huniq)). + destruct (Hdec y y') as [->|Hnot]; firstorder. Qed. (** With the following hint database, we can leverage [auto] to check diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 431a8ddf11..e925923be0 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -48,151 +48,151 @@ Theorem prop_ext_and_rel_choice_imp_EM (rel_choice : ChoiceFacts.RelationalChoice) : forall P : Prop, P \/ ~ P. Proof. - intros P. - set (A := (True, P)). set (B := (P, True)). - set (is_A_or_B := fun props => props = A \/ props = B). - set (A_proof := or_introl eq_refl : is_A_or_B A). - set (B_proof := or_intror eq_refl : is_A_or_B B). - set (A_or_B := {props | is_A_or_B props}). - set (A_with_proof := exist _ A A_proof : A_or_B). - set (B_with_proof := exist _ B B_proof : A_or_B). - assert (choice_premise : - forall props_with_proof : A_or_B, - exists b : bool, - if b - then fst (proj1_sig props_with_proof) - else snd (proj1_sig props_with_proof)). { - intros [props [H | H]]; rewrite H; simpl. - - exists true. constructor. - - exists false. constructor. - } - destruct (rel_choice _ _ _ choice_premise) as [R [R_subrelation R_functional]]. - unfold subrelation in R_subrelation. - destruct (R_functional A_with_proof) as [a [R_A_a a_unique]]. - pose proof (a_works := R_subrelation A_with_proof a R_A_a). simpl in a_works. - destruct (R_functional B_with_proof) as [b [R_B_b b_unique]]. - pose proof (b_works := R_subrelation B_with_proof b R_B_b). simpl in b_works. - destruct a. 2: { left. exact a_works. } - destruct b. 1: { left. exact b_works. } - right. intros HP. - assert (P = True). { apply prop_ext. tauto. } subst P. - assert (E : A_with_proof = B_with_proof). { - unfold A_with_proof, B_with_proof. f_equal. - apply (ClassicalFacts.ext_prop_dep_proof_irrel_cic prop_ext). - } - rewrite E in a_unique. - pose proof (true_eq_false := a_unique false R_B_b). - discriminate true_eq_false. -Qed. + intros P. + set (A := (True, P)). set (B := (P, True)). + set (is_A_or_B := fun props => props = A \/ props = B). + set (A_proof := or_introl eq_refl : is_A_or_B A). + set (B_proof := or_intror eq_refl : is_A_or_B B). + set (A_or_B := {props | is_A_or_B props}). + set (A_with_proof := exist _ A A_proof : A_or_B). + set (B_with_proof := exist _ B B_proof : A_or_B). + assert (choice_premise : + forall props_with_proof : A_or_B, + exists b : bool, + if b + then fst (proj1_sig props_with_proof) + else snd (proj1_sig props_with_proof)). { + intros [props [H | H]]; rewrite H; simpl. + - exists true. constructor. + - exists false. constructor. + } + destruct (rel_choice _ _ _ choice_premise) as [R [R_subrelation R_functional]]. + unfold subrelation in R_subrelation. + destruct (R_functional A_with_proof) as [a [R_A_a a_unique]]. + pose proof (a_works := R_subrelation A_with_proof a R_A_a). simpl in a_works. + destruct (R_functional B_with_proof) as [b [R_B_b b_unique]]. + pose proof (b_works := R_subrelation B_with_proof b R_B_b). simpl in b_works. + destruct a. 2: { left. exact a_works. } + destruct b. 1: { left. exact b_works. } + right. intros HP. + assert (P = True). { apply prop_ext. tauto. } subst P. + assert (E : A_with_proof = B_with_proof). { + unfold A_with_proof, B_with_proof. f_equal. + apply (ClassicalFacts.ext_prop_dep_proof_irrel_cic prop_ext). + } + rewrite E in a_unique. + pose proof (true_eq_false := a_unique false R_B_b). + discriminate true_eq_false. + Qed. (* This section is kept for backwards compatibility *) Section PredExt_RelChoice_imp_EM. -(** The axiom of extensionality for predicates *) + (** The axiom of extensionality for predicates *) -Definition PredicateExtensionality := - forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q. + Definition PredicateExtensionality := + forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q. -(** From predicate extensionality we get propositional extensionality + (** From predicate extensionality we get propositional extensionality hence proof-irrelevance *) -Import ClassicalFacts. + Import ClassicalFacts. -Variable pred_extensionality : PredicateExtensionality. + Variable pred_extensionality : PredicateExtensionality. -Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B. -Proof. - intros A B H. - change ((fun _ => A) true = (fun _ => B) true). - rewrite - pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B). - - reflexivity. - - intros _; exact H. -Qed. + Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B. + Proof. + intros A B H. + change ((fun _ => A) true = (fun _ => B) true). + rewrite + pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B). + - reflexivity. + - intros _; exact H. + Qed. -Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2. -Proof. - apply (ext_prop_dep_proof_irrel_cic prop_ext). -Qed. + Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2. + Proof. + apply (ext_prop_dep_proof_irrel_cic prop_ext). + Qed. -(** From proof-irrelevance and relational choice, we get guarded + (** From proof-irrelevance and relational choice, we get guarded relational choice *) -Import ChoiceFacts. + Import ChoiceFacts. -Variable rel_choice : RelationalChoice. + Variable rel_choice : RelationalChoice. -Lemma guarded_rel_choice : GuardedRelationalChoice. -Proof. - apply - (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel). -Qed. + Lemma guarded_rel_choice : GuardedRelationalChoice. + Proof. + apply + (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel). + Qed. -(** The form of choice we need: there is a functional relation which chooses + (** The form of choice we need: there is a functional relation which chooses an element in any non empty subset of bool *) -Import Bool. - -Lemma AC_bool_subset_to_bool : - exists R : (bool -> Prop) -> bool -> Prop, - (forall P:bool -> Prop, - (exists b : bool, P b) -> - exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')). -Proof. - destruct (guarded_rel_choice _ _ - (fun Q:bool -> Prop => exists y : _, Q y) - (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). - - exact (fun _ H => H). - - exists R; intros P HP. - destruct (HR P HP) as (y,(Hy,Huni)). - exists y; firstorder. -Qed. - -(** The proof of the excluded middle *) -(** Remark: P could have been in Set or Type *) - -Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P. -Proof. -intro P. - -(* first we exhibit the choice functional relation R *) -destruct AC_bool_subset_to_bool as [R H]. - -set (class_of_true := fun b => b = true \/ P). -set (class_of_false := fun b => b = false \/ P). - -(* the actual "decision": is (R class_of_true) = true or false? *) -destruct (H class_of_true) as [b0 [H0 [H0' H0'']]]. -- exists true; left; reflexivity. -- destruct H0. - - (* the actual "decision": is (R class_of_false) = true or false? *) - + destruct (H class_of_false) as [b1 [H1 [H1' H1'']]]. - * exists false; left; reflexivity. - * destruct H1. - - -- (* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *) - right. - intro HP. - assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b). - ++ intro b; split. - ** unfold class_of_false; right; assumption. - ** unfold class_of_true; right; assumption. - ++ assert (Heq : class_of_true = class_of_false). - ** apply pred_extensionality with (1 := Hequiv). - ** apply diff_true_false. - rewrite <- H0. - rewrite <- H1. - rewrite <- H0''. - { reflexivity. } - rewrite Heq. - assumption. - - -- (* cases where P is true *) - left; assumption. - + left; assumption. - -Qed. + Import Bool. + + Lemma AC_bool_subset_to_bool : + exists R : (bool -> Prop) -> bool -> Prop, + (forall P:bool -> Prop, + (exists b : bool, P b) -> + exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')). + Proof. + destruct (guarded_rel_choice _ _ + (fun Q:bool -> Prop => exists y : _, Q y) + (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). + - exact (fun _ H => H). + - exists R; intros P HP. + destruct (HR P HP) as (y,(Hy,Huni)). + exists y; firstorder. + Qed. + + (** The proof of the excluded middle *) + (** Remark: P could have been in Set or Type *) + + Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P. + Proof. + intro P. + + (* first we exhibit the choice functional relation R *) + destruct AC_bool_subset_to_bool as [R H]. + + set (class_of_true := fun b => b = true \/ P). + set (class_of_false := fun b => b = false \/ P). + + (* the actual "decision": is (R class_of_true) = true or false? *) + destruct (H class_of_true) as [b0 [H0 [H0' H0'']]]. + - exists true; left; reflexivity. + - destruct H0. + + (* the actual "decision": is (R class_of_false) = true or false? *) + + destruct (H class_of_false) as [b1 [H1 [H1' H1'']]]. + * exists false; left; reflexivity. + * destruct H1. + + -- (* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *) + right. + intro HP. + assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b). + ++ intro b; split. + ** unfold class_of_false; right; assumption. + ** unfold class_of_true; right; assumption. + ++ assert (Heq : class_of_true = class_of_false). + ** apply pred_extensionality with (1 := Hequiv). + ** apply diff_true_false. + rewrite <- H0. + rewrite <- H1. + rewrite <- H0''. + { reflexivity. } + rewrite Heq. + assumption. + + -- (* cases where P is true *) + left; assumption. + + left; assumption. + + Qed. End PredExt_RelChoice_imp_EM. @@ -204,104 +204,106 @@ End PredExt_RelChoice_imp_EM. Section ProofIrrel_RelChoice_imp_EqEM. -Import ChoiceFacts. + Import ChoiceFacts. -Variable rel_choice : RelationalChoice. + Variable rel_choice : RelationalChoice. -Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y. + Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y. -(** Let [a1] and [a2] be two elements in some type [A] *) + (** Let [a1] and [a2] be two elements in some type [A] *) -Variable A :Type. -Variables a1 a2 : A. + Variable A :Type. + Variables a1 a2 : A. -(** We build the subset [A'] of [A] made of [a1] and [a2] *) + (** We build the subset [A'] of [A] made of [a1] and [a2] *) -Definition A' := @sigT A (fun x => x=a1 \/ x=a2). + Definition A' := @sigT A (fun x => x=a1 \/ x=a2). -Definition a1':A'. -exists a1 ; auto. -Defined. + Definition a1':A'. + Proof. + exists a1 ; auto. + Defined. -Definition a2':A'. -exists a2 ; auto. -Defined. + Definition a2':A'. + Proof. + exists a2 ; auto. + Defined. -(** By proof-irrelevance, projection is a retraction *) + (** By proof-irrelevance, projection is a retraction *) -Lemma projT1_injective : a1=a2 -> a1'=a2'. -Proof. - intro Heq ; unfold a1', a2', A'. - rewrite Heq. - replace (or_introl (a2=a2) (eq_refl a2)) - with (or_intror (a2=a2) (eq_refl a2)). - - reflexivity. - - apply proof_irrelevance. -Qed. + Lemma projT1_injective : a1=a2 -> a1'=a2'. + Proof. + intro Heq ; unfold a1', a2', A'. + rewrite Heq. + replace (or_introl (a2=a2) (eq_refl a2)) + with (or_intror (a2=a2) (eq_refl a2)). + - reflexivity. + - apply proof_irrelevance. + Qed. -(** But from the actual proofs of being in [A'], we can assert in the + (** But from the actual proofs of being in [A'], we can assert in the proof-irrelevant world the existence of relevant boolean witnesses *) -Lemma decide : forall x:A', exists y:bool , - (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false). -Proof. - intros [a [Ha1|Ha2]]; [exists true | exists false]; auto. -Qed. + Lemma decide : forall x:A', exists y:bool , + (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false). + Proof. + intros [a [Ha1|Ha2]]; [exists true | exists false]; auto. + Qed. -(** Thanks to the axiom of choice, the boolean witnesses move from the + (** Thanks to the axiom of choice, the boolean witnesses move from the propositional world to the relevant world *) -Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2. -Proof. - destruct - (rel_choice A' bool - (fun x y => projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false)) - as (R,(HRsub,HR)). - - apply decide. - - destruct (HR a1') as (b1,(Ha1'b1,_Huni1)). - destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. - + destruct (HR a2') as (b2,(Ha2'b2,Huni2)). - destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)]. - * left; symmetry; assumption. - * right; intro H. - subst b1; subst b2. - rewrite (projT1_injective H) in Ha1'b1. - assert (false = true) by auto using Huni2. - discriminate. - + left; assumption. -Qed. - -(** An alternative more concise proof can be done by directly using - the guarded relational choice *) - -Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2. -Proof. - assert (decide: forall x:A, x=a1 \/ x=a2 -> - exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false). - - intros a [Ha1|Ha2]; [exists true | exists false]; auto. - - assert (guarded_rel_choice := - rel_choice_and_proof_irrel_imp_guarded_rel_choice - rel_choice - proof_irrelevance). + Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2. + Proof. destruct - (guarded_rel_choice A bool - (fun x => x=a1 \/ x=a2) - (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false)) + (rel_choice A' bool + (fun x y => projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false)) as (R,(HRsub,HR)). - + apply decide. - + destruct (HR a1) as (b1,(Ha1b1,_Huni1)). - * left; reflexivity. - * destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. - -- destruct (HR a2) as (b2,(Ha2b2,Huni2)). - ++ right; reflexivity. - ++ destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)]. - ** left; symmetry; assumption. - ** right; intro H. - subst b1; subst b2; subst a1. - assert (false = true) by auto using Huni2, Ha1b1. - discriminate. - -- left; assumption. -Qed. + - apply decide. + - destruct (HR a1') as (b1,(Ha1'b1,_Huni1)). + destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. + + destruct (HR a2') as (b2,(Ha2'b2,Huni2)). + destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)]. + * left; symmetry; assumption. + * right; intro H. + subst b1; subst b2. + rewrite (projT1_injective H) in Ha1'b1. + assert (false = true) by auto using Huni2. + discriminate. + + left; assumption. + Qed. + + (** An alternative more concise proof can be done by directly using + the guarded relational choice *) + + Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2. + Proof. + assert (decide: forall x:A, x=a1 \/ x=a2 -> + exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false). + - intros a [Ha1|Ha2]; [exists true | exists false]; auto. + - assert (guarded_rel_choice := + rel_choice_and_proof_irrel_imp_guarded_rel_choice + rel_choice + proof_irrelevance). + destruct + (guarded_rel_choice A bool + (fun x => x=a1 \/ x=a2) + (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false)) + as (R,(HRsub,HR)). + + apply decide. + + destruct (HR a1) as (b1,(Ha1b1,_Huni1)). + * left; reflexivity. + * destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. + -- destruct (HR a2) as (b2,(Ha2b2,Huni2)). + ++ right; reflexivity. + ++ destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)]. + ** left; symmetry; assumption. + ** right; intro H. + subst b1; subst b2; subst a1. + assert (false = true) by auto using Huni2, Ha1b1. + discriminate. + -- left; assumption. + Qed. End ProofIrrel_RelChoice_imp_EqEM. @@ -314,34 +316,34 @@ End ProofIrrel_RelChoice_imp_EqEM. Section ExtensionalEpsilon_imp_EM. -Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A. - -Hypothesis epsilon_spec : - forall (A:Type) (i:inhabited A) (P:A->Prop), - (exists x, P x) -> P (epsilon A i P). - -Hypothesis epsilon_extensionality : - forall (A:Type) (i:inhabited A) (P Q:A->Prop), - (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q. - -#[local] Notation eps := (epsilon bool true) (only parsing). - -Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P. -Proof. - intro P. - pose (B := fun y => y=false \/ P). - pose (C := fun y => y=true \/ P). - assert (B (eps B)) as [Hfalse|HP] - by (apply epsilon_spec; exists false; left; reflexivity). - - assert (C (eps C)) as [Htrue|HP] - by (apply epsilon_spec; exists true; left; reflexivity). - + right; intro HP. - assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption). - rewrite epsilon_extensionality with (1:=H) in Hfalse. - rewrite Htrue in Hfalse. - discriminate. - + auto. - - auto. -Qed. + Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A. + + Hypothesis epsilon_spec : + forall (A:Type) (i:inhabited A) (P:A->Prop), + (exists x, P x) -> P (epsilon A i P). + + Hypothesis epsilon_extensionality : + forall (A:Type) (i:inhabited A) (P Q:A->Prop), + (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q. + + #[local] Notation eps := (epsilon bool true) (only parsing). + + Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P. + Proof. + intro P. + pose (B := fun y => y=false \/ P). + pose (C := fun y => y=true \/ P). + assert (B (eps B)) as [Hfalse|HP] + by (apply epsilon_spec; exists false; left; reflexivity). + - assert (C (eps C)) as [Htrue|HP] + by (apply epsilon_spec; exists true; left; reflexivity). + + right; intro HP. + assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption). + rewrite epsilon_extensionality with (1:=H) in Hfalse. + rewrite Htrue in Hfalse. + discriminate. + + auto. + - auto. + Qed. End ExtensionalEpsilon_imp_EM. diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index 8ead37e8ad..0ef0e2d77c 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -25,8 +25,8 @@ From Stdlib Require Export EqdepFacts. Module Eq_rect_eq. -Axiom eq_rect_eq : - forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + Axiom eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. End Eq_rect_eq. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index eaac34ddb3..3e21073100 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -397,31 +397,31 @@ Theorem UIP_shift : forall U, UIP_refl_ U -> forall x:U, UIP_refl_ (x = x). Proof. exact (fun U UIP_refl x => @UIP_shift_on U x (UIP_refl x)). - Qed. +Qed. Section Corollaries. - Variable U:Type. + Variable U:Type. + + (** UIP implies the injectivity of equality on dependent pairs in Type *) - (** UIP implies the injectivity of equality on dependent pairs in Type *) + Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) := + forall (y : P p), existT P p x = existT P p y -> x = y. + Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x. - Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) := - forall (y : P p), existT P p x = existT P p y -> x = y. - Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x. - - Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) : - Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x. - Proof. - intro eq_dep_eq; red; intros. - apply eq_dep_eq. - apply eq_sigT_eq_dep. - assumption. - Qed. - Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair. - Proof. - exact (fun eq_dep_eq P p x => - @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x)). + Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) : + Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x. + Proof. + intro eq_dep_eq; red; intros. + apply eq_dep_eq. + apply eq_sigT_eq_dep. + assumption. + Qed. + Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair. + Proof. + exact (fun eq_dep_eq P p x => + @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x)). Qed. End Corollaries. @@ -444,61 +444,61 @@ End EqdepElimination. Module EqdepTheory (M:EqdepElimination). - Section Axioms. + Section Axioms. - Variable U:Type. + Variable U:Type. -(** Invariance by Substitution of Reflexive Equality Proofs *) + (** Invariance by Substitution of Reflexive Equality Proofs *) -Lemma eq_rect_eq : - forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. -Proof. - exact (M.eq_rect_eq U). -Qed. + Lemma eq_rect_eq : + forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + Proof. + exact (M.eq_rect_eq U). + Qed. -Lemma eq_rec_eq : - forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h. -Proof. exact (fun p Q => M.eq_rect_eq U p Q). Qed. + Lemma eq_rec_eq : + forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h. + Proof. exact (fun p Q => M.eq_rect_eq U p Q). Qed. -(** Injectivity of Dependent Equality *) + (** Injectivity of Dependent Equality *) -Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. -Proof. exact (eq_rect_eq__eq_dep_eq U eq_rect_eq). Qed. + Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. + Proof. exact (eq_rect_eq__eq_dep_eq U eq_rect_eq). Qed. -(** Uniqueness of Identity Proofs (UIP) is a consequence of *) -(** Injectivity of Dependent Equality *) + (** Uniqueness of Identity Proofs (UIP) is a consequence of *) + (** Injectivity of Dependent Equality *) -Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. -Proof. exact (eq_dep_eq__UIP U eq_dep_eq). Qed. + Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. + Proof. exact (eq_dep_eq__UIP U eq_dep_eq). Qed. -(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) + (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) -Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. -Proof. - exact (UIP__UIP_refl U UIP). -Qed. + Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. + Proof. + exact (UIP__UIP_refl U UIP). + Qed. -(** Streicher's axiom K is a direct consequence of Uniqueness of + (** Streicher's axiom K is a direct consequence of Uniqueness of Reflexive Identity Proofs *) -Lemma Streicher_K : - forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. -Proof. - exact (UIP_refl__Streicher_K U UIP_refl). -Qed. + Lemma Streicher_K : + forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. + Proof. + exact (UIP_refl__Streicher_K U UIP_refl). + Qed. -End Axioms. + End Axioms. -(** UIP implies the injectivity of equality on dependent pairs in Type *) + (** UIP implies the injectivity of equality on dependent pairs in Type *) -Lemma inj_pair2 : - forall (U:Type) (P:U -> Type) (p:U) (x y:P p), - existT P p x = existT P p y -> x = y. -Proof. - exact (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)). -Qed. + Lemma inj_pair2 : + forall (U:Type) (P:U -> Type) (p:U) (x y:P p), + existT P p x = existT P p y -> x = y. + Proof. + exact (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)). + Qed. -Notation inj_pairT2 := inj_pair2. + Notation inj_pairT2 := inj_pair2. End EqdepTheory. @@ -508,20 +508,20 @@ Lemma f_eq_dep : forall U (P:U->Type) R p q x y (f:forall p, P p -> R p), eq_dep p x q y -> eq_dep p (f p x) q (f q y). Proof. -intros * []. reflexivity. + intros * []. reflexivity. Qed. Lemma eq_dep_non_dep : forall U P p q x y, @eq_dep U (fun _ => P) p x q y -> x = y. Proof. -intros * []. reflexivity. + intros * []. reflexivity. Qed. Lemma f_eq_dep_non_dep : forall U (P:U->Type) R p q x y (f:forall p, P p -> R), eq_dep p x q y -> f p x = f q y. Proof. -intros * []. reflexivity. + intros * []. reflexivity. Qed. Arguments eq_dep U P p x q _ : clear implicits. diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 581dd501b5..dd159f466b 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -93,184 +93,184 @@ Set Universe Polymorphism. Module Generic. -(* begin hide *) -(* Notations used in the proof. Hidden in coqdoc. *) - -Reserved Notation "'∀₁' x : A , B" (at level 200, x name, A at level 200,right associativity). -Reserved Notation "A '⟶₁' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'λ₁' x , u" (at level 200, x name, right associativity). -Reserved Notation "f '·₁' x" (at level 5, left associativity). -Reserved Notation "'∀₂' A , F" (at level 200, A name, right associativity). -Reserved Notation "'λ₂' x , u" (at level 200, x name, right associativity). -#[warning="-postfix-notation-not-level-1"] -Reserved Notation "f '·₁' [ A ]" (at level 5, left associativity). -Reserved Notation "'∀₀' x : A , B" (at level 200, x name, A at level 200,right associativity). -Reserved Notation "A '⟶₀' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'λ₀' x , u" (at level 200, x name, right associativity). -Reserved Notation "f '·₀' x" (at level 5, left associativity). -Reserved Notation "'∀₀¹' A : U , F" (at level 200, A name, right associativity). -Reserved Notation "'λ₀¹' x , u" (at level 200, x name, right associativity). -#[warning="-postfix-notation-not-level-1"] -Reserved Notation "f '·₀' [ A ]" (at level 5, left associativity). - -(* end hide *) - -Section Paradox. - -(** ** Axiomatisation of impredicative universes in a Martin-Löf style *) - -(** System U- has two impredicative universes. In the proof of the + (* begin hide *) + (* Notations used in the proof. Hidden in coqdoc. *) + + Reserved Notation "'∀₁' x : A , B" (at level 200, x name, A at level 200,right associativity). + Reserved Notation "A '⟶₁' B" (at level 99, right associativity, B at level 200). + Reserved Notation "'λ₁' x , u" (at level 200, x name, right associativity). + Reserved Notation "f '·₁' x" (at level 5, left associativity). + Reserved Notation "'∀₂' A , F" (at level 200, A name, right associativity). + Reserved Notation "'λ₂' x , u" (at level 200, x name, right associativity). + #[warning="-postfix-notation-not-level-1"] + Reserved Notation "f '·₁' [ A ]" (at level 5, left associativity). + Reserved Notation "'∀₀' x : A , B" (at level 200, x name, A at level 200,right associativity). + Reserved Notation "A '⟶₀' B" (at level 99, right associativity, B at level 200). + Reserved Notation "'λ₀' x , u" (at level 200, x name, right associativity). + Reserved Notation "f '·₀' x" (at level 5, left associativity). + Reserved Notation "'∀₀¹' A : U , F" (at level 200, A name, right associativity). + Reserved Notation "'λ₀¹' x , u" (at level 200, x name, right associativity). + #[warning="-postfix-notation-not-level-1"] + Reserved Notation "f '·₀' [ A ]" (at level 5, left associativity). + + (* end hide *) + + Section Paradox. + + (** ** Axiomatisation of impredicative universes in a Martin-Löf style *) + + (** System U- has two impredicative universes. In the proof of the paradox they are slightly asymmetric (in particular the reduction rules of the small universe are not needed). Therefore, the axioms are duplicated allowing for a weaker requirement than the actual system U-. *) -(** *** Large universe *) -Variable U1 : Type. -Variable El1 : U1 -> Type. -(** **** Closure by small product *) -Variable Forall1 : forall u:U1, (El1 u -> U1) -> U1. - Notation "'∀₁' x : A , B" := (Forall1 A (fun x => B)). - Notation "A '⟶₁' B" := (Forall1 A (fun _ => B)). -Variable lam1 : forall u B, (forall x:El1 u, El1 (B x)) -> El1 (∀₁ x:u, B x). - Notation "'λ₁' x , u" := (lam1 _ _ (fun x => u)). -Variable app1 : forall u B (f:El1 (Forall1 u B)) (x:El1 u), El1 (B x). - Notation "f '·₁' x" := (app1 _ _ f x). -Variable beta1 : forall u B (f:forall x:El1 u, El1 (B x)) x, - (λ₁ y, f y) ·₁ x = f x. -(** **** Closure by large products *) -(** [U1] only needs to quantify over itself. *) -Variable ForallU1 : (U1->U1) -> U1. - Notation "'∀₂' A , F" := (ForallU1 (fun A => F)). -Variable lamU1 : forall F, (forall A:U1, El1 (F A)) -> El1 (∀₂ A, F A). - Notation "'λ₂' x , u" := (lamU1 _ (fun x => u)). -Variable appU1 : forall F (f:El1(∀₂ A,F A)) (A:U1), El1 (F A). - Notation "f '·₁' [ A ]" := (appU1 _ f A). -Variable betaU1 : forall F (f:forall A:U1, El1 (F A)) A, - (λ₂ x, f x) ·₁ [ A ] = f A. - -(** *** Small universe *) -(** The small universe is an element of the large one. *) -Variable u0 : U1. -Notation U0 := (El1 u0). -Variable El0 : U0 -> Type. -(** **** Closure by small product *) -(** [U0] does not need reduction rules *) -Variable Forall0 : forall u:U0, (El0 u -> U0) -> U0. - Notation "'∀₀' x : A , B" := (Forall0 A (fun x => B)). - Notation "A '⟶₀' B" := (Forall0 A (fun _ => B)). -Variable lam0 : forall u B, (forall x:El0 u, El0 (B x)) -> El0 (∀₀ x:u, B x). - Notation "'λ₀' x , u" := (lam0 _ _ (fun x => u)). -Variable app0 : forall u B (f:El0 (Forall0 u B)) (x:El0 u), El0 (B x). - Notation "f '·₀' x" := (app0 _ _ f x). -(** **** Closure by large products *) -Variable ForallU0 : forall u:U1, (El1 u->U0) -> U0. - Notation "'∀₀¹' A : U , F" := (ForallU0 U (fun A => F)). -Variable lamU0 : forall U F, (forall A:El1 U, El0 (F A)) -> El0 (∀₀¹ A:U, F A). - Notation "'λ₀¹' x , u" := (lamU0 _ _ (fun x => u)). -Variable appU0 : forall U F (f:El0(∀₀¹ A:U,F A)) (A:El1 U), El0 (F A). - Notation "f '·₀' [ A ]" := (appU0 _ _ f A). - -(** ** Automating the rewrite rules of our encoding. *) -#[local] Ltac simplify := - (* spiwack: ideally we could use [rewrite_strategy] here, but I am a tad + (** *** Large universe *) + Variable U1 : Type. + Variable El1 : U1 -> Type. + (** **** Closure by small product *) + Variable Forall1 : forall u:U1, (El1 u -> U1) -> U1. + Notation "'∀₁' x : A , B" := (Forall1 A (fun x => B)). + Notation "A '⟶₁' B" := (Forall1 A (fun _ => B)). + Variable lam1 : forall u B, (forall x:El1 u, El1 (B x)) -> El1 (∀₁ x:u, B x). + Notation "'λ₁' x , u" := (lam1 _ _ (fun x => u)). + Variable app1 : forall u B (f:El1 (Forall1 u B)) (x:El1 u), El1 (B x). + Notation "f '·₁' x" := (app1 _ _ f x). + Variable beta1 : forall u B (f:forall x:El1 u, El1 (B x)) x, + (λ₁ y, f y) ·₁ x = f x. + (** **** Closure by large products *) + (** [U1] only needs to quantify over itself. *) + Variable ForallU1 : (U1->U1) -> U1. + Notation "'∀₂' A , F" := (ForallU1 (fun A => F)). + Variable lamU1 : forall F, (forall A:U1, El1 (F A)) -> El1 (∀₂ A, F A). + Notation "'λ₂' x , u" := (lamU1 _ (fun x => u)). + Variable appU1 : forall F (f:El1(∀₂ A,F A)) (A:U1), El1 (F A). + Notation "f '·₁' [ A ]" := (appU1 _ f A). + Variable betaU1 : forall F (f:forall A:U1, El1 (F A)) A, + (λ₂ x, f x) ·₁ [ A ] = f A. + + (** *** Small universe *) + (** The small universe is an element of the large one. *) + Variable u0 : U1. + Notation U0 := (El1 u0). + Variable El0 : U0 -> Type. + (** **** Closure by small product *) + (** [U0] does not need reduction rules *) + Variable Forall0 : forall u:U0, (El0 u -> U0) -> U0. + Notation "'∀₀' x : A , B" := (Forall0 A (fun x => B)). + Notation "A '⟶₀' B" := (Forall0 A (fun _ => B)). + Variable lam0 : forall u B, (forall x:El0 u, El0 (B x)) -> El0 (∀₀ x:u, B x). + Notation "'λ₀' x , u" := (lam0 _ _ (fun x => u)). + Variable app0 : forall u B (f:El0 (Forall0 u B)) (x:El0 u), El0 (B x). + Notation "f '·₀' x" := (app0 _ _ f x). + (** **** Closure by large products *) + Variable ForallU0 : forall u:U1, (El1 u->U0) -> U0. + Notation "'∀₀¹' A : U , F" := (ForallU0 U (fun A => F)). + Variable lamU0 : forall U F, (forall A:El1 U, El0 (F A)) -> El0 (∀₀¹ A:U, F A). + Notation "'λ₀¹' x , u" := (lamU0 _ _ (fun x => u)). + Variable appU0 : forall U F (f:El0(∀₀¹ A:U,F A)) (A:El1 U), El0 (F A). + Notation "f '·₀' [ A ]" := (appU0 _ _ f A). + + (** ** Automating the rewrite rules of our encoding. *) + #[local] Ltac simplify := + (* spiwack: ideally we could use [rewrite_strategy] here, but I am a tad scared of the idea of depending on setoid rewrite in such a simple file. *) - (repeat rewrite ?beta1, ?betaU1); - lazy beta. - -#[local] Ltac simplify_in h := - (repeat rewrite ?beta1, ?betaU1 in h); - lazy beta in h. - - -(** ** Hurkens's paradox. *) - -(** An inhabitant of [U0] standing for [False]. *) -Variable F:U0. - -(** *** Preliminary definitions *) - -Definition V : U1 := ∀₂ A, ((A ⟶₁ u0) ⟶₁ A ⟶₁ u0) ⟶₁ A ⟶₁ u0. -Definition U : U1 := V ⟶₁ u0. - -Definition sb (z:El1 V) : El1 V := λ₂ A, λ₁ r, λ₁ a, r ·₁ (z·₁[A]·₁r) ·₁ a. - -Definition le (i:El1 (U⟶₁u0)) (x:El1 U) : U0 := - x ·₁ (λ₂ A, λ₁ r, λ₁ a, i ·₁ (λ₁ v, (sb v) ·₁ [A] ·₁ r ·₁ a)). -Definition le' : El1 ((U⟶₁u0) ⟶₁ U ⟶₁ u0) := λ₁ i, λ₁ x, le i x. -Definition induct (i:El1 (U⟶₁u0)) : U0 := - ∀₀¹ x:U, le i x ⟶₀ i ·₁ x. - -Definition WF : El1 U := λ₁ z, (induct (z·₁[U] ·₁ le')). -Definition I (x:El1 U) : U0 := - (∀₀¹ i:U⟶₁u0, le i x ⟶₀ i ·₁ (λ₁ v, (sb v) ·₁ [U] ·₁ le' ·₁ x)) ⟶₀ F -. - -(** *** Proof *) - -Lemma Omega : El0 (∀₀¹ i:U⟶₁u0, induct i ⟶₀ i ·₁ WF). -Proof. - refine (λ₀¹ i, λ₀ y, _). - refine (y·₀[_]·₀_). - unfold le,WF,induct. simplify. - refine (λ₀¹ x, λ₀ h0, _). simplify. - refine (y·₀[_]·₀_). - unfold le. simplify. - unfold sb at 1. simplify. - unfold le' at 1. simplify. - exact h0. -Qed. - -Lemma lemma1 : El0 (induct (λ₁ u, I u)). -Proof. - unfold induct. - refine (λ₀¹ x, λ₀ p, _). simplify. - refine (λ₀ q,_). - assert (El0 (I (λ₁ v, (sb v)·₁[U]·₁le'·₁x))) as h. - { generalize (q·₀[λ₁ u, I u]·₀p). simplify. - intros q'. - exact q'. } - refine (h·₀_). - refine (λ₀¹ i,_). - refine (λ₀ h', _). - generalize (q·₀[λ₁ y, i ·₁ (λ₁ v, (sb v)·₁[U] ·₁ le' ·₁ y)]). simplify. - intros q'. - refine (q'·₀_). clear q'. - unfold le at 1 in h'. simplify_in h'. - unfold sb at 1 in h'. simplify_in h'. - unfold le' at 1 in h'. simplify_in h'. - exact h'. -Qed. - -Lemma lemma2 : El0 ((∀₀¹i:U⟶₁u0, induct i ⟶₀ i·₁WF) ⟶₀ F). -Proof. - refine (λ₀ x, _). - assert (El0 (I WF)) as h. - { generalize (x·₀[λ₁ u, I u]·₀lemma1). simplify. - intros q. - exact q. } - refine (h·₀_). clear h. - refine (λ₀¹ i, λ₀ h0, _). - generalize (x·₀[λ₁ y, i·₁(λ₁ v, (sb v)·₁[U]·₁le'·₁y)]). simplify. - intros q. - refine (q·₀_). clear q. - unfold le in h0. simplify_in h0. - unfold WF in h0. simplify_in h0. - exact h0. -Qed. - -Theorem paradox : El0 F. -Proof. - exact (lemma2·₀Omega). -Qed. - -End Paradox. - -(** The [paradox] tactic can be called as a shortcut to use the paradox. *) -Ltac paradox h := - unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))). + (repeat rewrite ?beta1, ?betaU1); + lazy beta. + + #[local] Ltac simplify_in h := + (repeat rewrite ?beta1, ?betaU1 in h); + lazy beta in h. + + + (** ** Hurkens's paradox. *) + + (** An inhabitant of [U0] standing for [False]. *) + Variable F:U0. + + (** *** Preliminary definitions *) + + Definition V : U1 := ∀₂ A, ((A ⟶₁ u0) ⟶₁ A ⟶₁ u0) ⟶₁ A ⟶₁ u0. + Definition U : U1 := V ⟶₁ u0. + + Definition sb (z:El1 V) : El1 V := λ₂ A, λ₁ r, λ₁ a, r ·₁ (z·₁[A]·₁r) ·₁ a. + + Definition le (i:El1 (U⟶₁u0)) (x:El1 U) : U0 := + x ·₁ (λ₂ A, λ₁ r, λ₁ a, i ·₁ (λ₁ v, (sb v) ·₁ [A] ·₁ r ·₁ a)). + Definition le' : El1 ((U⟶₁u0) ⟶₁ U ⟶₁ u0) := λ₁ i, λ₁ x, le i x. + Definition induct (i:El1 (U⟶₁u0)) : U0 := + ∀₀¹ x:U, le i x ⟶₀ i ·₁ x. + + Definition WF : El1 U := λ₁ z, (induct (z·₁[U] ·₁ le')). + Definition I (x:El1 U) : U0 := + (∀₀¹ i:U⟶₁u0, le i x ⟶₀ i ·₁ (λ₁ v, (sb v) ·₁ [U] ·₁ le' ·₁ x)) ⟶₀ F + . + + (** *** Proof *) + + Lemma Omega : El0 (∀₀¹ i:U⟶₁u0, induct i ⟶₀ i ·₁ WF). + Proof. + refine (λ₀¹ i, λ₀ y, _). + refine (y·₀[_]·₀_). + unfold le,WF,induct. simplify. + refine (λ₀¹ x, λ₀ h0, _). simplify. + refine (y·₀[_]·₀_). + unfold le. simplify. + unfold sb at 1. simplify. + unfold le' at 1. simplify. + exact h0. + Qed. + + Lemma lemma1 : El0 (induct (λ₁ u, I u)). + Proof. + unfold induct. + refine (λ₀¹ x, λ₀ p, _). simplify. + refine (λ₀ q,_). + assert (El0 (I (λ₁ v, (sb v)·₁[U]·₁le'·₁x))) as h. + { generalize (q·₀[λ₁ u, I u]·₀p). simplify. + intros q'. + exact q'. } + refine (h·₀_). + refine (λ₀¹ i,_). + refine (λ₀ h', _). + generalize (q·₀[λ₁ y, i ·₁ (λ₁ v, (sb v)·₁[U] ·₁ le' ·₁ y)]). simplify. + intros q'. + refine (q'·₀_). clear q'. + unfold le at 1 in h'. simplify_in h'. + unfold sb at 1 in h'. simplify_in h'. + unfold le' at 1 in h'. simplify_in h'. + exact h'. + Qed. + + Lemma lemma2 : El0 ((∀₀¹i:U⟶₁u0, induct i ⟶₀ i·₁WF) ⟶₀ F). + Proof. + refine (λ₀ x, _). + assert (El0 (I WF)) as h. + { generalize (x·₀[λ₁ u, I u]·₀lemma1). simplify. + intros q. + exact q. } + refine (h·₀_). clear h. + refine (λ₀¹ i, λ₀ h0, _). + generalize (x·₀[λ₁ y, i·₁(λ₁ v, (sb v)·₁[U]·₁le'·₁y)]). simplify. + intros q. + refine (q·₀_). clear q. + unfold le in h0. simplify_in h0. + unfold WF in h0. simplify_in h0. + exact h0. + Qed. + + Theorem paradox : El0 F. + Proof. + exact (lemma2·₀Omega). + Qed. + + End Paradox. + + (** The [paradox] tactic can be called as a shortcut to use the paradox. *) + Ltac paradox h := + unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))). End Generic. @@ -284,16 +284,16 @@ End Generic. Module NoRetractToImpredicativeUniverse. -Section Paradox. + Section Paradox. -Let U2 := Type. -Let U1:U2 := Type. -Variable U0:U1. + Let U2 := Type. + Let U1:U2 := Type. + Variable U0:U1. -(** *** [U1] is impredicative *) -Variable u22u1 : U2 -> U1. -Hypothesis u22u1_unit : forall (c:U2), c -> u22u1 c. -(** [u22u1_counit] and [u22u1_coherent] only apply to dependent + (** *** [U1] is impredicative *) + Variable u22u1 : U2 -> U1. + Hypothesis u22u1_unit : forall (c:U2), c -> u22u1 c. + (** [u22u1_counit] and [u22u1_coherent] only apply to dependent product so that the equations happen in the smaller [U1] rather than [U2]. Indeed, it is not generally the case that one can project from a large universe to an impredicative universe and @@ -301,51 +301,51 @@ Hypothesis u22u1_unit : forall (c:U2), c -> u22u1 c. hypothesis to require (in particular, it is not true of [Prop]). The formulation is reminiscent of the monadic characteristic of the projection from a large type to [Prop].*) -Hypothesis u22u1_counit : forall (F:U1->U1), u22u1 (forall A,F A) -> (forall A,F A). -Hypothesis u22u1_coherent : forall (F:U1 -> U1) (f:forall x:U1, F x) (x:U1), - u22u1_counit _ (u22u1_unit _ f) x = f x. - -(** *** [U0] is a retract of [U1] *) -Variable u02u1 : U0 -> U1. -Variable u12u0 : U1 -> U0. -Hypothesis u12u0_unit : forall (b:U1), b -> u02u1 (u12u0 b). -Hypothesis u12u0_counit : forall (b:U1), u02u1 (u12u0 b) -> b. - -(** ** Paradox *) - -Theorem paradox : forall F:U1, F. -Proof. - intros F. - Generic.paradox h. - (** Large universe *) - + exact U1. - + exact (fun X => X). - + cbn. exact (fun u F => forall x:u, F x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - - + cbn. exact (fun F => u22u1 (forall x, F x)). - + cbn. exact (fun _ x => u22u1_unit _ x). - + cbn. exact (fun _ x => u22u1_counit _ x). - (** Small universe *) - + exact U0. - (** The interpretation of the small universe is the image of + Hypothesis u22u1_counit : forall (F:U1->U1), u22u1 (forall A,F A) -> (forall A,F A). + Hypothesis u22u1_coherent : forall (F:U1 -> U1) (f:forall x:U1, F x) (x:U1), + u22u1_counit _ (u22u1_unit _ f) x = f x. + + (** *** [U0] is a retract of [U1] *) + Variable u02u1 : U0 -> U1. + Variable u12u0 : U1 -> U0. + Hypothesis u12u0_unit : forall (b:U1), b -> u02u1 (u12u0 b). + Hypothesis u12u0_counit : forall (b:U1), u02u1 (u12u0 b) -> b. + + (** ** Paradox *) + + Theorem paradox : forall F:U1, F. + Proof. + intros F. + Generic.paradox h. + (** Large universe *) + + exact U1. + + exact (fun X => X). + + cbn. exact (fun u F => forall x:u, F x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + + cbn. exact (fun F => u22u1 (forall x, F x)). + + cbn. exact (fun _ x => u22u1_unit _ x). + + cbn. exact (fun _ x => u22u1_counit _ x). + (** Small universe *) + + exact U0. + (** The interpretation of the small universe is the image of [U0] in [U1]. *) - + cbn. exact (fun X => u02u1 X). - + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))). - + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). - + cbn. exact (u12u0 F). - + cbn in h. - exact (u12u0_counit _ h). - + cbn. easy. - + cbn. intros **. now rewrite u22u1_coherent. - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). -Qed. - -End Paradox. + + cbn. exact (fun X => u02u1 X). + + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))). + + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). + + cbn. exact (u12u0 F). + + cbn in h. + exact (u12u0_counit _ h). + + cbn. easy. + + cbn. intros **. now rewrite u22u1_coherent. + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + Qed. + + End Paradox. End NoRetractToImpredicativeUniverse. @@ -359,86 +359,86 @@ End NoRetractToImpredicativeUniverse. Module NoRetractToModalProposition. -(** ** Monadic modality *) + (** ** Monadic modality *) -Section Paradox. + Section Paradox. -Variable M : Prop -> Prop. -Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B. + Variable M : Prop -> Prop. + Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B. -Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x). -Proof. - intros A P h x. - eapply incr in h; eauto. -Qed. + Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x). + Proof. + intros A P h x. + eapply incr in h; eauto. + Qed. -(** ** The universe of modal propositions *) + (** ** The universe of modal propositions *) -Definition MProp := { P:Prop | M P -> P }. -Definition El : MProp -> Prop := @proj1_sig _ _. + Definition MProp := { P:Prop | M P -> P }. + Definition El : MProp -> Prop := @proj1_sig _ _. -Lemma modal : forall P:MProp, M(El P) -> El P. -Proof. - intros [P m]. cbn. - exact m. -Qed. + Lemma modal : forall P:MProp, M(El P) -> El P. + Proof. + intros [P m]. cbn. + exact m. + Qed. -Definition Forall {A:Type} (P:A->MProp) : MProp. -Proof. - unshelve (refine (exist _ _ _)). - + exact (forall x:A, El (P x)). - + intros h x. - eapply strength in h. - eauto using modal. -Defined. + Definition Forall {A:Type} (P:A->MProp) : MProp. + Proof. + unshelve (refine (exist _ _ _)). + + exact (forall x:A, El (P x)). + + intros h x. + eapply strength in h. + eauto using modal. + Defined. -(** ** Retract of the modal fragment of [Prop] in a small type *) + (** ** Retract of the modal fragment of [Prop] in a small type *) -(** The retract is axiomatized using logical equivalence as the + (** The retract is axiomatized using logical equivalence as the equality on propositions. *) -Variable bool : MProp. -Variable p2b : MProp -> El bool. -Variable b2p : El bool -> MProp. -Hypothesis p2p1 : forall A:MProp, El (b2p (p2b A)) -> El A. -Hypothesis p2p2 : forall A:MProp, El A -> El (b2p (p2b A)). - -(** ** Paradox *) - -Theorem paradox : forall B:MProp, El B. -Proof. - intros B. - Generic.paradox h. - (** Large universe *) - + exact MProp. - + exact El. - + exact (fun _ => Forall). - + cbn. exact (fun _ _ f => f). - + cbn. exact (fun _ _ f => f). - + exact Forall. - + cbn. exact (fun _ f => f). - + cbn. exact (fun _ f => f). - (** Small universe *) - + exact bool. - + exact (fun b => El (b2p b)). - + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). - + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). - + apply p2b. - exact B. - + cbn in h. auto. - + cbn. easy. - + cbn. easy. - + cbn. auto. - + cbn. intros * f. - apply p2p1 in f. cbn in f. - exact f. - + cbn. auto. - + cbn. intros * f. - apply p2p1 in f. cbn in f. - exact f. -Qed. - -End Paradox. + Variable bool : MProp. + Variable p2b : MProp -> El bool. + Variable b2p : El bool -> MProp. + Hypothesis p2p1 : forall A:MProp, El (b2p (p2b A)) -> El A. + Hypothesis p2p2 : forall A:MProp, El A -> El (b2p (p2b A)). + + (** ** Paradox *) + + Theorem paradox : forall B:MProp, El B. + Proof. + intros B. + Generic.paradox h. + (** Large universe *) + + exact MProp. + + exact El. + + exact (fun _ => Forall). + + cbn. exact (fun _ _ f => f). + + cbn. exact (fun _ _ f => f). + + exact Forall. + + cbn. exact (fun _ f => f). + + cbn. exact (fun _ f => f). + (** Small universe *) + + exact bool. + + exact (fun b => El (b2p b)). + + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + apply p2b. + exact B. + + cbn in h. auto. + + cbn. easy. + + cbn. easy. + + cbn. auto. + + cbn. intros * f. + apply p2p1 in f. cbn in f. + exact f. + + cbn. auto. + + cbn. intros * f. + apply p2p1 in f. cbn in f. + exact f. + Qed. + + End Paradox. End NoRetractToModalProposition. @@ -450,42 +450,42 @@ End NoRetractToModalProposition. Module NoRetractToNegativeProp. -(** ** The universe of negative propositions. *) + (** ** The universe of negative propositions. *) -Definition NProp := { P:Prop | ~~P -> P }. -Definition El : NProp -> Prop := @proj1_sig _ _. + Definition NProp := { P:Prop | ~~P -> P }. + Definition El : NProp -> Prop := @proj1_sig _ _. -Section Paradox. + Section Paradox. -(** ** Retract of the negative fragment of [Prop] in a small type *) + (** ** Retract of the negative fragment of [Prop] in a small type *) -(** The retract is axiomatized using logical equivalence as the + (** The retract is axiomatized using logical equivalence as the equality on propositions. *) -Variable bool : NProp. -Variable p2b : NProp -> El bool. -Variable b2p : El bool -> NProp. -Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. -Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). - -(** ** Paradox *) - -Theorem paradox : forall B:NProp, El B. -Proof. - intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). - + exact (fun P => ~~P). - + exact bool. - + exact p2b. - + exact b2p. - + exact B. - + exact h. - + cbn. auto. - + cbn. auto. - + cbn. auto. -Qed. - -End Paradox. + Variable bool : NProp. + Variable p2b : NProp -> El bool. + Variable b2p : El bool -> NProp. + Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. + Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). + + (** ** Paradox *) + + Theorem paradox : forall B:NProp, El B. + Proof. + intros B. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + + exact (fun P => ~~P). + + exact bool. + + exact p2b. + + exact b2p. + + exact B. + + exact h. + + cbn. auto. + + cbn. auto. + + cbn. auto. + Qed. + + End Paradox. End NoRetractToNegativeProp. @@ -497,66 +497,66 @@ End NoRetractToNegativeProp. Module NoRetractFromSmallPropositionToProp. -(** ** The universe of propositions. *) + (** ** The universe of propositions. *) -Definition NProp := { P:Prop | P -> P}. -Definition El : NProp -> Prop := @proj1_sig _ _. + Definition NProp := { P:Prop | P -> P}. + Definition El : NProp -> Prop := @proj1_sig _ _. -Section MParadox. + Section MParadox. -(** ** Retract of [Prop] in a small type, using the identity modality. *) + (** ** Retract of [Prop] in a small type, using the identity modality. *) -Variable bool : NProp. -Variable p2b : NProp -> El bool. -Variable b2p : El bool -> NProp. -Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. -Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). + Variable bool : NProp. + Variable p2b : NProp -> El bool. + Variable b2p : El bool -> NProp. + Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. + Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). -(** ** Paradox *) + (** ** Paradox *) -Theorem mparadox : forall B:NProp, El B. -Proof. - intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). - + exact (fun P => P). - + exact bool. - + exact p2b. - + exact b2p. - + exact B. - + exact h. - + cbn. auto. - + cbn. auto. - + cbn. auto. -Qed. + Theorem mparadox : forall B:NProp, El B. + Proof. + intros B. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + + exact (fun P => P). + + exact bool. + + exact p2b. + + exact b2p. + + exact B. + + exact h. + + cbn. auto. + + cbn. auto. + + cbn. auto. + Qed. -End MParadox. + End MParadox. -Section Paradox. + Section Paradox. -(** ** Retract of [Prop] in a small type *) + (** ** Retract of [Prop] in a small type *) -(** The retract is axiomatized using logical equivalence as the + (** The retract is axiomatized using logical equivalence as the equality on propositions. *) -Variable bool : Prop. -Variable p2b : Prop -> bool. -Variable b2p : bool -> Prop. -Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. -Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). - -(** ** Paradox *) - -Theorem paradox : forall B:Prop, B. -Proof. - intros B. - unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ - (exist _ B (fun x => x)))). - + intros p. red. red. exact (p2b (El p)). - + cbn. intros b. red. exists (b2p b). exact (fun x => x). - + cbn. intros [A H]. cbn. apply p2p1. - + cbn. intros [A H]. cbn. apply p2p2. -Qed. - -End Paradox. + Variable bool : Prop. + Variable p2b : Prop -> bool. + Variable b2p : bool -> Prop. + Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. + Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). + + (** ** Paradox *) + + Theorem paradox : forall B:Prop, B. + Proof. + intros B. + unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ + (exist _ B (fun x => x)))). + + intros p. red. red. exact (p2b (El p)). + + cbn. intros b. red. exists (b2p b). exact (fun x => x). + + cbn. intros [A H]. cbn. apply p2p1. + + cbn. intros [A H]. cbn. apply p2p2. + Qed. + + End Paradox. End NoRetractFromSmallPropositionToProp. @@ -573,54 +573,54 @@ End NoRetractFromSmallPropositionToProp. Module NoRetractFromTypeToProp. -Definition Type2 := Type. -Definition Type1 := Type : Type2. - -Section Paradox. - -(** ** Assumption of a retract from Type into Prop *) - -Variable down : Type1 -> Prop. -Variable up : Prop -> Type1. -Hypothesis up_down : forall (A:Type1), up (down A) = A :> Type1. - -(** ** Paradox *) - -Theorem paradox : forall P:Prop, P. -Proof. - intros P. - Generic.paradox h. - (** Large universe. *) - + exact Type1. - + exact (fun X => X). - + cbn. exact (fun u F => forall x, F x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + exact (fun F => forall A:Prop, F(up A)). - + cbn. exact (fun F f A => f (up A)). - + cbn. - intros F f A. - specialize (f (down A)). - rewrite up_down in f. - exact f. - + exact Prop. - + cbn. exact (fun X => X). - + cbn. exact (fun A P => forall x:A, P x). - + cbn. exact (fun A P => forall x:A, P x). - + cbn. exact P. - + exact h. - + cbn. easy. - + cbn. - intros F f A. - destruct (up_down A). cbn. - reflexivity. - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). -Qed. - -End Paradox. + Definition Type2 := Type. + Definition Type1 := Type : Type2. + + Section Paradox. + + (** ** Assumption of a retract from Type into Prop *) + + Variable down : Type1 -> Prop. + Variable up : Prop -> Type1. + Hypothesis up_down : forall (A:Type1), up (down A) = A :> Type1. + + (** ** Paradox *) + + Theorem paradox : forall P:Prop, P. + Proof. + intros P. + Generic.paradox h. + (** Large universe. *) + + exact Type1. + + exact (fun X => X). + + cbn. exact (fun u F => forall x, F x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + exact (fun F => forall A:Prop, F(up A)). + + cbn. exact (fun F f A => f (up A)). + + cbn. + intros F f A. + specialize (f (down A)). + rewrite up_down in f. + exact f. + + exact Prop. + + cbn. exact (fun X => X). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact P. + + exact h. + + cbn. easy. + + cbn. + intros F f A. + destruct (up_down A). cbn. + reflexivity. + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + Qed. + + End Paradox. End NoRetractFromTypeToProp. @@ -630,75 +630,75 @@ End NoRetractFromTypeToProp. Module TypeNeqSmallType. -Unset Universe Polymorphism. + Unset Universe Polymorphism. -Section Paradox. + Section Paradox. -(** ** Universe [U] is equal to one of its elements. *) + (** ** Universe [U] is equal to one of its elements. *) -Let U := Type. -Variable A:U. -Hypothesis h : U=A. + Let U := Type. + Variable A:U. + Hypothesis h : U=A. -(** ** Universe [U] is a retract of [A] *) + (** ** Universe [U] is a retract of [A] *) -(** The following context is actually sufficient for the paradox to + (** The following context is actually sufficient for the paradox to hold. The hypothesis [h:U=A] is only used to define [down], [up] and [up_down]. *) -Let down (X:U) : A := @eq_rect _ _ (fun X => X) X _ h. -Let up (X:A) : U := @eq_rect_r _ _ (fun X => X) X _ h. - -Lemma up_down : forall (X:U), up (down X) = X. -Proof. - unfold up,down. - rewrite <- h. - reflexivity. -Qed. - -Theorem paradox : False. -Proof. - Generic.paradox p. - (** Large universe *) - + exact U. - + exact (fun X=>X). - + cbn. exact (fun X F => forall x:X, F x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + exact (fun F => forall x:A, F (up x)). - + cbn. exact (fun _ f => fun x:A => f (up x)). - + cbn. intros * f X. - specialize (f (down X)). - rewrite up_down in f. - exact f. - (** Small universe *) - + exact A. - (** The interpretation of [A] as a universe is [U]. *) - + cbn. exact up. - + cbn. exact (fun _ F => down (forall x, up (F x))). - + cbn. exact (fun _ F => down (forall x, up (F x))). - + cbn. exact (down False). - + rewrite up_down in p. - exact p. - + cbn. easy. - + cbn. intros ? f X. - destruct (up_down X). cbn. - reflexivity. - + cbn. intros ? ? f. - rewrite up_down. - exact f. - + cbn. intros ? ? f. - rewrite up_down in f. - exact f. - + cbn. intros ? ? f. - rewrite up_down. - exact f. - + cbn. intros ? ? f. - rewrite up_down in f. - exact f. -Qed. - -End Paradox. + Let down (X:U) : A := @eq_rect _ _ (fun X => X) X _ h. + Let up (X:A) : U := @eq_rect_r _ _ (fun X => X) X _ h. + + Lemma up_down : forall (X:U), up (down X) = X. + Proof. + unfold up,down. + rewrite <- h. + reflexivity. + Qed. + + Theorem paradox : False. + Proof. + Generic.paradox p. + (** Large universe *) + + exact U. + + exact (fun X=>X). + + cbn. exact (fun X F => forall x:X, F x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + exact (fun F => forall x:A, F (up x)). + + cbn. exact (fun _ f => fun x:A => f (up x)). + + cbn. intros * f X. + specialize (f (down X)). + rewrite up_down in f. + exact f. + (** Small universe *) + + exact A. + (** The interpretation of [A] as a universe is [U]. *) + + cbn. exact up. + + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (down False). + + rewrite up_down in p. + exact p. + + cbn. easy. + + cbn. intros ? f X. + destruct (up_down X). cbn. + reflexivity. + + cbn. intros ? ? f. + rewrite up_down. + exact f. + + cbn. intros ? ? f. + rewrite up_down in f. + exact f. + + cbn. intros ? ? f. + rewrite up_down. + exact f. + + cbn. intros ? ? f. + rewrite up_down in f. + exact f. + Qed. + + End Paradox. End TypeNeqSmallType. @@ -708,13 +708,13 @@ End TypeNeqSmallType. Module PropNeqType. -Theorem paradox : Prop <> Type. -Proof. - intros h. - unshelve (refine (TypeNeqSmallType.paradox _ _)). - + exact Prop. - + easy. -Qed. + Theorem paradox : Prop <> Type. + Proof. + intros h. + unshelve (refine (TypeNeqSmallType.paradox _ _)). + + exact Prop. + + easy. + Qed. End PropNeqType. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 28e4255b02..3737ddb2be 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -42,7 +42,7 @@ Register JMeq_hom as core.JMeq.hom. Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. Proof. -intros A B x y H; destruct H; trivial. + intros A B x y H; destruct H; trivial. Qed. #[global] @@ -53,7 +53,7 @@ Register JMeq_sym as core.JMeq.sym. Lemma JMeq_trans : forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z. Proof. -destruct 2; trivial. + destruct 2; trivial. Qed. Register JMeq_trans as core.JMeq.trans. @@ -68,7 +68,7 @@ Qed. Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y, JMeq x y -> P y. Proof. -intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. + intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. Register JMeq_ind as core.JMeq.ind. @@ -76,37 +76,37 @@ Register JMeq_ind as core.JMeq.ind. Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y, JMeq x y -> P y. Proof. -intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. + intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type), P x -> forall y, JMeq x y -> P y. Proof. -intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. + intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y, JMeq y x -> P y. Proof. -intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. + intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. Qed. Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y, JMeq y x -> P y. Proof. -intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. + intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. Qed. Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type), P x -> forall y, JMeq y x -> P y. Proof. -intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. + intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. Qed. Lemma JMeq_congr : forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y. Proof. -intros A x B f y H; case JMeq_eq with (1 := H); trivial. + intros A x B f y H; case JMeq_eq with (1 := H); trivial. Qed. Register JMeq_congr as core.JMeq.congr. @@ -118,15 +118,15 @@ From Stdlib Require Import Eqdep. Lemma JMeq_eq_dep_id : forall (A B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X => X) A x B y. Proof. -destruct 1. -apply eq_dep_intro. + destruct 1. + apply eq_dep_intro. Qed. Lemma eq_dep_id_JMeq : forall (A B:Type) (x:A) (y:B), eq_dep Type (fun X => X) A x B y -> JMeq x y. Proof. -destruct 1. -apply JMeq_refl. + destruct 1. + apply JMeq_refl. Qed. (** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *) @@ -134,20 +134,20 @@ Qed. Lemma eq_dep_JMeq : forall U P p x q y, eq_dep U P p x q y -> JMeq x y. Proof. -destruct 1. -apply JMeq_refl. + destruct 1. + apply JMeq_refl. Qed. Lemma eq_dep_strictly_stronger_JMeq : exists U P p q x y, JMeq x y /\ ~ eq_dep U P p x q y. Proof. -exists bool. exists (fun _ => True). exists true. exists false. -exists I. exists I. -split. -- trivial. -- intro H. - assert (true=false) by (destruct H; reflexivity). - discriminate. + exists bool. exists (fun _ => True). exists true. exists false. + exists I. exists I. + split. + - trivial. + - intro H. + assert (true=false) by (destruct H; reflexivity). + discriminate. Qed. (** However, when the dependencies are equal, [JMeq (P p) x (P q) y] @@ -157,10 +157,10 @@ Lemma JMeq_eq_dep : forall U (P:U->Type) p q (x:P p) (y:P q), p = q -> JMeq x y -> eq_dep U P p x q y. Proof. -intros U P p q x y H H0. -destruct H. -apply JMeq_eq in H0 as ->. -reflexivity. + intros U P p q x y H H0. + destruct H. + apply JMeq_eq in H0 as ->. + reflexivity. Qed. diff --git a/theories/Logic/PropFacts.v b/theories/Logic/PropFacts.v index c4328a3e6e..b91d6c794e 100644 --- a/theories/Logic/PropFacts.v +++ b/theories/Logic/PropFacts.v @@ -26,27 +26,27 @@ Theorem injection_is_involution_in_Prop (ext : forall A B, A <-> B -> f A <-> f B) : forall A, f (f A) <-> A. Proof. -intros. -enough (f (f (f A)) <-> f A) by (apply inj; assumption). -split; intro H. -- now_show (f A). - enough (f A <-> True) by firstorder. - enough (f (f A) <-> f True) by (apply inj; assumption). - split; intro H'. - + now_show (f True). - enough (f (f (f A)) <-> f True) by firstorder. - apply ext; firstorder. - + now_show (f (f A)). - enough (f (f A) <-> True) by firstorder. - apply inj; firstorder. -- now_show (f (f (f A))). - enough (f A <-> f (f (f A))) by firstorder. - apply ext. - split; intro H'. - + now_show (f (f A)). - enough (f A <-> f (f A)) by firstorder. - apply ext; firstorder. - + now_show A. - enough (f A <-> A) by firstorder. - apply inj; firstorder. + intros. + enough (f (f (f A)) <-> f A) by (apply inj; assumption). + split; intro H. + - now_show (f A). + enough (f A <-> True) by firstorder. + enough (f (f A) <-> f True) by (apply inj; assumption). + split; intro H'. + + now_show (f True). + enough (f (f (f A)) <-> f True) by firstorder. + apply ext; firstorder. + + now_show (f (f A)). + enough (f (f A) <-> True) by firstorder. + apply inj; firstorder. + - now_show (f (f (f A))). + enough (f A <-> f (f (f A))) by firstorder. + apply ext. + split; intro H'. + + now_show (f (f A)). + enough (f A <-> f (f A)) by firstorder. + apply ext; firstorder. + + now_show A. + enough (f A <-> A) by firstorder. + apply inj; firstorder. Defined. diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v index c6143857c0..9b37dfcab5 100644 --- a/theories/Logic/WKL.v +++ b/theories/Logic/WKL.v @@ -40,29 +40,29 @@ Inductive is_path_from (P:list bool -> Prop) : nat -> list bool -> Prop := Proposition is_path_from_characterization P n l : is_path_from P n l <-> exists l', length l' = n /\ forall n', n'<=n -> ~ P (rev (firstn n' l') ++ l). Proof. -intros. split. -- induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')]. - + exists []. split. - * reflexivity. - * intros n ->%Nat.le_0_r. assumption. - + exists (true :: l'). split. - * apply eq_S, Hl'. - * intros [|] H. - -- assumption. - -- simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. - + exists (false :: l'). split. - * apply eq_S, Hl'. - * intros [|] H. - -- assumption. - -- simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. -- intros (l'& <- &HPl'). induction l' as [|[|]] in l, HPl' |- *. - + constructor. apply (HPl' 0). apply Nat.le_0_l. - + eapply next_left. - * apply (HPl' 0), Nat.le_0_l. - * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. - + apply next_right. - * apply (HPl' 0), Nat.le_0_l. - * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + intros. split. + - induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')]. + + exists []. split. + * reflexivity. + * intros n ->%Nat.le_0_r. assumption. + + exists (true :: l'). split. + * apply eq_S, Hl'. + * intros [|] H. + -- assumption. + -- simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. + + exists (false :: l'). split. + * apply eq_S, Hl'. + * intros [|] H. + -- assumption. + -- simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. + - intros (l'& <- &HPl'). induction l' as [|[|]] in l, HPl' |- *. + + constructor. apply (HPl' 0). apply Nat.le_0_l. + + eapply next_left. + * apply (HPl' 0), Nat.le_0_l. + * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + + apply next_right. + * apply (HPl' 0), Nat.le_0_l. + * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. Qed. (** [infinite_from P l] means that we can find arbitrary long paths @@ -104,27 +104,27 @@ From Stdlib Require Import Compare_dec. Lemma is_path_from_restrict : forall P n n' l, n <= n' -> is_path_from P n' l -> is_path_from P n l. Proof. -intros * Hle H; induction H in n, Hle, H |- * ; intros. -- apply Nat.le_0_r in Hle as ->. apply here. assumption. -- destruct n. - + apply here. assumption. - + apply Nat.succ_le_mono in Hle. - apply next_left; auto. -- destruct n. - + apply here. assumption. - + apply Nat.succ_le_mono in Hle. - apply next_right; auto. + intros * Hle H; induction H in n, Hle, H |- * ; intros. + - apply Nat.le_0_r in Hle as ->. apply here. assumption. + - destruct n. + + apply here. assumption. + + apply Nat.succ_le_mono in Hle. + apply next_left; auto. + - destruct n. + + apply here. assumption. + + apply Nat.succ_le_mono in Hle. + apply next_right; auto. Qed. Lemma inductively_barred_at_monotone : forall P l n n', n' <= n -> inductively_barred_at P n' l -> inductively_barred_at P n l. Proof. -intros * Hle Hbar. -induction Hbar in n, l, Hle, Hbar |- *. -- apply now_at; auto. -- destruct n; [apply Nat.nle_succ_0 in Hle; contradiction|]. - apply Nat.succ_le_mono in Hle. - apply propagate_at; auto. + intros * Hle Hbar. + induction Hbar in n, l, Hle, Hbar |- *. + - apply now_at; auto. + - destruct n; [apply Nat.nle_succ_0 in Hle; contradiction|]. + apply Nat.succ_le_mono in Hle. + apply propagate_at; auto. Qed. Definition demorgan_or (P:list bool -> Prop) l l' := ~ (P l /\ P l') -> ~ P l \/ ~ P l'. @@ -136,54 +136,54 @@ Lemma inductively_barred_at_imp_is_path_from : forall P, demorgan_inductively_barred_at P -> forall n l, ~ inductively_barred_at P n l -> is_path_from P n l. Proof. -intros P Hdemorgan; induction n; intros l H. -- apply here. - intro. apply H. - apply now_at. auto. -- assert (H0:~ (inductively_barred_at P n (true::l) /\ inductively_barred_at P n (false::l))) - by firstorder using inductively_barred_at. - assert (HnP:~ P l) by firstorder using inductively_barred_at. - apply Hdemorgan in H0 as [H0|H0]; apply IHn in H0; auto using is_path_from. + intros P Hdemorgan; induction n; intros l H. + - apply here. + intro. apply H. + apply now_at. auto. + - assert (H0:~ (inductively_barred_at P n (true::l) /\ inductively_barred_at P n (false::l))) + by firstorder using inductively_barred_at. + assert (HnP:~ P l) by firstorder using inductively_barred_at. + apply Hdemorgan in H0 as [H0|H0]; apply IHn in H0; auto using is_path_from. Qed. Lemma is_path_from_imp_inductively_barred_at : forall P n l, is_path_from P n l -> inductively_barred_at P n l -> False. Proof. -intros P; induction n; intros l H1 H2. -- inversion_clear H1. inversion_clear H2. auto. -- inversion_clear H1. - + inversion_clear H2. - * auto. - * apply IHn with (true::l); auto. - + inversion_clear H2. - * auto. - * apply IHn with (false::l); auto. + intros P; induction n; intros l H1 H2. + - inversion_clear H1. inversion_clear H2. auto. + - inversion_clear H1. + + inversion_clear H2. + * auto. + * apply IHn with (true::l); auto. + + inversion_clear H2. + * auto. + * apply IHn with (false::l); auto. Qed. Lemma find_left_path : forall P l n, is_path_from P (S n) l -> inductively_barred_at P n (false :: l) -> is_path_from P n (true :: l). Proof. -inversion 1; subst; intros. -- auto. -- exfalso. eauto using is_path_from_imp_inductively_barred_at. + inversion 1; subst; intros. + - auto. + - exfalso. eauto using is_path_from_imp_inductively_barred_at. Qed. Lemma Y_unique : forall P, demorgan_inductively_barred_at P -> forall l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2. Proof. -intros * DeMorgan. induction l1, l2. -- trivial. -- discriminate. -- discriminate. -- intros [= H] (HY1,H1) (HY2,H2). - pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. - subst l1. - f_equal. - destruct a, b; try reflexivity. - + destruct H1 as (n,Hbar). - destruct (is_path_from_imp_inductively_barred_at _ _ _ (H2 n) Hbar). - + destruct H2 as (n,Hbar). - destruct (is_path_from_imp_inductively_barred_at _ _ _ (H1 n) Hbar). + intros * DeMorgan. induction l1, l2. + - trivial. + - discriminate. + - discriminate. + - intros [= H] (HY1,H1) (HY2,H2). + pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. + subst l1. + f_equal. + destruct a, b; try reflexivity. + + destruct H1 as (n,Hbar). + destruct (is_path_from_imp_inductively_barred_at _ _ _ (H2 n) Hbar). + + destruct H2 as (n,Hbar). + destruct (is_path_from_imp_inductively_barred_at _ _ _ (H1 n) Hbar). Qed. (** [X] is the translation of [Y] as a predicate *) @@ -193,17 +193,17 @@ Definition X P n := exists l, length l = n /\ Y P (true::l). Lemma Y_approx : forall P, demorgan_inductively_barred_at P -> forall l, approx (X P) l -> Y P l. Proof. -intros P DeMorgan. induction l. -- trivial. -- intros (H,Hb). split. - + auto. - + unfold X in Hb. - destruct a. - * destruct Hb as (l',(Hl',(HYl',HY))). - rewrite <- (Y_unique P DeMorgan l' l Hl'); auto. - * intro n. apply inductively_barred_at_imp_is_path_from. - -- assumption. - -- firstorder. + intros P DeMorgan. induction l. + - trivial. + - intros (H,Hb). split. + + auto. + + unfold X in Hb. + destruct a. + * destruct Hb as (l',(Hl',(HYl',HY))). + rewrite <- (Y_unique P DeMorgan l' l Hl'); auto. + * intro n. apply inductively_barred_at_imp_is_path_from. + -- assumption. + -- firstorder. Qed. (** Main theorem *) @@ -211,54 +211,54 @@ Qed. Theorem PreWeakKonigsLemma : forall P, demorgan_inductively_barred_at P -> infinite_from P [] -> has_infinite_path P. Proof. -intros P DeMorgan Hinf. -exists (X P). intros l Hl. -assert (infinite_from P l). -{ induction l. - - assumption. - - destruct Hl as (Hl,Ha). - intros n. - pose proof (IHl Hl) as IHl'. clear IHl. - apply Y_approx in Hl; [|assumption]. - destruct a. - + destruct Ha as (l'&Hl'&HY'&n'&Hbar). - rewrite (Y_unique _ DeMorgan _ _ Hl' HY' Hl) in Hbar. - destruct (le_lt_dec n n') as [Hle|Hlt]. - * specialize (IHl' (S n')). - apply is_path_from_restrict with n'; [assumption|]. - apply find_left_path; trivial. - * specialize (IHl' (S n)). - apply inductively_barred_at_monotone with (n:=n) in Hbar; [|apply Nat.lt_le_incl, Hlt]. - apply find_left_path; trivial. - + apply inductively_barred_at_imp_is_path_from; firstorder. } -specialize (H 0). inversion H. assumption. + intros P DeMorgan Hinf. + exists (X P). intros l Hl. + assert (infinite_from P l). + { induction l. + - assumption. + - destruct Hl as (Hl,Ha). + intros n. + pose proof (IHl Hl) as IHl'. clear IHl. + apply Y_approx in Hl; [|assumption]. + destruct a. + + destruct Ha as (l'&Hl'&HY'&n'&Hbar). + rewrite (Y_unique _ DeMorgan _ _ Hl' HY' Hl) in Hbar. + destruct (le_lt_dec n n') as [Hle|Hlt]. + * specialize (IHl' (S n')). + apply is_path_from_restrict with n'; [assumption|]. + apply find_left_path; trivial. + * specialize (IHl' (S n)). + apply inductively_barred_at_monotone with (n:=n) in Hbar; [|apply Nat.lt_le_incl, Hlt]. + apply find_left_path; trivial. + + apply inductively_barred_at_imp_is_path_from; firstorder. } + specialize (H 0). inversion H. assumption. Qed. Lemma inductively_barred_at_decidable : forall P, (forall l, P l \/ ~ P l) -> forall n l, inductively_barred_at P n l \/ ~ inductively_barred_at P n l. Proof. -intros P HP. induction n; intros. -- destruct (HP l). - + left. apply now_at, H. - + right. inversion 1. auto. -- destruct (HP l). - + left. apply now_at, H. - + destruct (IHn (true::l)). - * destruct (IHn (false::l)). - { left. apply propagate_at; assumption. } - { right. inversion_clear 1; auto. } - * right. inversion_clear 1; auto. + intros P HP. induction n; intros. + - destruct (HP l). + + left. apply now_at, H. + + right. inversion 1. auto. + - destruct (HP l). + + left. apply now_at, H. + + destruct (IHn (true::l)). + * destruct (IHn (false::l)). + { left. apply propagate_at; assumption. } + { right. inversion_clear 1; auto. } + * right. inversion_clear 1; auto. Qed. Lemma inductively_barred_at_is_path_from_decidable : forall P, (forall l, P l \/ ~ P l) -> demorgan_inductively_barred_at P. Proof. -intros P Hdec n l H. -destruct (inductively_barred_at_decidable P Hdec n (true::l)). -- destruct (inductively_barred_at_decidable P Hdec n (false::l)). - + auto. - + auto. -- auto. + intros P Hdec n l H. + destruct (inductively_barred_at_decidable P Hdec n (true::l)). + - destruct (inductively_barred_at_decidable P Hdec n (false::l)). + + auto. + + auto. + - auto. Qed. (** Main corollary *) @@ -266,7 +266,7 @@ Qed. Corollary WeakKonigsLemma : forall P, (forall l, P l \/ ~ P l) -> infinite_from P [] -> has_infinite_path P. Proof. -intros P Hdec Hinf. -apply inductively_barred_at_is_path_from_decidable in Hdec. -apply PreWeakKonigsLemma; assumption. + intros P Hdec Hinf. + apply inductively_barred_at_is_path_from_decidable in Hdec. + apply PreWeakKonigsLemma; assumption. Qed. diff --git a/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v index 02d0229b27..9c0985818d 100644 --- a/theories/Logic/WeakFan.v +++ b/theories/Logic/WeakFan.v @@ -56,16 +56,16 @@ Fixpoint Y P (l:list bool) := Lemma Y_unique : forall P l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2. Proof. -induction l1, l2. -- trivial. -- discriminate. -- discriminate. -- intros H (HY1,H1) (HY2,H2). - injection H as [= H]. - pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. - subst l1. - f_equal. - destruct a, b; firstorder. + induction l1, l2. + - trivial. + - discriminate. + - discriminate. + - intros H (HY1,H1) (HY2,H2). + injection H as [= H]. + pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. + subst l1. + f_equal. + destruct a, b; firstorder. Qed. (** [X] is the translation of [Y] as a predicate *) @@ -74,28 +74,28 @@ Definition X P n := exists l, length l = n /\ Y P (true::l). Lemma Y_approx : forall P l, approx (X P) l -> Y P l. Proof. -induction l. -- trivial. -- intros (H,Hb). split. - + auto. - + unfold X in Hb. - destruct a. - * destruct Hb as (l',(Hl',(HYl',HY))). - rewrite <- (Y_unique P l' l Hl'); auto. - * firstorder. + induction l. + - trivial. + - intros (H,Hb). split. + + auto. + + unfold X in Hb. + destruct a. + * destruct Hb as (l',(Hl',(HYl',HY))). + rewrite <- (Y_unique P l' l Hl'); auto. + * firstorder. Qed. Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P nil. Proof. -intros P Hbar. -destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)). -assert (inductively_barred P l) by (apply (now P l), HP). -clear Hbar HP. -induction l as [|a l]. -- assumption. -- destruct Hd as (Hd,HX). - apply (IHl Hd). clear IHl. - destruct a; unfold X in HX; simpl in HX. - + apply propagate; assumption. - + exfalso; destruct (HX H). + intros P Hbar. + destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)). + assert (inductively_barred P l) by (apply (now P l), HP). + clear Hbar HP. + induction l as [|a l]. + - assumption. + - destruct Hd as (Hd,HX). + apply (IHl Hd). clear IHl. + destruct a; unfold X in HX; simpl in HX. + + apply propagate; assumption. + + exfalso; destruct (HX H). Qed. diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index 82e9acfc7b..a05b5c7bee 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -22,9 +22,9 @@ From Stdlib Require Import Decidable Setoid DecidableTypeEx MSetFacts. (** First, a version for Weak Sets in functorial presentation *) Module WDecideOn (E : DecidableType)(Import M : WSetsOn E). - Module F := MSetFacts.WFactsOn E M. + Module F := MSetFacts.WFactsOn E M. -(** * Overview + (** * Overview This functor defines the tactic [fsetdec], which will solve any valid goal of the form << @@ -112,33 +112,33 @@ the above form: >> *) - (** * Facts and Tactics for Propositional Logic + (** * Facts and Tactics for Propositional Logic These lemmas and tactics are in a module so that they do not affect the namespace if you import the enclosing module [Decide]. *) - Module MSetLogicalFacts. - Export Decidable. - Export Setoid. + Module MSetLogicalFacts. + Export Decidable. + Export Setoid. - (** ** Lemmas and Tactics About Decidable Propositions *) + (** ** Lemmas and Tactics About Decidable Propositions *) - (** ** Propositional Equivalences Involving Negation + (** ** Propositional Equivalences Involving Negation These are all written with the unfolded form of negation, since I am not sure if setoid rewriting will always perform conversion. *) - (** ** Tactics for Negations *) + (** ** Tactics for Negations *) - Tactic Notation "fold" "any" "not" := - repeat ( - match goal with - | H: context [?P -> False] |- _ => - fold (~ P) in H - | |- context [?P -> False] => - fold (~ P) - end). + Tactic Notation "fold" "any" "not" := + repeat ( + match goal with + | H: context [?P -> False] |- _ => + fold (~ P) in H + | |- context [?P -> False] => + fold (~ P) + end). - (** [push not using db] will pushes all negations to the + (** [push not using db] will pushes all negations to the leaves of propositions in the goal, using the lemmas in [db] to assist in checking the decidability of the propositions involved. If [using db] is omitted, then @@ -152,99 +152,99 @@ the above form: done more cleverly with the following explicit analysis of goals. *) - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || - (rewrite (or_not_l_iff_2 P Q) by tac). - - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || - (rewrite (or_not_r_iff_2 P Q) by tac). - - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || - (rewrite (or_not_l_iff_2 P Q) in H by tac). - - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || - (rewrite (or_not_r_iff_2 P Q) in H by tac). - - Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) - | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) - | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec - end); - fold any not. - - Tactic Notation "push" "not" := - push not using core. - - Tactic Notation - "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H - | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => - rewrite (not_imp_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "push" "not" "in" "*" "|-" := - push not in * |- using core. - - Tactic Notation "push" "not" "in" "*" "using" ident(db) := - push not using db; push not in * |- using db. - Tactic Notation "push" "not" "in" "*" := - push not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_push : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ ((R -> P) \/ (Q -> R))) -> - (~ (P /\ R)) -> - (~ (P -> R)) -> - True. - Proof. - intros. push not in *. - (* note that ~(R->P) remains (since R isn't decidable) *) - tauto. - Qed. - - (** [pull not using db] will pull as many negations as + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || + (rewrite (or_not_l_iff_2 P Q) by tac). + + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || + (rewrite (or_not_r_iff_2 P Q) by tac). + + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || + (rewrite (or_not_l_iff_2 P Q) in H by tac). + + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || + (rewrite (or_not_r_iff_2 P Q) in H by tac). + + Tactic Notation "push" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) + | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) + | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec + end); + fold any not. + + Tactic Notation "push" "not" := + push not using core. + + Tactic Notation + "push" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H + | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H + | H: context [(?P -> ?Q) -> False] |- _ => + rewrite (not_imp_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "push" "not" "in" "*" "|-" := + push not in * |- using core. + + Tactic Notation "push" "not" "in" "*" "using" ident(db) := + push not using db; push not in * |- using db. + Tactic Notation "push" "not" "in" "*" := + push not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_push : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ ((R -> P) \/ (Q -> R))) -> + (~ (P /\ R)) -> + (~ (P -> R)) -> + True. + Proof. + intros. push not in *. + (* note that ~(R->P) remains (since R isn't decidable) *) + tauto. + Qed. + + (** [pull not using db] will pull as many negations as possible toward the top of the propositions in the goal, using the lemmas in [db] to assist in checking the decidability of the propositions involved. If [using @@ -252,148 +252,148 @@ the above form: versions are provided to manipulate the hypotheses or the hypotheses and goal together. *) - Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [(?P -> False) /\ (?Q -> False)] => - rewrite <- (not_or_iff P Q) - | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) - | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => - rewrite <- (not_imp_rev_iff P Q) by dec - end); - fold any not. - - Tactic Notation "pull" "not" := - pull not using core. - - Tactic Notation - "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => - rewrite <- (not_and_iff P Q) in H - | H: context [?P /\ (?Q -> False)] |- _ => - rewrite <- (not_imp_iff P Q) in H by dec - | H: context [(?Q -> False) /\ ?P] |- _ => - rewrite <- (not_imp_rev_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "pull" "not" "in" "*" "|-" := - pull not in * |- using core. - - Tactic Notation "pull" "not" "in" "*" "using" ident(db) := - pull not using db; pull not in * |- using db. - Tactic Notation "pull" "not" "in" "*" := - pull not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_pull : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ (R -> P) /\ ~ (Q -> R)) -> - (~ P \/ ~ R) -> - (P /\ ~ R) -> - (~ R /\ P) -> - True. - Proof. - intros. pull not in *. tauto. - Qed. - - End MSetLogicalFacts. - Import MSetLogicalFacts. - - (** * Auxiliary Tactics + Tactic Notation "pull" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [(?P -> False) /\ (?Q -> False)] => + rewrite <- (not_or_iff P Q) + | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) + | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec + | |- context [(?Q -> False) /\ ?P] => + rewrite <- (not_imp_rev_iff P Q) by dec + end); + fold any not. + + Tactic Notation "pull" "not" := + pull not using core. + + Tactic Notation + "pull" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [(?P -> False) /\ (?Q -> False)] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_and_iff P Q) in H + | H: context [?P /\ (?Q -> False)] |- _ => + rewrite <- (not_imp_iff P Q) in H by dec + | H: context [(?Q -> False) /\ ?P] |- _ => + rewrite <- (not_imp_rev_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "pull" "not" "in" "*" "|-" := + pull not in * |- using core. + + Tactic Notation "pull" "not" "in" "*" "using" ident(db) := + pull not using db; pull not in * |- using db. + Tactic Notation "pull" "not" "in" "*" := + pull not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_pull : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ (R -> P) /\ ~ (Q -> R)) -> + (~ P \/ ~ R) -> + (P /\ ~ R) -> + (~ R /\ P) -> + True. + Proof. + intros. pull not in *. tauto. + Qed. + + End MSetLogicalFacts. + Import MSetLogicalFacts. + + (** * Auxiliary Tactics Again, these lemmas and tactics are in a module so that they do not affect the namespace if you import the enclosing module [Decide]. *) - Module MSetDecideAuxiliary. + Module MSetDecideAuxiliary. - (** ** Generic Tactics + (** ** Generic Tactics We begin by defining a few generic, useful tactics. *) - (** remove logical hypothesis inter-dependencies (fix #2136). *) - - Ltac no_logical_interdep := - match goal with - | H : ?P |- _ => - match type of P with - | Prop => - match goal with H' : context [ H ] |- _ => clear dependent H' end - | _ => fail - end; no_logical_interdep - | _ => idtac - end. - - Ltac abstract_term t := - tryif (is_var t) then fail "no need to abstract a variable" - else (let x := fresh "x" in set (x := t) in *; try clearbody x). - - Ltac abstract_elements := - repeat - (match goal with - | |- context [ singleton ?t ] => abstract_term t - | _ : context [ singleton ?t ] |- _ => abstract_term t - | |- context [ add ?t _ ] => abstract_term t - | _ : context [ add ?t _ ] |- _ => abstract_term t - | |- context [ remove ?t _ ] => abstract_term t - | _ : context [ remove ?t _ ] |- _ => abstract_term t - | |- context [ In ?t _ ] => abstract_term t - | _ : context [ In ?t _ ] |- _ => abstract_term t - end). - - (** [prop P holds by t] succeeds (but does not modify the + (** remove logical hypothesis inter-dependencies (fix #2136). *) + + Ltac no_logical_interdep := + match goal with + | H : ?P |- _ => + match type of P with + | Prop => + match goal with H' : context [ H ] |- _ => clear dependent H' end + | _ => fail + end; no_logical_interdep + | _ => idtac + end. + + Ltac abstract_term t := + tryif (is_var t) then fail "no need to abstract a variable" + else (let x := fresh "x" in set (x := t) in *; try clearbody x). + + Ltac abstract_elements := + repeat + (match goal with + | |- context [ singleton ?t ] => abstract_term t + | _ : context [ singleton ?t ] |- _ => abstract_term t + | |- context [ add ?t _ ] => abstract_term t + | _ : context [ add ?t _ ] |- _ => abstract_term t + | |- context [ remove ?t _ ] => abstract_term t + | _ : context [ remove ?t _ ] |- _ => abstract_term t + | |- context [ In ?t _ ] => abstract_term t + | _ : context [ In ?t _ ] |- _ => abstract_term t + end). + + (** [prop P holds by t] succeeds (but does not modify the goal or context) if the proposition [P] can be proved by [t] in the current context. Otherwise, the tactic fails. *) - Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := - let H := fresh in - assert P as H by t; - clear H. + Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := + let H := fresh in + assert P as H by t; + clear H. - (** This tactic acts just like [assert ... by ...] but will + (** This tactic acts just like [assert ... by ...] but will fail if the context already contains the proposition. *) - Tactic Notation "assert" "new" constr(e) "by" tactic(t) := - match goal with - | H: e |- _ => fail 1 - | _ => assert e by t - end. + Tactic Notation "assert" "new" constr(e) "by" tactic(t) := + match goal with + | H: e |- _ => fail 1 + | _ => assert e by t + end. - (** [subst++] is similar to [subst] except that + (** [subst++] is similar to [subst] except that - it never fails (as [subst] does on recursive equations), - it substitutes locally defined variable for their @@ -402,22 +402,22 @@ the above form: arise after substituting a locally defined function for its definition. *) - Tactic Notation "subst" "++" := - repeat ( - match goal with - | x : _ |- _ => subst x - end); - cbv zeta beta in *. - - (** [decompose records] calls [decompose record H] on every + Tactic Notation "subst" "++" := + repeat ( + match goal with + | x : _ |- _ => subst x + end); + cbv zeta beta in *. + + (** [decompose records] calls [decompose record H] on every relevant hypothesis [H]. *) - Tactic Notation "decompose" "records" := - repeat ( - match goal with - | H: _ |- _ => progress (decompose record H); clear H - end). + Tactic Notation "decompose" "records" := + repeat ( + match goal with + | H: _ |- _ => progress (decompose record H); clear H + end). - (** ** Discarding Irrelevant Hypotheses + (** ** Discarding Irrelevant Hypotheses We will want to clear the context of any non-MSet-related hypotheses in order to increase the speed of the tactic. To do this, we will need to be @@ -425,165 +425,165 @@ the above form: a simple inductive definition classifying the propositions of interest. *) - Inductive MSet_elt_Prop : Prop -> Prop := - | eq_Prop : forall (S : Type) (x y : S), - MSet_elt_Prop (x = y) - | eq_elt_prop : forall x y, - MSet_elt_Prop (E.eq x y) - | In_elt_prop : forall x s, - MSet_elt_Prop (In x s) - | True_elt_prop : - MSet_elt_Prop True - | False_elt_prop : - MSet_elt_Prop False - | conj_elt_prop : forall P Q, - MSet_elt_Prop P -> - MSet_elt_Prop Q -> - MSet_elt_Prop (P /\ Q) - | disj_elt_prop : forall P Q, - MSet_elt_Prop P -> - MSet_elt_Prop Q -> - MSet_elt_Prop (P \/ Q) - | impl_elt_prop : forall P Q, - MSet_elt_Prop P -> - MSet_elt_Prop Q -> - MSet_elt_Prop (P -> Q) - | not_elt_prop : forall P, - MSet_elt_Prop P -> - MSet_elt_Prop (~ P). - - Inductive MSet_Prop : Prop -> Prop := - | elt_MSet_Prop : forall P, - MSet_elt_Prop P -> - MSet_Prop P - | Empty_MSet_Prop : forall s, - MSet_Prop (Empty s) - | Subset_MSet_Prop : forall s1 s2, - MSet_Prop (Subset s1 s2) - | Equal_MSet_Prop : forall s1 s2, - MSet_Prop (Equal s1 s2). - - (** Here is the tactic that will throw away hypotheses that + Inductive MSet_elt_Prop : Prop -> Prop := + | eq_Prop : forall (S : Type) (x y : S), + MSet_elt_Prop (x = y) + | eq_elt_prop : forall x y, + MSet_elt_Prop (E.eq x y) + | In_elt_prop : forall x s, + MSet_elt_Prop (In x s) + | True_elt_prop : + MSet_elt_Prop True + | False_elt_prop : + MSet_elt_Prop False + | conj_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P /\ Q) + | disj_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P \/ Q) + | impl_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P -> Q) + | not_elt_prop : forall P, + MSet_elt_Prop P -> + MSet_elt_Prop (~ P). + + Inductive MSet_Prop : Prop -> Prop := + | elt_MSet_Prop : forall P, + MSet_elt_Prop P -> + MSet_Prop P + | Empty_MSet_Prop : forall s, + MSet_Prop (Empty s) + | Subset_MSet_Prop : forall s1 s2, + MSet_Prop (Subset s1 s2) + | Equal_MSet_Prop : forall s1 s2, + MSet_Prop (Equal s1 s2). + + (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) - #[global] - Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. - Ltac discard_nonMSet := - repeat ( - match goal with - | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - tryif (change T with E.t in H) then fail - else tryif (change T with t in H) then fail - else clear H - | H : ?P |- _ => - tryif prop (MSet_Prop P) holds by - (auto 100 with MSet_Prop) - then fail - else clear H - end). + #[global] + Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. + Ltac discard_nonMSet := + repeat ( + match goal with + | H : context [ @Logic.eq ?T ?x ?y ] |- _ => + tryif (change T with E.t in H) then fail + else tryif (change T with t in H) then fail + else clear H + | H : ?P |- _ => + tryif prop (MSet_Prop P) holds by + (auto 100 with MSet_Prop) + then fail + else clear H + end). - (** ** Turning Set Operators into Propositional Connectives + (** ** Turning Set Operators into Propositional Connectives The lemmas from [MSetFacts] will be used to break down set operations into propositional formulas built over the predicates [In] and [E.eq] applied only to variables. We are going to use them with [autorewrite]. *) - #[global] Hint Rewrite - F.empty_iff F.singleton_iff F.add_iff F.remove_iff - F.union_iff F.inter_iff F.diff_iff - : set_simpl. + #[global] Hint Rewrite + F.empty_iff F.singleton_iff F.add_iff F.remove_iff + F.union_iff F.inter_iff F.diff_iff + : set_simpl. - Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. - Proof. - now split. - Qed. + Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. + Proof. + now split. + Qed. - #[global] Hint Rewrite eq_refl_iff : set_eq_simpl. + #[global] Hint Rewrite eq_refl_iff : set_eq_simpl. - (** ** Decidability of MSet Propositions *) + (** ** Decidability of MSet Propositions *) - (** [In] is decidable. *) - Lemma dec_In : forall x s, - decidable (In x s). - Proof. - red; intros; generalize (F.mem_iff s x); case (mem x s); intuition auto with bool. - Qed. + (** [In] is decidable. *) + Lemma dec_In : forall x s, + decidable (In x s). + Proof. + red; intros; generalize (F.mem_iff s x); case (mem x s); intuition auto with bool. + Qed. - (** [E.eq] is decidable. *) - Lemma dec_eq : forall (x y : E.t), - decidable (E.eq x y). - Proof. - red; intros x y; destruct (E.eq_dec x y); auto. - Qed. + (** [E.eq] is decidable. *) + Lemma dec_eq : forall (x y : E.t), + decidable (E.eq x y). + Proof. + red; intros x y; destruct (E.eq_dec x y); auto. + Qed. - (** The hint database [MSet_decidability] will be given to + (** The hint database [MSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) - #[global] - Hint Resolve dec_In dec_eq : MSet_decidability. + #[global] + Hint Resolve dec_In dec_eq : MSet_decidability. - (** ** Normalizing Propositions About Equality + (** ** Normalizing Propositions About Equality We have to deal with the fact that [E.eq] may be convertible with Coq's equality. Thus, we will find the following tactics useful to replace one form with the other everywhere. *) - (** The next tactic, [Logic_eq_to_E_eq], mentions the term + (** The next tactic, [Logic_eq_to_E_eq], mentions the term [E.t]; thus, we must ensure that [E.t] is used in favor of any other convertible but syntactically distinct term. *) - Ltac change_to_E_t := - repeat ( - match goal with - | H : ?T |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - | H : forall x : ?T, _ |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - end). - - (** These two tactics take us from Coq's built-in equality + Ltac change_to_E_t := + repeat ( + match goal with + | H : ?T |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + | H : forall x : ?T, _ |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). + + (** These two tactics take us from Coq's built-in equality to [E.eq] (and vice versa) when possible. *) - Ltac Logic_eq_to_E_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change (@Logic.eq E.t) with E.eq in H) - | |- _ => - progress (change (@Logic.eq E.t) with E.eq) - end). + Ltac Logic_eq_to_E_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change (@Logic.eq E.t) with E.eq in H) + | |- _ => + progress (change (@Logic.eq E.t) with E.eq) + end). - Ltac E_eq_to_Logic_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change E.eq with (@Logic.eq E.t) in H) - | |- _ => - progress (change E.eq with (@Logic.eq E.t)) - end). + Ltac E_eq_to_Logic_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change E.eq with (@Logic.eq E.t) in H) + | |- _ => + progress (change E.eq with (@Logic.eq E.t)) + end). - (** This tactic works like the built-in tactic [subst], but + (** This tactic works like the built-in tactic [subst], but at the level of set element equality (which may not be the convertible with Coq's equality). *) - Ltac substMSet := - repeat ( - match goal with - | H: E.eq ?x ?x |- _ => clear H - | H: E.eq ?x ?y |- _ => rewrite H in *; clear H - end); - autorewrite with set_eq_simpl in *. - - (** ** Considering Decidability of Base Propositions + Ltac substMSet := + repeat ( + match goal with + | H: E.eq ?x ?x |- _ => clear H + | H: E.eq ?x ?y |- _ => rewrite H in *; clear H + end); + autorewrite with set_eq_simpl in *. + + (** ** Considering Decidability of Base Propositions This tactic adds assertions about the decidability of [E.eq] and [In] to the context. This is necessary for the completeness of the [fsetdec] tactic. However, in @@ -592,125 +592,125 @@ the above form: have been pushed to the leaves of the propositions, we only need to worry about decidability for those base propositions that appear in a negated form. *) - Ltac assert_decidability := - (** We actually don't want these rules to fire if the + Ltac assert_decidability := + (** We actually don't want these rules to fire if the syntactic context in the patterns below is trivially empty, but we'll just do some clean-up at the afterward. *) - repeat ( - match goal with - | H: context [~ E.eq ?x ?y] |- _ => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | H: context [~ In ?x ?s] |- _ => - assert new (In x s \/ ~ In x s) by (apply dec_In) - | |- context [~ E.eq ?x ?y] => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | |- context [~ In ?x ?s] => - assert new (In x s \/ ~ In x s) by (apply dec_In) - end); - (** Now we eliminate the useless facts we added (because + repeat ( + match goal with + | H: context [~ E.eq ?x ?y] |- _ => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | H: context [~ In ?x ?s] |- _ => + assert new (In x s \/ ~ In x s) by (apply dec_In) + | |- context [~ E.eq ?x ?y] => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | |- context [~ In ?x ?s] => + assert new (In x s \/ ~ In x s) by (apply dec_In) + end); + (** Now we eliminate the useless facts we added (because they would likely be very harmful to performance). *) - repeat ( - match goal with - | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H - end). + repeat ( + match goal with + | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H + end). - (** ** Handling [Empty], [Subset], and [Equal] + (** ** Handling [Empty], [Subset], and [Equal] This tactic instantiates universally quantified hypotheses (which arise from the unfolding of [Empty], [Subset], and [Equal]) for each of the set element expressions that is involved in some membership or equality fact. Then it throws away those hypotheses, which should no longer be needed. *) - Ltac inst_MSet_hypotheses := - repeat ( - match goal with - | H : forall a : E.t, _, - _ : context [ In ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ In ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq _ ?x ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq _ ?x ] => - let P := type of (H x) in - assert new P by (exact (H x)) - end); - repeat ( - match goal with - | H : forall a : E.t, _ |- _ => - clear H - end). + Ltac inst_MSet_hypotheses := + repeat ( + match goal with + | H : forall a : E.t, _, + _ : context [ In ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ In ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq _ ?x ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq _ ?x ] => + let P := type of (H x) in + assert new P by (exact (H x)) + end); + repeat ( + match goal with + | H : forall a : E.t, _ |- _ => + clear H + end). - (** ** The Core [fsetdec] Auxiliary Tactics *) + (** ** The Core [fsetdec] Auxiliary Tactics *) - (** Here is the crux of the proof search. Recursion through + (** Here is the crux of the proof search. Recursion through [intuition]! (This will terminate if I correctly understand the behavior of [intuition].) *) - Ltac fsetdec_rec := progress substMSet; intuition fsetdec_rec. + Ltac fsetdec_rec := progress substMSet; intuition fsetdec_rec. - (** If we add [unfold Empty, Subset, Equal in *; intros;] to + (** If we add [unfold Empty, Subset, Equal in *; intros;] to the beginning of this tactic, it will satisfy the same specification as the [fsetdec] tactic; however, it will be much slower than necessary without the pre-processing done by the wrapper tactic [fsetdec]. *) - Ltac fsetdec_body := - autorewrite with set_eq_simpl in *; - inst_MSet_hypotheses; - autorewrite with set_simpl set_eq_simpl in *; - push not in * using MSet_decidability; - substMSet; - assert_decidability; - auto; - (intuition fsetdec_rec) || - fail 1 - "because the goal is beyond the scope of this tactic". - - End MSetDecideAuxiliary. - Import MSetDecideAuxiliary. - - (** * The [fsetdec] Tactic + Ltac fsetdec_body := + autorewrite with set_eq_simpl in *; + inst_MSet_hypotheses; + autorewrite with set_simpl set_eq_simpl in *; + push not in * using MSet_decidability; + substMSet; + assert_decidability; + auto; + (intuition fsetdec_rec) || + fail 1 + "because the goal is beyond the scope of this tactic". + + End MSetDecideAuxiliary. + Import MSetDecideAuxiliary. + + (** * The [fsetdec] Tactic Here is the top-level tactic (the only one intended for clients of this library). It's specification is given at the top of the file. *) - Ltac fsetdec := - (** We first unfold any occurrences of [iff]. *) - unfold iff in *; - (** We fold occurrences of [not] because it is better for + Ltac fsetdec := + (** We first unfold any occurrences of [iff]. *) + unfold iff in *; + (** We fold occurrences of [not] because it is better for [intros] to leave us with a goal of [~ P] than a goal of [False]. *) - fold any not; intros; - (** We don't care about the value of elements : complex ones are + fold any not; intros; + (** We don't care about the value of elements : complex ones are abstracted as new variables (avoiding potential dependencies, see bug #2464) *) - abstract_elements; - (** We remove dependencies to logical hypothesis. This way, + abstract_elements; + (** We remove dependencies to logical hypothesis. This way, later "clear" will work nicely (see bug #2136) *) - no_logical_interdep; - (** Now we decompose conjunctions, which will allow the + no_logical_interdep; + (** Now we decompose conjunctions, which will allow the [discard_nonMSet] and [assert_decidability] tactics to do a much better job. *) - decompose records; - discard_nonMSet; - (** We unfold these defined propositions on finite sets. If + decompose records; + discard_nonMSet; + (** We unfold these defined propositions on finite sets. If our goal was one of them, then have one more item to introduce now. *) - unfold Empty, Subset, Equal in *; intros; - (** We now want to get rid of all uses of [=] in favor of + unfold Empty, Subset, Equal in *; intros; + (** We now want to get rid of all uses of [=] in favor of [E.eq]. However, the best way to eliminate a [=] is in the context is with [subst], so we will try that first. In fact, we may as well convert uses of [E.eq] into [=] @@ -720,8 +720,8 @@ the above form: use [change_to_E_t] to ensure that we have a canonical name for set elements, so that [Logic_eq_to_E_eq] will work properly. *) - change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; - (** The next optimization is to swap a negated goal with a + change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; + (** The next optimization is to swap a negated goal with a negated hypothesis when possible. Any swap will improve performance by eliminating the total number of negations, but we will get the maximum benefit if we @@ -732,161 +732,161 @@ the above form: swap with a decidable proposition; hence, we first test whether the hypothesis is an [MSet_elt_Prop], noting that any [MSet_elt_Prop] is decidable. *) - pull not using MSet_decidability; - unfold not in *; - match goal with - | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => - contradict H; fsetdec_body - | H: ?P -> False |- ?Q -> False => - tryif prop (MSet_elt_Prop P) holds by - (auto 100 with MSet_Prop) - then (contradict H; fsetdec_body) - else fsetdec_body - | |- _ => - fsetdec_body - end. - - (** * Examples *) - - Module MSetDecideTestCases. - - Lemma test_eq_trans_1 : forall x y z s, - E.eq x y -> - ~ ~ E.eq z y -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_trans_2 : forall x y z r s, - In x (singleton y) -> - ~ In z r -> - ~ ~ In z (add y r) -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_1 : forall w x y z s, - E.eq x w -> - ~ ~ E.eq x y -> - ~ E.eq y z -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, - In x (singleton w) -> - ~ In x r1 -> - In x (add y r1) -> - In y r2 -> - In y (remove z r2) -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_In_singleton : forall x, - In x (singleton x). - Proof. fsetdec. Qed. - - Lemma test_add_In : forall x y s, - In x (add y s) -> - ~ E.eq x y -> - In x s. - Proof. fsetdec. Qed. - - Lemma test_Subset_add_remove : forall x s, - s [<=] (add x (remove x s)). - Proof. fsetdec. Qed. - - Lemma test_eq_disjunction : forall w x y z, - In w (add x (add y (singleton z))) -> - E.eq w x \/ E.eq w y \/ E.eq w z. - Proof. fsetdec. Qed. - - Lemma test_not_In_disj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ (In x s1 \/ In x s4 \/ E.eq y x). - Proof. fsetdec. Qed. - - Lemma test_not_In_conj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. - Proof. fsetdec. Qed. - - Lemma test_iff_conj : forall a x s s', - (In a s' <-> E.eq x a \/ In a s) -> - (In a s' <-> In a (add x s)). - Proof. fsetdec. Qed. - - Lemma test_set_ops_1 : forall x q r s, - (singleton x) [<=] s -> - Empty (union q r) -> - Empty (inter (diff s q) (diff s r)) -> - ~ In x s. - Proof. fsetdec. Qed. - - Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, - Empty s1 -> - In x2 (add x1 s1) -> - In x3 s2 -> - ~ In x3 (remove x2 s2) -> - ~ In x4 s3 -> - In x4 (add x3 s3) -> - In x1 s4 -> - Subset (add x4 s4) s4. - Proof. fsetdec. Qed. - - Lemma test_too_complex : forall x y z r s, - E.eq x y -> - (In x (singleton y) -> r [<=] s) -> - In z r -> - In z s. - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until s; intros Heq H Hr; lapply H; fsetdec. - Qed. - - Lemma function_test_1 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g (g x2)) -> - In x1 s1 -> - In (g (g x2)) (f s2). - Proof. fsetdec. Qed. - - Lemma function_test_2 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g x2) -> - In x1 s1 -> - g x2 = g (g x2) -> - In (g (g x2)) (f s2). - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. - Qed. - - Lemma test_baydemir : - forall (f : t -> t), - forall (s : t), - forall (x y : elt), - In x (add y (f s)) -> - ~ E.eq x y -> - In x (f s). - Proof. - fsetdec. - Qed. - - End MSetDecideTestCases. + pull not using MSet_decidability; + unfold not in *; + match goal with + | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => + contradict H; fsetdec_body + | H: ?P -> False |- ?Q -> False => + tryif prop (MSet_elt_Prop P) holds by + (auto 100 with MSet_Prop) + then (contradict H; fsetdec_body) + else fsetdec_body + | |- _ => + fsetdec_body + end. + + (** * Examples *) + + Module MSetDecideTestCases. + + Lemma test_eq_trans_1 : forall x y z s, + E.eq x y -> + ~ ~ E.eq z y -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_trans_2 : forall x y z r s, + In x (singleton y) -> + ~ In z r -> + ~ ~ In z (add y r) -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_1 : forall w x y z s, + E.eq x w -> + ~ ~ E.eq x y -> + ~ E.eq y z -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, + In x (singleton w) -> + ~ In x r1 -> + In x (add y r1) -> + In y r2 -> + In y (remove z r2) -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_In_singleton : forall x, + In x (singleton x). + Proof. fsetdec. Qed. + + Lemma test_add_In : forall x y s, + In x (add y s) -> + ~ E.eq x y -> + In x s. + Proof. fsetdec. Qed. + + Lemma test_Subset_add_remove : forall x s, + s [<=] (add x (remove x s)). + Proof. fsetdec. Qed. + + Lemma test_eq_disjunction : forall w x y z, + In w (add x (add y (singleton z))) -> + E.eq w x \/ E.eq w y \/ E.eq w z. + Proof. fsetdec. Qed. + + Lemma test_not_In_disj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ (In x s1 \/ In x s4 \/ E.eq y x). + Proof. fsetdec. Qed. + + Lemma test_not_In_conj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. + Proof. fsetdec. Qed. + + Lemma test_iff_conj : forall a x s s', + (In a s' <-> E.eq x a \/ In a s) -> + (In a s' <-> In a (add x s)). + Proof. fsetdec. Qed. + + Lemma test_set_ops_1 : forall x q r s, + (singleton x) [<=] s -> + Empty (union q r) -> + Empty (inter (diff s q) (diff s r)) -> + ~ In x s. + Proof. fsetdec. Qed. + + Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, + Empty s1 -> + In x2 (add x1 s1) -> + In x3 s2 -> + ~ In x3 (remove x2 s2) -> + ~ In x4 s3 -> + In x4 (add x3 s3) -> + In x1 s4 -> + Subset (add x4 s4) s4. + Proof. fsetdec. Qed. + + Lemma test_too_complex : forall x y z r s, + E.eq x y -> + (In x (singleton y) -> r [<=] s) -> + In z r -> + In z s. + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until s; intros Heq H Hr; lapply H; fsetdec. + Qed. + + Lemma function_test_1 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2). + Proof. fsetdec. Qed. + + Lemma function_test_2 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2). + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. + Qed. + + Lemma test_baydemir : + forall (f : t -> t), + forall (s : t), + forall (x y : elt), + In x (add y (f s)) -> + ~ E.eq x y -> + In x (f s). + Proof. + fsetdec. + Qed. + + End MSetDecideTestCases. End WDecideOn. diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index ed7f90ff19..872263ee34 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -22,913 +22,914 @@ From Stdlib Require FSetEqProperties. Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E). -Module Import MP := WPropertiesOn E M. -Import FM Dec.F. -Import M. - -Definition Add := MP.Add. - -Section BasicProperties. - -(** Some old specifications written with boolean equalities. *) - -Variable s s' s'': t. -Variable x y z : elt. - -Lemma mem_eq: - E.eq x y -> mem x s=mem y s. -Proof. -intro H; rewrite H; auto. -Qed. - -Lemma equal_mem_1: - (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. -intros; apply equal_1; unfold Equal; intros. -do 2 rewrite mem_iff; rewrite H; tauto. -Qed. - -Lemma equal_mem_2: - equal s s'=true -> forall a, mem a s=mem a s'. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma subset_mem_1: - (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. -intros; apply subset_1; unfold Subset; intros a. -do 2 rewrite mem_iff; auto. -Qed. - -Lemma subset_mem_2: - subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. -intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. -Qed. - -Lemma empty_mem: mem x empty=false. -Proof. -rewrite <- not_mem_iff; auto with set. -Qed. - -Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. -apply bool_1; split; intros. -- auto with set. -- rewrite <- is_empty_iff; auto with set. -Qed. - -Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. -auto with set. -Qed. - -Lemma choose_mem_2: choose s=None -> is_empty s=true. -Proof. -auto with set. -Qed. - -Lemma add_mem_1: mem x (add x s)=true. -Proof. -auto with set relations. -Qed. - -Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. -apply add_neq_b. -Qed. - -Lemma remove_mem_1: mem x (remove x s)=false. -Proof. -rewrite <- not_mem_iff; auto with set relations. -Qed. - -Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. -apply remove_neq_b. -Qed. - -Lemma singleton_equal_add: - equal (singleton x) (add x empty)=true. -Proof. -rewrite (singleton_equal_add x); auto with set. -Qed. - -Lemma union_mem: - mem x (union s s')=mem x s || mem x s'. -Proof. -apply union_b. -Qed. - -Lemma inter_mem: - mem x (inter s s')=mem x s && mem x s'. -Proof. -apply inter_b. -Qed. - -Lemma diff_mem: - mem x (diff s s')=mem x s && negb (mem x s'). -Proof. -apply diff_b. -Qed. - -(** properties of [mem] *) - -Lemma mem_3 : ~In x s -> mem x s=false. -Proof. -intros; rewrite <- not_mem_iff; auto. -Qed. - -Lemma mem_4 : mem x s=false -> ~In x s. -Proof. -intros; rewrite not_mem_iff; auto. -Qed. - -(** Properties of [equal] *) - -Lemma equal_refl: equal s s=true. -Proof. -auto with set. -Qed. - -Lemma equal_sym: equal s s'=equal s' s. -Proof. -intros; apply bool_1; do 2 rewrite <- equal_iff; intuition auto with relations. -Qed. - -Lemma equal_trans: - equal s s'=true -> equal s' s''=true -> equal s s''=true. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_equal: - equal s s'=true -> equal s s''=equal s' s''. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_cardinal: - equal s s'=true -> cardinal s=cardinal s'. -Proof. -auto with set. -Qed. - -(* Properties of [subset] *) - -Lemma subset_refl: subset s s=true. -Proof. -auto with set. -Qed. - -Lemma subset_antisym: - subset s s'=true -> subset s' s=true -> equal s s'=true. -Proof. -auto with set. -Qed. - -Lemma subset_trans: - subset s s'=true -> subset s' s''=true -> subset s s''=true. -Proof. -do 3 rewrite <- subset_iff; intros. -apply subset_trans with s'; auto. -Qed. - -Lemma subset_equal: - equal s s'=true -> subset s s'=true. -Proof. -auto with set. -Qed. - -(** Properties of [choose] *) - -Lemma choose_mem_3: - is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. -Proof. -intros. -generalize (@choose_1 s) (@choose_2 s). -destruct (choose s);intros. -- exists e;auto with set. -- generalize (H1 (eq_refl None)); clear H1. - intros; rewrite (is_empty_1 H1) in H; discriminate. -Qed. - -Lemma choose_mem_4: choose empty=None. -Proof. -generalize (@choose_1 empty). -case (@choose empty);intros;auto. -elim (@empty_1 e); auto. -Qed. - -(** Properties of [add] *) - -Lemma add_mem_3: - mem y s=true -> mem y (add x s)=true. -Proof. -auto with set. -Qed. - -Lemma add_equal: - mem x s=true -> equal (add x s) s=true. -Proof. -auto with set. -Qed. - -(** Properties of [remove] *) - -Lemma remove_mem_3: - mem y (remove x s)=true -> mem y s=true. -Proof. -rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. -Qed. - -Lemma remove_equal: - mem x s=false -> equal (remove x s) s=true. -Proof. -intros; apply equal_1; apply remove_equal. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_remove: - mem x s=true -> equal (add x (remove x s)) s=true. -Proof. -intros; apply equal_1; apply add_remove; auto with set. -Qed. - -Lemma remove_add: - mem x s=false -> equal (remove x (add x s)) s=true. -Proof. -intros; apply equal_1; apply remove_add; auto. -rewrite not_mem_iff; auto. -Qed. - -(** Properties of [is_empty] *) - -Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). -Proof. -intros; apply bool_1; split; intros. -- rewrite MP.cardinal_1; simpl; auto with set. -- assert (cardinal s = 0) by (apply zerob_true_elim; auto). - auto with set. -Qed. - -(** Properties of [singleton] *) - -Lemma singleton_mem_1: mem x (singleton x)=true. -Proof. -auto with set relations. -Qed. - -Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. -Proof. -intros; rewrite singleton_b. -unfold eqb; destruct (E.eq_dec x y); intuition. -Qed. - -Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. -Proof. -intros; apply singleton_1; auto with set. -Qed. - -(** Properties of [union] *) - -Lemma union_sym: - equal (union s s') (union s' s)=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_equal: - subset s s'=true -> equal (union s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_1: - equal s s'=true-> equal (union s s'') (union s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_2: - equal s' s''=true-> equal (union s s') (union s s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_assoc: - equal (union (union s s') s'') (union s (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma add_union_singleton: - equal (add x s) (union (singleton x) s)=true. -Proof. -auto with set. -Qed. - -Lemma union_add: - equal (union (add x s) s') (add x (union s s'))=true. -Proof. -auto with set. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma union_subset_1: subset s (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_2: subset s' (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> - subset (union s s') s''=true. -Proof. -intros; apply subset_1; apply union_subset_3; auto with set. -Qed. - -(** Properties of [inter] *) - -Lemma inter_sym: equal (inter s s') (inter s' s)=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_equal: - subset s s'=true -> equal (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_1: - equal s s'=true -> equal (inter s s'') (inter s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_2: - equal s' s''=true -> equal (inter s s') (inter s s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_assoc: - equal (inter (inter s s') s'') (inter s (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_1: - equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_2: - equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_1: mem x s'=true -> - equal (inter (add x s) s') (add x (inter s s'))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_2: mem x s'=false -> - equal (inter (add x s) s') (inter s s')=true. -Proof. -intros; apply equal_1; apply inter_add_2. -rewrite not_mem_iff; auto. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma inter_subset_1: subset (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_2: subset (inter s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> - subset s'' (inter s s')=true. -Proof. -intros; apply subset_1; apply inter_subset_3; auto with set. -Qed. - -(** Properties of [diff] *) - -Lemma diff_subset: subset (diff s s') s=true. -Proof. -auto with set. -Qed. - -Lemma diff_subset_equal: - subset s s'=true -> equal (diff s s') empty=true. -Proof. -auto with set. -Qed. - -Lemma remove_inter_singleton: - equal (remove x s) (diff s (singleton x))=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_all: - equal (union (diff s s') (inter s s')) s=true. -Proof. -auto with set. -Qed. - -End BasicProperties. - -#[global] -Hint Immediate empty_mem is_empty_equal_empty add_mem_1 - remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. -#[global] -Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 - choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal - subset_refl subset_equal subset_antisym - add_mem_3 add_equal remove_mem_3 remove_equal : set. - - -(** General recursion principle *) - -Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> - P empty -> forall s, P s. -Proof. -intros. -apply set_induction; auto; intros. -- apply X with empty; auto with set. -- apply X with (add x s0); auto with set. - + apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. - + apply X0; auto with set; apply mem_3; auto. -Qed. - -(** Properties of [fold] *) - -Lemma exclusive_set : forall s s' x, - ~(In x s/\In x s') <-> mem x s && mem x s'=false. -Proof. -intros; do 2 rewrite mem_iff. -destruct (mem x s); destruct (mem x s'); intuition auto with bool. -Qed. - -Section Fold. -Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). -Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). -Variables (i:A). -Variables (s s':t)(x:elt). - -Lemma fold_empty: (fold f empty i) = i. -Proof. -apply fold_empty; auto. -Qed. - -Lemma fold_equal: - equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. -intros; apply fold_equal with (eqA:=eqA); auto with set. -Qed. - -Lemma fold_add: - mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. -intros; apply fold_add with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_fold: - mem x s=true -> eqA (fold f (add x s) i) (fold f s i). -Proof. -intros; apply add_fold with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_1: - mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). -Proof. -intros; apply remove_fold_1 with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_2: - mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). -Proof. -intros; apply remove_fold_2 with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). -Proof. -intros; apply fold_union with (eqA:=eqA); auto. -intros; rewrite exclusive_set; auto. -Qed. - -End Fold. - -(** Properties of [cardinal] *) - -Lemma add_cardinal_1: - forall s x, mem x s=true -> cardinal (add x s)=cardinal s. -Proof. -auto with set. -Qed. - -Lemma add_cardinal_2: - forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). -Proof. -intros; apply add_cardinal_2; auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma remove_cardinal_1: - forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. -Proof. -intros; apply remove_cardinal_1; auto with set. -Qed. - -Lemma remove_cardinal_2: - forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. -Proof. -intros; apply Equal_cardinal; apply equal_2; auto with set. -Qed. - -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> - cardinal (union s s')=cardinal s+cardinal s'. -Proof. -intros; apply union_cardinal; auto; intros. -rewrite exclusive_set; auto. -Qed. - -Lemma subset_cardinal: - forall s s', subset s s'=true -> cardinal s<=cardinal s'. -Proof. -intros; apply subset_cardinal; auto with set. -Qed. - -Section Bool. - -(** Properties of [filter] *) - -Variable f:elt->bool. -Variable Comp: Proper (E.eq==>Logic.eq) f. - -Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). -Proof. -repeat red; intros; f_equal; auto. -Defined. - -Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. -intros; apply filter_b; auto. -Qed. - -Lemma for_all_filter: - forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. -intros; apply bool_1; split; intros. -- apply is_empty_1. - unfold Empty; intros. - rewrite filter_iff; auto. - red; destruct 1. - rewrite <- (@for_all_iff s f) in H; auto. - rewrite (H a H0) in H1; discriminate. -- apply for_all_1; auto; red; intros. - revert H; rewrite <- is_empty_iff. - unfold Empty; intro H; generalize (H x); clear H. - rewrite filter_iff; auto. - destruct (f x); auto. -Qed. - -Lemma exists_filter : - forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. -- destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). - apply bool_6. - red; intros; apply (@is_empty_2 _ H0 a); auto with set. -- generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). - destruct (choose (filter f s)). - + intros H0 _; apply exists_1; auto. - exists e; generalize (H0 e); rewrite filter_iff; auto. - + intros _ H0. - rewrite (is_empty_1 (H0 (eq_refl None))) in H; auto; discriminate. -Qed. - -Lemma partition_filter_1: - forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. -auto with set. -Qed. - -Lemma partition_filter_2: - forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. -auto with set. -Qed. - -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). -Proof. -red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -rewrite <- H; apply Comp; auto with relations. -Qed. - -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. -Proof. -red; intros; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -assert (f x = f a) by (apply Comp; auto). -rewrite H in H1; rewrite H2 in H1; discriminate. -Qed. - -Lemma add_filter_1 : forall s s' x, - f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). -Proof. -unfold Add, MP.Add; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -intuition. -setoid_replace y with x; auto with relations. -Qed. - -Lemma add_filter_2 : forall s s' x, - f x=false -> (Add x s s') -> filter f s [=] filter f s'. -Proof. -unfold Add, MP.Add, Equal; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -intuition. -setoid_replace x with a in H; auto. congruence. -Qed. - -Lemma union_filter: forall f g, - Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. -Proof. -clear Comp' Comp f. -intros. -assert (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))). -- repeat red; intros. - rewrite (H x y H1); rewrite (H0 x y H1); auto. -- unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. - assert (f a || g a = true <-> f a = true \/ g a = true). - + split; auto with bool. - intro H3; destruct (orb_prop _ _ H3); auto. - + tauto. -Qed. - -Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). -Proof. -unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. -Qed. - -(** Properties of [for_all] *) - -Lemma for_all_mem_1: forall s, - (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. -Proof. -intros. -rewrite for_all_filter; auto. -rewrite is_empty_equal_empty. -apply equal_mem_1;intros. -rewrite filter_b; auto. -rewrite empty_mem. -generalize (H a); case (mem a s);intros;auto. -rewrite H0;auto. -Qed. - -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. -Proof. -intros. -rewrite for_all_filter in H; auto. -rewrite is_empty_equal_empty in H. -generalize (equal_mem_2 _ _ H x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H0; simpl;intros. -rewrite <- negb_false_iff; auto. -Qed. - -Lemma for_all_mem_3: - forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. -Proof. -intros. -apply (bool_eq_ind (for_all f s));intros;auto. -rewrite for_all_filter in H1; auto. -rewrite is_empty_equal_empty in H1. -generalize (equal_mem_2 _ _ H1 x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H. -rewrite H0. -simpl;auto. -Qed. - -Lemma for_all_mem_4: - forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. -Proof. -intros. -rewrite for_all_filter in H; auto. -destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. -exists x. -rewrite filter_b in H1; auto. -elim (andb_prop _ _ H1). -split;auto. -rewrite <- negb_true_iff; auto. -Qed. - -(** Properties of [exists] *) - -Lemma for_all_exists: - forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). -Proof. -intros. -rewrite for_all_b; auto. -rewrite exists_b; auto. -induction (elements s); simpl; auto. -destruct (f a); simpl; auto. -Qed. - -End Bool. -Section Bool'. - -Variable f:elt->bool. -Variable Comp: Proper (E.eq==>Logic.eq) f. - -#[local] Definition Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)). -Proof. -repeat red; intros; f_equal; auto. -Defined. - -#[local] Hint Resolve Comp' : core. - -Lemma exists_mem_1: - forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite for_all_mem_1;auto with bool. -intros;generalize (H x H0);intros. -rewrite negb_true_iff; auto. -Qed. - -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_false_iff in H. -rewrite <- negb_true_iff. -apply for_all_mem_2 with (2:=H); auto. -Qed. - -Lemma exists_mem_3: - forall s x, mem x s=true -> f x=true -> exists_ f s=true. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite negb_true_iff. -apply for_all_mem_3 with x;auto. -rewrite negb_false_iff; auto. -Qed. - -Lemma exists_mem_4: - forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_true_iff in H. -destruct (@for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,[]); auto. -exists x;split;auto. -rewrite <-negb_false_iff; auto. -Qed. - -End Bool'. - -Section Sum. - -(** Adding a valuation function on all elements of a set. *) - -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. -Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)). -Notation transposeL := (transpose Logic.eq). - -Lemma sum_plus : - forall f g, - Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. -Proof. -unfold sum. -intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))) by - (repeat red; intros; rewrite Hf; auto). -assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; lia). -assert (gc : compat_opL (fun x:elt => plus (g x))) by - (repeat red; intros; rewrite Hg; auto). -assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; lia). -assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by - (repeat red; intros; rewrite Hf,Hg; auto). -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; lia). -intros s;pattern s; apply set_rec. -- intros. - rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). - rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). - rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. -- intros. do 3 (rewrite fold_add by auto with fset). lia. -- do 3 rewrite fold_empty;auto. -Qed. - -Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f -> - forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). -Proof. -unfold sum; intros f Hf. -assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by - (repeat red; intros; rewrite Hf; auto). -assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by - (red; intros; lia). -intros s;pattern s; apply set_rec. -- intros. - change elt with E.t. - rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). - apply equal_2 in H; rewrite <- H, <-H0; auto. -- intros; rewrite (fold_add _ _ st _ cc ct); auto. - generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . - assert (~ In x (filter f s0)). - + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. - + case (f x); simpl; intros. - * rewrite (MP.cardinal_2 H1 (H2 (eq_refl true) (MP.Add_add s0 x))); auto. - * rewrite <- (MP.Equal_cardinal (H3 (eq_refl false) (MP.Add_add s0 x))); auto. -- intros; rewrite fold_empty;auto. - rewrite MP.cardinal_1; auto. - unfold Empty; intros. - rewrite filter_iff; auto; set_iff; tauto. -Qed. - -Lemma fold_compat : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f g:elt->A->A), - Proper (E.eq==>eqA==>eqA) f -> transpose eqA f -> - Proper (E.eq==>eqA==>eqA) g -> transpose eqA g -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> - (eqA (fold f s i) (fold g s i)). -Proof. -intros A eqA st f g fc ft gc gt i. -intro s; pattern s; apply set_rec; intros. -- transitivity (fold f s0 i). - + apply fold_equal with (eqA:=eqA); auto. - rewrite equal_sym; auto. - + transitivity (fold g s0 i). - * apply H0; intros; apply H1; auto with set. - elim (equal_2 H x); auto with set; intros. - * apply fold_equal with (eqA:=eqA); auto with set. -- transitivity (f x (fold f s0 i)). - + apply fold_add with (eqA:=eqA); auto with set. - + transitivity (g x (fold f s0 i)); auto with set relations. - transitivity (g x (fold g s0 i)); auto with set relations. - * apply gc; auto with set relations. - * symmetry; apply fold_add with (eqA:=eqA); auto. -- do 2 rewrite fold_empty; reflexivity. -Qed. - -Lemma sum_compat : - forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. -intros. -unfold sum; apply (@fold_compat _ (@Logic.eq nat)); - repeat red; auto with *; lia. -Qed. - -End Sum. + Module Import MP := WPropertiesOn E M. + Import FM Dec.F. + Import M. + + Definition Add := MP.Add. + + Section BasicProperties. + + (** Some old specifications written with boolean equalities. *) + + Variable s s' s'': t. + Variable x y z : elt. + + Lemma mem_eq: + E.eq x y -> mem x s=mem y s. + Proof. + intro H; rewrite H; auto. + Qed. + + Lemma equal_mem_1: + (forall a, mem a s=mem a s') -> equal s s'=true. + Proof. + intros; apply equal_1; unfold Equal; intros. + do 2 rewrite mem_iff; rewrite H; tauto. + Qed. + + Lemma equal_mem_2: + equal s s'=true -> forall a, mem a s=mem a s'. + Proof. + intros; rewrite (equal_2 H); auto. + Qed. + + Lemma subset_mem_1: + (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. + Proof. + intros; apply subset_1; unfold Subset; intros a. + do 2 rewrite mem_iff; auto. + Qed. + + Lemma subset_mem_2: + subset s s'=true -> forall a, mem a s=true -> mem a s'=true. + Proof. + intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. + Qed. + + Lemma empty_mem: mem x empty=false. + Proof. + rewrite <- not_mem_iff; auto with set. + Qed. + + Lemma is_empty_equal_empty: is_empty s = equal s empty. + Proof. + apply bool_1; split; intros. + - auto with set. + - rewrite <- is_empty_iff; auto with set. + Qed. + + Lemma choose_mem_1: choose s=Some x -> mem x s=true. + Proof. + auto with set. + Qed. + + Lemma choose_mem_2: choose s=None -> is_empty s=true. + Proof. + auto with set. + Qed. + + Lemma add_mem_1: mem x (add x s)=true. + Proof. + auto with set relations. + Qed. + + Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. + Proof. + apply add_neq_b. + Qed. + + Lemma remove_mem_1: mem x (remove x s)=false. + Proof. + rewrite <- not_mem_iff; auto with set relations. + Qed. + + Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. + Proof. + apply remove_neq_b. + Qed. + + Lemma singleton_equal_add: + equal (singleton x) (add x empty)=true. + Proof. + rewrite (singleton_equal_add x); auto with set. + Qed. + + Lemma union_mem: + mem x (union s s')=mem x s || mem x s'. + Proof. + apply union_b. + Qed. + + Lemma inter_mem: + mem x (inter s s')=mem x s && mem x s'. + Proof. + apply inter_b. + Qed. + + Lemma diff_mem: + mem x (diff s s')=mem x s && negb (mem x s'). + Proof. + apply diff_b. + Qed. + + (** properties of [mem] *) + + Lemma mem_3 : ~In x s -> mem x s=false. + Proof. + intros; rewrite <- not_mem_iff; auto. + Qed. + + Lemma mem_4 : mem x s=false -> ~In x s. + Proof. + intros; rewrite not_mem_iff; auto. + Qed. + + (** Properties of [equal] *) + + Lemma equal_refl: equal s s=true. + Proof. + auto with set. + Qed. + + Lemma equal_sym: equal s s'=equal s' s. + Proof. + intros; apply bool_1; do 2 rewrite <- equal_iff; intuition auto with relations. + Qed. + + Lemma equal_trans: + equal s s'=true -> equal s' s''=true -> equal s s''=true. + Proof. + intros; rewrite (equal_2 H); auto. + Qed. + + Lemma equal_equal: + equal s s'=true -> equal s s''=equal s' s''. + Proof. + intros; rewrite (equal_2 H); auto. + Qed. + + Lemma equal_cardinal: + equal s s'=true -> cardinal s=cardinal s'. + Proof. + auto with set. + Qed. + + (* Properties of [subset] *) + + Lemma subset_refl: subset s s=true. + Proof. + auto with set. + Qed. + + Lemma subset_antisym: + subset s s'=true -> subset s' s=true -> equal s s'=true. + Proof. + auto with set. + Qed. + + Lemma subset_trans: + subset s s'=true -> subset s' s''=true -> subset s s''=true. + Proof. + do 3 rewrite <- subset_iff; intros. + apply subset_trans with s'; auto. + Qed. + + Lemma subset_equal: + equal s s'=true -> subset s s'=true. + Proof. + auto with set. + Qed. + + (** Properties of [choose] *) + + Lemma choose_mem_3: + is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. + Proof. + intros. + generalize (@choose_1 s) (@choose_2 s). + destruct (choose s);intros. + - exists e;auto with set. + - generalize (H1 (eq_refl None)); clear H1. + intros; rewrite (is_empty_1 H1) in H; discriminate. + Qed. + + Lemma choose_mem_4: choose empty=None. + Proof. + generalize (@choose_1 empty). + case (@choose empty);intros;auto. + elim (@empty_1 e); auto. + Qed. + + (** Properties of [add] *) + + Lemma add_mem_3: + mem y s=true -> mem y (add x s)=true. + Proof. + auto with set. + Qed. + + Lemma add_equal: + mem x s=true -> equal (add x s) s=true. + Proof. + auto with set. + Qed. + + (** Properties of [remove] *) + + Lemma remove_mem_3: + mem y (remove x s)=true -> mem y s=true. + Proof. + rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. + Qed. + + Lemma remove_equal: + mem x s=false -> equal (remove x s) s=true. + Proof. + intros; apply equal_1; apply remove_equal. + rewrite not_mem_iff; auto. + Qed. + + Lemma add_remove: + mem x s=true -> equal (add x (remove x s)) s=true. + Proof. + intros; apply equal_1; apply add_remove; auto with set. + Qed. + + Lemma remove_add: + mem x s=false -> equal (remove x (add x s)) s=true. + Proof. + intros; apply equal_1; apply remove_add; auto. + rewrite not_mem_iff; auto. + Qed. + + (** Properties of [is_empty] *) + + Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). + Proof. + intros; apply bool_1; split; intros. + - rewrite MP.cardinal_1; simpl; auto with set. + - assert (cardinal s = 0) by (apply zerob_true_elim; auto). + auto with set. + Qed. + + (** Properties of [singleton] *) + + Lemma singleton_mem_1: mem x (singleton x)=true. + Proof. + auto with set relations. + Qed. + + Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. + Proof. + intros; rewrite singleton_b. + unfold eqb; destruct (E.eq_dec x y); intuition. + Qed. + + Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. + Proof. + intros; apply singleton_1; auto with set. + Qed. + + (** Properties of [union] *) + + Lemma union_sym: + equal (union s s') (union s' s)=true. + Proof. + auto with set. + Qed. + + Lemma union_subset_equal: + subset s s'=true -> equal (union s s') s'=true. + Proof. + auto with set. + Qed. + + Lemma union_equal_1: + equal s s'=true-> equal (union s s'') (union s' s'')=true. + Proof. + auto with set. + Qed. + + Lemma union_equal_2: + equal s' s''=true-> equal (union s s') (union s s'')=true. + Proof. + auto with set. + Qed. + + Lemma union_assoc: + equal (union (union s s') s'') (union s (union s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma add_union_singleton: + equal (add x s) (union (singleton x) s)=true. + Proof. + auto with set. + Qed. + + Lemma union_add: + equal (union (add x s) s') (add x (union s s'))=true. + Proof. + auto with set. + Qed. + + (* characterisation of [union] via [subset] *) + + Lemma union_subset_1: subset s (union s s')=true. + Proof. + auto with set. + Qed. + + Lemma union_subset_2: subset s' (union s s')=true. + Proof. + auto with set. + Qed. + + Lemma union_subset_3: + subset s s''=true -> subset s' s''=true -> + subset (union s s') s''=true. + Proof. + intros; apply subset_1; apply union_subset_3; auto with set. + Qed. + + (** Properties of [inter] *) + + Lemma inter_sym: equal (inter s s') (inter s' s)=true. + Proof. + auto with set. + Qed. + + Lemma inter_subset_equal: + subset s s'=true -> equal (inter s s') s=true. + Proof. + auto with set. + Qed. + + Lemma inter_equal_1: + equal s s'=true -> equal (inter s s'') (inter s' s'')=true. + Proof. + auto with set. + Qed. + + Lemma inter_equal_2: + equal s' s''=true -> equal (inter s s') (inter s s'')=true. + Proof. + auto with set. + Qed. + + Lemma inter_assoc: + equal (inter (inter s s') s'') (inter s (inter s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma union_inter_1: + equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma union_inter_2: + equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. + Proof. + auto with set. + Qed. + + Lemma inter_add_1: mem x s'=true -> + equal (inter (add x s) s') (add x (inter s s'))=true. + Proof. + auto with set. + Qed. + + Lemma inter_add_2: mem x s'=false -> + equal (inter (add x s) s') (inter s s')=true. + Proof. + intros; apply equal_1; apply inter_add_2. + rewrite not_mem_iff; auto. + Qed. + + (* characterisation of [union] via [subset] *) + + Lemma inter_subset_1: subset (inter s s') s=true. + Proof. + auto with set. + Qed. + + Lemma inter_subset_2: subset (inter s s') s'=true. + Proof. + auto with set. + Qed. + + Lemma inter_subset_3: + subset s'' s=true -> subset s'' s'=true -> + subset s'' (inter s s')=true. + Proof. + intros; apply subset_1; apply inter_subset_3; auto with set. + Qed. + + (** Properties of [diff] *) + + Lemma diff_subset: subset (diff s s') s=true. + Proof. + auto with set. + Qed. + + Lemma diff_subset_equal: + subset s s'=true -> equal (diff s s') empty=true. + Proof. + auto with set. + Qed. + + Lemma remove_inter_singleton: + equal (remove x s) (diff s (singleton x))=true. + Proof. + auto with set. + Qed. + + Lemma diff_inter_empty: + equal (inter (diff s s') (inter s s')) empty=true. + Proof. + auto with set. + Qed. + + Lemma diff_inter_all: + equal (union (diff s s') (inter s s')) s=true. + Proof. + auto with set. + Qed. + + End BasicProperties. + + #[global] + Hint Immediate empty_mem is_empty_equal_empty add_mem_1 + remove_mem_1 singleton_equal_add union_mem inter_mem + diff_mem equal_sym add_remove remove_add : set. + #[global] + Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 + choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal + subset_refl subset_equal subset_antisym + add_mem_3 add_equal remove_mem_3 remove_equal : set. + + + (** General recursion principle *) + + Lemma set_rec: forall (P:t->Type), + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> + P empty -> forall s, P s. + Proof. + intros. + apply set_induction; auto; intros. + - apply X with empty; auto with set. + - apply X with (add x s0); auto with set. + + apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. + + apply X0; auto with set; apply mem_3; auto. + Qed. + + (** Properties of [fold] *) + + Lemma exclusive_set : forall s s' x, + ~(In x s/\In x s') <-> mem x s && mem x s'=false. + Proof. + intros; do 2 rewrite mem_iff. + destruct (mem x s); destruct (mem x s'); intuition auto with bool. + Qed. + + Section Fold. + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). + Variables (i:A). + Variables (s s':t)(x:elt). + + Lemma fold_empty: (fold f empty i) = i. + Proof. + apply fold_empty; auto. + Qed. + + Lemma fold_equal: + equal s s'=true -> eqA (fold f s i) (fold f s' i). + Proof. + intros; apply fold_equal with (eqA:=eqA); auto with set. + Qed. + + Lemma fold_add: + mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_add with (eqA:=eqA); auto. + rewrite not_mem_iff; auto. + Qed. + + Lemma add_fold: + mem x s=true -> eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply add_fold with (eqA:=eqA); auto with set. + Qed. + + Lemma remove_fold_1: + mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros; apply remove_fold_1 with (eqA:=eqA); auto with set. + Qed. + + Lemma remove_fold_2: + mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros; apply remove_fold_2 with (eqA:=eqA); auto. + rewrite not_mem_iff; auto. + Qed. + + Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros; apply fold_union with (eqA:=eqA); auto. + intros; rewrite exclusive_set; auto. + Qed. + + End Fold. + + (** Properties of [cardinal] *) + + Lemma add_cardinal_1: + forall s x, mem x s=true -> cardinal (add x s)=cardinal s. + Proof. + auto with set. + Qed. + + Lemma add_cardinal_2: + forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). + Proof. + intros; apply add_cardinal_2; auto. + rewrite not_mem_iff; auto. + Qed. + + Lemma remove_cardinal_1: + forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. + Proof. + intros; apply remove_cardinal_1; auto with set. + Qed. + + Lemma remove_cardinal_2: + forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. + Proof. + intros; apply Equal_cardinal; apply equal_2; auto with set. + Qed. + + Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> + cardinal (union s s')=cardinal s+cardinal s'. + Proof. + intros; apply union_cardinal; auto; intros. + rewrite exclusive_set; auto. + Qed. + + Lemma subset_cardinal: + forall s s', subset s s'=true -> cardinal s<=cardinal s'. + Proof. + intros; apply subset_cardinal; auto with set. + Qed. + + Section Bool. + + (** Properties of [filter] *) + + Variable f:elt->bool. + Variable Comp: Proper (E.eq==>Logic.eq) f. + + Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). + Proof. + repeat red; intros; f_equal; auto. + Defined. + + Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. + Proof. + intros; apply filter_b; auto. + Qed. + + Lemma for_all_filter: + forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). + Proof. + intros; apply bool_1; split; intros. + - apply is_empty_1. + unfold Empty; intros. + rewrite filter_iff; auto. + red; destruct 1. + rewrite <- (@for_all_iff s f) in H; auto. + rewrite (H a H0) in H1; discriminate. + - apply for_all_1; auto; red; intros. + revert H; rewrite <- is_empty_iff. + unfold Empty; intro H; generalize (H x); clear H. + rewrite filter_iff; auto. + destruct (f x); auto. + Qed. + + Lemma exists_filter : + forall s, exists_ f s=negb (is_empty (filter f s)). + Proof. + intros; apply bool_1; split; intros. + - destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). + apply bool_6. + red; intros; apply (@is_empty_2 _ H0 a); auto with set. + - generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). + destruct (choose (filter f s)). + + intros H0 _; apply exists_1; auto. + exists e; generalize (H0 e); rewrite filter_iff; auto. + + intros _ H0. + rewrite (is_empty_1 (H0 (eq_refl None))) in H; auto; discriminate. + Qed. + + Lemma partition_filter_1: + forall s, equal (fst (partition f s)) (filter f s)=true. + Proof. + auto with set. + Qed. + + Lemma partition_filter_2: + forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. + Proof. + auto with set. + Qed. + + Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). + Proof. + red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. + intuition. + rewrite <- H; apply Comp; auto with relations. + Qed. + + Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. + Proof. + red; intros; do 2 (rewrite filter_iff; auto); set_iff. + intuition. + assert (f x = f a) by (apply Comp; auto). + rewrite H in H1; rewrite H2 in H1; discriminate. + Qed. + + Lemma add_filter_1 : forall s s' x, + f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). + Proof. + unfold Add, MP.Add; intros. + repeat rewrite filter_iff; auto. + rewrite H0; clear H0. + intuition. + setoid_replace y with x; auto with relations. + Qed. + + Lemma add_filter_2 : forall s s' x, + f x=false -> (Add x s s') -> filter f s [=] filter f s'. + Proof. + unfold Add, MP.Add, Equal; intros. + repeat rewrite filter_iff; auto. + rewrite H0; clear H0. + intuition. + setoid_replace x with a in H; auto. congruence. + Qed. + + Lemma union_filter: forall f g, + Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. + Proof. + clear Comp' Comp f. + intros. + assert (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))). + - repeat red; intros. + rewrite (H x y H1); rewrite (H0 x y H1); auto. + - unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. + assert (f a || g a = true <-> f a = true \/ g a = true). + + split; auto with bool. + intro H3; destruct (orb_prop _ _ H3); auto. + + tauto. + Qed. + + Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). + Proof. + unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. + Qed. + + (** Properties of [for_all] *) + + Lemma for_all_mem_1: forall s, + (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. + Proof. + intros. + rewrite for_all_filter; auto. + rewrite is_empty_equal_empty. + apply equal_mem_1;intros. + rewrite filter_b; auto. + rewrite empty_mem. + generalize (H a); case (mem a s);intros;auto. + rewrite H0;auto. + Qed. + + Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. + Proof. + intros. + rewrite for_all_filter in H; auto. + rewrite is_empty_equal_empty in H. + generalize (equal_mem_2 _ _ H x). + rewrite filter_b; auto. + rewrite empty_mem. + rewrite H0; simpl;intros. + rewrite <- negb_false_iff; auto. + Qed. + + Lemma for_all_mem_3: + forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. + Proof. + intros. + apply (bool_eq_ind (for_all f s));intros;auto. + rewrite for_all_filter in H1; auto. + rewrite is_empty_equal_empty in H1. + generalize (equal_mem_2 _ _ H1 x). + rewrite filter_b; auto. + rewrite empty_mem. + rewrite H. + rewrite H0. + simpl;auto. + Qed. + + Lemma for_all_mem_4: + forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. + Proof. + intros. + rewrite for_all_filter in H; auto. + destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. + exists x. + rewrite filter_b in H1; auto. + elim (andb_prop _ _ H1). + split;auto. + rewrite <- negb_true_iff; auto. + Qed. + + (** Properties of [exists] *) + + Lemma for_all_exists: + forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). + Proof. + intros. + rewrite for_all_b; auto. + rewrite exists_b; auto. + induction (elements s); simpl; auto. + destruct (f a); simpl; auto. + Qed. + + End Bool. + Section Bool'. + + Variable f:elt->bool. + Variable Comp: Proper (E.eq==>Logic.eq) f. + + #[local] Definition Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)). + Proof. + repeat red; intros; f_equal; auto. + Defined. + + #[local] Hint Resolve Comp' : core. + + Lemma exists_mem_1: + forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. + Proof. + intros. + rewrite for_all_exists; auto. + rewrite for_all_mem_1;auto with bool. + intros;generalize (H x H0);intros. + rewrite negb_true_iff; auto. + Qed. + + Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. + Proof. + intros. + rewrite for_all_exists in H; auto. + rewrite negb_false_iff in H. + rewrite <- negb_true_iff. + apply for_all_mem_2 with (2:=H); auto. + Qed. + + Lemma exists_mem_3: + forall s x, mem x s=true -> f x=true -> exists_ f s=true. + Proof. + intros. + rewrite for_all_exists; auto. + rewrite negb_true_iff. + apply for_all_mem_3 with x;auto. + rewrite negb_false_iff; auto. + Qed. + + Lemma exists_mem_4: + forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. + Proof. + intros. + rewrite for_all_exists in H; auto. + rewrite negb_true_iff in H. + destruct (@for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,[]); auto. + exists x;split;auto. + rewrite <-negb_false_iff; auto. + Qed. + + End Bool'. + + Section Sum. + + (** Adding a valuation function on all elements of a set. *) + + Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. + Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)). + Notation transposeL := (transpose Logic.eq). + + Lemma sum_plus : + forall f g, + Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. + Proof. + unfold sum. + intros f g Hf Hg. + assert (fc : compat_opL (fun x:elt =>plus (f x))) by + (repeat red; intros; rewrite Hf; auto). + assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; lia). + assert (gc : compat_opL (fun x:elt => plus (g x))) by + (repeat red; intros; rewrite Hg; auto). + assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; lia). + assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by + (repeat red; intros; rewrite Hf,Hg; auto). + assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; lia). + intros s;pattern s; apply set_rec. + - intros. + rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). + rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). + rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. + - intros. do 3 (rewrite fold_add by auto with fset). lia. + - do 3 rewrite fold_empty;auto. + Qed. + + Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f -> + forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). + Proof. + unfold sum; intros f Hf. + assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). + assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by + (repeat red; intros; rewrite Hf; auto). + assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by + (red; intros; lia). + intros s;pattern s; apply set_rec. + - intros. + change elt with E.t. + rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). + apply equal_2 in H; rewrite <- H, <-H0; auto. + - intros; rewrite (fold_add _ _ st _ cc ct); auto. + generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . + assert (~ In x (filter f s0)). + + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. + + case (f x); simpl; intros. + * rewrite (MP.cardinal_2 H1 (H2 (eq_refl true) (MP.Add_add s0 x))); auto. + * rewrite <- (MP.Equal_cardinal (H3 (eq_refl false) (MP.Add_add s0 x))); auto. + - intros; rewrite fold_empty;auto. + rewrite MP.cardinal_1; auto. + unfold Empty; intros. + rewrite filter_iff; auto; set_iff; tauto. + Qed. + + Lemma fold_compat : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f g:elt->A->A), + Proper (E.eq==>eqA==>eqA) f -> transpose eqA f -> + Proper (E.eq==>eqA==>eqA) g -> transpose eqA g -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (eqA (fold f s i) (fold g s i)). + Proof. + intros A eqA st f g fc ft gc gt i. + intro s; pattern s; apply set_rec; intros. + - transitivity (fold f s0 i). + + apply fold_equal with (eqA:=eqA); auto. + rewrite equal_sym; auto. + + transitivity (fold g s0 i). + * apply H0; intros; apply H1; auto with set. + elim (equal_2 H x); auto with set; intros. + * apply fold_equal with (eqA:=eqA); auto with set. + - transitivity (f x (fold f s0 i)). + + apply fold_add with (eqA:=eqA); auto with set. + + transitivity (g x (fold f s0 i)); auto with set relations. + transitivity (g x (fold g s0 i)); auto with set relations. + * apply gc; auto with set relations. + * symmetry; apply fold_add with (eqA:=eqA); auto. + - do 2 rewrite fold_empty; reflexivity. + Qed. + + Lemma sum_compat : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. + Proof. + intros. + unfold sum; apply (@fold_compat _ (@Logic.eq nat)); + repeat red; auto with *; lia. + Qed. + + End Sum. End WEqPropertiesOn. diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v index b546081c2e..771d4c524a 100644 --- a/theories/MSets/MSetFacts.v +++ b/theories/MSets/MSetFacts.v @@ -27,520 +27,520 @@ Unset Strict Implicit. Module WFactsOn (Import E : DecidableType)(Import M : WSetsOn E). -Notation eq_dec := E.eq_dec. -Definition eqb x y := if eq_dec x y then true else false. + Notation eq_dec := E.eq_dec. + Definition eqb x y := if eq_dec x y then true else false. -(** * Specifications written using implications : + (** * Specifications written using implications : this used to be the default interface. *) -Section ImplSpec. -Variable s s' : t. -Variable x y : elt. - -Lemma In_1 : E.eq x y -> In x s -> In y s. -Proof. intros E; rewrite E; auto. Qed. - -Lemma mem_1 : In x s -> mem x s = true. -Proof. intros; apply <- mem_spec; auto. Qed. -Lemma mem_2 : mem x s = true -> In x s. -Proof. intros; apply -> mem_spec; auto. Qed. - -Lemma equal_1 : Equal s s' -> equal s s' = true. -Proof. intros; apply <- equal_spec; auto. Qed. -Lemma equal_2 : equal s s' = true -> Equal s s'. -Proof. intros; apply -> equal_spec; auto. Qed. - -Lemma subset_1 : Subset s s' -> subset s s' = true. -Proof. intros; apply <- subset_spec; auto. Qed. -Lemma subset_2 : subset s s' = true -> Subset s s'. -Proof. intros; apply -> subset_spec; auto. Qed. - -Lemma is_empty_1 : Empty s -> is_empty s = true. -Proof. intros; apply <- is_empty_spec; auto. Qed. -Lemma is_empty_2 : is_empty s = true -> Empty s. -Proof. intros; apply -> is_empty_spec; auto. Qed. - -Lemma add_1 : E.eq x y -> In y (add x s). -Proof. intros; apply <- add_spec. auto with relations. Qed. -Lemma add_2 : In y s -> In y (add x s). -Proof. intros; apply <- add_spec; auto. Qed. -Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. -Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed. - -Lemma remove_1 : E.eq x y -> ~ In y (remove x s). -Proof. intros; rewrite remove_spec; intuition. Qed. -Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). -Proof. intros; apply <- remove_spec; auto with relations. Qed. -Lemma remove_3 : In y (remove x s) -> In y s. -Proof. rewrite remove_spec; intuition. Qed. - -Lemma singleton_1 : In y (singleton x) -> E.eq x y. -Proof. rewrite singleton_spec; auto with relations. Qed. -Lemma singleton_2 : E.eq x y -> In y (singleton x). -Proof. rewrite singleton_spec; auto with relations. Qed. - -Lemma union_1 : In x (union s s') -> In x s \/ In x s'. -Proof. rewrite union_spec; auto. Qed. -Lemma union_2 : In x s -> In x (union s s'). -Proof. rewrite union_spec; auto. Qed. -Lemma union_3 : In x s' -> In x (union s s'). -Proof. rewrite union_spec; auto. Qed. - -Lemma inter_1 : In x (inter s s') -> In x s. -Proof. rewrite inter_spec; intuition. Qed. -Lemma inter_2 : In x (inter s s') -> In x s'. -Proof. rewrite inter_spec; intuition. Qed. -Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). -Proof. rewrite inter_spec; intuition. Qed. - -Lemma diff_1 : In x (diff s s') -> In x s. -Proof. rewrite diff_spec; intuition. Qed. -Lemma diff_2 : In x (diff s s') -> ~ In x s'. -Proof. rewrite diff_spec; intuition. Qed. -Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). -Proof. rewrite diff_spec; auto. Qed. - -Variable f : elt -> bool. -Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - -Lemma filter_1 : compatb f -> In x (filter f s) -> In x s. -Proof. intros P; rewrite filter_spec; intuition. Qed. -Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true. -Proof. intros P; rewrite filter_spec; intuition. Qed. -Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s). -Proof. intros P; rewrite filter_spec; intuition. Qed. - -Lemma for_all_1 : compatb f -> - For_all (fun x => f x = true) s -> for_all f s = true. -Proof. intros; apply <- for_all_spec; auto. Qed. -Lemma for_all_2 : compatb f -> - for_all f s = true -> For_all (fun x => f x = true) s. -Proof. intros; apply -> for_all_spec; auto. Qed. - -Lemma exists_1 : compatb f -> - Exists (fun x => f x = true) s -> exists_ f s = true. -Proof. intros; apply <- exists_spec; auto. Qed. - -Lemma exists_2 : compatb f -> - exists_ f s = true -> Exists (fun x => f x = true) s. -Proof. intros; apply -> exists_spec; auto. Qed. - -Lemma elements_1 : In x s -> InA E.eq x (elements s). -Proof. intros; apply <- elements_spec1; auto. Qed. -Lemma elements_2 : InA E.eq x (elements s) -> In x s. -Proof. intros; apply -> elements_spec1; auto. Qed. - -End ImplSpec. - -Notation empty_1 := empty_spec (only parsing). -Notation fold_1 := fold_spec (only parsing). -Notation cardinal_1 := cardinal_spec (only parsing). -Notation partition_1 := partition_spec1 (only parsing). -Notation partition_2 := partition_spec2 (only parsing). -Notation choose_1 := choose_spec1 (only parsing). -Notation choose_2 := choose_spec2 (only parsing). -Notation elements_3w := elements_spec2w (only parsing). - -#[global] -Hint Resolve mem_1 equal_1 subset_1 empty_1 - is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 - remove_2 singleton_2 union_1 union_2 union_3 - inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 - partition_1 partition_2 elements_1 elements_3w - : set. -#[global] -Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 - remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 - filter_1 filter_2 for_all_2 exists_2 elements_2 - : set. - - -(** * Specifications written using equivalences : + Section ImplSpec. + Variable s s' : t. + Variable x y : elt. + + Lemma In_1 : E.eq x y -> In x s -> In y s. + Proof. intros E; rewrite E; auto. Qed. + + Lemma mem_1 : In x s -> mem x s = true. + Proof. intros; apply <- mem_spec; auto. Qed. + Lemma mem_2 : mem x s = true -> In x s. + Proof. intros; apply -> mem_spec; auto. Qed. + + Lemma equal_1 : Equal s s' -> equal s s' = true. + Proof. intros; apply <- equal_spec; auto. Qed. + Lemma equal_2 : equal s s' = true -> Equal s s'. + Proof. intros; apply -> equal_spec; auto. Qed. + + Lemma subset_1 : Subset s s' -> subset s s' = true. + Proof. intros; apply <- subset_spec; auto. Qed. + Lemma subset_2 : subset s s' = true -> Subset s s'. + Proof. intros; apply -> subset_spec; auto. Qed. + + Lemma is_empty_1 : Empty s -> is_empty s = true. + Proof. intros; apply <- is_empty_spec; auto. Qed. + Lemma is_empty_2 : is_empty s = true -> Empty s. + Proof. intros; apply -> is_empty_spec; auto. Qed. + + Lemma add_1 : E.eq x y -> In y (add x s). + Proof. intros; apply <- add_spec. auto with relations. Qed. + Lemma add_2 : In y s -> In y (add x s). + Proof. intros; apply <- add_spec; auto. Qed. + Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed. + + Lemma remove_1 : E.eq x y -> ~ In y (remove x s). + Proof. intros; rewrite remove_spec; intuition. Qed. + Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). + Proof. intros; apply <- remove_spec; auto with relations. Qed. + Lemma remove_3 : In y (remove x s) -> In y s. + Proof. rewrite remove_spec; intuition. Qed. + + Lemma singleton_1 : In y (singleton x) -> E.eq x y. + Proof. rewrite singleton_spec; auto with relations. Qed. + Lemma singleton_2 : E.eq x y -> In y (singleton x). + Proof. rewrite singleton_spec; auto with relations. Qed. + + Lemma union_1 : In x (union s s') -> In x s \/ In x s'. + Proof. rewrite union_spec; auto. Qed. + Lemma union_2 : In x s -> In x (union s s'). + Proof. rewrite union_spec; auto. Qed. + Lemma union_3 : In x s' -> In x (union s s'). + Proof. rewrite union_spec; auto. Qed. + + Lemma inter_1 : In x (inter s s') -> In x s. + Proof. rewrite inter_spec; intuition. Qed. + Lemma inter_2 : In x (inter s s') -> In x s'. + Proof. rewrite inter_spec; intuition. Qed. + Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). + Proof. rewrite inter_spec; intuition. Qed. + + Lemma diff_1 : In x (diff s s') -> In x s. + Proof. rewrite diff_spec; intuition. Qed. + Lemma diff_2 : In x (diff s s') -> ~ In x s'. + Proof. rewrite diff_spec; intuition. Qed. + Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). + Proof. rewrite diff_spec; auto. Qed. + + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Lemma filter_1 : compatb f -> In x (filter f s) -> In x s. + Proof. intros P; rewrite filter_spec; intuition. Qed. + Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true. + Proof. intros P; rewrite filter_spec; intuition. Qed. + Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s). + Proof. intros P; rewrite filter_spec; intuition. Qed. + + Lemma for_all_1 : compatb f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. intros; apply <- for_all_spec; auto. Qed. + Lemma for_all_2 : compatb f -> + for_all f s = true -> For_all (fun x => f x = true) s. + Proof. intros; apply -> for_all_spec; auto. Qed. + + Lemma exists_1 : compatb f -> + Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. intros; apply <- exists_spec; auto. Qed. + + Lemma exists_2 : compatb f -> + exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. intros; apply -> exists_spec; auto. Qed. + + Lemma elements_1 : In x s -> InA E.eq x (elements s). + Proof. intros; apply <- elements_spec1; auto. Qed. + Lemma elements_2 : InA E.eq x (elements s) -> In x s. + Proof. intros; apply -> elements_spec1; auto. Qed. + + End ImplSpec. + + Notation empty_1 := empty_spec (only parsing). + Notation fold_1 := fold_spec (only parsing). + Notation cardinal_1 := cardinal_spec (only parsing). + Notation partition_1 := partition_spec1 (only parsing). + Notation partition_2 := partition_spec2 (only parsing). + Notation choose_1 := choose_spec1 (only parsing). + Notation choose_2 := choose_spec2 (only parsing). + Notation elements_3w := elements_spec2w (only parsing). + + #[global] + Hint Resolve mem_1 equal_1 subset_1 empty_1 + is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 + remove_2 singleton_2 union_1 union_2 union_3 + inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 + partition_1 partition_2 elements_1 elements_3w + : set. + #[global] + Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 + remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 + : set. + + + (** * Specifications written using equivalences : this is now provided by the default interface. *) -Section IffSpec. -Variable s s' s'' : t. -Variable x y z : elt. + Section IffSpec. + Variable s s' s'' : t. + Variable x y z : elt. -Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). -Proof. -intros E; rewrite E; intuition. -Qed. + Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). + Proof. + intros E; rewrite E; intuition. + Qed. -Lemma mem_iff : In x s <-> mem x s = true. -Proof. apply iff_sym, mem_spec. Qed. + Lemma mem_iff : In x s <-> mem x s = true. + Proof. apply iff_sym, mem_spec. Qed. -Lemma not_mem_iff : ~In x s <-> mem x s = false. -Proof. -rewrite <-mem_spec; destruct (mem x s); intuition auto with bool. -Qed. + Lemma not_mem_iff : ~In x s <-> mem x s = false. + Proof. + rewrite <-mem_spec; destruct (mem x s); intuition auto with bool. + Qed. -Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. apply iff_sym, equal_spec. Qed. + Lemma equal_iff : s[=]s' <-> equal s s' = true. + Proof. apply iff_sym, equal_spec. Qed. -Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. apply iff_sym, subset_spec. Qed. + Lemma subset_iff : s[<=]s' <-> subset s s' = true. + Proof. apply iff_sym, subset_spec. Qed. -Lemma empty_iff : In x empty <-> False. -Proof. intuition; apply (empty_spec H). Qed. + Lemma empty_iff : In x empty <-> False. + Proof. intuition; apply (empty_spec H). Qed. -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. apply iff_sym, is_empty_spec. Qed. + Lemma is_empty_iff : Empty s <-> is_empty s = true. + Proof. apply iff_sym, is_empty_spec. Qed. -Lemma singleton_iff : In y (singleton x) <-> E.eq x y. -Proof. rewrite singleton_spec; intuition. Qed. - -Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. rewrite add_spec; intuition. Qed. - -Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). -Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed. - -Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. -Proof. rewrite remove_spec; intuition. Qed. - -Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). -Proof. rewrite remove_spec; intuition. Qed. - -Variable f : elt -> bool. - -Lemma for_all_iff : Proper (E.eq==>Logic.eq) f -> - (For_all (fun x => f x = true) s <-> for_all f s = true). -Proof. intros; apply iff_sym, for_all_spec; auto. Qed. - -Lemma exists_iff : Proper (E.eq==>Logic.eq) f -> - (Exists (fun x => f x = true) s <-> exists_ f s = true). -Proof. intros; apply iff_sym, exists_spec; auto. Qed. - -Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. apply iff_sym, elements_spec1. Qed. - -End IffSpec. - -Notation union_iff := union_spec (only parsing). -Notation inter_iff := inter_spec (only parsing). -Notation diff_iff := diff_spec (only parsing). -Notation filter_iff := filter_spec (only parsing). - -(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := - repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff - || rewrite union_iff || rewrite inter_iff || rewrite diff_iff - || rewrite empty_iff)). - -(** * Specifications written using boolean predicates *) - -Section BoolSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. -intros. -generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). -destruct (mem x s); destruct (mem y s); intuition. -Qed. - -Lemma empty_b : mem y empty = false. -Proof. -generalize (empty_iff y)(mem_iff empty y). -destruct (mem y empty); intuition. -Qed. - -Lemma add_b : mem y (add x s) = eqb x y || mem y s. -Proof. -generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. -Proof. -intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). -destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). -Proof. -generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. -Qed. - -Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. -Proof. -intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). -destruct (mem y s); destruct (mem y (remove x s)); intuition. -Qed. - -Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. -generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. -Qed. - -Lemma union_b : mem x (union s s') = mem x s || mem x s'. -Proof. -generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. -Qed. - -Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. -Proof. -generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. -Qed. - -Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). -Proof. -generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. -Qed. - -Lemma elements_b : mem x s = existsb (eqb x) (elements s). -Proof. -generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). -rewrite InA_alt. -destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. -- symmetry. - rewrite H1. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. - exists a; intuition. - unfold eqb; destruct (eq_dec x a); auto. -- rewrite <- H. - rewrite H0. - destruct H1 as (H1,_). - destruct H1 as (a,(Ha1,Ha2)); [intuition|]. - exists a; intuition. - unfold eqb in *; destruct (eq_dec x a); auto; discriminate. -Qed. - -Variable f : elt->bool. - -Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x. -Proof. -intros. -generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). -destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. -Qed. - -Lemma for_all_b : Proper (E.eq==>Logic.eq) f -> - for_all f s = forallb f (elements s). -Proof. -intros. -generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). -unfold For_all. -destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - rewrite (H2 x0) in H3. - rewrite (InA_alt E.eq x0 (elements s)) in H3. - destruct H3 as (a,(Ha1,Ha2)). - rewrite (H _ _ Ha1). - apply H0; auto. -- symmetry. - rewrite H0; intros. - destruct H1 as (_,H1). - apply H1; auto. - rewrite H2. - rewrite InA_alt. exists x0; split; auto with relations. -Qed. - -Lemma exists_b : Proper (E.eq==>Logic.eq) f -> - exists_ f s = existsb f (elements s). -Proof. -intros. -generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). -unfold Exists. -destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); auto. - exists a; split; auto. - rewrite H2; rewrite InA_alt; exists a; auto with relations. -- symmetry. - rewrite H0. - destruct H1 as (_,H1). - destruct H1 as (a,(Ha1,Ha2)); auto. - rewrite (H2 a) in Ha1. - rewrite (InA_alt E.eq a (elements s)) in Ha1. - destruct Ha1 as (b,(Hb1,Hb2)). - exists b; auto. - rewrite <- (H _ _ Hb1); auto. -Qed. - -End BoolSpec. - -(** * Declarations of morphisms with respects to [E.eq] and [Equal] *) - -#[global] -Instance In_m : Proper (E.eq==>Equal==>iff) In. -Proof. -unfold Equal; intros x y H s s' H0. -rewrite (In_eq_iff s H); auto. -Qed. - -#[global] -Instance Empty_m : Proper (Equal==>iff) Empty. -Proof. -repeat red; unfold Empty; intros s s' E. -setoid_rewrite E; auto. -Qed. - -#[global] -Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty. -Proof. -intros s s' H. -generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff. -destruct (is_empty s); destruct (is_empty s'); intuition. -Qed. - -#[global] -Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem. -Proof. -intros x x' Hx s s' Hs. -generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff. -destruct (mem x s), (mem x' s'); intuition. -Qed. - -#[global] -Instance singleton_m : Proper (E.eq==>Equal) singleton. -Proof. -intros x y H a. rewrite !singleton_iff, H; intuition. -Qed. - -#[global] -Instance add_m : Proper (E.eq==>Equal==>Equal) add. -Proof. -intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition. -Qed. - -#[global] -Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. -Proof. -intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition. -Qed. - -#[global] -Instance union_m : Proper (Equal==>Equal==>Equal) union. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance inter_m : Proper (Equal==>Equal==>Equal) inter. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance diff_m : Proper (Equal==>Equal==>Equal) diff. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. -Proof. -unfold Equal, Subset; firstorder. -Qed. - -#[global] -Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2. -generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff. -destruct (subset s1 s2); destruct (subset s1' s2'); intuition. -Qed. - -#[global] -Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2. -generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff. -destruct (equal s1 s2); destruct (equal s1' s2'); intuition. -Qed. - -#[global] -Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *) -Proof. firstorder. Qed. - -Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid. -Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid. - -#[global] -Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1. -Proof. - simpl_relation. eauto with set. -Qed. - -#[global] -Instance Empty_s_m : Proper (Subset-->impl) Empty. -Proof. firstorder. Qed. - -#[global] -Instance add_s_m : Proper (E.eq==>Subset++>Subset) add. -Proof. -intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition. -Qed. - -#[global] -Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove. -Proof. -intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition. -Qed. - -#[global] -Instance union_s_m : Proper (Subset++>Subset++>Subset) union. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. -Qed. - - -(* [fold], [filter], [for_all], [exists_] and [partition] requires + Lemma singleton_iff : In y (singleton x) <-> E.eq x y. + Proof. rewrite singleton_spec; intuition. Qed. + + Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. + Proof. rewrite add_spec; intuition. Qed. + + Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). + Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed. + + Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. + Proof. rewrite remove_spec; intuition. Qed. + + Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). + Proof. rewrite remove_spec; intuition. Qed. + + Variable f : elt -> bool. + + Lemma for_all_iff : Proper (E.eq==>Logic.eq) f -> + (For_all (fun x => f x = true) s <-> for_all f s = true). + Proof. intros; apply iff_sym, for_all_spec; auto. Qed. + + Lemma exists_iff : Proper (E.eq==>Logic.eq) f -> + (Exists (fun x => f x = true) s <-> exists_ f s = true). + Proof. intros; apply iff_sym, exists_spec; auto. Qed. + + Lemma elements_iff : In x s <-> InA E.eq x (elements s). + Proof. apply iff_sym, elements_spec1. Qed. + + End IffSpec. + + Notation union_iff := union_spec (only parsing). + Notation inter_iff := inter_spec (only parsing). + Notation diff_iff := diff_spec (only parsing). + Notation filter_iff := filter_spec (only parsing). + + (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + + Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + + (** * Specifications written using boolean predicates *) + + Section BoolSpec. + Variable s s' s'' : t. + Variable x y z : elt. + + Lemma mem_b : E.eq x y -> mem x s = mem y s. + Proof. + intros. + generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). + destruct (mem x s); destruct (mem y s); intuition. + Qed. + + Lemma empty_b : mem y empty = false. + Proof. + generalize (empty_iff y)(mem_iff empty y). + destruct (mem y empty); intuition. + Qed. + + Lemma add_b : mem y (add x s) = eqb x y || mem y s. + Proof. + generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. + destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. + Qed. + + Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. + Proof. + intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). + destruct (mem y s); destruct (mem y (add x s)); intuition. + Qed. + + Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). + Proof. + generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. + destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. + Qed. + + Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. + Proof. + intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). + destruct (mem y s); destruct (mem y (remove x s)); intuition. + Qed. + + Lemma singleton_b : mem y (singleton x) = eqb x y. + Proof. + generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. + destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. + Qed. + + Lemma union_b : mem x (union s s') = mem x s || mem x s'. + Proof. + generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). + destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. + Qed. + + Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. + Proof. + generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). + destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. + Qed. + + Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). + Proof. + generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). + destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. + Qed. + + Lemma elements_b : mem x s = existsb (eqb x) (elements s). + Proof. + generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). + rewrite InA_alt. + destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. + - symmetry. + rewrite H1. + destruct H0 as (H0,_). + destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. + exists a; intuition. + unfold eqb; destruct (eq_dec x a); auto. + - rewrite <- H. + rewrite H0. + destruct H1 as (H1,_). + destruct H1 as (a,(Ha1,Ha2)); [intuition|]. + exists a; intuition. + unfold eqb in *; destruct (eq_dec x a); auto; discriminate. + Qed. + + Variable f : elt->bool. + + Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x. + Proof. + intros. + generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). + destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. + Qed. + + Lemma for_all_b : Proper (E.eq==>Logic.eq) f -> + for_all f s = forallb f (elements s). + Proof. + intros. + generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). + unfold For_all. + destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. + - rewrite <- H1; intros. + destruct H0 as (H0,_). + rewrite (H2 x0) in H3. + rewrite (InA_alt E.eq x0 (elements s)) in H3. + destruct H3 as (a,(Ha1,Ha2)). + rewrite (H _ _ Ha1). + apply H0; auto. + - symmetry. + rewrite H0; intros. + destruct H1 as (_,H1). + apply H1; auto. + rewrite H2. + rewrite InA_alt. exists x0; split; auto with relations. + Qed. + + Lemma exists_b : Proper (E.eq==>Logic.eq) f -> + exists_ f s = existsb f (elements s). + Proof. + intros. + generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). + unfold Exists. + destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. + - rewrite <- H1; intros. + destruct H0 as (H0,_). + destruct H0 as (a,(Ha1,Ha2)); auto. + exists a; split; auto. + rewrite H2; rewrite InA_alt; exists a; auto with relations. + - symmetry. + rewrite H0. + destruct H1 as (_,H1). + destruct H1 as (a,(Ha1,Ha2)); auto. + rewrite (H2 a) in Ha1. + rewrite (InA_alt E.eq a (elements s)) in Ha1. + destruct Ha1 as (b,(Hb1,Hb2)). + exists b; auto. + rewrite <- (H _ _ Hb1); auto. + Qed. + + End BoolSpec. + + (** * Declarations of morphisms with respects to [E.eq] and [Equal] *) + + #[global] + Instance In_m : Proper (E.eq==>Equal==>iff) In. + Proof. + unfold Equal; intros x y H s s' H0. + rewrite (In_eq_iff s H); auto. + Qed. + + #[global] + Instance Empty_m : Proper (Equal==>iff) Empty. + Proof. + repeat red; unfold Empty; intros s s' E. + setoid_rewrite E; auto. + Qed. + + #[global] + Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty. + Proof. + intros s s' H. + generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff. + destruct (is_empty s); destruct (is_empty s'); intuition. + Qed. + + #[global] + Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem. + Proof. + intros x x' Hx s s' Hs. + generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff. + destruct (mem x s), (mem x' s'); intuition. + Qed. + + #[global] + Instance singleton_m : Proper (E.eq==>Equal) singleton. + Proof. + intros x y H a. rewrite !singleton_iff, H; intuition. + Qed. + + #[global] + Instance add_m : Proper (E.eq==>Equal==>Equal) add. + Proof. + intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition. + Qed. + + #[global] + Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. + Proof. + intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition. + Qed. + + #[global] + Instance union_m : Proper (Equal==>Equal==>Equal) union. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. + Qed. + + #[global] + Instance inter_m : Proper (Equal==>Equal==>Equal) inter. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. + Qed. + + #[global] + Instance diff_m : Proper (Equal==>Equal==>Equal) diff. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. + Qed. + + #[global] + Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. + Proof. + unfold Equal, Subset; firstorder. + Qed. + + #[global] + Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2. + generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff. + destruct (subset s1 s2); destruct (subset s1' s2'); intuition. + Qed. + + #[global] + Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2. + generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff. + destruct (equal s1 s2); destruct (equal s1' s2'); intuition. + Qed. + + #[global] + Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *) + Proof. firstorder. Qed. + + Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid. + Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid. + + #[global] + Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1. + Proof. + simpl_relation. eauto with set. + Qed. + + #[global] + Instance Empty_s_m : Proper (Subset-->impl) Empty. + Proof. firstorder. Qed. + + #[global] + Instance add_s_m : Proper (E.eq==>Subset++>Subset) add. + Proof. + intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition. + Qed. + + #[global] + Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove. + Proof. + intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition. + Qed. + + #[global] + Instance union_s_m : Proper (Subset++>Subset++>Subset) union. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. + Qed. + + #[global] + Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. + Qed. + + #[global] + Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff. + Proof. + intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. + Qed. + + + (* [fold], [filter], [for_all], [exists_] and [partition] requires some knowledge on [f] in order to be known as morphisms. *) -Generalizable Variables f. - -#[global] -Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f), - Proper (Equal==>Equal) (filter f). -Proof. -intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. -Qed. - -#[global] -Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f), - Proper (Subset==>Subset) (filter f). -Proof. -intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. -Qed. - -Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) -> - forall s s', s[=]s' -> filter f s [=] filter f' s'. -Proof. -intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto. -- rewrite Hff', Hss'; intuition. -- red; red; intros; rewrite <- 2 Hff'; auto. -Qed. - -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid + Generalizable Variables f. + + #[global] + Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f), + Proper (Equal==>Equal) (filter f). + Proof. + intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. + Qed. + + #[global] + Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f), + Proper (Subset==>Subset) (filter f). + Proof. + intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. + Qed. + + Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) -> + forall s s', s[=]s' -> filter f s [=] filter f' s'. + Proof. + intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto. + - rewrite Hff', Hss'; intuition. + - red; red; intros; rewrite <- 2 Hff'; auto. + Qed. + + (* For [elements], [min_elt], [max_elt] and [choose], we would need setoid structures on [list elt] and [option elt]. *) -(* Later: + (* Later: Add Morphism cardinal ; cardinal_m. *) diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index b8e2a1e31d..cd100be0cf 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -39,125 +39,125 @@ From Stdlib Require Arith. (* contains deprecated dependencies *) #[local] Unset Elimination Schemes. Module Type InfoTyp. - Parameter t : Set. + Parameter t : Set. End InfoTyp. (** * Ops : the pure functions *) Module Type Ops (X:OrderedType)(Info:InfoTyp). -Definition elt := X.t. -#[global] -Hint Transparent elt : core. + Definition elt := X.t. + #[global] + Hint Transparent elt : core. -Inductive tree : Type := -| Leaf : tree -| Node : Info.t -> tree -> X.t -> tree -> tree. + Inductive tree : Type := + | Leaf : tree + | Node : Info.t -> tree -> X.t -> tree -> tree. -(** ** The empty set and emptyness test *) + (** ** The empty set and emptyness test *) -Definition empty := Leaf. + Definition empty := Leaf. -Definition is_empty t := - match t with - | Leaf => true - | _ => false - end. + Definition is_empty t := + match t with + | Leaf => true + | _ => false + end. -(** ** Membership test *) + (** ** Membership test *) -(** The [mem] function is deciding membership. It exploits the + (** The [mem] function is deciding membership. It exploits the binary search tree invariant to achieve logarithmic complexity. *) -Fixpoint mem x t := - match t with - | Leaf => false - | Node _ l k r => - match X.compare x k with - | Lt => mem x l - | Eq => true - | Gt => mem x r - end - end. - -(** ** Minimal, maximal, arbitrary elements *) - -Fixpoint min_elt (t : tree) : option elt := - match t with - | Leaf => None - | Node _ Leaf x r => Some x - | Node _ l x r => min_elt l - end. - -Fixpoint max_elt (t : tree) : option elt := - match t with - | Leaf => None - | Node _ l x Leaf => Some x - | Node _ l x r => max_elt r - end. - -Definition choose := min_elt. - -(** ** Iteration on elements *) - -Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A := - match t with - | Leaf => base - | Node _ l x r => fold f r (f x (fold f l base)) - end. - -Fixpoint elements_aux acc s := - match s with - | Leaf => acc - | Node _ l x r => elements_aux (x :: elements_aux acc r) l - end. - -Definition elements := elements_aux nil. - -Fixpoint rev_elements_aux acc s := - match s with - | Leaf => acc - | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r - end. - -Definition rev_elements := rev_elements_aux nil. - -Fixpoint cardinal (s : tree) : nat := - match s with + Fixpoint mem x t := + match t with + | Leaf => false + | Node _ l k r => + match X.compare x k with + | Lt => mem x l + | Eq => true + | Gt => mem x r + end + end. + + (** ** Minimal, maximal, arbitrary elements *) + + Fixpoint min_elt (t : tree) : option elt := + match t with + | Leaf => None + | Node _ Leaf x r => Some x + | Node _ l x r => min_elt l + end. + + Fixpoint max_elt (t : tree) : option elt := + match t with + | Leaf => None + | Node _ l x Leaf => Some x + | Node _ l x r => max_elt r + end. + + Definition choose := min_elt. + + (** ** Iteration on elements *) + + Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A := + match t with + | Leaf => base + | Node _ l x r => fold f r (f x (fold f l base)) + end. + + Fixpoint elements_aux acc s := + match s with + | Leaf => acc + | Node _ l x r => elements_aux (x :: elements_aux acc r) l + end. + + Definition elements := elements_aux nil. + + Fixpoint rev_elements_aux acc s := + match s with + | Leaf => acc + | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r + end. + + Definition rev_elements := rev_elements_aux nil. + + Fixpoint cardinal (s : tree) : nat := + match s with + | Leaf => 0 + | Node _ l _ r => S (cardinal l + cardinal r) + end. + + Fixpoint maxdepth s := + match s with | Leaf => 0 - | Node _ l _ r => S (cardinal l + cardinal r) - end. + | Node _ l _ r => S (max (maxdepth l) (maxdepth r)) + end. -Fixpoint maxdepth s := - match s with - | Leaf => 0 - | Node _ l _ r => S (max (maxdepth l) (maxdepth r)) - end. - -Fixpoint mindepth s := - match s with - | Leaf => 0 - | Node _ l _ r => S (min (mindepth l) (mindepth r)) - end. + Fixpoint mindepth s := + match s with + | Leaf => 0 + | Node _ l _ r => S (min (mindepth l) (mindepth r)) + end. -(** ** Testing universal or existential properties. *) + (** ** Testing universal or existential properties. *) -(** We do not use the standard boolean operators of Coq, + (** We do not use the standard boolean operators of Coq, but lazy ones. *) -Fixpoint for_all (f:elt->bool) s := match s with - | Leaf => true - | Node _ l x r => f x &&& for_all f l &&& for_all f r -end. + Fixpoint for_all (f:elt->bool) s := match s with + | Leaf => true + | Node _ l x r => f x &&& for_all f l &&& for_all f r + end. -Fixpoint exists_ (f:elt->bool) s := match s with - | Leaf => false - | Node _ l x r => f x ||| exists_ f l ||| exists_ f r -end. + Fixpoint exists_ (f:elt->bool) s := match s with + | Leaf => false + | Node _ l x r => f x ||| exists_ f l ||| exists_ f r + end. -(** ** Comparison of trees *) + (** ** Comparison of trees *) -(** The algorithm here has been suggested by Xavier Leroy, + (** The algorithm here has been suggested by Xavier Leroy, and transformed into c.p.s. by Benjamin Grégoire. The original ocaml code (with non-structural recursive calls) has also been formalized (thanks to Function+measure), see @@ -166,60 +166,60 @@ end. should be almost as efficient after extraction. *) -(** Enumeration of the elements of a tree. This corresponds + (** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the literature. *) -Inductive enumeration := - | End : enumeration - | More : elt -> tree -> enumeration -> enumeration. + Inductive enumeration := + | End : enumeration + | More : elt -> tree -> enumeration -> enumeration. -(** [cons t e] adds the elements of tree [t] on the head of + (** [cons t e] adds the elements of tree [t] on the head of enumeration [e]. *) -Fixpoint cons s e : enumeration := - match s with - | Leaf => e - | Node _ l x r => cons l (More x r e) - end. - -(** One step of comparison of elements *) - -Definition compare_more x1 (cont:enumeration->comparison) e2 := - match e2 with - | End => Gt - | More x2 r2 e2 => - match X.compare x1 x2 with - | Eq => cont (cons r2 e2) - | Lt => Lt - | Gt => Gt - end - end. + Fixpoint cons s e : enumeration := + match s with + | Leaf => e + | Node _ l x r => cons l (More x r e) + end. -(** Comparison of left tree, middle element, then right tree *) + (** One step of comparison of elements *) -Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := - match s1 with - | Leaf => cont e2 - | Node _ l1 x1 r1 => - compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 - end. + Definition compare_more x1 (cont:enumeration->comparison) e2 := + match e2 with + | End => Gt + | More x2 r2 e2 => + match X.compare x1 x2 with + | Eq => cont (cons r2 e2) + | Lt => Lt + | Gt => Gt + end + end. + + (** Comparison of left tree, middle element, then right tree *) -(** Initial continuation *) + Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := + match s1 with + | Leaf => cont e2 + | Node _ l1 x1 r1 => + compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 + end. -Definition compare_end e2 := - match e2 with End => Eq | _ => Lt end. + (** Initial continuation *) -(** The complete comparison *) + Definition compare_end e2 := + match e2 with End => Eq | _ => Lt end. -Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). + (** The complete comparison *) -Definition equal s1 s2 := - match compare s1 s2 with Eq => true | _ => false end. + Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). -(** ** Subset test *) + Definition equal s1 s2 := + match compare s1 s2 with Eq => true | _ => false end. -(** In ocaml, recursive calls are made on "half-trees" such as + (** ** Subset test *) + + (** In ocaml, recursive calls are made on "half-trees" such as (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these non-structural calls, we propose here two specialized functions for these situations. This version should be almost as efficient @@ -229,38 +229,38 @@ Definition equal s1 s2 := [MSetFullAVL]. *) -Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node _ l2 x2 r2 => - match X.compare x1 x2 with - | Eq => subset_l1 l2 - | Lt => subsetl subset_l1 x1 l2 - | Gt => mem x1 r2 &&& subset_l1 s2 - end - end. - -Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node _ l2 x2 r2 => - match X.compare x1 x2 with - | Eq => subset_r1 r2 - | Lt => mem x1 l2 &&& subset_r1 s2 - | Gt => subsetr subset_r1 x1 r2 - end - end. - -Fixpoint subset s1 s2 : bool := match s1, s2 with - | Leaf, _ => true - | Node _ _ _ _, Leaf => false - | Node _ l1 x1 r1, Node _ l2 x2 r2 => - match X.compare x1 x2 with - | Eq => subset l1 l2 &&& subset r1 r2 - | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 - | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 - end - end. + Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node _ l2 x2 r2 => + match X.compare x1 x2 with + | Eq => subset_l1 l2 + | Lt => subsetl subset_l1 x1 l2 + | Gt => mem x1 r2 &&& subset_l1 s2 + end + end. + + Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node _ l2 x2 r2 => + match X.compare x1 x2 with + | Eq => subset_r1 r2 + | Lt => mem x1 l2 &&& subset_r1 s2 + | Gt => subsetr subset_r1 x1 r2 + end + end. + + Fixpoint subset s1 s2 : bool := match s1, s2 with + | Leaf, _ => true + | Node _ _ _ _, Leaf => false + | Node _ l1 x1 r1, Node _ l2 x2 r2 => + match X.compare x1 x2 with + | Eq => subset l1 l2 &&& subset r1 r2 + | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 + | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 + end + end. End Ops. @@ -268,902 +268,902 @@ End Ops. Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info). -(** ** Occurrence in a tree *) + (** ** Occurrence in a tree *) -Inductive InT (x : elt) : tree -> Prop := - | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r) - | InLeft : forall c l r y, InT x l -> InT x (Node c l y r) - | InRight : forall c l r y, InT x r -> InT x (Node c l y r). + Inductive InT (x : elt) : tree -> Prop := + | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r) + | InLeft : forall c l r y, InT x l -> InT x (Node c l y r) + | InRight : forall c l r y, InT x r -> InT x (Node c l y r). -Definition In := InT. + Definition In := InT. -(** ** Some shortcuts *) + (** ** Some shortcuts *) -Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. -Definition Subset s s' := forall a : elt, InT a s -> InT a s'. -Definition Empty s := forall a : elt, ~ InT a s. -Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. -Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. + Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. + Definition Subset s s' := forall a : elt, InT a s -> InT a s'. + Definition Empty s := forall a : elt, ~ InT a s. + Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. -(** ** Binary search trees *) + (** ** Binary search trees *) -(** [lt_tree x s]: all elements in [s] are smaller than [x] + (** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) -Definition lt_tree x s := forall y, InT y s -> X.lt y x. -Definition gt_tree x s := forall y, InT y s -> X.lt x y. + Definition lt_tree x s := forall y, InT y s -> X.lt y x. + Definition gt_tree x s := forall y, InT y s -> X.lt x y. -(** [bst t] : [t] is a binary search tree *) + (** [bst t] : [t] is a binary search tree *) -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : forall c x l r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (Node c l x r). + Inductive bst : tree -> Prop := + | BSLeaf : bst Leaf + | BSNode : forall c x l r, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (Node c l x r). -(** [bst] is the (decidable) invariant our trees will have to satisfy. *) + (** [bst] is the (decidable) invariant our trees will have to satisfy. *) -Definition IsOk := bst. + Definition IsOk := bst. -Class Ok (s:tree) : Prop := ok : bst s. + Class Ok (s:tree) : Prop := ok : bst s. -#[global] -Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }. + #[global] + Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }. -Fixpoint ltb_tree x s := - match s with - | Leaf => true - | Node _ l y r => - match X.compare x y with - | Gt => ltb_tree x l && ltb_tree x r - | _ => false - end - end. - -Fixpoint gtb_tree x s := - match s with - | Leaf => true - | Node _ l y r => - match X.compare x y with - | Lt => gtb_tree x l && gtb_tree x r - | _ => false - end - end. + Fixpoint ltb_tree x s := + match s with + | Leaf => true + | Node _ l y r => + match X.compare x y with + | Gt => ltb_tree x l && ltb_tree x r + | _ => false + end + end. -Fixpoint isok s := - match s with - | Leaf => true - | Node _ l x r => isok l && isok r && ltb_tree x l && gtb_tree x r - end. + Fixpoint gtb_tree x s := + match s with + | Leaf => true + | Node _ l y r => + match X.compare x y with + | Lt => gtb_tree x l && gtb_tree x r + | _ => false + end + end. + Fixpoint isok s := + match s with + | Leaf => true + | Node _ l x r => isok l && isok r && ltb_tree x l && gtb_tree x r + end. -(** ** Known facts about ordered types *) -Module Import MX := OrderedTypeFacts X. + (** ** Known facts about ordered types *) -(** ** Automation and dedicated tactics *) + Module Import MX := OrderedTypeFacts X. -Scheme tree_ind := Induction for tree Sort Prop. -Scheme bst_ind := Induction for bst Sort Prop. + (** ** Automation and dedicated tactics *) -#[local] Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. -#[local] Hint Immediate MX.eq_sym : core. -#[local] Hint Unfold In lt_tree gt_tree : core. -#[local] Hint Constructors InT bst : core. -#[local] Hint Unfold Ok : core. + Scheme tree_ind := Induction for tree Sort Prop. + Scheme bst_ind := Induction for bst Sort Prop. -(** Automatic treatment of [Ok] hypothesis *) + #[local] Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. + #[local] Hint Immediate MX.eq_sym : core. + #[local] Hint Unfold In lt_tree gt_tree : core. + #[local] Hint Constructors InT bst : core. + #[local] Hint Unfold Ok : core. -Ltac clear_inversion H := inversion H; clear H; subst. + (** Automatic treatment of [Ok] hypothesis *) -Ltac inv_ok := match goal with - | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok - | H:Ok Leaf |- _ => clear H; inv_ok - | H:bst ?x |- _ => change (Ok x) in H; inv_ok - | _ => idtac -end. + Ltac clear_inversion H := inversion H; clear H; subst. -(** A tactic to repeat [inversion_clear] on all hyps of the + Ltac inv_ok := match goal with + | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok + | H:Ok Leaf |- _ => clear H; inv_ok + | H:bst ?x |- _ => change (Ok x) in H; inv_ok + | _ => idtac + end. + + (** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node _ _ _ _))] *) -Ltac is_tree_constr c := - match c with - | Leaf => idtac - | Node _ _ _ _ => idtac - | _ => fail - end. + Ltac is_tree_constr c := + match c with + | Leaf => idtac + | Node _ _ _ _ => idtac + | _ => fail + end. + + Ltac invtree f := + match goal with + | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f + | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f + | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f + | _ => idtac + end. -Ltac invtree f := - match goal with - | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f - | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f - | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f - | _ => idtac + Ltac inv := inv_ok; invtree InT. + + Ltac intuition_in := repeat (intuition auto; inv). + + (** Helper tactic concerning order of elements. *) + + Ltac order := match goal with + | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | _ => MX.order end. -Ltac inv := inv_ok; invtree InT. - -Ltac intuition_in := repeat (intuition auto; inv). - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order - | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order - | _ => MX.order -end. - - -(** [isok] is indeed a decision procedure for [Ok] *) - -Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. -Proof. - induction s as [|c l IHl y r IHr]; simpl. - - unfold lt_tree; intuition_in. - - elim_compare x y. - + split; intros; try discriminate. assert (X.lt y x) by auto. order. - + split; intros; try discriminate. assert (X.lt y x) by auto. order. - + rewrite !andb_true_iff, <-IHl, <-IHr. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. -Proof. - induction s as [|c l IHl y r IHr]; simpl. - - unfold gt_tree; intuition_in. - - elim_compare x y. - + split; intros; try discriminate. assert (X.lt x y) by auto. order. - + rewrite !andb_true_iff, <-IHl, <-IHr. - unfold gt_tree; intuition_in; order. - + split; intros; try discriminate. assert (X.lt x y) by auto. order. -Qed. - -Lemma isok_iff : forall s, Ok s <-> isok s = true. -Proof. - induction s as [|c l IHl y r IHr]; simpl. - - intuition_in. - - rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. - intuition_in. -Qed. - -#[global] -Instance isok_Ok s : isok s = true -> Ok s | 10. -Proof. intros; apply <- isok_iff; auto. Qed. - -(** ** Basic results about [In] *) - -Lemma In_1 : - forall s x y, X.eq x y -> InT x s -> InT y s. -Proof. - induction s; simpl; intuition_in; eauto. -Qed. -#[local] Hint Immediate In_1 : core. - -#[global] -Instance In_compat : Proper (X.eq==>eq==>iff) InT. -Proof. -apply proper_sym_impl_iff_2; auto with *. -repeat red; intros; subst. apply In_1 with x; auto. -Qed. - -Lemma In_node_iff : - forall c l x r y, - InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r. -Proof. - intuition_in. -Qed. - -Lemma In_leaf_iff : forall x, InT x Leaf <-> False. -Proof. - intuition_in. -Qed. - -(** Results about [lt_tree] and [gt_tree] *) - -Lemma lt_leaf : forall x : elt, lt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma gt_leaf : forall x : elt, gt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma lt_tree_node : - forall (x y : elt) (l r : tree) (i : Info.t), - lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r). -Proof. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gt_tree_node : - forall (x y : elt) (l r : tree) (i : Info.t), - gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r). -Proof. - unfold gt_tree; intuition_in; order. -Qed. - -#[local] Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. - -Lemma lt_tree_not_in : - forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. -Proof. - intros; intro; order. -Qed. - -Lemma lt_tree_trans : - forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. -Proof. - eauto. -Qed. - -Lemma gt_tree_not_in : - forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. -Proof. - intros; intro; order. -Qed. - -Lemma gt_tree_trans : - forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. -Proof. - eauto. -Qed. - -#[global] -Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree. -Proof. - apply proper_sym_impl_iff_2; auto. - intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. -Qed. - -#[global] -Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree. -Proof. - apply proper_sym_impl_iff_2; auto. - intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. -Qed. - -#[local] Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. - -Ltac induct s x := - induction s as [|i l IHl x' r IHr]; simpl; intros; - [|elim_compare x x'; intros; inv]. - -Ltac auto_tc := auto with typeclass_instances. - -Ltac ok := - inv; change bst with Ok in *; - match goal with - | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok - | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok - | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok - | _ => eauto with typeclass_instances - end. - -(** ** Empty set *) - -Lemma empty_spec : Empty empty. -Proof. - intros x H. inversion H. -Qed. - -#[global] -Instance empty_ok : Ok empty. -Proof. - auto. -Qed. - -(** ** Emptyness test *) - -Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. -Proof. - destruct s as [|c r x l]; simpl; auto. - - split; auto. intros _ x H. inv. - - split; auto. - + try discriminate. - + intro H; elim (H x); auto. -Qed. - -(** ** Membership *) - -Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. -Proof. - split. - - induct s x; now auto. - - induct s x; intuition_in; order. -Qed. - -(** ** Minimal and maximal elements *) - -Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s. -Proof. -induction s as [|t1 [|] IHs1 y s2 IHs2]; simpl; auto; inversion 1; auto. -Qed. - -Lemma min_elt_spec2 s x y `{Ok s} : - min_elt s = Some x -> InT y s -> ~ X.lt y x. -Proof. -revert x y; induction H as [|? z l r Hl IHl Hr IHr Hlt Hgt]; simpl in *; [discriminate|]. -intros x y He Hi; apply In_node_iff in Hi. -destruct l as [|t l1 w l2]. -+ intros; replace z with x in * by congruence. - destruct Hi as [Hi|[Hi|Hi]]; try order. - apply In_leaf_iff in Hi; contradiction. -+ destruct Hi as [Hi|[Hi|Hi]]. - - apply IHl; assumption. - - intros H; eapply lt_tree_trans in Hlt; [|rewrite <- Hi; eassumption]. - apply min_elt_spec1 in He; apply lt_tree_not_in in Hlt; contradiction. - - intros H. - apply min_elt_spec1, Hlt in He. - elim (gt_tree_not_in y r); [|assumption]. - eapply gt_tree_trans; [|exact Hgt]; order. -Qed. - -Lemma min_elt_spec3 s : min_elt s = None -> Empty s. -Proof. -induction s as [|t1 s1 IHs1 x s2 IHs2]; simpl in *; intros H. -+ inversion 1. -+ destruct s1 as [|? ? y]; [congruence|]. - destruct (IHs1 H y); auto. -Qed. - -Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s. -Proof. -induction s as [|t1 s1 IHs1 y [|] IHs2]; simpl in *; intros H; [congruence| |auto]. -replace y with x by congruence; auto. -Qed. - -Lemma max_elt_spec2 s x y `{Ok s} : - max_elt s = Some x -> InT y s -> ~ X.lt x y. -Proof. -revert x y; induction H as [|? z l r Hl IHl Hr IHr Hlt Hgt]; simpl in *; [discriminate|]. -intros x y He Hi; apply In_node_iff in Hi. -destruct r as [|t l1 w l2]. -+ intros; replace z with x in * by congruence. - destruct Hi as [Hi|[Hi|Hi]]; try order. - apply In_leaf_iff in Hi; contradiction. -+ destruct Hi as [Hi|[Hi|Hi]]. - - intros H. - apply max_elt_spec1, Hgt in He. - elim (lt_tree_not_in y l); [|assumption]. - eapply lt_tree_trans; [|exact Hlt]; order. - - intros H; eapply gt_tree_trans in Hgt; [|rewrite <- Hi; eassumption]. - apply max_elt_spec1 in He; apply gt_tree_not_in in Hgt; contradiction. - - apply IHr; assumption. -Qed. - -Lemma max_elt_spec3 s : max_elt s = None -> Empty s. -Proof. -induction s as [|t1 s1 IHs1 x s2 IHs2]; simpl in *; intros H. -+ inversion 1. -+ destruct s2 as [|? ? y]; [congruence|]. - destruct (IHs2 H y); auto. -Qed. - -Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. -Proof. - exact min_elt_spec1. -Qed. - -Lemma choose_spec2 : forall s, choose s = None -> Empty s. -Proof. - exact min_elt_spec3. -Qed. - -Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, - choose s = Some x -> choose s' = Some x' -> - Equal s s' -> X.eq x x'. -Proof. - unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. - assert (~X.lt x x'). { - apply min_elt_spec2 with s'; auto. - rewrite <-H; auto using min_elt_spec1. - } - assert (~X.lt x' x). { - apply min_elt_spec2 with s; auto. - rewrite H; auto using min_elt_spec1. - } - elim_compare x x'; intuition. -Qed. - -(** ** Elements *) - -Lemma elements_spec1' : forall s acc x, - InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. -Proof. - induction s as [ | c l Hl x r Hr ]; simpl; auto. - - intuition. - inversion H0. - - intros. - rewrite Hl. - destruct (Hr acc x0); clear Hl Hr. - intuition; inversion_clear H3; intuition. -Qed. - -Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. -Proof. - intros; generalize (elements_spec1' s nil x); intuition. - inversion_clear H0. -Qed. - -Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> - (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> - sort X.lt (elements_aux acc s). -Proof. - induction s as [ | c l Hl y r Hr]; simpl; intuition. - inv. - apply Hl; auto. - - constructor. - + apply Hr; auto. - + eapply InA_InfA; eauto with *. - intros. - destruct (elements_spec1' r acc y0); intuition. - - intros. - inversion_clear H. - + order. - + destruct (elements_spec1' r acc x); intuition eauto. -Qed. - -Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). -Proof. - intros; unfold elements; apply elements_spec2'; auto. - intros; inversion H0. -Qed. -#[local] Hint Resolve elements_spec2 : core. - -Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). -Proof. - intros. eapply SortA_NoDupA; eauto with *. -Qed. - -Lemma elements_aux_cardinal : - forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). -Proof. - simple induction s; simpl; intuition. - rewrite <- H. - simpl. - rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)). - now rewrite <- Nat.add_succ_r, Nat.add_assoc. -Qed. - -Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). -Proof. - exact (fun s => elements_aux_cardinal s nil). -Qed. - -Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s. - -Lemma elements_app : - forall s acc, elements_aux acc s = elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold elements; simpl. - rewrite 2 IHs1, IHs2, !app_nil_r, <- !app_assoc; auto. -Qed. - -Lemma elements_node c l x r : - elements (Node c l x r) = elements l ++ x :: elements r. -Proof. - unfold elements; simpl. - now rewrite !elements_app, !app_nil_r. -Qed. - -Lemma rev_elements_app : - forall s acc, rev_elements_aux acc s = rev_elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold rev_elements; simpl. - rewrite IHs1, 2 IHs2, !app_nil_r, <- !app_assoc; auto. -Qed. - -Lemma rev_elements_node c l x r : - rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l. -Proof. - unfold rev_elements; simpl. - now rewrite !rev_elements_app, !app_nil_r. -Qed. - -Lemma rev_elements_rev s : rev_elements s = rev (elements s). -Proof. - induction s as [|c l IHl x r IHr]; trivial. - rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr. - simpl. now rewrite <- !app_assoc. -Qed. - -(** The converse of [elements_spec2], used in MSetRBT *) - -(* TODO: TO MIGRATE ELSEWHERE... *) - -Lemma sorted_app_inv l1 l2 : - sort X.lt (l1++l2) -> - sort X.lt l1 /\ sort X.lt l2 /\ - forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2. -Proof. - induction l1 as [|a1 l1 IHl1]. - - simpl; repeat split; auto. - intros. now rewrite InA_nil in *. - - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ]. - destruct (IHl1 Hs) as (H1 & H2 & H3). - repeat split. - * constructor; auto. - destruct l1; simpl in *; auto; inversion_clear Hhd; auto. - * trivial. - * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1. - + rewrite H. - apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc. - rewrite InA_app_iff; auto_tc. - + auto. -Qed. - -Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s. -Proof. - induction s as [|c l IHl x r IHr]. - - auto. - - rewrite elements_node. - intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3). - inversion_clear H2. - constructor; ok. - * intros y Hy. apply H3. - + now rewrite elements_spec1. - + rewrite InA_cons. now left. - * intros y Hy. - apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc. - now rewrite elements_spec1. -Qed. - -(** ** [for_all] and [exists] *) - -Lemma for_all_spec s f : Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). -Proof. - intros Hf; unfold For_all. - induction s as [|i l IHl x r IHr]; simpl; auto. - - split; intros; inv; auto. - - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr. - intuition_in. eauto. -Qed. - -Lemma exists_spec s f : Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). -Proof. - intros Hf; unfold Exists. - induction s as [|i l IHl x r IHr]; simpl; auto. - - split. - * discriminate. - * intros (y,(H,_)); inv. - - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr. - split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))]. - * exists x; auto. - * exists y; auto. - * exists y; auto. - * inv; [left;left|left;right|right]; try (exists y); eauto. -Qed. - -(** ** Fold *) - -Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) : - fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). -Proof. - revert i acc. - induction s as [|c l IHl x r IHr]; simpl; intros; auto. - rewrite IHl. - simpl. unfold flip at 2. - apply IHr. -Qed. - -Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) : - fold f s i = fold_left (flip f) (elements s) i. -Proof. - revert i. unfold elements. - induction s as [|c l IHl x r IHr]; simpl; intros; auto. - rewrite fold_spec'. - rewrite IHr. - simpl; auto. -Qed. - - -(** ** Subset *) - -Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2 - `{Ok (Node c1 l1 x1 Leaf), Ok s2}, - (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> - (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ). -Proof. - induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. - - unfold Subset; intuition; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - - specialize (IHl2 H). - specialize (IHr2 H). - inv. - elim_compare x1 x2. - - + rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (X.eq a x2) by order; intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite IHl2 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. - * rewrite mem_spec; auto. - assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. -Qed. - - -Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2, - bst (Node c1 Leaf x1 r1) -> bst s2 -> - (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> - (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2). -Proof. - induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. - - unfold Subset; intuition; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - - specialize (IHl2 H). - specialize (IHr2 H). - inv. - elim_compare x1 x2. - - + rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (X.eq a x2) by order; intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. - * rewrite mem_spec; auto. - assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite IHr2 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. -Qed. - -Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, - (subset s1 s2 = true <-> Subset s1 s2). -Proof. - induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros. - - unfold Subset; intuition_in. - - destruct s2 as [|c2 l2 x2 r2]; simpl; intros. - + unfold Subset; intuition_in; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - + inv. - elim_compare x1 x2. - - * rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - -- assert (X.eq a x2) by order; intuition_in. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - * rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. - rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - * rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. - rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. -Qed. - - -(** ** Comparison *) - -(** Relations [eq] and [lt] over trees *) - -Module L := MSetInterface.MakeListOrdering X. - -Definition eq := Equal. -#[global] -Instance eq_equiv : Equivalence eq. -Proof. firstorder. Qed. - -Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). -Proof. - unfold eq, Equal, L.eq; intros. - setoid_rewrite elements_spec1. - firstorder. -Qed. - -Definition lt (s1 s2 : tree) : Prop := - exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' - /\ L.lt (elements s1') (elements s2'). - -Declare Equivalent Keys L.eq equivlistA. - -#[global] -Instance lt_strorder : StrictOrder lt. -Proof. - split. - - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). - assert (eqlistA X.eq (elements s1) (elements s2)). - + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. - rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. - + rewrite H in L. - apply (StrictOrder_Irreflexive (elements s2)); auto. - - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) - (s2'' & s3' & B2' & B3 & E2' & E3 & L23). - exists s1', s3'; do 4 (split; trivial). - assert (eqlistA X.eq (elements s2') (elements s2'')). - + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. - rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. - + transitivity (elements s2'); auto. - rewrite H; auto. -Qed. - -#[global] -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. - intros s1 s2 E12 s3 s4 E34. split. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s1; auto. symmetry; auto. - + split; auto. transitivity s3; auto. symmetry; auto. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s2; auto. - + split; auto. transitivity s4; auto. -Qed. - - -(** Proof of the comparison algorithm *) - -(** [flatten_e e] returns the list of elements of [e] i.e. the list + + (** [isok] is indeed a decision procedure for [Ok] *) + + Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. + Proof. + induction s as [|c l IHl y r IHr]; simpl. + - unfold lt_tree; intuition_in. + - elim_compare x y. + + split; intros; try discriminate. assert (X.lt y x) by auto. order. + + split; intros; try discriminate. assert (X.lt y x) by auto. order. + + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold lt_tree; intuition_in; order. + Qed. + + Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. + Proof. + induction s as [|c l IHl y r IHr]; simpl. + - unfold gt_tree; intuition_in. + - elim_compare x y. + + split; intros; try discriminate. assert (X.lt x y) by auto. order. + + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold gt_tree; intuition_in; order. + + split; intros; try discriminate. assert (X.lt x y) by auto. order. + Qed. + + Lemma isok_iff : forall s, Ok s <-> isok s = true. + Proof. + induction s as [|c l IHl y r IHr]; simpl. + - intuition_in. + - rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. + intuition_in. + Qed. + + #[global] + Instance isok_Ok s : isok s = true -> Ok s | 10. + Proof. intros; apply <- isok_iff; auto. Qed. + + (** ** Basic results about [In] *) + + Lemma In_1 : + forall s x y, X.eq x y -> InT x s -> InT y s. + Proof. + induction s; simpl; intuition_in; eauto. + Qed. + #[local] Hint Immediate In_1 : core. + + #[global] + Instance In_compat : Proper (X.eq==>eq==>iff) InT. + Proof. + apply proper_sym_impl_iff_2; auto with *. + repeat red; intros; subst. apply In_1 with x; auto. + Qed. + + Lemma In_node_iff : + forall c l x r y, + InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r. + Proof. + intuition_in. + Qed. + + Lemma In_leaf_iff : forall x, InT x Leaf <-> False. + Proof. + intuition_in. + Qed. + + (** Results about [lt_tree] and [gt_tree] *) + + Lemma lt_leaf : forall x : elt, lt_tree x Leaf. + Proof. + red; inversion 1. + Qed. + + Lemma gt_leaf : forall x : elt, gt_tree x Leaf. + Proof. + red; inversion 1. + Qed. + + Lemma lt_tree_node : + forall (x y : elt) (l r : tree) (i : Info.t), + lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r). + Proof. + unfold lt_tree; intuition_in; order. + Qed. + + Lemma gt_tree_node : + forall (x y : elt) (l r : tree) (i : Info.t), + gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r). + Proof. + unfold gt_tree; intuition_in; order. + Qed. + + #[local] Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. + + Lemma lt_tree_not_in : + forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. + Proof. + intros; intro; order. + Qed. + + Lemma lt_tree_trans : + forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. + Proof. + eauto. + Qed. + + Lemma gt_tree_not_in : + forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. + Proof. + intros; intro; order. + Qed. + + Lemma gt_tree_trans : + forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. + Proof. + eauto. + Qed. + + #[global] + Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree. + Proof. + apply proper_sym_impl_iff_2; auto. + intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. + Qed. + + #[global] + Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree. + Proof. + apply proper_sym_impl_iff_2; auto. + intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. + Qed. + + #[local] Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. + + Ltac induct s x := + induction s as [|i l IHl x' r IHr]; simpl; intros; + [|elim_compare x x'; intros; inv]. + + Ltac auto_tc := auto with typeclass_instances. + + Ltac ok := + inv; change bst with Ok in *; + match goal with + | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok + | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok + | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok + | _ => eauto with typeclass_instances + end. + + (** ** Empty set *) + + Lemma empty_spec : Empty empty. + Proof. + intros x H. inversion H. + Qed. + + #[global] + Instance empty_ok : Ok empty. + Proof. + auto. + Qed. + + (** ** Emptyness test *) + + Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. + Proof. + destruct s as [|c r x l]; simpl; auto. + - split; auto. intros _ x H. inv. + - split; auto. + + try discriminate. + + intro H; elim (H x); auto. + Qed. + + (** ** Membership *) + + Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. + Proof. + split. + - induct s x; now auto. + - induct s x; intuition_in; order. + Qed. + + (** ** Minimal and maximal elements *) + + Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s. + Proof. + induction s as [|t1 [|] IHs1 y s2 IHs2]; simpl; auto; inversion 1; auto. + Qed. + + Lemma min_elt_spec2 s x y `{Ok s} : + min_elt s = Some x -> InT y s -> ~ X.lt y x. + Proof. + revert x y; induction H as [|? z l r Hl IHl Hr IHr Hlt Hgt]; simpl in *; [discriminate|]. + intros x y He Hi; apply In_node_iff in Hi. + destruct l as [|t l1 w l2]. + + intros; replace z with x in * by congruence. + destruct Hi as [Hi|[Hi|Hi]]; try order. + apply In_leaf_iff in Hi; contradiction. + + destruct Hi as [Hi|[Hi|Hi]]. + - apply IHl; assumption. + - intros H; eapply lt_tree_trans in Hlt; [|rewrite <- Hi; eassumption]. + apply min_elt_spec1 in He; apply lt_tree_not_in in Hlt; contradiction. + - intros H. + apply min_elt_spec1, Hlt in He. + elim (gt_tree_not_in y r); [|assumption]. + eapply gt_tree_trans; [|exact Hgt]; order. + Qed. + + Lemma min_elt_spec3 s : min_elt s = None -> Empty s. + Proof. + induction s as [|t1 s1 IHs1 x s2 IHs2]; simpl in *; intros H. + + inversion 1. + + destruct s1 as [|? ? y]; [congruence|]. + destruct (IHs1 H y); auto. + Qed. + + Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s. + Proof. + induction s as [|t1 s1 IHs1 y [|] IHs2]; simpl in *; intros H; [congruence| |auto]. + replace y with x by congruence; auto. + Qed. + + Lemma max_elt_spec2 s x y `{Ok s} : + max_elt s = Some x -> InT y s -> ~ X.lt x y. + Proof. + revert x y; induction H as [|? z l r Hl IHl Hr IHr Hlt Hgt]; simpl in *; [discriminate|]. + intros x y He Hi; apply In_node_iff in Hi. + destruct r as [|t l1 w l2]. + + intros; replace z with x in * by congruence. + destruct Hi as [Hi|[Hi|Hi]]; try order. + apply In_leaf_iff in Hi; contradiction. + + destruct Hi as [Hi|[Hi|Hi]]. + - intros H. + apply max_elt_spec1, Hgt in He. + elim (lt_tree_not_in y l); [|assumption]. + eapply lt_tree_trans; [|exact Hlt]; order. + - intros H; eapply gt_tree_trans in Hgt; [|rewrite <- Hi; eassumption]. + apply max_elt_spec1 in He; apply gt_tree_not_in in Hgt; contradiction. + - apply IHr; assumption. + Qed. + + Lemma max_elt_spec3 s : max_elt s = None -> Empty s. + Proof. + induction s as [|t1 s1 IHs1 x s2 IHs2]; simpl in *; intros H. + + inversion 1. + + destruct s2 as [|? ? y]; [congruence|]. + destruct (IHs2 H y); auto. + Qed. + + Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. + Proof. + exact min_elt_spec1. + Qed. + + Lemma choose_spec2 : forall s, choose s = None -> Empty s. + Proof. + exact min_elt_spec3. + Qed. + + Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some x' -> + Equal s s' -> X.eq x x'. + Proof. + unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. + assert (~X.lt x x'). { + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + } + assert (~X.lt x' x). { + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + } + elim_compare x x'; intuition. + Qed. + + (** ** Elements *) + + Lemma elements_spec1' : forall s acc x, + InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. + Proof. + induction s as [ | c l Hl x r Hr ]; simpl; auto. + - intuition. + inversion H0. + - intros. + rewrite Hl. + destruct (Hr acc x0); clear Hl Hr. + intuition; inversion_clear H3; intuition. + Qed. + + Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. + Proof. + intros; generalize (elements_spec1' s nil x); intuition. + inversion_clear H0. + Qed. + + Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> + (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> + sort X.lt (elements_aux acc s). + Proof. + induction s as [ | c l Hl y r Hr]; simpl; intuition. + inv. + apply Hl; auto. + - constructor. + + apply Hr; auto. + + eapply InA_InfA; eauto with *. + intros. + destruct (elements_spec1' r acc y0); intuition. + - intros. + inversion_clear H. + + order. + + destruct (elements_spec1' r acc x); intuition eauto. + Qed. + + Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). + Proof. + intros; unfold elements; apply elements_spec2'; auto. + intros; inversion H0. + Qed. + #[local] Hint Resolve elements_spec2 : core. + + Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). + Proof. + intros. eapply SortA_NoDupA; eauto with *. + Qed. + + Lemma elements_aux_cardinal : + forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). + Proof. + simple induction s; simpl; intuition. + rewrite <- H. + simpl. + rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)). + now rewrite <- Nat.add_succ_r, Nat.add_assoc. + Qed. + + Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). + Proof. + exact (fun s => elements_aux_cardinal s nil). + Qed. + + Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s. + + Lemma elements_app : + forall s acc, elements_aux acc s = elements s ++ acc. + Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold elements; simpl. + rewrite 2 IHs1, IHs2, !app_nil_r, <- !app_assoc; auto. + Qed. + + Lemma elements_node c l x r : + elements (Node c l x r) = elements l ++ x :: elements r. + Proof. + unfold elements; simpl. + now rewrite !elements_app, !app_nil_r. + Qed. + + Lemma rev_elements_app : + forall s acc, rev_elements_aux acc s = rev_elements s ++ acc. + Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold rev_elements; simpl. + rewrite IHs1, 2 IHs2, !app_nil_r, <- !app_assoc; auto. + Qed. + + Lemma rev_elements_node c l x r : + rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l. + Proof. + unfold rev_elements; simpl. + now rewrite !rev_elements_app, !app_nil_r. + Qed. + + Lemma rev_elements_rev s : rev_elements s = rev (elements s). + Proof. + induction s as [|c l IHl x r IHr]; trivial. + rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr. + simpl. now rewrite <- !app_assoc. + Qed. + + (** The converse of [elements_spec2], used in MSetRBT *) + + (* TODO: TO MIGRATE ELSEWHERE... *) + + Lemma sorted_app_inv l1 l2 : + sort X.lt (l1++l2) -> + sort X.lt l1 /\ sort X.lt l2 /\ + forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2. + Proof. + induction l1 as [|a1 l1 IHl1]. + - simpl; repeat split; auto. + intros. now rewrite InA_nil in *. + - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ]. + destruct (IHl1 Hs) as (H1 & H2 & H3). + repeat split. + * constructor; auto. + destruct l1; simpl in *; auto; inversion_clear Hhd; auto. + * trivial. + * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1. + + rewrite H. + apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc. + rewrite InA_app_iff; auto_tc. + + auto. + Qed. + + Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s. + Proof. + induction s as [|c l IHl x r IHr]. + - auto. + - rewrite elements_node. + intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3). + inversion_clear H2. + constructor; ok. + * intros y Hy. apply H3. + + now rewrite elements_spec1. + + rewrite InA_cons. now left. + * intros y Hy. + apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc. + now rewrite elements_spec1. + Qed. + + (** ** [for_all] and [exists] *) + + Lemma for_all_spec s f : Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + intros Hf; unfold For_all. + induction s as [|i l IHl x r IHr]; simpl; auto. + - split; intros; inv; auto. + - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr. + intuition_in. eauto. + Qed. + + Lemma exists_spec s f : Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + intros Hf; unfold Exists. + induction s as [|i l IHl x r IHr]; simpl; auto. + - split. + * discriminate. + * intros (y,(H,_)); inv. + - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr. + split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))]. + * exists x; auto. + * exists y; auto. + * exists y; auto. + * inv; [left;left|left;right|right]; try (exists y); eauto. + Qed. + + (** ** Fold *) + + Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) : + fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). + Proof. + revert i acc. + induction s as [|c l IHl x r IHr]; simpl; intros; auto. + rewrite IHl. + simpl. unfold flip at 2. + apply IHr. + Qed. + + Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) : + fold f s i = fold_left (flip f) (elements s) i. + Proof. + revert i. unfold elements. + induction s as [|c l IHl x r IHr]; simpl; intros; auto. + rewrite fold_spec'. + rewrite IHr. + simpl; auto. + Qed. + + + (** ** Subset *) + + Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2 + `{Ok (Node c1 l1 x1 Leaf), Ok s2}, + (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> + (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ). + Proof. + induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. + - unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + - specialize (IHl2 H). + specialize (IHr2 H). + inv. + elim_compare x1 x2. + + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + * assert (X.eq a x2) by order; intuition_in. + * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + + rewrite IHl2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + * constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + * rewrite mem_spec; auto. + assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. + Qed. + + + Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2, + bst (Node c1 Leaf x1 r1) -> bst s2 -> + (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> + (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2). + Proof. + induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. + - unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + - specialize (IHl2 H). + specialize (IHr2 H). + inv. + elim_compare x1 x2. + + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + * assert (X.eq a x2) by order; intuition_in. + * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + * constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + * rewrite mem_spec; auto. + assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + + rewrite IHr2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + Qed. + + Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, + (subset s1 s2 = true <-> Subset s1 s2). + Proof. + induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros. + - unfold Subset; intuition_in. + - destruct s2 as [|c2 l2 x2 r2]; simpl; intros. + + unfold Subset; intuition_in; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + + inv. + elim_compare x1 x2. + + * rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + -- assert (X.eq a x2) by order; intuition_in. + -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + * rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. + rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + * rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. + rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + Qed. + + + (** ** Comparison *) + + (** Relations [eq] and [lt] over trees *) + + Module L := MSetInterface.MakeListOrdering X. + + Definition eq := Equal. + #[global] + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). + Proof. + unfold eq, Equal, L.eq; intros. + setoid_rewrite elements_spec1. + firstorder. + Qed. + + Definition lt (s1 s2 : tree) : Prop := + exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' + /\ L.lt (elements s1') (elements s2'). + + Declare Equivalent Keys L.eq equivlistA. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + assert (eqlistA X.eq (elements s1) (elements s2)). + + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. + + rewrite H in L. + apply (StrictOrder_Irreflexive (elements s2)); auto. + - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'; do 4 (split; trivial). + assert (eqlistA X.eq (elements s2') (elements s2'')). + + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. + + transitivity (elements s2'); auto. + rewrite H; auto. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros s1 s2 E12 s3 s4 E34. split. + - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. + + transitivity s1; auto. symmetry; auto. + + split; auto. transitivity s3; auto. symmetry; auto. + - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. + + transitivity s2; auto. + + split; auto. transitivity s4; auto. + Qed. + + + (** Proof of the comparison algorithm *) + + (** [flatten_e e] returns the list of elements of [e] i.e. the list of elements actually compared *) -Fixpoint flatten_e (e : enumeration) : list elt := match e with - | End => nil - | More x t r => x :: elements t ++ flatten_e r - end. - -Lemma flatten_e_elements : - forall l x r c e, - elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e. -Proof. - intros. now rewrite elements_node, <- app_assoc. -Qed. - -Lemma cons_1 : forall s e, - flatten_e (cons s e) = elements s ++ flatten_e e. -Proof. - induction s; simpl; auto; intros. - rewrite IHs1; apply flatten_e_elements. -Qed. - -(** Correctness of this comparison *) - -Definition Cmp c x y := CompSpec L.eq L.lt x y c. - -#[local] Hint Unfold Cmp flip : core. - -Lemma compare_end_Cmp : - forall e2, Cmp (compare_end e2) nil (flatten_e e2). -Proof. - destruct e2; simpl; constructor; auto. reflexivity. -Qed. - -Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, - Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) - (flatten_e (More x2 r2 e2)). -Proof. - simpl; intros; elim_compare x1 x2; simpl; red; auto. -Qed. - -Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). -Proof. - induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; intros; auto. - rewrite elements_node, <- app_assoc; simpl. - apply Hl1; auto. clear e2. intros [|x2 r2 e2]. - - simpl; auto. - - apply compare_more_Cmp. - rewrite <- cons_1; auto. -Qed. - -Lemma compare_Cmp : forall s1 s2, - Cmp (compare s1 s2) (elements s1) (elements s2). -Proof. - intros; unfold compare. - rewrite <- (app_nil_r (elements s1)). - replace (elements s2) with (flatten_e (cons s2 End)) by - (rewrite cons_1; simpl; rewrite app_nil_r; auto). - apply compare_cont_Cmp; auto. - intros. - apply compare_end_Cmp; auto. -Qed. - -Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, - CompSpec eq lt s1 s2 (compare s1 s2). -Proof. - intros. - destruct (compare_Cmp s1 s2); constructor. - - rewrite eq_Leq; auto. - - intros; exists s1, s2; repeat split; auto. - - intros; exists s2, s1; repeat split; auto. -Qed. - - -(** ** Equality test *) - -Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, - equal s1 s2 = true <-> eq s1 s2. -Proof. -unfold equal; intros s1 s2 B1 B2. -destruct (@compare_spec s1 s2 B1 B2) as [H|H|H]; - split; intros H'; auto; try discriminate. -- rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. -- rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. -Qed. - -(** ** A few results about [mindepth] and [maxdepth] *) - -Lemma mindepth_maxdepth s : mindepth s <= maxdepth s. -Proof. - induction s; simpl; auto. - rewrite <- Nat.succ_le_mono. - transitivity (mindepth s1). - - apply Nat.le_min_l. - - transitivity (maxdepth s1). - + trivial. - + apply Nat.le_max_l. -Qed. - -Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s). -Proof. - unfold Peano.lt. - induction s as [|c l IHl x r IHr]. - - auto. - - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. - apply Nat.add_le_mono; etransitivity; - try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. - * apply Nat.le_max_l. - * apply Nat.le_max_r. -Qed. - -Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s). -Proof. - unfold Peano.lt. - induction s as [|c l IHl x r IHr]. - - auto. - - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. - apply Nat.add_le_mono; etransitivity; - try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. - * apply Nat.le_min_l. - * apply Nat.le_min_r. -Qed. - -Lemma maxdepth_log_cardinal s : s <> Leaf -> - Nat.log2 (cardinal s) < maxdepth s. -Proof. - intros H. - apply Nat.log2_lt_pow2. - - destruct s; simpl; intuition auto with arith. - - apply maxdepth_cardinal. -Qed. - -Lemma mindepth_log_cardinal s : mindepth s <= Nat.log2 (S (cardinal s)). -Proof. - apply Nat.log2_le_pow2. - - auto with arith. - - apply mindepth_cardinal. -Qed. + Fixpoint flatten_e (e : enumeration) : list elt := match e with + | End => nil + | More x t r => x :: elements t ++ flatten_e r + end. + + Lemma flatten_e_elements : + forall l x r c e, + elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e. + Proof. + intros. now rewrite elements_node, <- app_assoc. + Qed. + + Lemma cons_1 : forall s e, + flatten_e (cons s e) = elements s ++ flatten_e e. + Proof. + induction s; simpl; auto; intros. + rewrite IHs1; apply flatten_e_elements. + Qed. + + (** Correctness of this comparison *) + + Definition Cmp c x y := CompSpec L.eq L.lt x y c. + + #[local] Hint Unfold Cmp flip : core. + + Lemma compare_end_Cmp : + forall e2, Cmp (compare_end e2) nil (flatten_e e2). + Proof. + destruct e2; simpl; constructor; auto. reflexivity. + Qed. + + Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, + Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) + (flatten_e (More x2 r2 e2)). + Proof. + simpl; intros; elim_compare x1 x2; simpl; red; auto. + Qed. + + Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, Cmp (cont e) l (flatten_e e)) -> + Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). + Proof. + induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; intros; auto. + rewrite elements_node, <- app_assoc; simpl. + apply Hl1; auto. clear e2. intros [|x2 r2 e2]. + - simpl; auto. + - apply compare_more_Cmp. + rewrite <- cons_1; auto. + Qed. + + Lemma compare_Cmp : forall s1 s2, + Cmp (compare s1 s2) (elements s1) (elements s2). + Proof. + intros; unfold compare. + rewrite <- (app_nil_r (elements s1)). + replace (elements s2) with (flatten_e (cons s2 End)) by + (rewrite cons_1; simpl; rewrite app_nil_r; auto). + apply compare_cont_Cmp; auto. + intros. + apply compare_end_Cmp; auto. + Qed. + + Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, + CompSpec eq lt s1 s2 (compare s1 s2). + Proof. + intros. + destruct (compare_Cmp s1 s2); constructor. + - rewrite eq_Leq; auto. + - intros; exists s1, s2; repeat split; auto. + - intros; exists s2, s1; repeat split; auto. + Qed. + + + (** ** Equality test *) + + Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, + equal s1 s2 = true <-> eq s1 s2. + Proof. + unfold equal; intros s1 s2 B1 B2. + destruct (@compare_spec s1 s2 B1 B2) as [H|H|H]; + split; intros H'; auto; try discriminate. + - rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. + - rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. + Qed. + + (** ** A few results about [mindepth] and [maxdepth] *) + + Lemma mindepth_maxdepth s : mindepth s <= maxdepth s. + Proof. + induction s; simpl; auto. + rewrite <- Nat.succ_le_mono. + transitivity (mindepth s1). + - apply Nat.le_min_l. + - transitivity (maxdepth s1). + + trivial. + + apply Nat.le_max_l. + Qed. + + Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s). + Proof. + unfold Peano.lt. + induction s as [|c l IHl x r IHr]. + - auto. + - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. + apply Nat.add_le_mono; etransitivity; + try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. + * apply Nat.le_max_l. + * apply Nat.le_max_r. + Qed. + + Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s). + Proof. + unfold Peano.lt. + induction s as [|c l IHl x r IHr]. + - auto. + - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. + apply Nat.add_le_mono; etransitivity; + try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. + * apply Nat.le_min_l. + * apply Nat.le_min_r. + Qed. + + Lemma maxdepth_log_cardinal s : s <> Leaf -> + Nat.log2 (cardinal s) < maxdepth s. + Proof. + intros H. + apply Nat.log2_lt_pow2. + - destruct s; simpl; intuition auto with arith. + - apply maxdepth_cardinal. + Qed. + + Lemma mindepth_log_cardinal s : mindepth s <= Nat.log2 (S (cardinal s)). + Proof. + apply Nat.log2_le_pow2. + - auto with arith. + - apply mindepth_cardinal. + Qed. End Props. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 4b08bc73cc..e0f4a56501 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -35,7 +35,7 @@ Set Implicit Arguments. Unset Strict Implicit. Module Type TypElt. - Parameters t elt : Type. + Parameters t elt : Type. End TypElt. Module Type HasWOps (Import T:TypElt). @@ -127,67 +127,67 @@ End WOps. a decidable equality. *) Module Type WSetsOn (E : DecidableType). - (** First, we ask for all the functions *) - Include WOps E. - - (** Logical predicates *) - Parameter In : elt -> t -> Prop. -#[global] - Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq : t -> t -> Prop := Equal. - Include IsEq. (** [eq] is obviously an equivalence, for subtyping only *) - Include HasEqDec. - - (** Specifications of set operators *) - - Section Spec. - Variable s s': t. - Variable x y : elt. - Variable f : elt -> bool. - Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - - Parameter mem_spec : mem x s = true <-> In x s. - Parameter equal_spec : equal s s' = true <-> s[=]s'. - Parameter subset_spec : subset s s' = true <-> s[<=]s'. - Parameter empty_spec : Empty empty. - Parameter is_empty_spec : is_empty s = true <-> Empty s. - Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s. - Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. - Parameter singleton_spec : In y (singleton x) <-> E.eq y x. - Parameter union_spec : In x (union s s') <-> In x s \/ In x s'. - Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'. - Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. - Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Parameter cardinal_spec : cardinal s = length (elements s). - Parameter filter_spec : compatb f -> - (In x (filter f s) <-> In x s /\ f x = true). - Parameter for_all_spec : compatb f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Parameter exists_spec : compatb f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Parameter partition_spec1 : compatb f -> - fst (partition f s) [=] filter f s. - Parameter partition_spec2 : compatb f -> - snd (partition f s) [=] filter (fun x => negb (f x)) s. - Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. - (** When compared with ordered sets, here comes the only + (** First, we ask for all the functions *) + Include WOps E. + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + #[global] + Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + Include IsEq. (** [eq] is obviously an equivalence, for subtyping only *) + Include HasEqDec. + + (** Specifications of set operators *) + + Section Spec. + Variable s s': t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Parameter mem_spec : mem x s = true <-> In x s. + Parameter equal_spec : equal s s' = true <-> s[=]s'. + Parameter subset_spec : subset s s' = true <-> s[<=]s'. + Parameter empty_spec : Empty empty. + Parameter is_empty_spec : is_empty s = true <-> Empty s. + Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Parameter singleton_spec : In y (singleton x) <-> E.eq y x. + Parameter union_spec : In x (union s s') <-> In x s \/ In x s'. + Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'. + Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. + Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Parameter cardinal_spec : cardinal s = length (elements s). + Parameter filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Parameter for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Parameter exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Parameter partition_spec1 : compatb f -> + fst (partition f s) [=] filter f s. + Parameter partition_spec2 : compatb f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. + (** When compared with ordered sets, here comes the only property that is really weaker: *) - Parameter elements_spec2w : NoDupA E.eq (elements s). - Parameter choose_spec1 : choose s = Some x -> In x s. - Parameter choose_spec2 : choose s = None -> Empty s. + Parameter elements_spec2w : NoDupA E.eq (elements s). + Parameter choose_spec1 : choose s = Some x -> In x s. + Parameter choose_spec2 : choose s = None -> Empty s. - End Spec. + End Spec. End WSetsOn. @@ -230,30 +230,30 @@ Module Type SetsOn (E : OrderedType). Include WSetsOn E <+ HasOrdOps <+ HasLt <+ IsStrOrder. Section Spec. - Variable s s': t. - Variable x y : elt. + Variable s s': t. + Variable x y : elt. - Parameter compare_spec : CompSpec eq lt s s' (compare s s'). + Parameter compare_spec : CompSpec eq lt s s' (compare s s'). - (** Additional specification of [elements] *) - Parameter elements_spec2 : sort E.lt (elements s). + (** Additional specification of [elements] *) + Parameter elements_spec2 : sort E.lt (elements s). - (** Remark: since [fold] is specified via [elements], this stronger + (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) - Parameter min_elt_spec1 : min_elt s = Some x -> In x s. - Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Parameter min_elt_spec3 : min_elt s = None -> Empty s. + Parameter min_elt_spec1 : min_elt s = Some x -> In x s. + Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_spec3 : min_elt s = None -> Empty s. - Parameter max_elt_spec1 : max_elt s = Some x -> In x s. - Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Parameter max_elt_spec3 : max_elt s = None -> Empty s. + Parameter max_elt_spec1 : max_elt s = Some x -> In x s. + Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_spec3 : max_elt s = None -> Empty s. - (** Additional specification of [choose] *) - Parameter choose_spec3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. + (** Additional specification of [choose] *) + Parameter choose_spec3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. End Spec. @@ -335,112 +335,112 @@ Module WS_WSfun (M : WSets) <: WSetsOn M.E := M. Module Type WRawSets (E : DecidableType). - (** First, we ask for all the functions *) - Include WOps E. + (** First, we ask for all the functions *) + Include WOps E. - (** Is a set well-formed or ill-formed ? *) + (** Is a set well-formed or ill-formed ? *) - Parameter IsOk : t -> Prop. - Class Ok (s:t) : Prop := ok : IsOk s. + Parameter IsOk : t -> Prop. + Class Ok (s:t) : Prop := ok : IsOk s. - (** In order to be able to validate (at least some) particular sets as + (** In order to be able to validate (at least some) particular sets as well-formed, we ask for a boolean function for (semi-)deciding predicate [Ok]. If [Ok] isn't decidable, [isok] may be the always-false function. *) - Parameter isok : t -> bool. - (** MS: + Parameter isok : t -> bool. + (** MS: Dangerous instance, the [isok s = true] hypothesis cannot be discharged with typeclass resolution. Is it really an instance? *) -#[global] - Declare Instance isok_Ok s `(isok s = true) : Ok s | 10. - - (** Logical predicates *) - Parameter In : elt -> t -> Prop. -#[global] - Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq : t -> t -> Prop := Equal. -#[global] - Declare Instance eq_equiv : Equivalence eq. - - (** First, all operations are compatible with the well-formed predicate. *) - -#[global] - Declare Instance empty_ok : Ok empty. -#[global] - Declare Instance add_ok s x `(Ok s) : Ok (add x s). -#[global] - Declare Instance remove_ok s x `(Ok s) : Ok (remove x s). -#[global] - Declare Instance singleton_ok x : Ok (singleton x). -#[global] - Declare Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). -#[global] - Declare Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). -#[global] - Declare Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). -#[global] - Declare Instance filter_ok s f `(Ok s) : Ok (filter f s). -#[global] - Declare Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). -#[global] - Declare Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). - - (** Now, the specifications, with constraints on the input sets. *) - - Section Spec. - Variable s s': t. - Variable x y : elt. - Variable f : elt -> bool. - Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - - Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s. - Parameter equal_spec : forall `{Ok s, Ok s'}, - equal s s' = true <-> s[=]s'. - Parameter subset_spec : forall `{Ok s, Ok s'}, - subset s s' = true <-> s[<=]s'. - Parameter empty_spec : Empty empty. - Parameter is_empty_spec : is_empty s = true <-> Empty s. - Parameter add_spec : forall `{Ok s}, - In y (add x s) <-> E.eq y x \/ In y s. - Parameter remove_spec : forall `{Ok s}, - In y (remove x s) <-> In y s /\ ~E.eq y x. - Parameter singleton_spec : In y (singleton x) <-> E.eq y x. - Parameter union_spec : forall `{Ok s, Ok s'}, - In x (union s s') <-> In x s \/ In x s'. - Parameter inter_spec : forall `{Ok s, Ok s'}, - In x (inter s s') <-> In x s /\ In x s'. - Parameter diff_spec : forall `{Ok s, Ok s'}, - In x (diff s s') <-> In x s /\ ~In x s'. - Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Parameter cardinal_spec : forall `{Ok s}, - cardinal s = length (elements s). - Parameter filter_spec : compatb f -> - (In x (filter f s) <-> In x s /\ f x = true). - Parameter for_all_spec : compatb f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Parameter exists_spec : compatb f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Parameter partition_spec1 : compatb f -> - fst (partition f s) [=] filter f s. - Parameter partition_spec2 : compatb f -> - snd (partition f s) [=] filter (fun x => negb (f x)) s. - Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. - Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s). - Parameter choose_spec1 : choose s = Some x -> In x s. - Parameter choose_spec2 : choose s = None -> Empty s. - - End Spec. + #[global] + Declare Instance isok_Ok s `(isok s = true) : Ok s | 10. + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + #[global] + Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + #[global] + Declare Instance eq_equiv : Equivalence eq. + + (** First, all operations are compatible with the well-formed predicate. *) + + #[global] + Declare Instance empty_ok : Ok empty. + #[global] + Declare Instance add_ok s x `(Ok s) : Ok (add x s). + #[global] + Declare Instance remove_ok s x `(Ok s) : Ok (remove x s). + #[global] + Declare Instance singleton_ok x : Ok (singleton x). + #[global] + Declare Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). + #[global] + Declare Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + #[global] + Declare Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). + #[global] + Declare Instance filter_ok s f `(Ok s) : Ok (filter f s). + #[global] + Declare Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). + #[global] + Declare Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). + + (** Now, the specifications, with constraints on the input sets. *) + + Section Spec. + Variable s s': t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s. + Parameter equal_spec : forall `{Ok s, Ok s'}, + equal s s' = true <-> s[=]s'. + Parameter subset_spec : forall `{Ok s, Ok s'}, + subset s s' = true <-> s[<=]s'. + Parameter empty_spec : Empty empty. + Parameter is_empty_spec : is_empty s = true <-> Empty s. + Parameter add_spec : forall `{Ok s}, + In y (add x s) <-> E.eq y x \/ In y s. + Parameter remove_spec : forall `{Ok s}, + In y (remove x s) <-> In y s /\ ~E.eq y x. + Parameter singleton_spec : In y (singleton x) <-> E.eq y x. + Parameter union_spec : forall `{Ok s, Ok s'}, + In x (union s s') <-> In x s \/ In x s'. + Parameter inter_spec : forall `{Ok s, Ok s'}, + In x (inter s s') <-> In x s /\ In x s'. + Parameter diff_spec : forall `{Ok s, Ok s'}, + In x (diff s s') <-> In x s /\ ~In x s'. + Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Parameter cardinal_spec : forall `{Ok s}, + cardinal s = length (elements s). + Parameter filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Parameter for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Parameter exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Parameter partition_spec1 : compatb f -> + fst (partition f s) [=] filter f s. + Parameter partition_spec2 : compatb f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. + Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s). + Parameter choose_spec1 : choose s = Some x -> In x s. + Parameter choose_spec2 : choose s = None -> Empty s. + + End Spec. End WRawSets. @@ -448,121 +448,121 @@ End WRawSets. Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. - (** We avoid creating induction principles for the Record *) - #[local] Unset Elimination Schemes. - - Definition elt := E.t. - - Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. - Definition t := t_. - Arguments Mkt this {is_ok}. - #[global] - Hint Resolve is_ok : typeclass_instances. - - Definition In (x : elt)(s : t) := M.In x (this s). - Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'. - Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'. - Definition Empty (s : t) := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop)(s : t) := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop)(s : t) := exists x, In x s /\ P x. - - Definition mem (x : elt)(s : t) := M.mem x s. - Definition add (x : elt)(s : t) : t := Mkt (M.add x s). - Definition remove (x : elt)(s : t) : t := Mkt (M.remove x s). - Definition singleton (x : elt) : t := Mkt (M.singleton x). - Definition union (s s' : t) : t := Mkt (M.union s s'). - Definition inter (s s' : t) : t := Mkt (M.inter s s'). - Definition diff (s s' : t) : t := Mkt (M.diff s s'). - Definition equal (s s' : t) := M.equal s s'. - Definition subset (s s' : t) := M.subset s s'. - Definition empty : t := Mkt M.empty. - Definition is_empty (s : t) := M.is_empty s. - Definition elements (s : t) : list elt := M.elements s. - Definition choose (s : t) : option elt := M.choose s. - Definition fold (A : Type)(f : elt -> A -> A)(s : t) : A -> A := M.fold f s. - Definition cardinal (s : t) := M.cardinal s. - Definition filter (f : elt -> bool)(s : t) : t := Mkt (M.filter f s). - Definition for_all (f : elt -> bool)(s : t) := M.for_all f s. - Definition exists_ (f : elt -> bool)(s : t) := M.exists_ f s. - Definition partition (f : elt -> bool)(s : t) : t * t := - let p := M.partition f s in (Mkt (fst p), Mkt (snd p)). - -#[global] - Instance In_compat : Proper (E.eq==>eq==>iff) In. - Proof. repeat red. intros; apply M.In_compat; congruence. Qed. - - Definition eq : t -> t -> Prop := Equal. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. firstorder. Qed. - - Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }. - Proof. - intros (s,Hs) (s',Hs'). - change ({M.Equal s s'}+{~M.Equal s s'}). - destruct (M.equal s s') eqn:H; [left|right]; - rewrite <- M.equal_spec; congruence. - Defined. - - - Section Spec. - Variable s s' : t. - Variable x y : elt. - Variable f : elt -> bool. - Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - - Lemma mem_spec : mem x s = true <-> In x s. - Proof. exact (@M.mem_spec _ _ _). Qed. - Lemma equal_spec : equal s s' = true <-> Equal s s'. - Proof. exact (@M.equal_spec _ _ _ _). Qed. - Lemma subset_spec : subset s s' = true <-> Subset s s'. - Proof. exact (@M.subset_spec _ _ _ _). Qed. - Lemma empty_spec : Empty empty. - Proof. exact M.empty_spec. Qed. - Lemma is_empty_spec : is_empty s = true <-> Empty s. - Proof. exact (@M.is_empty_spec _). Qed. - Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. - Proof. exact (@M.add_spec _ _ _ _). Qed. - Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. - Proof. exact (@M.remove_spec _ _ _ _). Qed. - Lemma singleton_spec : In y (singleton x) <-> E.eq y x. - Proof. exact (@M.singleton_spec _ _). Qed. - Lemma union_spec : In x (union s s') <-> In x s \/ In x s'. - Proof. exact (@M.union_spec _ _ _ _ _). Qed. - Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'. - Proof. exact (@M.inter_spec _ _ _ _ _). Qed. - Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. - Proof. exact (@M.diff_spec _ _ _ _ _). Qed. - Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. exact (@M.fold_spec _). Qed. - Lemma cardinal_spec : cardinal s = length (elements s). - Proof. exact (@M.cardinal_spec s _). Qed. - Lemma filter_spec : compatb f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. exact (@M.filter_spec _ _ _). Qed. - Lemma for_all_spec : compatb f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. exact (@M.for_all_spec _ _). Qed. - Lemma exists_spec : compatb f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. exact (@M.exists_spec _ _). Qed. - Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s). - Proof. exact (@M.partition_spec1 _ _). Qed. - Lemma partition_spec2 : compatb f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. exact (@M.partition_spec2 _ _). Qed. - Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. - Proof. exact (@M.elements_spec1 _ _). Qed. - Lemma elements_spec2w : NoDupA E.eq (elements s). - Proof. exact (@M.elements_spec2w _ _). Qed. - Lemma choose_spec1 : choose s = Some x -> In x s. - Proof. exact (@M.choose_spec1 _ _). Qed. - Lemma choose_spec2 : choose s = None -> Empty s. - Proof. exact (@M.choose_spec2 _). Qed. - - End Spec. + (** We avoid creating induction principles for the Record *) + #[local] Unset Elimination Schemes. + + Definition elt := E.t. + + Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. + Definition t := t_. + Arguments Mkt this {is_ok}. + #[global] + Hint Resolve is_ok : typeclass_instances. + + Definition In (x : elt)(s : t) := M.In x (this s). + Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'. + Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'. + Definition Empty (s : t) := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop)(s : t) := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop)(s : t) := exists x, In x s /\ P x. + + Definition mem (x : elt)(s : t) := M.mem x s. + Definition add (x : elt)(s : t) : t := Mkt (M.add x s). + Definition remove (x : elt)(s : t) : t := Mkt (M.remove x s). + Definition singleton (x : elt) : t := Mkt (M.singleton x). + Definition union (s s' : t) : t := Mkt (M.union s s'). + Definition inter (s s' : t) : t := Mkt (M.inter s s'). + Definition diff (s s' : t) : t := Mkt (M.diff s s'). + Definition equal (s s' : t) := M.equal s s'. + Definition subset (s s' : t) := M.subset s s'. + Definition empty : t := Mkt M.empty. + Definition is_empty (s : t) := M.is_empty s. + Definition elements (s : t) : list elt := M.elements s. + Definition choose (s : t) : option elt := M.choose s. + Definition fold (A : Type)(f : elt -> A -> A)(s : t) : A -> A := M.fold f s. + Definition cardinal (s : t) := M.cardinal s. + Definition filter (f : elt -> bool)(s : t) : t := Mkt (M.filter f s). + Definition for_all (f : elt -> bool)(s : t) := M.for_all f s. + Definition exists_ (f : elt -> bool)(s : t) := M.exists_ f s. + Definition partition (f : elt -> bool)(s : t) : t * t := + let p := M.partition f s in (Mkt (fst p), Mkt (snd p)). + + #[global] + Instance In_compat : Proper (E.eq==>eq==>iff) In. + Proof. repeat red. intros; apply M.In_compat; congruence. Qed. + + Definition eq : t -> t -> Prop := Equal. + + #[global] + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }. + Proof. + intros (s,Hs) (s',Hs'). + change ({M.Equal s s'}+{~M.Equal s s'}). + destruct (M.equal s s') eqn:H; [left|right]; + rewrite <- M.equal_spec; congruence. + Defined. + + + Section Spec. + Variable s s' : t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Lemma mem_spec : mem x s = true <-> In x s. + Proof. exact (@M.mem_spec _ _ _). Qed. + Lemma equal_spec : equal s s' = true <-> Equal s s'. + Proof. exact (@M.equal_spec _ _ _ _). Qed. + Lemma subset_spec : subset s s' = true <-> Subset s s'. + Proof. exact (@M.subset_spec _ _ _ _). Qed. + Lemma empty_spec : Empty empty. + Proof. exact M.empty_spec. Qed. + Lemma is_empty_spec : is_empty s = true <-> Empty s. + Proof. exact (@M.is_empty_spec _). Qed. + Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Proof. exact (@M.add_spec _ _ _ _). Qed. + Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Proof. exact (@M.remove_spec _ _ _ _). Qed. + Lemma singleton_spec : In y (singleton x) <-> E.eq y x. + Proof. exact (@M.singleton_spec _ _). Qed. + Lemma union_spec : In x (union s s') <-> In x s \/ In x s'. + Proof. exact (@M.union_spec _ _ _ _ _). Qed. + Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'. + Proof. exact (@M.inter_spec _ _ _ _ _). Qed. + Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. + Proof. exact (@M.diff_spec _ _ _ _ _). Qed. + Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. exact (@M.fold_spec _). Qed. + Lemma cardinal_spec : cardinal s = length (elements s). + Proof. exact (@M.cardinal_spec s _). Qed. + Lemma filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. exact (@M.filter_spec _ _ _). Qed. + Lemma for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. exact (@M.for_all_spec _ _). Qed. + Lemma exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. exact (@M.exists_spec _ _). Qed. + Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s). + Proof. exact (@M.partition_spec1 _ _). Qed. + Lemma partition_spec2 : compatb f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. exact (@M.partition_spec2 _ _). Qed. + Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. + Proof. exact (@M.elements_spec1 _ _). Qed. + Lemma elements_spec2w : NoDupA E.eq (elements s). + Proof. exact (@M.elements_spec2w _ _). Qed. + Lemma choose_spec1 : choose s = Some x -> In x s. + Proof. exact (@M.choose_spec1 _ _). Qed. + Lemma choose_spec2 : choose s = None -> Empty s. + Proof. exact (@M.choose_spec2 _). Qed. + + End Spec. End WRaw2SetsOn. @@ -577,28 +577,28 @@ Module Type RawSets (E : OrderedType). Include WRawSets E <+ HasOrdOps <+ HasLt <+ IsStrOrder. Section Spec. - Variable s s': t. - Variable x y : elt. + Variable s s': t. + Variable x y : elt. - (** Specification of [compare] *) - Parameter compare_spec : forall `{Ok s, Ok s'}, CompSpec eq lt s s' (compare s s'). + (** Specification of [compare] *) + Parameter compare_spec : forall `{Ok s, Ok s'}, CompSpec eq lt s s' (compare s s'). - (** Additional specification of [elements] *) - Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s). + (** Additional specification of [elements] *) + Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s). - (** Specification of [min_elt] *) - Parameter min_elt_spec1 : min_elt s = Some x -> In x s. - Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x. - Parameter min_elt_spec3 : min_elt s = None -> Empty s. + (** Specification of [min_elt] *) + Parameter min_elt_spec1 : min_elt s = Some x -> In x s. + Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_spec3 : min_elt s = None -> Empty s. - (** Specification of [max_elt] *) - Parameter max_elt_spec1 : max_elt s = Some x -> In x s. - Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y. - Parameter max_elt_spec3 : max_elt s = None -> Empty s. + (** Specification of [max_elt] *) + Parameter max_elt_spec1 : max_elt s = Some x -> In x s. + Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_spec3 : max_elt s = None -> Empty s. - (** Additional specification of [choose] *) - Parameter choose_spec3 : forall `{Ok s, Ok s'}, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + (** Additional specification of [choose] *) + Parameter choose_spec3 : forall `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. End Spec. @@ -607,65 +607,65 @@ End RawSets. (** From Raw to usual sets *) Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O. - Include WRaw2SetsOn O M. - - Definition compare (s s':t) := M.compare s s'. - Definition min_elt (s:t) : option elt := M.min_elt s. - Definition max_elt (s:t) : option elt := M.max_elt s. - Definition lt (s s':t) := M.lt s s'. - - (** Specification of [lt] *) -#[global] - Instance lt_strorder : StrictOrder lt. -Proof. - constructor ; unfold lt; red. - - unfold complement. red. intros. apply (irreflexivity H). - - intros. transitivity y; auto. - Qed. + Include WRaw2SetsOn O M. + + Definition compare (s s':t) := M.compare s s'. + Definition min_elt (s:t) : option elt := M.min_elt s. + Definition max_elt (s:t) : option elt := M.max_elt s. + Definition lt (s s':t) := M.lt s s'. -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. + (** Specification of [lt] *) + #[global] + Instance lt_strorder : StrictOrder lt. Proof. - repeat red. unfold eq, lt. - intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl. - change (M.eq s1 s2) in E. - change (M.eq s1' s2') in E'. - rewrite E,E'; intuition. + constructor ; unfold lt; red. + - unfold complement. red. intros. apply (irreflexivity H). + - intros. transitivity y; auto. Qed. - Section Spec. - Variable s s' s'' : t. - Variable x y : elt. - - Lemma compare_spec : CompSpec eq lt s s' (compare s s'). - Proof. unfold compare; destruct (@M.compare_spec s s' _ _); auto. Qed. - - (** Additional specification of [elements] *) - Lemma elements_spec2 : sort O.lt (elements s). - Proof. exact (@M.elements_spec2 _ _). Qed. - - (** Specification of [min_elt] *) - Lemma min_elt_spec1 : min_elt s = Some x -> In x s. - Proof. exact (@M.min_elt_spec1 _ _). Qed. - Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x. - Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed. - Lemma min_elt_spec3 : min_elt s = None -> Empty s. - Proof. exact (@M.min_elt_spec3 _). Qed. - - (** Specification of [max_elt] *) - Lemma max_elt_spec1 : max_elt s = Some x -> In x s. - Proof. exact (@M.max_elt_spec1 _ _). Qed. - Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y. - Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed. - Lemma max_elt_spec3 : max_elt s = None -> Empty s. - Proof. exact (@M.max_elt_spec3 _). Qed. - - (** Additional specification of [choose] *) - Lemma choose_spec3 : - choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y. - Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed. - - End Spec. + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + repeat red. unfold eq, lt. + intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl. + change (M.eq s1 s2) in E. + change (M.eq s1' s2') in E'. + rewrite E,E'; intuition. + Qed. + + Section Spec. + Variable s s' s'' : t. + Variable x y : elt. + + Lemma compare_spec : CompSpec eq lt s s' (compare s s'). + Proof. unfold compare; destruct (@M.compare_spec s s' _ _); auto. Qed. + + (** Additional specification of [elements] *) + Lemma elements_spec2 : sort O.lt (elements s). + Proof. exact (@M.elements_spec2 _ _). Qed. + + (** Specification of [min_elt] *) + Lemma min_elt_spec1 : min_elt s = Some x -> In x s. + Proof. exact (@M.min_elt_spec1 _ _). Qed. + Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x. + Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed. + Lemma min_elt_spec3 : min_elt s = None -> Empty s. + Proof. exact (@M.min_elt_spec3 _). Qed. + + (** Specification of [max_elt] *) + Lemma max_elt_spec1 : max_elt s = Some x -> In x s. + Proof. exact (@M.max_elt_spec1 _ _). Qed. + Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y. + Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed. + Lemma max_elt_spec3 : max_elt s = None -> Empty s. + Proof. exact (@M.max_elt_spec3 _). Qed. + + (** Additional specification of [choose] *) + Lemma choose_spec3 : + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y. + Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed. + + End Spec. End Raw2SetsOn. @@ -683,309 +683,309 @@ End Raw2Sets. *) Module Type IN (O:OrderedType). - Parameter Inline t : Type. - Parameter Inline In : O.t -> t -> Prop. -#[global] - Declare Instance In_compat : Proper (O.eq==>eq==>iff) In. - Definition Equal s s' := forall x, In x s <-> In x s'. - Definition Empty s := forall x, ~In x s. + Parameter Inline t : Type. + Parameter Inline In : O.t -> t -> Prop. + #[global] + Declare Instance In_compat : Proper (O.eq==>eq==>iff) In. + Definition Equal s s' := forall x, In x s <-> In x s'. + Definition Empty s := forall x, ~In x s. End IN. Module MakeSetOrdering (O:OrderedType)(Import M:IN O). - Module Import MO := OrderedTypeFacts O. - - Definition eq : t -> t -> Prop := Equal. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. firstorder. Qed. - -#[global] - Instance : Proper (O.eq==>eq==>iff) In. - Proof. - intros x x' Ex s s' Es. rewrite Ex. apply Es. - Qed. - - Definition Below x s := forall y, In y s -> O.lt y x. - Definition Above x s := forall y, In y s -> O.lt x y. - - Definition EquivBefore x s s' := - forall y, O.lt y x -> (In y s <-> In y s'). - - Definition EmptyBetween x y s := - forall z, In z s -> O.lt z y -> O.lt z x. - - Definition lt s s' := exists x, EquivBefore x s s' /\ - ((In x s' /\ Below x s) \/ - (In x s /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')). - -#[global] - Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore. - Proof. - unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2. - setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition. - Qed. - -#[global] - Instance : Proper (O.eq==>eq==>iff) Below. - Proof. - unfold Below. intros x x' Ex s s' Es. - setoid_rewrite Ex; setoid_rewrite Es; intuition. - Qed. - -#[global] - Instance : Proper (O.eq==>eq==>iff) Above. - Proof. - unfold Above. intros x x' Ex s s' Es. - setoid_rewrite Ex; setoid_rewrite Es; intuition. - Qed. - -#[global] - Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween. - Proof. - unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es. - setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - unfold lt. intros s1 s1' E1 s2 s2' E2. - setoid_rewrite E1; setoid_rewrite E2; intuition. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - (* irreflexive *) - intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]). - + specialize (Em x IN); order. - + specialize (Be x IN LT); order. - - (* transitive *) - intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)]) - (x' & EQ' & [(IN',Pre')|(IN',Lex')]). - + (* 1) Pre / Pre --> Pre *) - assert (O.lt x x') by (specialize (Pre' x IN); auto). - exists x; split. - * intros y Hy; rewrite <- (EQ' y); auto; order. - * left; split; auto. - rewrite <- (EQ' x); auto. - + (* 2) Pre / Lex *) - elim_compare x x'. - * (* 2a) x=x' --> Pre *) - destruct Lex' as (y & INy & LT & Be). - exists y; split. - -- intros z Hz. split; intros INz. - ++ specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order. - ++ specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order. - -- left; split; auto. - intros z Hz. transitivity x; auto; order. - * (* 2b) x Pre *) - exists x; split. - -- intros z Hz. rewrite <- (EQ' z) by order; auto. - -- left; split; auto. - rewrite <- (EQ' x); auto. - * (* 2c) x>x' --> Lex *) - exists x'; split. - -- intros z Hz. rewrite (EQ z) by order; auto. - -- right; split; auto. - rewrite (EQ x'); auto. - + (* 3) Lex / Pre --> Lex *) - destruct Lex as (y & INy & LT & Be). - specialize (Pre' y INy). - exists x; split. - * intros z Hz. rewrite <- (EQ' z) by order; auto. - * right; split; auto. - exists y; repeat split; auto. - -- rewrite <- (EQ' y); auto. - -- intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order. - + (* 4) Lex / Lex *) - elim_compare x x'. - * (* 4a) x=x' --> impossible *) - destruct Lex as (y & INy & LT & Be). - setoid_replace x with x' in LT; auto. - specialize (Be x' IN' LT); order. - * (* 4b) x Lex *) - exists x; split. - -- intros z Hz. rewrite <- (EQ' z) by order; auto. - -- right; split; auto. + Module Import MO := OrderedTypeFacts O. + + Definition eq : t -> t -> Prop := Equal. + + #[global] + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + #[global] + Instance : Proper (O.eq==>eq==>iff) In. + Proof. + intros x x' Ex s s' Es. rewrite Ex. apply Es. + Qed. + + Definition Below x s := forall y, In y s -> O.lt y x. + Definition Above x s := forall y, In y s -> O.lt x y. + + Definition EquivBefore x s s' := + forall y, O.lt y x -> (In y s <-> In y s'). + + Definition EmptyBetween x y s := + forall z, In z s -> O.lt z y -> O.lt z x. + + Definition lt s s' := exists x, EquivBefore x s s' /\ + ((In x s' /\ Below x s) \/ + (In x s /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')). + + #[global] + Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore. + Proof. + unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2. + setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition. + Qed. + + #[global] + Instance : Proper (O.eq==>eq==>iff) Below. + Proof. + unfold Below. intros x x' Ex s s' Es. + setoid_rewrite Ex; setoid_rewrite Es; intuition. + Qed. + + #[global] + Instance : Proper (O.eq==>eq==>iff) Above. + Proof. + unfold Above. intros x x' Ex s s' Es. + setoid_rewrite Ex; setoid_rewrite Es; intuition. + Qed. + + #[global] + Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween. + Proof. + unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es. + setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + unfold lt. intros s1 s1' E1 s2 s2' E2. + setoid_rewrite E1; setoid_rewrite E2; intuition. + Qed. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - (* irreflexive *) + intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]). + + specialize (Em x IN); order. + + specialize (Be x IN LT); order. + - (* transitive *) + intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)]) + (x' & EQ' & [(IN',Pre')|(IN',Lex')]). + + (* 1) Pre / Pre --> Pre *) + assert (O.lt x x') by (specialize (Pre' x IN); auto). + exists x; split. + * intros y Hy; rewrite <- (EQ' y); auto; order. + * left; split; auto. + rewrite <- (EQ' x); auto. + + (* 2) Pre / Lex *) + elim_compare x x'. + * (* 2a) x=x' --> Pre *) + destruct Lex' as (y & INy & LT & Be). + exists y; split. + -- intros z Hz. split; intros INz. + ++ specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order. + ++ specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order. + -- left; split; auto. + intros z Hz. transitivity x; auto; order. + * (* 2b) x Pre *) + exists x; split. + -- intros z Hz. rewrite <- (EQ' z) by order; auto. + -- left; split; auto. + rewrite <- (EQ' x); auto. + * (* 2c) x>x' --> Lex *) + exists x'; split. + -- intros z Hz. rewrite (EQ z) by order; auto. + -- right; split; auto. + rewrite (EQ x'); auto. + + (* 3) Lex / Pre --> Lex *) + destruct Lex as (y & INy & LT & Be). + specialize (Pre' y INy). + exists x; split. + * intros z Hz. rewrite <- (EQ' z) by order; auto. + * right; split; auto. + exists y; repeat split; auto. + -- rewrite <- (EQ' y); auto. + -- intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order. + + (* 4) Lex / Lex *) + elim_compare x x'. + * (* 4a) x=x' --> impossible *) destruct Lex as (y & INy & LT & Be). - elim_compare y x'. - ++ (* 4ba *) - destruct Lex' as (y' & Iny' & LT' & Be'). - exists y'; repeat split; auto. - ** order. - ** intros z Hz LTz. specialize (Be' z Hz LTz). - rewrite <- (EQ' z) in Hz by order. - apply Be; auto. order. - ++ (* 4bb *) - exists y; repeat split; auto. - ** rewrite <- (EQ' y); auto. - ** intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order. - ++ (* 4bc*) - assert (O.lt x' x) by auto. order. - * (* 4c) x>x' --> Lex *) - exists x'; split. - -- intros z Hz. rewrite (EQ z) by order; auto. - -- right; split; auto. - rewrite (EQ x'); auto. - Qed. - - Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'. - Proof. - intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]). - - elim (Hs' x IN). - - elim (Hs' y IN). - Qed. - - Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s. - - Lemma lt_empty_l : forall x s1 s2 s2', - Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'. - Proof. - intros x s1 s2 s2' Em Ab Ad. - exists x; split. - - intros y Hy; split; intros IN. - + elim (Em y IN). - + rewrite (Ad y) in IN; destruct IN as [EQ|IN]. - * order. - * specialize (Ab y IN). order. - - left; split. - + rewrite (Ad x). now left. - + intros y Hy. elim (Em y Hy). - Qed. - - Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2', - Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> - O.lt x1 x2 -> lt s1' s2'. - Proof. - intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT. - exists x1; split; [ | right; split]; auto. - - intros y Hy. rewrite (Ad1 y), (Ad2 y). - split; intros [U|U]; try order. - + specialize (Ab1 y U). order. - + specialize (Ab2 y U). order. - - rewrite (Ad1 x1); auto with *. - - exists x2; repeat split; auto. - + rewrite (Ad2 x2); now left. - + intros y. rewrite (Ad2 y). intros [U|U]. - * order. - * specialize (Ab2 y U). order. - Qed. - - Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2', - Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> - O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'. - Proof. - intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj). - assert (O.lt x1 x). - - destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto. - - exists x; split. - + intros z Hz. rewrite (Ad1 z), (Ad2 z). - split; intros [U|U]; try (left; order); right. - * rewrite <- (EQ z); auto. - * rewrite (EQ z); auto. - + destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)]. - * left; split; auto. - -- rewrite (Ad2 x); auto. - -- intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); auto; order. - * right; split; auto. - -- rewrite (Ad1 x); auto. - -- exists y; repeat split; auto. - ++ rewrite (Ad2 y); auto. - ++ intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); auto; order. - Qed. + setoid_replace x with x' in LT; auto. + specialize (Be x' IN' LT); order. + * (* 4b) x Lex *) + exists x; split. + -- intros z Hz. rewrite <- (EQ' z) by order; auto. + -- right; split; auto. + destruct Lex as (y & INy & LT & Be). + elim_compare y x'. + ++ (* 4ba *) + destruct Lex' as (y' & Iny' & LT' & Be'). + exists y'; repeat split; auto. + ** order. + ** intros z Hz LTz. specialize (Be' z Hz LTz). + rewrite <- (EQ' z) in Hz by order. + apply Be; auto. order. + ++ (* 4bb *) + exists y; repeat split; auto. + ** rewrite <- (EQ' y); auto. + ** intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order. + ++ (* 4bc*) + assert (O.lt x' x) by auto. order. + * (* 4c) x>x' --> Lex *) + exists x'; split. + -- intros z Hz. rewrite (EQ z) by order; auto. + -- right; split; auto. + rewrite (EQ x'); auto. + Qed. + + Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'. + Proof. + intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]). + - elim (Hs' x IN). + - elim (Hs' y IN). + Qed. + + Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s. + + Lemma lt_empty_l : forall x s1 s2 s2', + Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'. + Proof. + intros x s1 s2 s2' Em Ab Ad. + exists x; split. + - intros y Hy; split; intros IN. + + elim (Em y IN). + + rewrite (Ad y) in IN; destruct IN as [EQ|IN]. + * order. + * specialize (Ab y IN). order. + - left; split. + + rewrite (Ad x). now left. + + intros y Hy. elim (Em y Hy). + Qed. + + Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2', + Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> + O.lt x1 x2 -> lt s1' s2'. + Proof. + intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT. + exists x1; split; [ | right; split]; auto. + - intros y Hy. rewrite (Ad1 y), (Ad2 y). + split; intros [U|U]; try order. + + specialize (Ab1 y U). order. + + specialize (Ab2 y U). order. + - rewrite (Ad1 x1); auto with *. + - exists x2; repeat split; auto. + + rewrite (Ad2 x2); now left. + + intros y. rewrite (Ad2 y). intros [U|U]. + * order. + * specialize (Ab2 y U). order. + Qed. + + Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2', + Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> + O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'. + Proof. + intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj). + assert (O.lt x1 x). + - destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto. + - exists x; split. + + intros z Hz. rewrite (Ad1 z), (Ad2 z). + split; intros [U|U]; try (left; order); right. + * rewrite <- (EQ z); auto. + * rewrite (EQ z); auto. + + destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)]. + * left; split; auto. + -- rewrite (Ad2 x); auto. + -- intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); auto; order. + * right; split; auto. + -- rewrite (Ad1 x); auto. + -- exists y; repeat split; auto. + ++ rewrite (Ad2 y); auto. + ++ intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); auto; order. + Qed. End MakeSetOrdering. Module MakeListOrdering (O:OrderedType). - Module MO:=OrderedTypeFacts O. - - #[local] Notation t := (list O.t). - #[local] Notation In := (InA O.eq). - - Definition eq s s' := forall x, In x s <-> In x s'. - -#[global] - Instance eq_equiv : Equivalence eq := _. - - Inductive lt_list : t -> t -> Prop := - | lt_nil : forall x s, lt_list nil (x :: s) - | lt_cons_lt : forall x y s s', - O.lt x y -> lt_list (x :: s) (y :: s') - | lt_cons_eq : forall x y s s', - O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). - #[global] - Hint Constructors lt_list : core. - - Definition lt := lt_list. - #[global] - Hint Unfold lt : core. - - #[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - (* irreflexive *) - assert (forall s s', s=s' -> ~lt s s'). { - red; induction 2. - - discriminate. - - inversion H; subst. - apply (StrictOrder_Irreflexive y); auto. - - inversion H; subst; auto. - } - intros s Hs; exact (H s s (eq_refl s) Hs). - - (* transitive *) - intros s s' s'' H; generalize s''; clear s''; elim H. - + intros x l s'' H'; inversion_clear H'; auto. - + intros x x' l l' E s'' H'; inversion_clear H'; auto. - * constructor 2. transitivity x'; auto. - * constructor 2. rewrite <- H0; auto. - + intros. - inversion_clear H3. - * constructor 2. rewrite H0; auto. - * constructor 3; auto. - -- transitivity y; auto. - -- unfold lt in *; auto. - Qed. - -#[global] - Instance lt_compat' : - Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - intros s1 s1' E1 s2 s2' E2 H. - revert s1' E1 s2' E2. - induction H; intros; inversion_clear E1; inversion_clear E2. - - constructor 1. - - constructor 2. MO.order. - - constructor 3. - + MO.order. - + unfold lt in *; auto. - Qed. - - Lemma eq_cons : - forall l1 l2 x y, - O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2). - Proof. - unfold eq; intros l1 l2 x y Exy E12 z. - split; inversion_clear 1. - - left; MO.order. - - right; rewrite <- E12; auto. - - left; MO.order. - - right; rewrite E12; auto. - Qed. - #[global] - Hint Resolve eq_cons : core. - - Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> - CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c. - Proof. - destruct c; simpl; inversion_clear 2; auto with relations. - Qed. - #[global] - Hint Resolve cons_CompSpec : core. + Module MO:=OrderedTypeFacts O. + + #[local] Notation t := (list O.t). + #[local] Notation In := (InA O.eq). + + Definition eq s s' := forall x, In x s <-> In x s'. + + #[global] + Instance eq_equiv : Equivalence eq := _. + + Inductive lt_list : t -> t -> Prop := + | lt_nil : forall x s, lt_list nil (x :: s) + | lt_cons_lt : forall x y s s', + O.lt x y -> lt_list (x :: s) (y :: s') + | lt_cons_eq : forall x y s s', + O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). + #[global] + Hint Constructors lt_list : core. + + Definition lt := lt_list. + #[global] + Hint Unfold lt : core. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - (* irreflexive *) + assert (forall s s', s=s' -> ~lt s s'). { + red; induction 2. + - discriminate. + - inversion H; subst. + apply (StrictOrder_Irreflexive y); auto. + - inversion H; subst; auto. + } + intros s Hs; exact (H s s (eq_refl s) Hs). + - (* transitive *) + intros s s' s'' H; generalize s''; clear s''; elim H. + + intros x l s'' H'; inversion_clear H'; auto. + + intros x x' l l' E s'' H'; inversion_clear H'; auto. + * constructor 2. transitivity x'; auto. + * constructor 2. rewrite <- H0; auto. + + intros. + inversion_clear H3. + * constructor 2. rewrite H0; auto. + * constructor 3; auto. + -- transitivity y; auto. + -- unfold lt in *; auto. + Qed. + + #[global] + Instance lt_compat' : + Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros s1 s1' E1 s2 s2' E2 H. + revert s1' E1 s2' E2. + induction H; intros; inversion_clear E1; inversion_clear E2. + - constructor 1. + - constructor 2. MO.order. + - constructor 3. + + MO.order. + + unfold lt in *; auto. + Qed. + + Lemma eq_cons : + forall l1 l2 x y, + O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2). + Proof. + unfold eq; intros l1 l2 x y Exy E12 z. + split; inversion_clear 1. + - left; MO.order. + - right; rewrite <- E12; auto. + - left; MO.order. + - right; rewrite E12; auto. + Qed. + #[global] + Hint Resolve eq_cons : core. + + Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> + CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c. + Proof. + destruct c; simpl; inversion_clear 2; auto with relations. + Qed. + #[global] + Hint Resolve cons_CompSpec : core. End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index 7c58cf2db5..930cef2333 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -205,676 +205,676 @@ Module Ops (X:OrderedType) <: WOps X. End Ops. Module MakeRaw (X: OrderedType) <: RawSets X. - Module Import MX := OrderedTypeFacts X. - Module Import ML := OrderedTypeLists X. - - Include Ops X. - - (** ** Proofs of set operation specifications. *) - - Section ForNotations. - - Definition inf x l := - match l with - | nil => true - | y::_ => match X.compare x y with Lt => true | _ => false end - end. - - Fixpoint isok l := - match l with - | nil => true - | x::l => inf x l && isok l - end. - - Notation Sort l := (isok l = true). - Notation Inf := (lelistA X.lt). - Notation In := (InA X.eq). - - Existing Instance X.eq_equiv. - #[local] - Hint Extern 20 => solve [order] : core. - - Definition IsOk s := Sort s. - - Class Ok (s:t) : Prop := ok : Sort s. - - #[local] - Hint Resolve ok : core. - #[local] - Hint Unfold Ok : core. - - Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. - - Lemma inf_iff : forall x l, Inf x l <-> inf x l = true. - Proof. - intros x l; split; intro H. - - (* -> *) - destruct H; simpl in *. - + reflexivity. - + rewrite <- compare_lt_iff in H; rewrite H; reflexivity. - - (* <- *) - destruct l as [|y ys]; simpl in *. - + constructor; fail. - + revert H; case_eq (X.compare x y); try discriminate; []. - intros Ha _. - rewrite compare_lt_iff in Ha. - constructor; assumption. - Qed. - - Lemma isok_iff : forall l, sort X.lt l <-> Ok l. - Proof. - intro l; split; intro H. - - (* -> *) - elim H. - + constructor; fail. - + intros y ys Ha Hb Hc. - change (inf y ys && isok ys = true). - rewrite inf_iff in Hc. - rewrite andb_true_iff; tauto. - - (* <- *) - induction l as [|x xs]. - + constructor. - + change (inf x xs && isok xs = true) in H. - rewrite andb_true_iff, <- inf_iff in H. - destruct H; constructor; tauto. - Qed. - - #[local] - Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. - - Ltac inv_ok := match goal with - | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok - | H:sort X.lt nil |- _ => clear H; inv_ok - | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok - | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok - | |- Ok _ => rewrite <- isok_iff - | _ => idtac - end. - - Ltac inv := invlist InA; inv_ok; invlist lelistA. - Ltac constructors := repeat constructor. - - Ltac sort_inf_in := match goal with - | H:Inf ?x ?l, H':In ?y ?l |- _ => - cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto] - | _ => fail - end. - - #[global] Instance isok_Ok s `(isok s = true) : Ok s | 10. - Proof. - intros. assumption. - Qed. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. - - Lemma mem_spec : - forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s. - Proof. - induction s; intros x Hs; inv; simpl. - - intuition. - + discriminate. - + inv. - - elim_compare x a; rewrite InA_cons; intuition; try order. - + discriminate. - + sort_inf_in. order. - + rewrite <- IHs; auto. - + rewrite IHs; auto. - Qed. - - Lemma add_inf : - forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). - Proof. - simple induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; intuition. - Qed. - #[local] - Hint Resolve add_inf : core. - - #[global] Instance add_ok s x : forall `(Ok s), Ok (add x s). - Proof. - repeat rewrite <- isok_iff; revert s x. - simple induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; auto. - Qed. - - Lemma add_spec : - forall (s : t) (x y : elt) (Hs : Ok s), - In y (add x s) <-> X.eq y x \/ In y s. - Proof. - induction s; simpl; intros. - - intuition. inv; auto. - - elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition. - Qed. - - Lemma remove_inf : - forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s). - Proof. - induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; auto. - apply Inf_lt with a; auto. - Qed. - #[local] - Hint Resolve remove_inf : core. - - #[global] Instance remove_ok s x : forall `(Ok s), Ok (remove x s). - Proof. - repeat rewrite <- isok_iff; revert s x. - induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; auto. - Qed. - - Lemma remove_spec : - forall (s : t) (x y : elt) (Hs : Ok s), - In y (remove x s) <-> In y s /\ ~X.eq y x. - Proof. - induction s; simpl; intros. - - intuition; inv; auto. - - elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition; - try sort_inf_in; try order. - Qed. - - #[global] Instance singleton_ok x : Ok (singleton x). - Proof. - unfold singleton; simpl; auto. - Qed. - - Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. - Proof. - unfold singleton; simpl; split; intros; inv; auto. - Qed. - - Ltac induction2 := - simple induction s; - [ simpl; auto; try solve [ intros; inv ] - | intros x l Hrec; simple induction s'; - [ simpl; auto; try solve [ intros; inv ] - | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]]. - - Lemma union_inf : - forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), - Inf a s -> Inf a s' -> Inf a (union s s'). - Proof. - induction2. - Qed. - #[local] - Hint Resolve union_inf : core. - - #[global] Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). - Proof. - repeat rewrite <- isok_iff; revert s s'. - induction2; constructors; try apply @ok; auto. - - apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto; order. - - change (Inf x' (union (x :: l) l')); auto. - Qed. - - Lemma union_spec : - forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), - In x (union s s') <-> In x s \/ In x s'. - Proof. - induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto. - Qed. - - Lemma inter_inf : - forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), - Inf a s -> Inf a s' -> Inf a (inter s s'). - Proof. - induction2. - - apply Inf_lt with x; auto. - - apply Hrec'; auto. - apply Inf_lt with x'; auto. - Qed. - #[local] - Hint Resolve inter_inf : core. - - #[global] Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). - Proof. - repeat rewrite <- isok_iff; revert s s'. - induction2. - constructors; auto. - apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto. - Qed. - - Lemma inter_spec : - forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), - In x (inter s s') <-> In x s /\ In x s'. - Proof. - induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; - try sort_inf_in; try order. - Qed. - - Lemma diff_inf : - forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt), - Inf a s -> Inf a s' -> Inf a (diff s s'). - Proof. - intros s s'; repeat rewrite <- isok_iff; revert s s'. - induction2. - - apply Hrec; trivial. - + apply Inf_lt with x; auto. - + apply Inf_lt with x'; auto. - - apply Hrec'; auto. - apply Inf_lt with x'; auto. - Qed. - #[local] - Hint Resolve diff_inf : core. - - #[global] Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). - Proof. - repeat rewrite <- isok_iff; revert s s'. - induction2. - Qed. - - Lemma diff_spec : - forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), - In x (diff s s') <-> In x s /\ ~In x s'. - Proof. - induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; - try sort_inf_in; try order. - right; intuition; inv; auto. - Qed. - - Lemma equal_spec : - forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), - equal s s' = true <-> Equal s s'. - Proof. - induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. - - intuition reflexivity. - - split; intros H. - + discriminate. - + assert (In x' nil) by (rewrite H; auto). inv. - - split; intros H. - + discriminate. - + assert (In x nil) by (rewrite <-H; auto). inv. - - inv. - elim_compare x x' as C; try discriminate. - + (* x=x' *) - rewrite IH; auto. - split; intros E y; specialize (E y). - * rewrite !InA_cons, E, C; intuition. - * rewrite !InA_cons, C in E. intuition; try sort_inf_in; order. - + (* xx' *) - split; intros E. - * discriminate. - * assert (In x' (x::s)) by (rewrite E; auto). - inv; try sort_inf_in; order. - Qed. - - Lemma subset_spec : - forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), - subset s s' = true <-> Subset s s'. - Proof. - intros s s'; revert s. - induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto. - - split; try red; intros; auto. - - split; intros H. - + discriminate. - + assert (In x nil) by (apply H; auto). inv. - - split; try red; intros; auto. inv. - - inv. elim_compare x x' as C. - + (* x=x' *) - rewrite IH; auto. - split; intros S y; specialize (S y). - * rewrite !InA_cons, C. intuition. - * rewrite !InA_cons, C in S. intuition; try sort_inf_in; order. - + (* xx' *) - rewrite IH; auto. - split; intros S y; specialize (S y). - * rewrite !InA_cons. intuition. - * rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order. - Qed. - - #[global] Instance empty_ok : Ok empty. - Proof. - constructors. - Qed. - - Lemma empty_spec : Empty empty. - Proof. - unfold Empty, empty; intuition; inv. - Qed. - - Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. - Proof. - intros [ | x s]; simpl. - - split; auto. intros _ x H. inv. - - split. - + discriminate. - + intros H. elim (H x); auto. - Qed. - - Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. - Proof. - intuition. - Qed. - - Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s). - Proof. - intro s; repeat rewrite <- isok_iff; auto. - Qed. - - Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s). - Proof. - intro s; repeat rewrite <- isok_iff; auto. - Qed. - - Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. - Proof. - destruct s; simpl; inversion 1; auto. - Qed. - - Lemma min_elt_spec2 : - forall (s : t) (x y : elt) (Hs : Ok s), - min_elt s = Some x -> In y s -> ~ X.lt y x. - Proof. - induction s as [ | x s IH]; simpl; inversion 2; subst. - intros; inv; try sort_inf_in; order. - Qed. - - Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s. - Proof. - destruct s; simpl; red; intuition. - - inv. - - discriminate. - Qed. - - Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. - Proof. - induction s as [ | x s IH]. - - inversion 1. - - destruct s as [ | y s]. - + simpl. inversion 1; subst; auto. - + right; apply IH; auto. - Qed. - - Lemma max_elt_spec2 : - forall (s : t) (x y : elt) (Hs : Ok s), - max_elt s = Some x -> In y s -> ~ X.lt x y. - Proof. - induction s as [ | a s IH]. - - inversion 2. - - destruct s as [ | b s]. - + inversion 2; subst. intros; inv; order. - + intros. inv; auto. - assert (~X.lt x b) by (apply IH; auto). - assert (X.lt a b) by auto. + Module Import MX := OrderedTypeFacts X. + Module Import ML := OrderedTypeLists X. + + Include Ops X. + + (** ** Proofs of set operation specifications. *) + + Section ForNotations. + + Definition inf x l := + match l with + | nil => true + | y::_ => match X.compare x y with Lt => true | _ => false end + end. + + Fixpoint isok l := + match l with + | nil => true + | x::l => inf x l && isok l + end. + + Notation Sort l := (isok l = true). + Notation Inf := (lelistA X.lt). + Notation In := (InA X.eq). + + Existing Instance X.eq_equiv. + #[local] + Hint Extern 20 => solve [order] : core. + + Definition IsOk s := Sort s. + + Class Ok (s:t) : Prop := ok : Sort s. + + #[local] + Hint Resolve ok : core. + #[local] + Hint Unfold Ok : core. + + Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. + + Lemma inf_iff : forall x l, Inf x l <-> inf x l = true. + Proof. + intros x l; split; intro H. + - (* -> *) + destruct H; simpl in *. + + reflexivity. + + rewrite <- compare_lt_iff in H; rewrite H; reflexivity. + - (* <- *) + destruct l as [|y ys]; simpl in *. + + constructor; fail. + + revert H; case_eq (X.compare x y); try discriminate; []. + intros Ha _. + rewrite compare_lt_iff in Ha. + constructor; assumption. + Qed. + + Lemma isok_iff : forall l, sort X.lt l <-> Ok l. + Proof. + intro l; split; intro H. + - (* -> *) + elim H. + + constructor; fail. + + intros y ys Ha Hb Hc. + change (inf y ys && isok ys = true). + rewrite inf_iff in Hc. + rewrite andb_true_iff; tauto. + - (* <- *) + induction l as [|x xs]. + + constructor. + + change (inf x xs && isok xs = true) in H. + rewrite andb_true_iff, <- inf_iff in H. + destruct H; constructor; tauto. + Qed. + + #[local] + Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. + + Ltac inv_ok := match goal with + | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok + | H:sort X.lt nil |- _ => clear H; inv_ok + | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok + | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok + | |- Ok _ => rewrite <- isok_iff + | _ => idtac + end. + + Ltac inv := invlist InA; inv_ok; invlist lelistA. + Ltac constructors := repeat constructor. + + Ltac sort_inf_in := match goal with + | H:Inf ?x ?l, H':In ?y ?l |- _ => + cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto] + | _ => fail + end. + + #[global] Instance isok_Ok s `(isok s = true) : Ok s | 10. + Proof. + intros. assumption. + Qed. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. + + Lemma mem_spec : + forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s. + Proof. + induction s; intros x Hs; inv; simpl. + - intuition. + + discriminate. + + inv. + - elim_compare x a; rewrite InA_cons; intuition; try order. + + discriminate. + + sort_inf_in. order. + + rewrite <- IHs; auto. + + rewrite IHs; auto. + Qed. + + Lemma add_inf : + forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). + Proof. + simple induction s; simpl. + - intuition. + - intros; elim_compare x a; inv; intuition. + Qed. + #[local] + Hint Resolve add_inf : core. + + #[global] Instance add_ok s x : forall `(Ok s), Ok (add x s). + Proof. + repeat rewrite <- isok_iff; revert s x. + simple induction s; simpl. + - intuition. + - intros; elim_compare x a; inv; auto. + Qed. + + Lemma add_spec : + forall (s : t) (x y : elt) (Hs : Ok s), + In y (add x s) <-> X.eq y x \/ In y s. + Proof. + induction s; simpl; intros. + - intuition. inv; auto. + - elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition. + Qed. + + Lemma remove_inf : + forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s). + Proof. + induction s; simpl. + - intuition. + - intros; elim_compare x a; inv; auto. + apply Inf_lt with a; auto. + Qed. + #[local] + Hint Resolve remove_inf : core. + + #[global] Instance remove_ok s x : forall `(Ok s), Ok (remove x s). + Proof. + repeat rewrite <- isok_iff; revert s x. + induction s; simpl. + - intuition. + - intros; elim_compare x a; inv; auto. + Qed. + + Lemma remove_spec : + forall (s : t) (x y : elt) (Hs : Ok s), + In y (remove x s) <-> In y s /\ ~X.eq y x. + Proof. + induction s; simpl; intros. + - intuition; inv; auto. + - elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition; + try sort_inf_in; try order. + Qed. + + #[global] Instance singleton_ok x : Ok (singleton x). + Proof. + unfold singleton; simpl; auto. + Qed. + + Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; simpl; split; intros; inv; auto. + Qed. + + Ltac induction2 := + simple induction s; + [ simpl; auto; try solve [ intros; inv ] + | intros x l Hrec; simple induction s'; + [ simpl; auto; try solve [ intros; inv ] + | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]]. + + Lemma union_inf : + forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), + Inf a s -> Inf a s' -> Inf a (union s s'). + Proof. + induction2. + Qed. + #[local] + Hint Resolve union_inf : core. + + #[global] Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). + Proof. + repeat rewrite <- isok_iff; revert s s'. + induction2; constructors; try apply @ok; auto. + - apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto; order. + - change (Inf x' (union (x :: l) l')); auto. + Qed. + + Lemma union_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (union s s') <-> In x s \/ In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto. + Qed. + + Lemma inter_inf : + forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), + Inf a s -> Inf a s' -> Inf a (inter s s'). + Proof. + induction2. + - apply Inf_lt with x; auto. + - apply Hrec'; auto. + apply Inf_lt with x'; auto. + Qed. + #[local] + Hint Resolve inter_inf : core. + + #[global] Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). + Proof. + repeat rewrite <- isok_iff; revert s s'. + induction2. + constructors; auto. + apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto. + Qed. + + Lemma inter_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (inter s s') <-> In x s /\ In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; + try sort_inf_in; try order. + Qed. + + Lemma diff_inf : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt), + Inf a s -> Inf a s' -> Inf a (diff s s'). + Proof. + intros s s'; repeat rewrite <- isok_iff; revert s s'. + induction2. + - apply Hrec; trivial. + + apply Inf_lt with x; auto. + + apply Inf_lt with x'; auto. + - apply Hrec'; auto. + apply Inf_lt with x'; auto. + Qed. + #[local] + Hint Resolve diff_inf : core. + + #[global] Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). + Proof. + repeat rewrite <- isok_iff; revert s s'. + induction2. + Qed. + + Lemma diff_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (diff s s') <-> In x s /\ ~In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; + try sort_inf_in; try order. + right; intuition; inv; auto. + Qed. + + Lemma equal_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), + equal s s' = true <-> Equal s s'. + Proof. + induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. + - intuition reflexivity. + - split; intros H. + + discriminate. + + assert (In x' nil) by (rewrite H; auto). inv. + - split; intros H. + + discriminate. + + assert (In x nil) by (rewrite <-H; auto). inv. + - inv. + elim_compare x x' as C; try discriminate. + + (* x=x' *) + rewrite IH; auto. + split; intros E y; specialize (E y). + * rewrite !InA_cons, E, C; intuition. + * rewrite !InA_cons, C in E. intuition; try sort_inf_in; order. + + (* xx' *) + split; intros E. + * discriminate. + * assert (In x' (x::s)) by (rewrite E; auto). + inv; try sort_inf_in; order. + Qed. + + Lemma subset_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), + subset s s' = true <-> Subset s s'. + Proof. + intros s s'; revert s. + induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto. + - split; try red; intros; auto. + - split; intros H. + + discriminate. + + assert (In x nil) by (apply H; auto). inv. + - split; try red; intros; auto. inv. + - inv. elim_compare x x' as C. + + (* x=x' *) + rewrite IH; auto. + split; intros S y; specialize (S y). + * rewrite !InA_cons, C. intuition. + * rewrite !InA_cons, C in S. intuition; try sort_inf_in; order. + + (* xx' *) + rewrite IH; auto. + split; intros S y; specialize (S y). + * rewrite !InA_cons. intuition. + * rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order. + Qed. + + #[global] Instance empty_ok : Ok empty. + Proof. + constructors. + Qed. + + Lemma empty_spec : Empty empty. + Proof. + unfold Empty, empty; intuition; inv. + Qed. + + Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. + Proof. + intros [ | x s]; simpl. + - split; auto. intros _ x H. inv. + - split. + + discriminate. + + intros H. elim (H x); auto. + Qed. + + Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. + Proof. + intuition. + Qed. + + Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s). + Proof. + intro s; repeat rewrite <- isok_iff; auto. + Qed. + + Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s). + Proof. + intro s; repeat rewrite <- isok_iff; auto. + Qed. + + Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Proof. + destruct s; simpl; inversion 1; auto. + Qed. + + Lemma min_elt_spec2 : + forall (s : t) (x y : elt) (Hs : Ok s), + min_elt s = Some x -> In y s -> ~ X.lt y x. + Proof. + induction s as [ | x s IH]; simpl; inversion 2; subst. + intros; inv; try sort_inf_in; order. + Qed. + + Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s. + Proof. + destruct s; simpl; red; intuition. + - inv. + - discriminate. + Qed. + + Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. + induction s as [ | x s IH]. + - inversion 1. + - destruct s as [ | y s]. + + simpl. inversion 1; subst; auto. + + right; apply IH; auto. + Qed. + + Lemma max_elt_spec2 : + forall (s : t) (x y : elt) (Hs : Ok s), + max_elt s = Some x -> In y s -> ~ X.lt x y. + Proof. + induction s as [ | a s IH]. + - inversion 2. + - destruct s as [ | b s]. + + inversion 2; subst. intros; inv; order. + + intros. inv; auto. + assert (~X.lt x b) by (apply IH; auto). + assert (X.lt a b) by auto. + order. + Qed. + + Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s. + Proof. + induction s as [ | a s IH]. + - red; intuition; inv. + - destruct s as [ | b s]. + + inversion 1. + + intros; elim IH with b; auto. + Qed. + + Definition choose_spec1 : + forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1. + + Definition choose_spec2 : + forall s : t, choose s = None -> Empty s := min_elt_spec3. + + Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' -> + choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. + Proof. + unfold choose; intros s s' x x' Hs Hs' Hx Hx' H. + assert (~X.lt x x'). { + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + } + assert (~X.lt x' x). { + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + } order. - Qed. - - Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s. - Proof. - induction s as [ | a s IH]. - - red; intuition; inv. - - destruct s as [ | b s]. - + inversion 1. - + intros; elim IH with b; auto. - Qed. - - Definition choose_spec1 : - forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1. - - Definition choose_spec2 : - forall s : t, choose s = None -> Empty s := min_elt_spec3. - - Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' -> - choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. - Proof. - unfold choose; intros s s' x x' Hs Hs' Hx Hx' H. - assert (~X.lt x x'). { - apply min_elt_spec2 with s'; auto. - rewrite <-H; auto using min_elt_spec1. - } - assert (~X.lt x' x). { - apply min_elt_spec2 with s; auto. - rewrite H; auto using min_elt_spec1. - } - order. - Qed. - - Lemma fold_spec : - forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Proof. - reflexivity. - Qed. - - Lemma cardinal_spec : - forall (s : t) (Hs : Ok s), - cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_inf : - forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s), - Inf x s -> Inf x (filter f s). - Proof. - simple induction s; simpl. - - intuition. - - intros x l Hrec a f Hs Ha; inv. - case (f x); auto. - apply Hrec; auto. - apply Inf_lt with x; auto. - Qed. - - #[global] Instance filter_ok s f : forall `(Ok s), Ok (filter f s). - Proof. - repeat rewrite <- isok_iff; revert s f. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - case (f x); auto. - constructors; auto. - apply filter_inf; auto. - Qed. - - Lemma filter_spec : - forall (s : t) (x : elt) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. - induction s; simpl; intros. - - split; intuition; inv. - - destruct (f a) eqn:F; rewrite !InA_cons, ?IHs; intuition. - + setoid_replace x with a; auto. - + setoid_replace a with x in F; auto; congruence. - Qed. - - Lemma for_all_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. - unfold For_all; induction s; simpl; intros. - - split; intros; auto. inv. - - destruct (f a) eqn:F. - + rewrite IHs; auto. firstorder. inv; auto. - setoid_replace x with a; auto. - + split; intros H'. - * discriminate. - * rewrite H' in F; auto. - Qed. - - Lemma exists_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. - unfold Exists; induction s; simpl; intros. - - firstorder. - + discriminate. - + inv. - - destruct (f a) eqn:F. - + firstorder. - + rewrite IHs; auto. - firstorder. - inv. - * setoid_replace a with x in F; auto; congruence. - * exists x; auto. - Qed. - - Lemma partition_inf1 : - forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), - Inf x s -> Inf x (fst (partition f s)). - Proof. - intros s f x; repeat rewrite <- isok_iff; revert s f x. - simple induction s; simpl. - - intuition. - - intros x l Hrec f a Hs Ha; inv. - generalize (Hrec f a H). - case (f x); case (partition f l); simpl. - + auto. - + intros; apply H2; apply Inf_lt with x; auto. - Qed. - - Lemma partition_inf2 : - forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), - Inf x s -> Inf x (snd (partition f s)). - Proof. - intros s f x; repeat rewrite <- isok_iff; revert s f x. - simple induction s; simpl. - - intuition. - - intros x l Hrec f a Hs Ha; inv. - generalize (Hrec f a H). - case (f x); case (partition f l); simpl. - + intros; apply H2; apply Inf_lt with x; auto. - + auto. - Qed. - - #[global] Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)). - Proof. - repeat rewrite <- isok_iff; revert s f. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (Hrec f H); generalize (@partition_inf1 l f x). - case (f x); case (partition f l); simpl; auto. - Qed. - - #[global] Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)). - Proof. - repeat rewrite <- isok_iff; revert s f. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (Hrec f H); generalize (@partition_inf2 l f x). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_spec1 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - split; auto. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - + constructor 2; rewrite <- H; auto. - + constructor 2; rewrite H; auto. - Qed. - - Lemma partition_spec2 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - split; auto. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - + constructor 2; rewrite <- H; auto. - + constructor 2; rewrite H; auto. - Qed. - - End ForNotations. - - Definition In := InA X.eq. -#[global] - Instance In_compat : Proper (X.eq==>eq==> iff) In. - Proof. repeat red; intros; rewrite H, H0; auto. Qed. - - Module L := MakeListOrdering X. - Definition eq := L.eq. - Definition eq_equiv := L.eq_equiv. - Definition lt l1 l2 := - exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). - repeat rewrite <- isok_iff in *. - assert (eqlistA X.eq s1 s2). { - apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. - transitivity s; auto. symmetry; auto. - } - rewrite H in L. - apply (StrictOrder_Irreflexive s2); auto. - - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) - (s2'' & s3' & B2' & B3 & E2' & E3 & L23). - exists s1', s3'. - repeat rewrite <- isok_iff in *. - do 4 (split; trivial). - assert (eqlistA X.eq s2' s2''). - + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. - transitivity s2; auto. symmetry; auto. - + transitivity s2'; auto. - rewrite H; auto. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros s1 s2 E12 s3 s4 E34. split. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s1; auto. symmetry; auto. - + split; auto. transitivity s3; auto. symmetry; auto. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s2; auto. - + split; auto. transitivity s4; auto. - Qed. - - Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s'). - Proof. - induction s as [|x s IH]; intros [|x' s']; simpl; intuition auto with relations. - elim_compare x x'; auto. - Qed. - - Lemma compare_spec : forall s s', Ok s -> Ok s' -> - CompSpec eq lt s s' (compare s s'). - Proof. - intros s s' Hs Hs'. - destruct (compare_spec_aux s s'); constructor; auto. - - exists s, s'; repeat split; auto using @ok. - - exists s', s; repeat split; auto using @ok. - Qed. + Qed. + + Lemma fold_spec : + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Proof. + reflexivity. + Qed. + + Lemma cardinal_spec : + forall (s : t) (Hs : Ok s), + cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_inf : + forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s), + Inf x s -> Inf x (filter f s). + Proof. + simple induction s; simpl. + - intuition. + - intros x l Hrec a f Hs Ha; inv. + case (f x); auto. + apply Hrec; auto. + apply Inf_lt with x; auto. + Qed. + + #[global] Instance filter_ok s f : forall `(Ok s), Ok (filter f s). + Proof. + repeat rewrite <- isok_iff; revert s f. + simple induction s; simpl. + - auto. + - intros x l Hrec f Hs; inv. + case (f x); auto. + constructors; auto. + apply filter_inf; auto. + Qed. + + Lemma filter_spec : + forall (s : t) (x : elt) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. + induction s; simpl; intros. + - split; intuition; inv. + - destruct (f a) eqn:F; rewrite !InA_cons, ?IHs; intuition. + + setoid_replace x with a; auto. + + setoid_replace a with x in F; auto; congruence. + Qed. + + Lemma for_all_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + unfold For_all; induction s; simpl; intros. + - split; intros; auto. inv. + - destruct (f a) eqn:F. + + rewrite IHs; auto. firstorder. inv; auto. + setoid_replace x with a; auto. + + split; intros H'. + * discriminate. + * rewrite H' in F; auto. + Qed. + + Lemma exists_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + unfold Exists; induction s; simpl; intros. + - firstorder. + + discriminate. + + inv. + - destruct (f a) eqn:F. + + firstorder. + + rewrite IHs; auto. + firstorder. + inv. + * setoid_replace a with x in F; auto; congruence. + * exists x; auto. + Qed. + + Lemma partition_inf1 : + forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), + Inf x s -> Inf x (fst (partition f s)). + Proof. + intros s f x; repeat rewrite <- isok_iff; revert s f x. + simple induction s; simpl. + - intuition. + - intros x l Hrec f a Hs Ha; inv. + generalize (Hrec f a H). + case (f x); case (partition f l); simpl. + + auto. + + intros; apply H2; apply Inf_lt with x; auto. + Qed. + + Lemma partition_inf2 : + forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), + Inf x s -> Inf x (snd (partition f s)). + Proof. + intros s f x; repeat rewrite <- isok_iff; revert s f x. + simple induction s; simpl. + - intuition. + - intros x l Hrec f a Hs Ha; inv. + generalize (Hrec f a H). + case (f x); case (partition f l); simpl. + + intros; apply H2; apply Inf_lt with x; auto. + + auto. + Qed. + + #[global] Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)). + Proof. + repeat rewrite <- isok_iff; revert s f. + simple induction s; simpl. + - auto. + - intros x l Hrec f Hs; inv. + generalize (Hrec f H); generalize (@partition_inf1 l f x). + case (f x); case (partition f l); simpl; auto. + Qed. + + #[global] Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)). + Proof. + repeat rewrite <- isok_iff; revert s f. + simple induction s; simpl. + - auto. + - intros x l Hrec f Hs; inv. + generalize (Hrec f H); generalize (@partition_inf2 l f x). + case (f x); case (partition f l); simpl; auto. + Qed. + + Lemma partition_spec1 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s). + Proof. + simple induction s; simpl; auto; unfold Equal. + - split; auto. + - intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + destruct (partition f l) as [s1 s2]; simpl; intros. + case (f x); simpl; auto. + split; inversion_clear 1; auto. + + constructor 2; rewrite <- H; auto. + + constructor 2; rewrite H; auto. + Qed. + + Lemma partition_spec2 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + simple induction s; simpl; auto; unfold Equal. + - split; auto. + - intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + destruct (partition f l) as [s1 s2]; simpl; intros. + case (f x); simpl; auto. + split; inversion_clear 1; auto. + + constructor 2; rewrite <- H; auto. + + constructor 2; rewrite H; auto. + Qed. + + End ForNotations. + + Definition In := InA X.eq. + #[global] + Instance In_compat : Proper (X.eq==>eq==> iff) In. + Proof. repeat red; intros; rewrite H, H0; auto. Qed. + + Module L := MakeListOrdering X. + Definition eq := L.eq. + Definition eq_equiv := L.eq_equiv. + Definition lt l1 l2 := + exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + repeat rewrite <- isok_iff in *. + assert (eqlistA X.eq s1 s2). { + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. + transitivity s; auto. symmetry; auto. + } + rewrite H in L. + apply (StrictOrder_Irreflexive s2); auto. + - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'. + repeat rewrite <- isok_iff in *. + do 4 (split; trivial). + assert (eqlistA X.eq s2' s2''). + + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. + transitivity s2; auto. symmetry; auto. + + transitivity s2'; auto. + rewrite H; auto. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros s1 s2 E12 s3 s4 E34. split. + - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. + + transitivity s1; auto. symmetry; auto. + + split; auto. transitivity s3; auto. symmetry; auto. + - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. + + transitivity s2; auto. + + split; auto. transitivity s4; auto. + Qed. + + Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s'). + Proof. + induction s as [|x s IH]; intros [|x' s']; simpl; intuition auto with relations. + elim_compare x x'; auto. + Qed. + + Lemma compare_spec : forall s s', Ok s -> Ok s' -> + CompSpec eq lt s s' (compare s s'). + Proof. + intros s s' Hs Hs'. + destruct (compare_spec_aux s s'); constructor; auto. + - exists s, s'; repeat split; auto using @ok. + - exists s', s; repeat split; auto using @ok. + Qed. End MakeRaw. @@ -884,8 +884,8 @@ End MakeRaw. need to encapsulate everything into a type of strictly ordered lists. *) Module Make (X: OrderedType) <: S with Module E := X. - Module Raw := MakeRaw X. - Include Raw2Sets X Raw. + Module Raw := MakeRaw X. + Include Raw2Sets X Raw. End Make. (** For this specific implementation, eq coincides with Leibniz equality *) diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index 112edc77fb..93c877ca5e 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -27,1074 +27,1074 @@ Set Implicit Arguments. Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. - Module E:=PositiveOrderedTypeBits. - - Definition elt := positive : Type. - - Inductive tree := - | Leaf : tree - | Node : tree -> bool -> tree -> tree. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree : Type. - - Definition empty : t := Leaf. - - Fixpoint is_empty (m : t) : bool := - match m with - | Leaf => true - | Node l b r => negb b &&& is_empty l &&& is_empty r - end. - - Fixpoint mem (i : positive) (m : t) {struct m} : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | 1 => o - | i~0 => mem i l - | i~1 => mem i r - end - end. - - Fixpoint add (i : positive) (m : t) : t := - match m with - | Leaf => - match i with - | 1 => Node Leaf true Leaf - | i~0 => Node (add i Leaf) false Leaf - | i~1 => Node Leaf false (add i Leaf) - end - | Node l o r => - match i with - | 1 => Node l true r - | i~0 => Node (add i l) o r - | i~1 => Node l o (add i r) - end - end. - - Definition singleton i := add i empty. - - (** helper function to avoid creating empty trees that are not leaves *) - - Definition node (l : t) (b: bool) (r : t) : t := - if b then Node l b r else - match l,r with - | Leaf,Leaf => Leaf - | _,_ => Node l false r end. - - Fixpoint remove (i : positive) (m : t) {struct m} : t := - match m with - | Leaf => Leaf - | Node l o r => - match i with - | 1 => node l false r - | i~0 => node (remove i l) o r - | i~1 => node l o (remove i r) - end - end. - - Fixpoint union (m m': t) : t := - match m with - | Leaf => m' - | Node l o r => - match m' with - | Leaf => m - | Node l' o' r' => Node (union l l') (o||o') (union r r') - end - end. - - Fixpoint inter (m m': t) : t := - match m with - | Leaf => Leaf - | Node l o r => - match m' with - | Leaf => Leaf - | Node l' o' r' => node (inter l l') (o&&o') (inter r r') - end - end. + Module E:=PositiveOrderedTypeBits. - Fixpoint diff (m m': t) : t := - match m with - | Leaf => Leaf - | Node l o r => - match m' with - | Leaf => m - | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') - end - end. - - Fixpoint equal (m m': t): bool := - match m with - | Leaf => is_empty m' - | Node l o r => - match m' with - | Leaf => is_empty m - | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' - end - end. - - Fixpoint subset (m m': t): bool := - match m with + Definition elt := positive : Type. + + Inductive tree := + | Leaf : tree + | Node : tree -> bool -> tree -> tree. + + Scheme tree_ind := Induction for tree Sort Prop. + + Definition t := tree : Type. + + Definition empty : t := Leaf. + + Fixpoint is_empty (m : t) : bool := + match m with | Leaf => true + | Node l b r => negb b &&& is_empty l &&& is_empty r + end. + + Fixpoint mem (i : positive) (m : t) {struct m} : bool := + match m with + | Leaf => false | Node l o r => - match m' with - | Leaf => is_empty m - | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' - end - end. + match i with + | 1 => o + | i~0 => mem i l + | i~1 => mem i r + end + end. - (** reverses [y] and concatenate it with [x] *) + Fixpoint add (i : positive) (m : t) : t := + match m with + | Leaf => + match i with + | 1 => Node Leaf true Leaf + | i~0 => Node (add i Leaf) false Leaf + | i~1 => Node Leaf false (add i Leaf) + end + | Node l o r => + match i with + | 1 => Node l true r + | i~0 => Node (add i l) o r + | i~1 => Node l o (add i r) + end + end. - Fixpoint rev_append (y x : elt) : elt := - match y with - | 1 => x - | y~1 => rev_append y x~1 - | y~0 => rev_append y x~0 - end. - Infix "@" := rev_append (at level 60). - Definition rev x := x@1. + Definition singleton i := add i empty. - Section Fold. + (** helper function to avoid creating empty trees that are not leaves *) - Variables B : Type. - Variable f : positive -> B -> B. + Definition node (l : t) (b: bool) (r : t) : t := + if b then Node l b r else + match l,r with + | Leaf,Leaf => Leaf + | _,_ => Node l false r end. - (** the additional argument, [i], records the current path, in - reverse order (this should be more efficient: we reverse this argument - only at present nodes only, rather than at each node of the tree). - we also use this convention in all functions below - *) + Fixpoint remove (i : positive) (m : t) {struct m} : t := + match m with + | Leaf => Leaf + | Node l o r => + match i with + | 1 => node l false r + | i~0 => node (remove i l) o r + | i~1 => node l o (remove i r) + end + end. - Fixpoint xfold (m : t) (v : B) (i : positive) := + Fixpoint union (m m': t) : t := match m with - | Leaf => v - | Node l true r => - xfold r (f (rev i) (xfold l v i~0)) i~1 - | Node l false r => - xfold r (xfold l v i~0) i~1 + | Leaf => m' + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => Node (union l l') (o||o') (union r r') + end end. - Definition fold m i := xfold m i 1. - End Fold. + Fixpoint inter (m m': t) : t := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => Leaf + | Node l' o' r' => node (inter l l') (o&&o') (inter r r') + end + end. - Section Quantifiers. + Fixpoint diff (m m': t) : t := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') + end + end. - Variable f : positive -> bool. + Fixpoint equal (m m': t): bool := + match m with + | Leaf => is_empty m' + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' + end + end. - Fixpoint xforall (m : t) (i : positive) := + Fixpoint subset (m m': t): bool := match m with | Leaf => true | Node l o r => - (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 + match m' with + | Leaf => is_empty m + | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' + end + end. + + (** reverses [y] and concatenate it with [x] *) + + Fixpoint rev_append (y x : elt) : elt := + match y with + | 1 => x + | y~1 => rev_append y x~1 + | y~0 => rev_append y x~0 end. - Definition for_all m := xforall m 1. + Infix "@" := rev_append (at level 60). + Definition rev x := x@1. - Fixpoint xexists (m : t) (i : positive) := + Section Fold. + + Variables B : Type. + Variable f : positive -> B -> B. + + (** the additional argument, [i], records the current path, in + reverse order (this should be more efficient: we reverse this argument + only at present nodes only, rather than at each node of the tree). + we also use this convention in all functions below + *) + + Fixpoint xfold (m : t) (v : B) (i : positive) := + match m with + | Leaf => v + | Node l true r => + xfold r (f (rev i) (xfold l v i~0)) i~1 + | Node l false r => + xfold r (xfold l v i~0) i~1 + end. + Definition fold m i := xfold m i 1. + + End Fold. + + Section Quantifiers. + + Variable f : positive -> bool. + + Fixpoint xforall (m : t) (i : positive) := + match m with + | Leaf => true + | Node l o r => + (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 + end. + Definition for_all m := xforall m 1. + + Fixpoint xexists (m : t) (i : positive) := + match m with + | Leaf => false + | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 + end. + Definition exists_ m := xexists m 1. + + Fixpoint xfilter (m : t) (i : positive) : t := + match m with + | Leaf => Leaf + | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) + end. + Definition filter m := xfilter m 1. + + Fixpoint xpartition (m : t) (i : positive) : t * t := + match m with + | Leaf => (Leaf,Leaf) + | Node l o r => + let (lt,lf) := xpartition l i~0 in + let (rt,rf) := xpartition r i~1 in + if o then + let fi := f (rev i) in + (node lt fi rt, node lf (negb fi) rf) + else + (node lt false rt, node lf false rf) + end. + Definition partition m := xpartition m 1. + + End Quantifiers. + + (** uses [a] to accumulate values rather than doing a lot of concatenations *) + + Fixpoint xelements (m : t) (i : positive) (a: list positive) := match m with - | Leaf => false - | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 + | Leaf => a + | Node l false r => xelements l i~0 (xelements r i~1 a) + | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) end. - Definition exists_ m := xexists m 1. - Fixpoint xfilter (m : t) (i : positive) : t := + Definition elements (m : t) := xelements m 1 nil. + + Fixpoint cardinal (m : t) : nat := match m with - | Leaf => Leaf - | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) + | Leaf => O + | Node l false r => (cardinal l + cardinal r)%nat + | Node l true r => S (cardinal l + cardinal r) + end. + + (** would it be more efficient to use a path like in the above functions ? *) + + Fixpoint choose (m: t) : option elt := + match m with + | Leaf => None + | Node l o r => if o then Some 1 else + match choose l with + | None => option_map xI (choose r) + | Some i => Some i~0 + end end. - Definition filter m := xfilter m 1. - Fixpoint xpartition (m : t) (i : positive) : t * t := + Fixpoint min_elt (m: t) : option elt := match m with - | Leaf => (Leaf,Leaf) + | Leaf => None | Node l o r => - let (lt,lf) := xpartition l i~0 in - let (rt,rf) := xpartition r i~1 in - if o then - let fi := f (rev i) in - (node lt fi rt, node lf (negb fi) rf) - else - (node lt false rt, node lf false rf) + match min_elt l with + | None => if o then Some 1 else option_map xI (min_elt r) + | Some i => Some i~0 + end end. - Definition partition m := xpartition m 1. - - End Quantifiers. - - (** uses [a] to accumulate values rather than doing a lot of concatenations *) - - Fixpoint xelements (m : t) (i : positive) (a: list positive) := - match m with - | Leaf => a - | Node l false r => xelements l i~0 (xelements r i~1 a) - | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) - end. - - Definition elements (m : t) := xelements m 1 nil. - - Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => O - | Node l false r => (cardinal l + cardinal r)%nat - | Node l true r => S (cardinal l + cardinal r) - end. - - (** would it be more efficient to use a path like in the above functions ? *) - - Fixpoint choose (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => if o then Some 1 else - match choose l with - | None => option_map xI (choose r) - | Some i => Some i~0 - end - end. - - Fixpoint min_elt (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => - match min_elt l with - | None => if o then Some 1 else option_map xI (min_elt r) - | Some i => Some i~0 - end - end. - - Fixpoint max_elt (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => - match max_elt r with - | None => if o then Some 1 else option_map xO (max_elt l) - | Some i => Some i~1 - end - end. - - (** lexicographic product, defined using a notation to keep things lazy *) - - Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. - - Definition compare_bool a b := - match a,b with - | false, true => Lt - | true, false => Gt - | _,_ => Eq - end. - - Fixpoint compare (m m': t): comparison := - match m,m' with - | Leaf,_ => if is_empty m' then Eq else Lt - | _,Leaf => if is_empty m then Eq else Gt - | Node l o r,Node l' o' r' => - lex (compare_bool o o') (lex (compare l l') (compare r r')) - end. - - - Definition In i t := mem i t = true. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq := Equal. - Definition lt m m' := compare m m' = Lt. - - (** Specification of [In] *) - -#[global] - Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. - Proof. - intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition. - Qed. - - (** Specification of [eq] *) - - #[local] Instance eq_equiv : Equivalence eq. - Proof. firstorder. Qed. - - (** Specification of [mem] *) - - Lemma mem_spec: forall s x, mem x s = true <-> In x s. - Proof. unfold In. intuition. Qed. - - (** Additional lemmas for mem *) - - Lemma mem_Leaf: forall x, mem x Leaf = false. - Proof. destruct x; trivial. Qed. - - (** Specification of [empty] *) - - Lemma empty_spec : Empty empty. - Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. - - (** Specification of node *) - - Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). - Proof. - intros x l o r. - case o; trivial. - destruct l; trivial. - destruct r; trivial. - destruct x; reflexivity. - Qed. - #[local] Opaque node. - - (** Specification of [is_empty] *) - - Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s. - Proof. - unfold Empty, In. - induction s as [|l IHl o r IHr]; simpl. - - firstorder. - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr. - destruct o; simpl; split. - + intuition discriminate. - + intro H. elim (H 1). reflexivity. - + intros H [a|a|]; apply H || intro; discriminate. - + intro H. split. - * split. - -- reflexivity. - -- intro a. apply (H a~0). - * intro a. apply (H a~1). - Qed. - - (** Specification of [subset] *) - - Lemma subset_Leaf_s: forall s, Leaf [<=] s. - Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed. - - Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'. - Proof. - induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. - - split; intros. - + apply subset_Leaf_s. - + reflexivity. - - - split; intros. - + apply subset_Leaf_s. - + reflexivity. - - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec. - destruct o; simpl. - + split. - * intuition discriminate. - * intro H. elim (@empty_spec 1). apply H. reflexivity. - + split; intro H. - * destruct H as [[_ Hl] Hr]. - intros [i|i|] Hi. - -- elim (Hr i Hi). - -- elim (Hl i Hi). - -- discriminate. - * split. - -- split. - ++ reflexivity. - ++ unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption. - -- unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption. - - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear. - destruct o; simpl. - + split; intro H. - * destruct H as [[Ho' Hl] Hr]. rewrite Ho'. - intros i Hi. destruct i. - -- apply (Hr i). assumption. - -- apply (Hl i). assumption. - -- assumption. - * split. - -- split. - ++ destruct o'; trivial. - specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. - ++ intros i Hi. apply (H i~0). apply Hi. - -- intros i Hi. apply (H i~1). apply Hi. - + split; intros. - * intros i Hi. destruct i; destruct H as [[H Hl] Hr]. - -- apply (Hr i). assumption. - -- apply (Hl i). assumption. - -- discriminate Hi. - * split. - -- split. - ++ reflexivity. - ++ intros i Hi. apply (H i~0). apply Hi. - -- intros i Hi. apply (H i~1). apply Hi. - Qed. - - (** Specification of [equal] (via subset) *) - - Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. - Proof. - induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. - - destruct o. - + reflexivity. - + rewrite andb_comm. reflexivity. - - rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. - rewrite 7andb_true_iff, eqb_true_iff. - rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. - + destruct o'; reflexivity. - + destruct o'; reflexivity. - + destruct o; auto. destruct o'; trivial. - Qed. - - Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'. - Proof. - intros. rewrite equal_subset. rewrite andb_true_iff. - rewrite 2subset_spec. unfold Equal, Subset. firstorder. - Qed. - - Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. - Proof. - unfold eq. - intros. case_eq (equal s s'); intro H. - - left. apply equal_spec, H. - - right. rewrite <- equal_spec. congruence. - Defined. - - (** (Specified) definition of [compare] *) - - Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> - lex u v = CompOpp (lex u' v'). - Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. - - Lemma compare_bool_inv: forall b b', - compare_bool b b' = CompOpp (compare_bool b' b). - Proof. intros [|] [|]; reflexivity. Qed. - - Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s). - Proof. - induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. - - unfold compare. case is_empty; reflexivity. - - unfold compare. case is_empty; reflexivity. - - simpl. rewrite compare_bool_inv. - case compare_bool; simpl; trivial; apply lex_Opp; auto. - Qed. - - Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. - Proof. intros u v; destruct u; intuition discriminate. Qed. - - Lemma compare_bool_Eq: forall b1 b2, - compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. - Proof. intros [|] [|]; intuition discriminate. Qed. - - Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true. - Proof. - induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. - - simpl. tauto. - - unfold compare, equal. case is_empty; intuition discriminate. - - unfold compare, equal. case is_empty; intuition discriminate. - - simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. - rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. - rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. - Qed. - - - Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s. - Proof. - unfold lt. intros s s'. rewrite compare_inv. - case compare; trivial; intros; discriminate. - Qed. - - Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'. - Proof. - unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. - Qed. - - Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s'). - Proof. - intros. case_eq (compare s s'); intro H; constructor. - - apply compare_eq, H. - - assumption. - - apply compare_gt, H. - Qed. - - Section lt_spec. - - Inductive ct: comparison -> comparison -> comparison -> Prop := - | ct_xxx: forall x, ct x x x - | ct_xex: forall x, ct x Eq x - | ct_exx: forall x, ct Eq x x - | ct_glx: forall x, ct Gt Lt x - | ct_lgx: forall x, ct Lt Gt x. - - Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_xce: forall x, ct x (CompOpp x) Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_lxl: forall x, ct Lt x Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_gxg: forall x, ct Gt x Gt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xll: forall x, ct x Lt Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xgg: forall x, ct x Gt Gt. - Proof. destruct x; constructor. Qed. - - #[local] Hint Constructors ct: ct. - #[local] Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. - Ltac ct := trivial with ct. - - Lemma ct_lex: forall u v w u' v' w', - ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). - Proof. - intros u v w u' v' w' H H'. - inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. - Qed. - - Lemma ct_compare_bool: - forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). - Proof. - intros [|] [|] [|]; constructor. - Qed. - - Lemma compare_x_Leaf: forall s, - compare s Leaf = if is_empty s then Eq else Gt. - Proof. - intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. - Qed. - - Lemma compare_empty_x: forall a, is_empty a = true -> - forall b, compare a b = if is_empty b then Eq else Lt. - Proof. - induction a as [|l IHl o r IHr]; trivial. - destruct o. - - intro; discriminate. - - simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. - intros [Hl Hr]. - destruct b as [|l' [|] r']; simpl compare; trivial. - + rewrite Hl, Hr. trivial. - + rewrite (IHl Hl), (IHr Hr). simpl. - case (is_empty l'); case (is_empty r'); trivial. - Qed. - - Lemma compare_x_empty: forall a, is_empty a = true -> - forall b, compare b a = if is_empty b then Eq else Gt. - Proof. - setoid_rewrite <- compare_x_Leaf. - intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. - Qed. - - Lemma ct_compare: - forall a b c, ct (compare a b) (compare b c) (compare a c). - Proof. - induction a as [|l IHl o r IHr]; intros s' s''. - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. - + rewrite compare_inv. ct. - + unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'. - * rewrite (compare_empty_x _ H'). ct. - * unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H'. ct. - -- ct. - - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. - + ct. - + unfold compare at 2. rewrite compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite (compare_empty_x _ H). ct. - * case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H. ct. - -- ct. - - + rewrite 2 compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite compare_inv, (compare_x_empty _ H). ct. - * case_eq (is_empty (Node l' o' r')); intro H'. - -- rewrite (compare_x_empty _ H'), H. ct. - -- ct. - - + simpl compare. apply ct_lex. - * apply ct_compare_bool. - * apply ct_lex; trivial. - Qed. - - End lt_spec. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - unfold lt. split. - - intros x H. - assert (compare x x = Eq). - + apply compare_equal, equal_spec. reflexivity. - + congruence. - - intros a b c. assert (H := ct_compare a b c). - inversion_clear H; trivial; intros; discriminate. - Qed. - - #[local] Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare. - Proof. - intros x x' Hx y y' Hy. subst y'. - unfold eq in *. rewrite <- equal_spec, <- compare_equal in *. - assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto. - Qed. - -#[global] - Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. - Proof. - intros x x' Hx y y' Hy. rewrite Hx. - rewrite compare_inv, Hy, <- compare_inv. reflexivity. - Qed. - - #[local] Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition. - Qed. - - (** Specification of [add] *) - - Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s. - Proof. - unfold In. intros s x y; revert x y s. - induction x; intros [y|y|] [|l o r]; simpl mem; - try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. - Qed. - - (** Specification of [remove] *) - - Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x. - Proof. - unfold In. intros s x y; revert x y s. - induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; - simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; - intuition congruence. - Qed. - - (** Specification of [singleton] *) - - Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x. - Proof. - unfold singleton. intros x y. rewrite add_spec. intuition. - unfold In in *. rewrite mem_Leaf in *. discriminate. - Qed. - - (** Specification of [union] *) - - Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'. - Proof. - unfold In. intros s s' x; revert x s s'. - induction x; destruct s; destruct s'; simpl union; simpl mem; - try (rewrite IHx; clear IHx); try intuition congruence. - apply orb_true_iff. - Qed. - - (** Specification of [inter] *) - - Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'. - Proof. - unfold In. intros s s' x; revert x s s'. - induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; - simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. - apply andb_true_iff. - Qed. - - (** Specification of [diff] *) - - Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'. - Proof. - unfold In. intros s s' x; revert x s s'. - induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; - rewrite ?mem_node; simpl mem; - try (rewrite IHx; clear IHx); try intuition congruence. - rewrite andb_true_iff. destruct o'; intuition discriminate. - Qed. - - (** Specification of [fold] *) - - Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - unfold fold, elements. intros s A i f. revert s i. - set (f' := fun a e => f e a). - assert (H: forall s i j acc, - fold_left f' acc (xfold f s i j) = - fold_left f' (xelements s j acc) i). - - - induction s as [|l IHl o r IHr]; intros; trivial. - destruct o; simpl xelements; simpl xfold. - + rewrite IHr, <- IHl. reflexivity. - + rewrite IHr. apply IHl. - - - intros. exact (H s i 1 nil). - Qed. - - (** Specification of [cardinal] *) - - Lemma cardinal_spec: forall s, cardinal s = length (elements s). - Proof. - unfold elements. - assert (H: forall s j acc, - (cardinal s + length acc)%nat = length (xelements s j acc)). - - - induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. - + rewrite <- IHl. simpl. rewrite <- IHr. - rewrite <- plus_n_Sm, Nat.add_assoc. reflexivity. - + rewrite <- IHl, <- IHr. rewrite Nat.add_assoc. reflexivity. - - - intros. rewrite <- H. simpl. rewrite Nat.add_comm. reflexivity. - Qed. - - (** Specification of [filter] *) - - Lemma xfilter_spec: forall f s x i, - In x (xfilter f s i) <-> In x s /\ f (i@x) = true. - Proof. - intro f. unfold In. - induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. - - rewrite mem_Leaf. intuition discriminate. - - rewrite mem_node. destruct x; simpl. - + rewrite IHr. reflexivity. - + rewrite IHl. reflexivity. - + rewrite <- andb_lazy_alt. apply andb_true_iff. - Qed. - - Lemma filter_spec: forall s x f, @compat_bool elt E.eq f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. intros. apply xfilter_spec. Qed. - - (** Specification of [for_all] *) - - Lemma xforall_spec: forall f s i, - xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. - Proof. - unfold For_all, In. intro f. - induction s as [|l IHl o r IHr]; intros i; simpl. - - intuition discriminate. - - rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. - rewrite IHl, IHr. clear IHl IHr. - split. - + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. - * apply Hr, H. - * apply Hl, H. - * rewrite H in Hi. assumption. - + intro H; intuition. - * specialize (H 1). destruct o. - -- apply H. reflexivity. - -- reflexivity. - * apply H. assumption. - * apply H. assumption. - Qed. - - Lemma for_all_spec: forall s f, @compat_bool elt E.eq f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. intros. apply xforall_spec. Qed. - - (** Specification of [exists] *) - - Lemma xexists_spec: forall f s i, - xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. - Proof. - unfold Exists, In. intro f. - induction s as [|l IHl o r IHr]; intros i; simpl. - - firstorder with bool. - - rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. - rewrite IHl, IHr. clear IHl IHr. - split. - + intros [[Hi|[x Hr]]|[x Hl]]. - * exists 1. exact Hi. - * exists x~1. exact Hr. - * exists x~0. exact Hl. - + intros [[x|x|] H]; eauto. - Qed. - - Lemma exists_spec : forall s f, @compat_bool elt E.eq f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. intros. apply xexists_spec. Qed. - - - (** Specification of [partition] *) - - Lemma partition_filter : forall s f, - partition f s = (filter f s, filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter. intros s f. generalize 1 as j. - induction s as [|l IHl o r IHr]; intro j. - - reflexivity. - - destruct o; simpl; rewrite IHl, IHr; reflexivity. - Qed. - - Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. intros. rewrite partition_filter. reflexivity. Qed. - - Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. intros. rewrite partition_filter. reflexivity. Qed. - - - (** Specification of [elements] *) - - Notation InL := (InA E.eq). - - Lemma xelements_spec: forall s j acc y, - InL y (xelements s j acc) - <-> - InL y acc \/ exists x, y=(j@x) /\ mem x s = true. - Proof. - induction s as [|l IHl o r IHr]; simpl. - - intros. split; intro H. - + left. assumption. - + destruct H as [H|[x [Hx Hx']]]. - * assumption. - * discriminate. - - - intros j acc y. case o. - + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. - * intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. - -- right. exists x~1. auto. - -- right. exists x~0. auto. - * intros [H|[x [-> H]]]. - -- eauto. - -- destruct x. - ++ left. right. right. exists x; auto. - ++ right. exists x; auto. - ++ left. left. reflexivity. - - + rewrite IHl, IHr. clear IHl IHr. split. - * intros [[H|[x [-> H]]]|[x [-> H]]]. - -- eauto. - -- right. exists x~1. auto. - -- right. exists x~0. auto. - * intros [H|[x [-> H]]]. - -- eauto. - -- destruct x. - ++ left. right. exists x; auto. - ++ right. exists x; auto. - ++ discriminate. - Qed. - - Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s. - Proof. - unfold elements. intros. rewrite xelements_spec. - split; [ intros [A|(y & B & C)] | intros IN ]. - - inversion A. - - simpl in *. congruence. - - right. exists x. auto. - Qed. - - Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). - Proof. induction j; intros; simpl; auto. Qed. - - Lemma elements_spec2: forall s, sort E.lt (elements s). - Proof. - unfold elements. - assert (H: forall s j acc, - sort E.lt acc -> - (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> - sort E.lt (xelements s j acc)). - - - induction s as [|l IHl o r IHr]; simpl; trivial. - intros j acc Hacc Hsacc. destruct o. - + apply IHl. - * constructor. - -- apply IHr. - ++ apply Hacc. - ++ intros x y Hx Hy. apply Hsacc; assumption. - -- case_eq (xelements r j~1 acc). - ++ constructor. - ++ intros z q H. constructor. - assert (H': InL z (xelements r j~1 acc)). - ** rewrite H. constructor. reflexivity. - ** { clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. - - apply (Hsacc 1 z); trivial. reflexivity. - - simpl. apply lt_rev_append. exact I. - } - * intros x y Hx Hy. inversion_clear Hy. - -- rewrite H. simpl. apply lt_rev_append. exact I. - -- rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. - ++ apply Hsacc; assumption. - ++ simpl. apply lt_rev_append. exact I. - - + apply IHl. - * apply IHr. - -- apply Hacc. - -- intros x y Hx Hy. apply Hsacc; assumption. - * intros x y Hx Hy. rewrite xelements_spec in Hy. - destruct Hy as [Hy|[z [-> Hy]]]. - -- apply Hsacc; assumption. - -- simpl. apply lt_rev_append. exact I. - - - intros. apply H. - + constructor. - + intros x y _ H'. inversion H'. - Qed. - - Lemma elements_spec2w: forall s, NoDupA E.eq (elements s). - Proof. - intro. apply SortA_NoDupA with E.lt; auto with *. - apply elements_spec2. - Qed. - - - (** Specification of [choose] *) - - Lemma choose_spec1: forall s x, choose s = Some x -> In x s. - Proof. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - destruct o. - + intros x H. injection H; intros; subst. reflexivity. - + revert IHl. case choose. - * intros p Hp x [= <-]. apply Hp. - reflexivity. - * intros _ x. revert IHr. case choose. - -- intros p Hp [= <-]. apply Hp. - reflexivity. - -- intros. discriminate. - Qed. - - Lemma choose_spec2: forall s, choose s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_spec. - - destruct o. - + discriminate. - + simpl in H. destruct (choose l). - * discriminate. - * destruct (choose r). - -- discriminate. - -- intros [a|a|]. - ++ apply IHr. reflexivity. - ++ apply IHl. reflexivity. - ++ discriminate. - Qed. - - Lemma choose_empty: forall s, is_empty s = true -> choose s = None. - Proof. - intros s Hs. case_eq (choose s); trivial. - intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs. - elim (Hs _ Hp). - Qed. - - Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'. - Proof. - setoid_rewrite <- equal_spec. - induction s as [|l IHl o r IHr]. - - intros. symmetry. apply choose_empty. assumption. - - - destruct s' as [|l' o' r']. - + generalize (Node l o r) as s. simpl. intros. apply choose_empty. - rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H. - assumption. - - + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. - intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. - Qed. - - Lemma choose_spec3: forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. - Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed. - - - (** Specification of [min_elt] *) - - Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s. - Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (min_elt l); intros. - + injection H as [= <-]. apply IHl. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (min_elt r); simpl in *. - -- injection H as [= <-]. apply IHr. reflexivity. - -- discriminate. - Qed. - - Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_spec. - - intros [a|a|]. - + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. - case min_elt; intros; try discriminate. destruct o; discriminate. - + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. - intro; discriminate. - + revert H. clear. simpl. case min_elt; intros; try discriminate. - destruct o; discriminate. - Qed. - - Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. - unfold In. - induction s as [|l IHl o r IHr]; intros x y H H'. - - discriminate. - - simpl in H. case_eq (min_elt l). - + intros p Hp. rewrite Hp in H. injection H as [= <-]. - destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. - + intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp. - destruct o. - * injection H as [= <-]. intros Hl. - destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). - - * destruct (min_elt r). - -- injection H as [= <-]. - destruct y as [z|z|]. - ++ apply (IHr e z); trivial. - ++ elim (Hp _ H'). - ++ discriminate. - -- discriminate. - Qed. - - - (** Specification of [max_elt] *) - - Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s. - Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (max_elt r); intros. - + injection H as [= <-]. apply IHr. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (max_elt l); simpl in *. - -- injection H as [= <-]. apply IHl. reflexivity. - -- discriminate. - Qed. - - Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_spec. - - intros [a|a|]. - + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. - intro; discriminate. - + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. - case max_elt; intros; try discriminate. destruct o; discriminate. - + revert H. clear. simpl. case max_elt; intros; try discriminate. - destruct o; discriminate. - Qed. - - Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. - unfold In. - induction s as [|l IHl o r IHr]; intros x y H H'. - - discriminate. - - simpl in H. case_eq (max_elt r). - + intros p Hp. rewrite Hp in H. injection H as [= <-]. - destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. - + intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp. + + Fixpoint max_elt (m: t) : option elt := + match m with + | Leaf => None + | Node l o r => + match max_elt r with + | None => if o then Some 1 else option_map xO (max_elt l) + | Some i => Some i~1 + end + end. + + (** lexicographic product, defined using a notation to keep things lazy *) + + Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. + + Definition compare_bool a b := + match a,b with + | false, true => Lt + | true, false => Gt + | _,_ => Eq + end. + + Fixpoint compare (m m': t): comparison := + match m,m' with + | Leaf,_ => if is_empty m' then Eq else Lt + | _,Leaf => if is_empty m then Eq else Gt + | Node l o r,Node l' o' r' => + lex (compare_bool o o') (lex (compare l l') (compare r r')) + end. + + + Definition In i t := mem i t = true. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq := Equal. + Definition lt m m' := compare m m' = Lt. + + (** Specification of [In] *) + + #[global] + Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. + Proof. + intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition. + Qed. + + (** Specification of [eq] *) + + #[local] Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + (** Specification of [mem] *) + + Lemma mem_spec: forall s x, mem x s = true <-> In x s. + Proof. unfold In. intuition. Qed. + + (** Additional lemmas for mem *) + + Lemma mem_Leaf: forall x, mem x Leaf = false. + Proof. destruct x; trivial. Qed. + + (** Specification of [empty] *) + + Lemma empty_spec : Empty empty. + Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. + + (** Specification of node *) + + Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). + Proof. + intros x l o r. + case o; trivial. + destruct l; trivial. + destruct r; trivial. + destruct x; reflexivity. + Qed. + #[local] Opaque node. + + (** Specification of [is_empty] *) + + Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s. + Proof. + unfold Empty, In. + induction s as [|l IHl o r IHr]; simpl. + - firstorder. + - rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr. + destruct o; simpl; split. + + intuition discriminate. + + intro H. elim (H 1). reflexivity. + + intros H [a|a|]; apply H || intro; discriminate. + + intro H. split. + * split. + -- reflexivity. + -- intro a. apply (H a~0). + * intro a. apply (H a~1). + Qed. + + (** Specification of [subset] *) + + Lemma subset_Leaf_s: forall s, Leaf [<=] s. + Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed. + + Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. + - split; intros. + + apply subset_Leaf_s. + + reflexivity. + + - split; intros. + + apply subset_Leaf_s. + + reflexivity. + + - rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec. + destruct o; simpl. + + split. + * intuition discriminate. + * intro H. elim (@empty_spec 1). apply H. reflexivity. + + split; intro H. + * destruct H as [[_ Hl] Hr]. + intros [i|i|] Hi. + -- elim (Hr i Hi). + -- elim (Hl i Hi). + -- discriminate. + * split. + -- split. + ++ reflexivity. + ++ unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption. + -- unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption. + + - rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear. + destruct o; simpl. + + split; intro H. + * destruct H as [[Ho' Hl] Hr]. rewrite Ho'. + intros i Hi. destruct i. + -- apply (Hr i). assumption. + -- apply (Hl i). assumption. + -- assumption. + * split. + -- split. + ++ destruct o'; trivial. + specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. + ++ intros i Hi. apply (H i~0). apply Hi. + -- intros i Hi. apply (H i~1). apply Hi. + + split; intros. + * intros i Hi. destruct i; destruct H as [[H Hl] Hr]. + -- apply (Hr i). assumption. + -- apply (Hl i). assumption. + -- discriminate Hi. + * split. + -- split. + ++ reflexivity. + ++ intros i Hi. apply (H i~0). apply Hi. + -- intros i Hi. apply (H i~1). apply Hi. + Qed. + + (** Specification of [equal] (via subset) *) + + Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. + - destruct o. + + reflexivity. + + rewrite andb_comm. reflexivity. + - rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. + rewrite 7andb_true_iff, eqb_true_iff. + rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. + + destruct o'; reflexivity. + + destruct o'; reflexivity. + + destruct o; auto. destruct o'; trivial. + Qed. + + Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'. + Proof. + intros. rewrite equal_subset. rewrite andb_true_iff. + rewrite 2subset_spec. unfold Equal, Subset. firstorder. + Qed. + + Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. + Proof. + unfold eq. + intros. case_eq (equal s s'); intro H. + - left. apply equal_spec, H. + - right. rewrite <- equal_spec. congruence. + Defined. + + (** (Specified) definition of [compare] *) + + Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> + lex u v = CompOpp (lex u' v'). + Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. + + Lemma compare_bool_inv: forall b b', + compare_bool b b' = CompOpp (compare_bool b' b). + Proof. intros [|] [|]; reflexivity. Qed. + + Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s). + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. + - unfold compare. case is_empty; reflexivity. + - unfold compare. case is_empty; reflexivity. + - simpl. rewrite compare_bool_inv. + case compare_bool; simpl; trivial; apply lex_Opp; auto. + Qed. + + Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. + Proof. intros u v; destruct u; intuition discriminate. Qed. + + Lemma compare_bool_Eq: forall b1 b2, + compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. + Proof. intros [|] [|]; intuition discriminate. Qed. + + Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true. + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. + - simpl. tauto. + - unfold compare, equal. case is_empty; intuition discriminate. + - unfold compare, equal. case is_empty; intuition discriminate. + - simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. + rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. + rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. + Qed. + + + Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s. + Proof. + unfold lt. intros s s'. rewrite compare_inv. + case compare; trivial; intros; discriminate. + Qed. + + Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'. + Proof. + unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. + Qed. + + Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s'). + Proof. + intros. case_eq (compare s s'); intro H; constructor. + - apply compare_eq, H. + - assumption. + - apply compare_gt, H. + Qed. + + Section lt_spec. + + Inductive ct: comparison -> comparison -> comparison -> Prop := + | ct_xxx: forall x, ct x x x + | ct_xex: forall x, ct x Eq x + | ct_exx: forall x, ct Eq x x + | ct_glx: forall x, ct Gt Lt x + | ct_lgx: forall x, ct Lt Gt x. + + Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_xce: forall x, ct x (CompOpp x) Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_lxl: forall x, ct Lt x Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_gxg: forall x, ct Gt x Gt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xll: forall x, ct x Lt Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xgg: forall x, ct x Gt Gt. + Proof. destruct x; constructor. Qed. + + #[local] Hint Constructors ct: ct. + #[local] Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. + Ltac ct := trivial with ct. + + Lemma ct_lex: forall u v w u' v' w', + ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). + Proof. + intros u v w u' v' w' H H'. + inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. + Qed. + + Lemma ct_compare_bool: + forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). + Proof. + intros [|] [|] [|]; constructor. + Qed. + + Lemma compare_x_Leaf: forall s, + compare s Leaf = if is_empty s then Eq else Gt. + Proof. + intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. + Qed. + + Lemma compare_empty_x: forall a, is_empty a = true -> + forall b, compare a b = if is_empty b then Eq else Lt. + Proof. + induction a as [|l IHl o r IHr]; trivial. destruct o. - * injection H as [= <-]. intros Hl. - destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). - - * destruct (max_elt l). - -- injection H as [= <-]. - destruct y as [z|z|]. - ++ elim (Hp _ H'). - ++ apply (IHl e z); trivial. - ++ discriminate. - -- discriminate. - Qed. + - intro; discriminate. + - simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. + intros [Hl Hr]. + destruct b as [|l' [|] r']; simpl compare; trivial. + + rewrite Hl, Hr. trivial. + + rewrite (IHl Hl), (IHr Hr). simpl. + case (is_empty l'); case (is_empty r'); trivial. + Qed. + + Lemma compare_x_empty: forall a, is_empty a = true -> + forall b, compare b a = if is_empty b then Eq else Gt. + Proof. + setoid_rewrite <- compare_x_Leaf. + intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. + Qed. + + Lemma ct_compare: + forall a b c, ct (compare a b) (compare b c) (compare a c). + Proof. + induction a as [|l IHl o r IHr]; intros s' s''. + - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. + + rewrite compare_inv. ct. + + unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'. + * rewrite (compare_empty_x _ H'). ct. + * unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. + -- rewrite (compare_x_empty _ H''), H'. ct. + -- ct. + + - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. + + ct. + + unfold compare at 2. rewrite compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + * rewrite (compare_empty_x _ H). ct. + * case_eq (is_empty (Node l'' o'' r'')); intro H''. + -- rewrite (compare_x_empty _ H''), H. ct. + -- ct. + + + rewrite 2 compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + * rewrite compare_inv, (compare_x_empty _ H). ct. + * case_eq (is_empty (Node l' o' r')); intro H'. + -- rewrite (compare_x_empty _ H'), H. ct. + -- ct. + + + simpl compare. apply ct_lex. + * apply ct_compare_bool. + * apply ct_lex; trivial. + Qed. + + End lt_spec. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + unfold lt. split. + - intros x H. + assert (compare x x = Eq). + + apply compare_equal, equal_spec. reflexivity. + + congruence. + - intros a b c. assert (H := ct_compare a b c). + inversion_clear H; trivial; intros; discriminate. + Qed. + + #[local] Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare. + Proof. + intros x x' Hx y y' Hy. subst y'. + unfold eq in *. rewrite <- equal_spec, <- compare_equal in *. + assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto. + Qed. + + #[global] + Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. + Proof. + intros x x' Hx y y' Hy. rewrite Hx. + rewrite compare_inv, Hy, <- compare_inv. reflexivity. + Qed. + + #[local] Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition. + Qed. + + (** Specification of [add] *) + + Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s. + Proof. + unfold In. intros s x y; revert x y s. + induction x; intros [y|y|] [|l o r]; simpl mem; + try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. + Qed. + + (** Specification of [remove] *) + + Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x. + Proof. + unfold In. intros s x y; revert x y s. + induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; + intuition congruence. + Qed. + + (** Specification of [singleton] *) + + Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x. + Proof. + unfold singleton. intros x y. rewrite add_spec. intuition. + unfold In in *. rewrite mem_Leaf in *. discriminate. + Qed. + + (** Specification of [union] *) + + Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'. + Proof. + unfold In. intros s s' x; revert x s s'. + induction x; destruct s; destruct s'; simpl union; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + apply orb_true_iff. + Qed. + + (** Specification of [inter] *) + + Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold In. intros s s' x; revert x s s'. + induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. + apply andb_true_iff. + Qed. + + (** Specification of [diff] *) + + Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'. + Proof. + unfold In. intros s s' x; revert x s s'. + induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; + rewrite ?mem_node; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + rewrite andb_true_iff. destruct o'; intuition discriminate. + Qed. + + (** Specification of [fold] *) + + Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. + unfold fold, elements. intros s A i f. revert s i. + set (f' := fun a e => f e a). + assert (H: forall s i j acc, + fold_left f' acc (xfold f s i j) = + fold_left f' (xelements s j acc) i). + + - induction s as [|l IHl o r IHr]; intros; trivial. + destruct o; simpl xelements; simpl xfold. + + rewrite IHr, <- IHl. reflexivity. + + rewrite IHr. apply IHl. + + - intros. exact (H s i 1 nil). + Qed. + + (** Specification of [cardinal] *) + + Lemma cardinal_spec: forall s, cardinal s = length (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + (cardinal s + length acc)%nat = length (xelements s j acc)). + + - induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. + + rewrite <- IHl. simpl. rewrite <- IHr. + rewrite <- plus_n_Sm, Nat.add_assoc. reflexivity. + + rewrite <- IHl, <- IHr. rewrite Nat.add_assoc. reflexivity. + + - intros. rewrite <- H. simpl. rewrite Nat.add_comm. reflexivity. + Qed. + + (** Specification of [filter] *) + + Lemma xfilter_spec: forall f s x i, + In x (xfilter f s i) <-> In x s /\ f (i@x) = true. + Proof. + intro f. unfold In. + induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. + - rewrite mem_Leaf. intuition discriminate. + - rewrite mem_node. destruct x; simpl. + + rewrite IHr. reflexivity. + + rewrite IHl. reflexivity. + + rewrite <- andb_lazy_alt. apply andb_true_iff. + Qed. + + Lemma filter_spec: forall s x f, @compat_bool elt E.eq f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. intros. apply xfilter_spec. Qed. + + (** Specification of [for_all] *) + + Lemma xforall_spec: forall f s i, + xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. + Proof. + unfold For_all, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + - intuition discriminate. + - rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. + * apply Hr, H. + * apply Hl, H. + * rewrite H in Hi. assumption. + + intro H; intuition. + * specialize (H 1). destruct o. + -- apply H. reflexivity. + -- reflexivity. + * apply H. assumption. + * apply H. assumption. + Qed. + + Lemma for_all_spec: forall s f, @compat_bool elt E.eq f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. intros. apply xforall_spec. Qed. + + (** Specification of [exists] *) + + Lemma xexists_spec: forall f s i, + xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. + Proof. + unfold Exists, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + - firstorder with bool. + - rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + + intros [[Hi|[x Hr]]|[x Hl]]. + * exists 1. exact Hi. + * exists x~1. exact Hr. + * exists x~0. exact Hl. + + intros [[x|x|] H]; eauto. + Qed. + + Lemma exists_spec : forall s f, @compat_bool elt E.eq f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. intros. apply xexists_spec. Qed. + + + (** Specification of [partition] *) + + Lemma partition_filter : forall s f, + partition f s = (filter f s, filter (fun x => negb (f x)) s). + Proof. + unfold partition, filter. intros s f. generalize 1 as j. + induction s as [|l IHl o r IHr]; intro j. + - reflexivity. + - destruct o; simpl; rewrite IHl, IHr; reflexivity. + Qed. + + Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f -> + Equal (fst (partition f s)) (filter f s). + Proof. intros. rewrite partition_filter. reflexivity. Qed. + + Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. intros. rewrite partition_filter. reflexivity. Qed. + + + (** Specification of [elements] *) + + Notation InL := (InA E.eq). + + Lemma xelements_spec: forall s j acc y, + InL y (xelements s j acc) + <-> + InL y acc \/ exists x, y=(j@x) /\ mem x s = true. + Proof. + induction s as [|l IHl o r IHr]; simpl. + - intros. split; intro H. + + left. assumption. + + destruct H as [H|[x [Hx Hx']]]. + * assumption. + * discriminate. + + - intros j acc y. case o. + + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. + * intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. + -- right. exists x~1. auto. + -- right. exists x~0. auto. + * intros [H|[x [-> H]]]. + -- eauto. + -- destruct x. + ++ left. right. right. exists x; auto. + ++ right. exists x; auto. + ++ left. left. reflexivity. + + + rewrite IHl, IHr. clear IHl IHr. split. + * intros [[H|[x [-> H]]]|[x [-> H]]]. + -- eauto. + -- right. exists x~1. auto. + -- right. exists x~0. auto. + * intros [H|[x [-> H]]]. + -- eauto. + -- destruct x. + ++ left. right. exists x; auto. + ++ right. exists x; auto. + ++ discriminate. + Qed. + + Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s. + Proof. + unfold elements. intros. rewrite xelements_spec. + split; [ intros [A|(y & B & C)] | intros IN ]. + - inversion A. + - simpl in *. congruence. + - right. exists x. auto. + Qed. + + Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). + Proof. induction j; intros; simpl; auto. Qed. + + Lemma elements_spec2: forall s, sort E.lt (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + sort E.lt acc -> + (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> + sort E.lt (xelements s j acc)). + + - induction s as [|l IHl o r IHr]; simpl; trivial. + intros j acc Hacc Hsacc. destruct o. + + apply IHl. + * constructor. + -- apply IHr. + ++ apply Hacc. + ++ intros x y Hx Hy. apply Hsacc; assumption. + -- case_eq (xelements r j~1 acc). + ++ constructor. + ++ intros z q H. constructor. + assert (H': InL z (xelements r j~1 acc)). + ** rewrite H. constructor. reflexivity. + ** { clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. + - apply (Hsacc 1 z); trivial. reflexivity. + - simpl. apply lt_rev_append. exact I. + } + * intros x y Hx Hy. inversion_clear Hy. + -- rewrite H. simpl. apply lt_rev_append. exact I. + -- rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. + ++ apply Hsacc; assumption. + ++ simpl. apply lt_rev_append. exact I. + + + apply IHl. + * apply IHr. + -- apply Hacc. + -- intros x y Hx Hy. apply Hsacc; assumption. + * intros x y Hx Hy. rewrite xelements_spec in Hy. + destruct Hy as [Hy|[z [-> Hy]]]. + -- apply Hsacc; assumption. + -- simpl. apply lt_rev_append. exact I. + + - intros. apply H. + + constructor. + + intros x y _ H'. inversion H'. + Qed. + + Lemma elements_spec2w: forall s, NoDupA E.eq (elements s). + Proof. + intro. apply SortA_NoDupA with E.lt; auto with *. + apply elements_spec2. + Qed. + + + (** Specification of [choose] *) + + Lemma choose_spec1: forall s x, choose s = Some x -> In x s. + Proof. + induction s as [| l IHl o r IHr]; simpl. + - intros. discriminate. + - destruct o. + + intros x H. injection H; intros; subst. reflexivity. + + revert IHl. case choose. + * intros p Hp x [= <-]. apply Hp. + reflexivity. + * intros _ x. revert IHr. case choose. + -- intros p Hp [= <-]. apply Hp. + reflexivity. + -- intros. discriminate. + Qed. + + Lemma choose_spec2: forall s, choose s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + - intro. apply empty_spec. + - destruct o. + + discriminate. + + simpl in H. destruct (choose l). + * discriminate. + * destruct (choose r). + -- discriminate. + -- intros [a|a|]. + ++ apply IHr. reflexivity. + ++ apply IHl. reflexivity. + ++ discriminate. + Qed. + + Lemma choose_empty: forall s, is_empty s = true -> choose s = None. + Proof. + intros s Hs. case_eq (choose s); trivial. + intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs. + elim (Hs _ Hp). + Qed. + + Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'. + Proof. + setoid_rewrite <- equal_spec. + induction s as [|l IHl o r IHr]. + - intros. symmetry. apply choose_empty. assumption. + + - destruct s' as [|l' o' r']. + + generalize (Node l o r) as s. simpl. intros. apply choose_empty. + rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H. + assumption. + + + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. + intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. + Qed. + + Lemma choose_spec3: forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed. + + + (** Specification of [min_elt] *) + + Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + - intros. discriminate. + - intros x. destruct (min_elt l); intros. + + injection H as [= <-]. apply IHl. reflexivity. + + destruct o; simpl. + * injection H as [= <-]. reflexivity. + * destruct (min_elt r); simpl in *. + -- injection H as [= <-]. apply IHr. reflexivity. + -- discriminate. + Qed. + + Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + - intro. apply empty_spec. + - intros [a|a|]. + + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. + case min_elt; intros; try discriminate. destruct o; discriminate. + + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. + intro; discriminate. + + revert H. clear. simpl. case min_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + - discriminate. + - simpl in H. case_eq (min_elt l). + + intros p Hp. rewrite Hp in H. injection H as [= <-]. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. + + intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp. + destruct o. + * injection H as [= <-]. intros Hl. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + * destruct (min_elt r). + -- injection H as [= <-]. + destruct y as [z|z|]. + ++ apply (IHr e z); trivial. + ++ elim (Hp _ H'). + ++ discriminate. + -- discriminate. + Qed. + + + (** Specification of [max_elt] *) + + Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + - intros. discriminate. + - intros x. destruct (max_elt r); intros. + + injection H as [= <-]. apply IHr. reflexivity. + + destruct o; simpl. + * injection H as [= <-]. reflexivity. + * destruct (max_elt l); simpl in *. + -- injection H as [= <-]. apply IHl. reflexivity. + -- discriminate. + Qed. + + Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + - intro. apply empty_spec. + - intros [a|a|]. + + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. + intro; discriminate. + + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. + case max_elt; intros; try discriminate. destruct o; discriminate. + + revert H. clear. simpl. case max_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + - discriminate. + - simpl in H. case_eq (max_elt r). + + intros p Hp. rewrite Hp in H. injection H as [= <-]. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. + + intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp. + destruct o. + * injection H as [= <-]. intros Hl. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + * destruct (max_elt l). + -- injection H as [= <-]. + destruct y as [z|z|]. + ++ elim (Hp _ H'). + ++ apply (IHl e z); trivial. + ++ discriminate. + -- discriminate. + Qed. End PositiveSet. diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v index d449e7e2e6..ea7d717fa5 100644 --- a/theories/MSets/MSetProperties.v +++ b/theories/MSets/MSetProperties.v @@ -29,889 +29,889 @@ Hint Unfold transpose : core. (** First, a functor for Weak Sets in functorial version. *) Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). - Module Import Dec := WDecideOn E M. - Module Import FM := Dec.F (* MSetFacts.WFactsOn E M *). - Import M. + Module Import Dec := WDecideOn E M. + Module Import FM := Dec.F (* MSetFacts.WFactsOn E M *). + Import M. - Lemma In_dec : forall x s, {In x s} + {~ In x s}. - Proof. - intros; generalize (mem_iff s x); case (mem x s); intuition auto with bool. - Qed. + Lemma In_dec : forall x s, {In x s} + {~ In x s}. + Proof. + intros; generalize (mem_iff s x); case (mem x s); intuition auto with bool. + Qed. - Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. + Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. - Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. - Proof. - unfold Add. - split; intros. - - red; intros. - rewrite H; clear H. - fsetdec. - - fsetdec. - Qed. + Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. + Proof. + unfold Add. + split; intros. + - red; intros. + rewrite H; clear H. + fsetdec. + - fsetdec. + Qed. - Ltac expAdd := repeat rewrite Add_Equal. + Ltac expAdd := repeat rewrite Add_Equal. - Section BasicProperties. + Section BasicProperties. - Variable s s' s'' s1 s2 s3 : t. - Variable x x' : elt. + Variable s s' s'' s1 s2 s3 : t. + Variable x x' : elt. - Lemma equal_refl : s[=]s. - Proof. fsetdec. Qed. + Lemma equal_refl : s[=]s. + Proof. fsetdec. Qed. - Lemma equal_sym : s[=]s' -> s'[=]s. - Proof. fsetdec. Qed. + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. fsetdec. Qed. - Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. - Proof. fsetdec. Qed. + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. fsetdec. Qed. - Lemma subset_refl : s[<=]s. - Proof. fsetdec. Qed. + Lemma subset_refl : s[<=]s. + Proof. fsetdec. Qed. - Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. - Proof. fsetdec. Qed. + Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. + Proof. fsetdec. Qed. - Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. - Proof. fsetdec. Qed. + Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. + Proof. fsetdec. Qed. - Lemma subset_equal : s[=]s' -> s[<=]s'. - Proof. fsetdec. Qed. + Lemma subset_equal : s[=]s' -> s[<=]s'. + Proof. fsetdec. Qed. - Lemma subset_empty : empty[<=]s. - Proof. fsetdec. Qed. + Lemma subset_empty : empty[<=]s. + Proof. fsetdec. Qed. - Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. - Proof. fsetdec. Qed. + Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. + Proof. fsetdec. Qed. - Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. - Proof. fsetdec. Qed. + Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. + Proof. fsetdec. Qed. - Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. - Proof. fsetdec. Qed. + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. + Proof. fsetdec. Qed. - Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. - Proof. fsetdec. Qed. + Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. + Proof. fsetdec. Qed. - Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. - Proof. fsetdec. Qed. + Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. + Proof. fsetdec. Qed. - Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. - Proof. intuition fsetdec. Qed. + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. + Proof. intuition fsetdec. Qed. - Lemma empty_is_empty_1 : Empty s -> s[=]empty. - Proof. fsetdec. Qed. + Lemma empty_is_empty_1 : Empty s -> s[=]empty. + Proof. fsetdec. Qed. - Lemma empty_is_empty_2 : s[=]empty -> Empty s. - Proof. fsetdec. Qed. + Lemma empty_is_empty_2 : s[=]empty -> Empty s. + Proof. fsetdec. Qed. - Lemma add_equal : In x s -> add x s [=] s. - Proof. fsetdec. Qed. + Lemma add_equal : In x s -> add x s [=] s. + Proof. fsetdec. Qed. - Lemma add_add : add x (add x' s) [=] add x' (add x s). - Proof. fsetdec. Qed. + Lemma add_add : add x (add x' s) [=] add x' (add x s). + Proof. fsetdec. Qed. - Lemma remove_equal : ~ In x s -> remove x s [=] s. - Proof. fsetdec. Qed. + Lemma remove_equal : ~ In x s -> remove x s [=] s. + Proof. fsetdec. Qed. - Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. - Proof. fsetdec. Qed. + Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. + Proof. fsetdec. Qed. - Lemma add_remove : In x s -> add x (remove x s) [=] s. - Proof. fsetdec. Qed. + Lemma add_remove : In x s -> add x (remove x s) [=] s. + Proof. fsetdec. Qed. - Lemma remove_add : ~In x s -> remove x (add x s) [=] s. - Proof. fsetdec. Qed. + Lemma remove_add : ~In x s -> remove x (add x s) [=] s. + Proof. fsetdec. Qed. - Lemma singleton_equal_add : singleton x [=] add x empty. - Proof. fsetdec. Qed. + Lemma singleton_equal_add : singleton x [=] add x empty. + Proof. fsetdec. Qed. - Lemma remove_singleton_empty : - In x s -> remove x s [=] empty -> singleton x [=] s. - Proof. fsetdec. Qed. + Lemma remove_singleton_empty : + In x s -> remove x s [=] empty -> singleton x [=] s. + Proof. fsetdec. Qed. - Lemma union_sym : union s s' [=] union s' s. - Proof. fsetdec. Qed. + Lemma union_sym : union s s' [=] union s' s. + Proof. fsetdec. Qed. - Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. - Proof. fsetdec. Qed. + Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. + Proof. fsetdec. Qed. - Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. - Proof. fsetdec. Qed. + Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. + Proof. fsetdec. Qed. - Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. - Proof. fsetdec. Qed. + Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. + Proof. fsetdec. Qed. - Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). - Proof. fsetdec. Qed. + Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). + Proof. fsetdec. Qed. - Lemma add_union_singleton : add x s [=] union (singleton x) s. - Proof. fsetdec. Qed. + Lemma add_union_singleton : add x s [=] union (singleton x) s. + Proof. fsetdec. Qed. - Lemma union_add : union (add x s) s' [=] add x (union s s'). - Proof. fsetdec. Qed. + Lemma union_add : union (add x s) s' [=] add x (union s s'). + Proof. fsetdec. Qed. - Lemma union_remove_add_1 : - union (remove x s) (add x s') [=] union (add x s) (remove x s'). - Proof. fsetdec. Qed. + Lemma union_remove_add_1 : + union (remove x s) (add x s') [=] union (add x s) (remove x s'). + Proof. fsetdec. Qed. - Lemma union_remove_add_2 : In x s -> - union (remove x s) (add x s') [=] union s s'. - Proof. fsetdec. Qed. + Lemma union_remove_add_2 : In x s -> + union (remove x s) (add x s') [=] union s s'. + Proof. fsetdec. Qed. - Lemma union_subset_1 : s [<=] union s s'. - Proof. fsetdec. Qed. + Lemma union_subset_1 : s [<=] union s s'. + Proof. fsetdec. Qed. - Lemma union_subset_2 : s' [<=] union s s'. - Proof. fsetdec. Qed. + Lemma union_subset_2 : s' [<=] union s s'. + Proof. fsetdec. Qed. - Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. - Proof. fsetdec. Qed. + Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. + Proof. fsetdec. Qed. - Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. + Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. + Proof. fsetdec. Qed. - Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. + Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. + Proof. fsetdec. Qed. - Lemma empty_union_1 : Empty s -> union s s' [=] s'. - Proof. fsetdec. Qed. + Lemma empty_union_1 : Empty s -> union s s' [=] s'. + Proof. fsetdec. Qed. - Lemma empty_union_2 : Empty s -> union s' s [=] s'. - Proof. fsetdec. Qed. + Lemma empty_union_2 : Empty s -> union s' s [=] s'. + Proof. fsetdec. Qed. - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). - Proof. fsetdec. Qed. + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Proof. fsetdec. Qed. - Lemma inter_sym : inter s s' [=] inter s' s. - Proof. fsetdec. Qed. + Lemma inter_sym : inter s s' [=] inter s' s. + Proof. fsetdec. Qed. - Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. - Proof. fsetdec. Qed. + Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. + Proof. fsetdec. Qed. - Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. - Proof. fsetdec. Qed. + Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. + Proof. fsetdec. Qed. - Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. - Proof. fsetdec. Qed. + Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. + Proof. fsetdec. Qed. - Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). - Proof. fsetdec. Qed. + Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). + Proof. fsetdec. Qed. - Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). - Proof. fsetdec. Qed. + Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). + Proof. fsetdec. Qed. - Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). - Proof. fsetdec. Qed. + Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). + Proof. fsetdec. Qed. - Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). - Proof. fsetdec. Qed. + Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). + Proof. fsetdec. Qed. - Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. - Proof. fsetdec. Qed. + Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. + Proof. fsetdec. Qed. - Lemma empty_inter_1 : Empty s -> Empty (inter s s'). - Proof. fsetdec. Qed. + Lemma empty_inter_1 : Empty s -> Empty (inter s s'). + Proof. fsetdec. Qed. - Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). - Proof. fsetdec. Qed. + Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). + Proof. fsetdec. Qed. - Lemma inter_subset_1 : inter s s' [<=] s. - Proof. fsetdec. Qed. + Lemma inter_subset_1 : inter s s' [<=] s. + Proof. fsetdec. Qed. - Lemma inter_subset_2 : inter s s' [<=] s'. - Proof. fsetdec. Qed. + Lemma inter_subset_2 : inter s s' [<=] s'. + Proof. fsetdec. Qed. - Lemma inter_subset_3 : - s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. - Proof. fsetdec. Qed. + Lemma inter_subset_3 : + s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. + Proof. fsetdec. Qed. - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). - Proof. fsetdec. Qed. + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Proof. fsetdec. Qed. - Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. - Proof. fsetdec. Qed. + Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. + Proof. fsetdec. Qed. - Lemma diff_subset : diff s s' [<=] s. - Proof. fsetdec. Qed. + Lemma diff_subset : diff s s' [<=] s. + Proof. fsetdec. Qed. - Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. - Proof. fsetdec. Qed. + Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. + Proof. fsetdec. Qed. - Lemma remove_diff_singleton : - remove x s [=] diff s (singleton x). - Proof. fsetdec. Qed. + Lemma remove_diff_singleton : + remove x s [=] diff s (singleton x). + Proof. fsetdec. Qed. - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. - Proof. fsetdec. Qed. + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Proof. fsetdec. Qed. - Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. - Proof. fsetdec. Qed. + Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. + Proof. fsetdec. Qed. - Lemma Add_add : Add x s (add x s). - Proof. expAdd; fsetdec. Qed. + Lemma Add_add : Add x s (add x s). + Proof. expAdd; fsetdec. Qed. - Lemma Add_remove : In x s -> Add x (remove x s) s. - Proof. expAdd; fsetdec. Qed. + Lemma Add_remove : In x s -> Add x (remove x s) s. + Proof. expAdd; fsetdec. Qed. - Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. + Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). + Proof. expAdd; fsetdec. Qed. - Lemma inter_Add : - In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. + Lemma inter_Add : + In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). + Proof. expAdd; fsetdec. Qed. - Lemma union_Equal : - In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. + Lemma union_Equal : + In x s'' -> Add x s s' -> union s s'' [=] union s' s''. + Proof. expAdd; fsetdec. Qed. - Lemma inter_Add_2 : - ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. - Proof. expAdd; fsetdec. Qed. + Lemma inter_Add_2 : + ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. + Proof. expAdd; fsetdec. Qed. - End BasicProperties. + End BasicProperties. - #[global] - Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. - #[global] - Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 - subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 - union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 - inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal - remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove - Equal_remove add_add : set. - - (** * Properties of elements *) - - Lemma elements_Empty : forall s, Empty s <-> elements s = nil. - Proof. - intros. - unfold Empty. - split; intros. - - assert (forall a, ~ List.In a (elements s)). { - red; intros. - apply (H a). - rewrite elements_iff. - rewrite InA_alt; exists a; auto with relations. - } - destruct (elements s); auto. - elim (H0 e); simpl; auto. - - red; intros. - rewrite elements_iff in H0. - rewrite InA_alt in H0; destruct H0. - rewrite H in H0; destruct H0 as (_,H0); inversion H0. - Qed. - - Lemma elements_empty : elements empty = nil. - Proof. - rewrite <-elements_Empty; auto with set. - Qed. - - (** * Conversions between lists and sets *) - - Definition of_list (l : list elt) := List.fold_right add empty l. - - Definition to_list := elements. - - Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. - Proof. - induction l; simpl; intro x. - - rewrite empty_iff, InA_nil. intuition. - - rewrite add_iff, InA_cons, IHl. intuition. - Qed. - - Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. - Proof. - unfold to_list; red; intros. - rewrite <- elements_iff; apply of_list_1. - Qed. - - Lemma of_list_3 : forall s, of_list (to_list s) [=] s. - Proof. - unfold to_list; red; intros. - rewrite of_list_1; symmetry; apply elements_iff. - Qed. - - (** * Fold *) - - Section Fold. - - Notation NoDup := (NoDupA E.eq). - Notation InA := (InA E.eq). - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : - fold f s i = List.fold_right f i (rev (elements s)). - Proof. - rewrite fold_spec. symmetry. apply fold_left_rev_right. - Qed. - - (** ** Induction principles for fold (contributed by S. Lescuyer) *) - - (** In the following lemma, the step hypothesis is deliberately restricted + #[global] + Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + #[global] + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 + inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove + Equal_remove add_add : set. + + (** * Properties of elements *) + + Lemma elements_Empty : forall s, Empty s <-> elements s = nil. + Proof. + intros. + unfold Empty. + split; intros. + - assert (forall a, ~ List.In a (elements s)). { + red; intros. + apply (H a). + rewrite elements_iff. + rewrite InA_alt; exists a; auto with relations. + } + destruct (elements s); auto. + elim (H0 e); simpl; auto. + - red; intros. + rewrite elements_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. + Qed. + + Lemma elements_empty : elements empty = nil. + Proof. + rewrite <-elements_Empty; auto with set. + Qed. + + (** * Conversions between lists and sets *) + + Definition of_list (l : list elt) := List.fold_right add empty l. + + Definition to_list := elements. + + Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. + Proof. + induction l; simpl; intro x. + - rewrite empty_iff, InA_nil. intuition. + - rewrite add_iff, InA_cons, IHl. intuition. + Qed. + + Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. + Proof. + unfold to_list; red; intros. + rewrite <- elements_iff; apply of_list_1. + Qed. + + Lemma of_list_3 : forall s, of_list (to_list s) [=] s. + Proof. + unfold to_list; red; intros. + rewrite of_list_1; symmetry; apply elements_iff. + Qed. + + (** * Fold *) + + Section Fold. + + Notation NoDup := (NoDupA E.eq). + Notation InA := (InA E.eq). + + (** Alternative specification via [fold_right] *) + + Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : + fold f s i = List.fold_right f i (rev (elements s)). + Proof. + rewrite fold_spec. symmetry. apply fold_left_rev_right. + Qed. + + (** ** Induction principles for fold (contributed by S. Lescuyer) *) + + (** In the following lemma, the step hypothesis is deliberately restricted to the precise set s we are considering. *) - Theorem fold_rec : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s', Empty s' -> P s' i) -> - (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> - P s' a -> P s'' (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pempty Pstep. - rewrite fold_spec_right. set (l:=rev (elements s)). - assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> - P s' a -> P s'' (f x a)). { - intros; eapply Pstep; eauto. - rewrite elements_iff, <- InA_rev; auto with *. - } - assert (Hdup : NoDup l) by - (unfold l; eauto using elements_3w, NoDupA_rev with * ). - assert (Hsame : forall x, In x s <-> InA x l) by - (unfold l; intros; rewrite elements_iff, InA_rev; intuition). - clear Pstep; clearbody l; revert s Hsame; induction l. - - (* empty *) - intros s Hsame; simpl. - apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. - - (* step *) - intros s Hsame; simpl. - apply Pstep' with (of_list l); auto with relations. - + inversion_clear Hdup; rewrite of_list_1; auto. - + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. - + apply IHl. - * intros; eapply Pstep'; eauto. - * inversion_clear Hdup; auto. - * exact (of_list_1 l). - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + Theorem fold_rec : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s', Empty s' -> P s' i) -> + (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pempty Pstep. + rewrite fold_spec_right. set (l:=rev (elements s)). + assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)). { + intros; eapply Pstep; eauto. + rewrite elements_iff, <- InA_rev; auto with *. + } + assert (Hdup : NoDup l) by + (unfold l; eauto using elements_3w, NoDupA_rev with * ). + assert (Hsame : forall x, In x s <-> InA x l) by + (unfold l; intros; rewrite elements_iff, InA_rev; intuition). + clear Pstep; clearbody l; revert s Hsame; induction l. + - (* empty *) + intros s Hsame; simpl. + apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. + - (* step *) + intros s Hsame; simpl. + apply Pstep' with (of_list l); auto with relations. + + inversion_clear Hdup; rewrite of_list_1; auto. + + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. + + apply IHl. + * intros; eapply Pstep'; eauto. + * inversion_clear Hdup; auto. + * exact (of_list_1 l). + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this case, [P] must be compatible with equality of sets *) - Theorem fold_rec_bis : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - (P empty i) -> - (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pmorphism Pempty Pstep. - apply fold_rec; intros. - - apply Pmorphism with empty; auto with set. - - rewrite Add_Equal in H1; auto with set. - apply Pmorphism with (add x s'); auto with set. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), - P i -> (forall x a, In x s -> P a -> P (f x a)) -> - P (fold f s i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + Theorem fold_rec_bis : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + (P empty i) -> + (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pmorphism Pempty Pstep. + apply fold_rec; intros. + - apply Pmorphism with empty; auto with set. + - rewrite Add_Equal in H1; auto with set. + apply Pmorphism with (add x s'); auto with set. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), + P i -> (forall x a, In x s -> P a -> P (f x a)) -> + P (fold f s i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : the step hypothesis must here be applicable to any [x]. At the same time, it looks more like an induction principle, and hence can be easier to use. *) - Lemma fold_rec_weak : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - P empty i -> - (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> - forall s, P s (fold f s i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), - R i j -> - (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> - R (fold f s i) (fold g s j). - Proof. - intros A B R f g i j s Rempty Rstep. - rewrite 2 fold_spec_right. set (l:=rev (elements s)). - assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by - (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with * ). - clearbody l; clear Rstep s. - induction l; simpl; auto with relations. - Qed. - - (** From the induction principle on [fold], we can deduce some general + Lemma fold_rec_weak : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + P empty i -> + (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> + forall s, P s (fold f s i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), + R i j -> + (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> + R (fold f s i) (fold g s j). + Proof. + intros A B R f g i j s Rempty Rstep. + rewrite 2 fold_spec_right. set (l:=rev (elements s)). + assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with * ). + clearbody l; clear Rstep s. + induction l; simpl; auto with relations. + Qed. + + (** From the induction principle on [fold], we can deduce some general induction principles on sets. *) - Lemma set_induction : - forall P : t -> Type, - (forall s, Empty s -> P s) -> - (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> - forall s, P s. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - Lemma set_induction_bis : - forall P : t -> Type, - (forall s s', s [=] s' -> P s -> P s') -> - P empty -> - (forall x s, ~In x s -> P s -> P (add x s)) -> - forall s, P s. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall s, fold add s empty [=] s. - Proof. - intros. - apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. - intros. rewrite H2; rewrite Add_Equal in H1; auto with set. - Qed. - - (** ** Alternative (weaker) specifications for [fold] *) - - (** When [MSets] was first designed, the order in which Ocaml's [Set.fold] + Lemma set_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall s, P s. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + Lemma set_induction_bis : + forall P : t -> Type, + (forall s s', s [=] s' -> P s -> P s') -> + P empty -> + (forall x s, ~In x s -> P s -> P (add x s)) -> + forall s, P s. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall s, fold add s empty [=] s. + Proof. + intros. + apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. + intros. rewrite H2; rewrite Add_Equal in H1; auto with set. + Qed. + + (** ** Alternative (weaker) specifications for [fold] *) + + (** When [MSets] was first designed, the order in which Ocaml's [Set.fold] takes the set elements was unspecified. This specification reflects this fact: *) - Lemma fold_0 : - forall s (A : Type) (i : A) (f : elt -> A -> A), - exists l : list elt, - NoDup l /\ - (forall x : elt, In x s <-> InA x l) /\ - fold f s i = fold_right f i l. - Proof. - intros; exists (rev (elements s)); split. - - apply NoDupA_rev; auto with *. - - split; intros. - + rewrite elements_iff; do 2 rewrite InA_alt. - split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. - + apply fold_spec_right. - Qed. - - (** An alternate (and previous) specification for [fold] was based on + Lemma fold_0 : + forall s (A : Type) (i : A) (f : elt -> A -> A), + exists l : list elt, + NoDup l /\ + (forall x : elt, In x s <-> InA x l) /\ + fold f s i = fold_right f i l. + Proof. + intros; exists (rev (elements s)); split. + - apply NoDupA_rev; auto with *. + - split; intros. + + rewrite elements_iff; do 2 rewrite InA_alt. + split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. + + apply fold_spec_right. + Qed. + + (** An alternate (and previous) specification for [fold] was based on the recursive structure of a set. It is now lemmas [fold_1] and [fold_2]. *) - Lemma fold_1 : - forall s (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Empty s -> eqA (fold f s i) i. - Proof. - unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). - rewrite H3; clear H3. - generalize H H2; clear H H2; case l; simpl; intros. - - reflexivity. - - elim (H e). - elim (H2 e); intuition. - Qed. - - Lemma fold_2 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Proper (E.eq==>eqA==>eqA) f -> - transpose eqA f -> - ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); - destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). - rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. - apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. - - eauto with *. - - rewrite <- Hl1; auto. - - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; - rewrite (H2 a); intuition. - Qed. - - (** In fact, [fold] on empty sets is more than equivalent to + Lemma fold_1 : + forall s (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Empty s -> eqA (fold f s i) i. + Proof. + unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). + rewrite H3; clear H3. + generalize H H2; clear H H2; case l; simpl; intros. + - reflexivity. + - elim (H e). + elim (H2 e); intuition. + Qed. + + Lemma fold_2 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + transpose eqA f -> + ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). + rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. + - eauto with *. + - rewrite <- Hl1; auto. + - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + rewrite (H2 a); intuition. + Qed. + + (** In fact, [fold] on empty sets is more than equivalent to the initial element, it is Leibniz-equal to it. *) - Lemma fold_1b : - forall s (A : Type)(i : A) (f : elt -> A -> A), - Empty s -> (fold f s i) = i. - Proof. - intros. - rewrite FM.fold_1. - rewrite elements_Empty in H; rewrite H; simpl; auto. - Qed. - - Section Fold_More. - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). - - Lemma fold_commutes : forall i s x, - eqA (fold f s (f x i)) (f x (fold f s i)). - Proof. - intros. - apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. - - reflexivity. - - transitivity (f x0 (f x b)); auto. - apply Comp; auto with relations. - Qed. - - (** ** Fold is a morphism *) - - Lemma fold_init : forall i i' s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros. apply fold_rel with (R:=eqA); auto. - intros; apply Comp; auto with relations. - Qed. - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros i s; pattern s; apply set_induction; clear s; intros. - - transitivity i. - + apply fold_1; auto. - + symmetry; apply fold_1; auto. - rewrite <- H0; auto. - - transitivity (f x (fold f s i)). - + apply fold_2 with (eqA := eqA); auto. - + symmetry; apply fold_2 with (eqA := eqA); auto. - unfold Add in *; intros. - rewrite <- H2; auto. - Qed. - - (** ** Fold and other set operators *) - - Lemma fold_empty : forall i, fold f empty i = i. - Proof. - intros i; apply fold_1b; auto with set. - Qed. - - Lemma fold_add : forall i s x, ~In x s -> - eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. - intros; apply fold_2 with (eqA := eqA); auto with set. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_1: forall i s x, In x s -> - eqA (f x (fold f (remove x s) i)) (fold f s i). - Proof. - intros. - symmetry. - apply fold_2 with (eqA:=eqA); auto with set relations. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - Lemma fold_union_inter : forall i s s', - eqA (fold f (union s s') (fold f (inter s s') i)) - (fold f s (fold f s' i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - - transitivity (fold f s' (fold f (inter s s') i)). - { apply fold_equal; auto with set. } - transitivity (fold f s' i). - { apply fold_init; auto. - apply fold_1; auto with set. } - symmetry; apply fold_1; auto. - - rename s'0 into s''. - destruct (In_dec x s'). - + (* In x s' *) - transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. - { apply fold_init; auto. - apply fold_2 with (eqA:=eqA); auto with set. - rewrite inter_iff; intuition. } - transitivity (f x (fold f s (fold f s' i))). - 1:transitivity (fold f (union s s') (f x (fold f (inter s s') i))). - 2:transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - * apply fold_equal; auto. - apply equal_sym; apply union_Equal with x; auto with set. - * apply fold_commutes; auto. - * apply Comp; auto with relations. - * symmetry; apply fold_2 with (eqA:=eqA); auto. - + (* ~(In x s') *) - transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). - { apply fold_2 with (eqA:=eqA); auto with set. } - transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - { apply Comp;auto with relations. - apply fold_init;auto. - apply fold_equal;auto. - apply equal_sym; apply inter_Add_2 with x; auto with set. } - transitivity (f x (fold f s (fold f s' i))). - * apply Comp; auto with relations. - * symmetry; apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma fold_diff_inter : forall i s s', - eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). - Proof. - intros. - transitivity (fold f (union (diff s s') (inter s s')) - (fold f (inter (diff s s') (inter s s')) i)). - 1:symmetry; apply fold_union_inter; auto. - transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). - - apply fold_equal; auto with set. - - apply fold_init; auto. - apply fold_1; auto with set. - Qed. - - Lemma fold_union: forall i s s', - (forall x, ~(In x s/\In x s')) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). - Proof. - intros. - transitivity (fold f (union s s') (fold f (inter s s') i)). - { apply fold_init; auto. - symmetry; apply fold_1; auto with set. - unfold Empty; intro a; generalize (H a); set_iff; tauto. } - apply fold_union_inter; auto. - Qed. - - End Fold_More. - - Lemma fold_plus : - forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. - Proof. - intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. - Qed. - - End Fold. - - (** * Cardinal *) - - (** ** Characterization of cardinal in terms of fold *) - - Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. - Proof. - intros; rewrite cardinal_1; rewrite FM.fold_1. - symmetry; apply fold_left_S_0; auto. - Qed. - - (** ** Old specifications for [cardinal]. *) - - Lemma cardinal_0 : - forall s, exists l : list elt, - NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ - cardinal s = length l. - Proof. - intros; exists (elements s); intuition auto with set; apply cardinal_1. - Qed. - - Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. - Proof. - intros; rewrite cardinal_fold; apply fold_1; auto with *. - Qed. - - Lemma cardinal_2 : - forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x). - apply fold_2; auto. - - split; congruence. - - congruence. - Qed. - - (** ** Cardinal and (non-)emptiness *) - - Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. - Proof. - intros. - rewrite elements_Empty, FM.cardinal_1. - destruct (elements s); intuition; discriminate. - Qed. - - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - #[global] - Hint Resolve cardinal_inv_1 : core. - - Lemma cardinal_inv_2 : - forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. - intros; rewrite FM.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto with relations. - Qed. - - Lemma cardinal_inv_2b : - forall s, cardinal s <> 0 -> { x : elt | In x s }. - Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; - [intuition|eauto]. - Qed. - - (** ** Cardinal is a morphism *) - - Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. - symmetry. - remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. - induction n; intros. - - apply cardinal_1; rewrite <- H; auto. - - destruct (cardinal_inv_2 Heqn) as (x,H2). - revert Heqn. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); - auto with set relations. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); - eauto with set relations. - Qed. - -#[global] - Instance cardinal_m : Proper (Equal==>Logic.eq) cardinal. - Proof. - exact Equal_cardinal. - Qed. - - #[global] - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. - - (** ** Cardinal and set operators *) - - Lemma empty_cardinal : cardinal empty = 0. - Proof. - rewrite cardinal_fold; apply fold_1; auto with *. - Qed. - - #[global] - Hint Immediate empty_cardinal cardinal_1 : set. - - Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. - Proof. - intros. - rewrite (singleton_equal_add x). - replace 0 with (cardinal empty); auto with set. - apply cardinal_2 with x; auto with set. - Qed. - - #[global] - Hint Resolve singleton_cardinal: set. - - Lemma diff_inter_cardinal : - forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma union_cardinal: - forall s s', (forall x, ~(In x s/\In x s')) -> - cardinal (union s s')=cardinal s+cardinal s'. - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_union; auto. - - split; congruence. - - congruence. - Qed. - - Lemma subset_cardinal : - forall s s', s[<=]s' -> cardinal s <= cardinal s' . - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - apply Nat.le_add_l. - Qed. - - Lemma subset_cardinal_lt : - forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - generalize (@cardinal_inv_1 (diff s' s)). - destruct (cardinal (diff s' s)). - - intro H2; destruct (H2 (eq_refl _) x). - set_iff; auto. - - intros _. - change (0 + cardinal s < S n + cardinal s). - apply Nat.add_lt_le_mono; [ apply Nat.lt_0_succ | reflexivity ]. - Qed. - - Theorem union_inter_cardinal : - forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . - Proof. - intros. - do 4 rewrite cardinal_fold. - do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma union_cardinal_inter : - forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). - Proof. - intros. - rewrite <- union_inter_cardinal, Nat.add_sub. - reflexivity. - Qed. - - Lemma union_cardinal_le : - forall s s', cardinal (union s s') <= cardinal s + cardinal s'. - Proof. - intros; generalize (union_inter_cardinal s s'). - intros; rewrite <- H; auto with arith. - Qed. - - Lemma add_cardinal_1 : - forall s x, In x s -> cardinal (add x s) = cardinal s. - Proof. - auto with set. - Qed. - - Lemma add_cardinal_2 : - forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x); - apply fold_add with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma remove_cardinal_1 : - forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma remove_cardinal_2 : - forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. - auto with set. - Qed. + Lemma fold_1b : + forall s (A : Type)(i : A) (f : elt -> A -> A), + Empty s -> (fold f s i) = i. + Proof. + intros. + rewrite FM.fold_1. + rewrite elements_Empty in H; rewrite H; simpl; auto. + Qed. + + Section Fold_More. + + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). + + Lemma fold_commutes : forall i s x, + eqA (fold f s (f x i)) (f x (fold f s i)). + Proof. + intros. + apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. + - reflexivity. + - transitivity (f x0 (f x b)); auto. + apply Comp; auto with relations. + Qed. + + (** ** Fold is a morphism *) + + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros; apply Comp; auto with relations. + Qed. + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros i s; pattern s; apply set_induction; clear s; intros. + - transitivity i. + + apply fold_1; auto. + + symmetry; apply fold_1; auto. + rewrite <- H0; auto. + - transitivity (f x (fold f s i)). + + apply fold_2 with (eqA := eqA); auto. + + symmetry; apply fold_2 with (eqA := eqA); auto. + unfold Add in *; intros. + rewrite <- H2; auto. + Qed. + + (** ** Fold and other set operators *) + + Lemma fold_empty : forall i, fold f empty i = i. + Proof. + intros i; apply fold_1b; auto with set. + Qed. + + Lemma fold_add : forall i s x, ~In x s -> + eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_2 with (eqA := eqA); auto with set. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_1: forall i s x, In x s -> + eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros. + symmetry. + apply fold_2 with (eqA:=eqA); auto with set relations. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + Lemma fold_union_inter : forall i s s', + eqA (fold f (union s s') (fold f (inter s s') i)) + (fold f s (fold f s' i)). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + - transitivity (fold f s' (fold f (inter s s') i)). + { apply fold_equal; auto with set. } + transitivity (fold f s' i). + { apply fold_init; auto. + apply fold_1; auto with set. } + symmetry; apply fold_1; auto. + - rename s'0 into s''. + destruct (In_dec x s'). + + (* In x s' *) + transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. + { apply fold_init; auto. + apply fold_2 with (eqA:=eqA); auto with set. + rewrite inter_iff; intuition. } + transitivity (f x (fold f s (fold f s' i))). + 1:transitivity (fold f (union s s') (f x (fold f (inter s s') i))). + 2:transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + * apply fold_equal; auto. + apply equal_sym; apply union_Equal with x; auto with set. + * apply fold_commutes; auto. + * apply Comp; auto with relations. + * symmetry; apply fold_2 with (eqA:=eqA); auto. + + (* ~(In x s') *) + transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). + { apply fold_2 with (eqA:=eqA); auto with set. } + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + { apply Comp;auto with relations. + apply fold_init;auto. + apply fold_equal;auto. + apply equal_sym; apply inter_Add_2 with x; auto with set. } + transitivity (f x (fold f s (fold f s' i))). + * apply Comp; auto with relations. + * symmetry; apply fold_2 with (eqA:=eqA); auto. + Qed. + + Lemma fold_diff_inter : forall i s s', + eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). + Proof. + intros. + transitivity (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + 1:symmetry; apply fold_union_inter; auto. + transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). + - apply fold_equal; auto with set. + - apply fold_init; auto. + apply fold_1; auto with set. + Qed. + + Lemma fold_union: forall i s s', + (forall x, ~(In x s/\In x s')) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros. + transitivity (fold f (union s s') (fold f (inter s s') i)). + { apply fold_init; auto. + symmetry; apply fold_1; auto with set. + unfold Empty; intro a; generalize (H a); set_iff; tauto. } + apply fold_union_inter; auto. + Qed. + + End Fold_More. + + Lemma fold_plus : + forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. + Proof. + intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. + Qed. + + End Fold. + + (** * Cardinal *) + + (** ** Characterization of cardinal in terms of fold *) + + Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. + Proof. + intros; rewrite cardinal_1; rewrite FM.fold_1. + symmetry; apply fold_left_S_0; auto. + Qed. + + (** ** Old specifications for [cardinal]. *) + + Lemma cardinal_0 : + forall s, exists l : list elt, + NoDupA E.eq l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + cardinal s = length l. + Proof. + intros; exists (elements s); intuition auto with set; apply cardinal_1. + Qed. + + Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. + Proof. + intros; rewrite cardinal_fold; apply fold_1; auto with *. + Qed. + + Lemma cardinal_2 : + forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). + Proof. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x). + apply fold_2; auto. + - split; congruence. + - congruence. + Qed. + + (** ** Cardinal and (non-)emptiness *) + + Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Proof. + intros. + rewrite elements_Empty, FM.cardinal_1. + destruct (elements s); intuition; discriminate. + Qed. + + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + #[global] + Hint Resolve cardinal_inv_1 : core. + + Lemma cardinal_inv_2 : + forall s n, cardinal s = S n -> { x : elt | In x s }. + Proof. + intros; rewrite FM.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto with relations. + Qed. + + Lemma cardinal_inv_2b : + forall s, cardinal s <> 0 -> { x : elt | In x s }. + Proof. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. + Qed. + + (** ** Cardinal is a morphism *) + + Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. + Proof. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + - apply cardinal_1; rewrite <- H; auto. + - destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); + auto with set relations. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); + eauto with set relations. + Qed. #[global] - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. + Instance cardinal_m : Proper (Equal==>Logic.eq) cardinal. + Proof. + exact Equal_cardinal. + Qed. + + #[global] + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. + + (** ** Cardinal and set operators *) + + Lemma empty_cardinal : cardinal empty = 0. + Proof. + rewrite cardinal_fold; apply fold_1; auto with *. + Qed. + + #[global] + Hint Immediate empty_cardinal cardinal_1 : set. + + Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. + Proof. + intros. + rewrite (singleton_equal_add x). + replace 0 with (cardinal empty); auto with set. + apply cardinal_2 with x; auto with set. + Qed. + + #[global] + Hint Resolve singleton_cardinal: set. + + Lemma diff_inter_cardinal : + forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma union_cardinal: + forall s s', (forall x, ~(In x s/\In x s')) -> + cardinal (union s s')=cardinal s+cardinal s'. + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_union; auto. + - split; congruence. + - congruence. + Qed. + + Lemma subset_cardinal : + forall s s', s[<=]s' -> cardinal s <= cardinal s' . + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H). + apply Nat.le_add_l. + Qed. + + Lemma subset_cardinal_lt : + forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H). + generalize (@cardinal_inv_1 (diff s' s)). + destruct (cardinal (diff s' s)). + - intro H2; destruct (H2 (eq_refl _) x). + set_iff; auto. + - intros _. + change (0 + cardinal s < S n + cardinal s). + apply Nat.add_lt_le_mono; [ apply Nat.lt_0_succ | reflexivity ]. + Qed. + + Theorem union_inter_cardinal : + forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . + Proof. + intros. + do 4 rewrite cardinal_fold. + do 2 rewrite <- fold_plus. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma union_cardinal_inter : + forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). + Proof. + intros. + rewrite <- union_inter_cardinal, Nat.add_sub. + reflexivity. + Qed. + + Lemma union_cardinal_le : + forall s s', cardinal (union s s') <= cardinal s + cardinal s'. + Proof. + intros; generalize (union_inter_cardinal s s'). + intros; rewrite <- H; auto with arith. + Qed. + + Lemma add_cardinal_1 : + forall s x, In x s -> cardinal (add x s) = cardinal s. + Proof. + auto with set. + Qed. + + Lemma add_cardinal_2 : + forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x); + apply fold_add with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma remove_cardinal_1 : + forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ =>S) x). + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma remove_cardinal_2 : + forall s x, ~In x s -> cardinal (remove x s) = cardinal s. + Proof. + auto with set. + Qed. + + #[global] + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WPropertiesOn. @@ -928,272 +928,272 @@ Module Properties := WProperties. invalid for Weak Sets. *) Module OrdProperties (M:Sets). - Module Import ME:=OrderedTypeFacts(M.E). - Module Import ML:=OrderedTypeLists(M.E). - Module Import P := Properties M. - Import FM. - Import M.E. - Import M. + Module Import ME:=OrderedTypeFacts(M.E). + Module Import ML:=OrderedTypeLists(M.E). + Module Import P := Properties M. + Import FM. + Import M.E. + Import M. + + #[global] + Hint Resolve elements_spec2 : core. + #[global] + Hint Immediate + min_elt_spec1 min_elt_spec2 min_elt_spec3 + max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. + + (** First, a specialized version of SortA_equivlistA_eqlistA: *) + Lemma sort_equivlistA_eqlistA : forall l l' : list elt, + sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. + Proof. + apply SortA_equivlistA_eqlistA; eauto with *. + Qed. + + Definition gtb x y := match E.compare x y with Gt => true | _ => false end. + Definition leb x := fun y => negb (gtb x y). + + Definition elements_lt x s := List.filter (gtb x) (elements s). + Definition elements_ge x s := List.filter (leb x) (elements s). + + Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. + Proof. + intros; rewrite <- compare_gt_iff. unfold gtb. + destruct E.compare; intuition; try discriminate. + Qed. + + Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. + Proof. + intros; rewrite <- compare_gt_iff. unfold leb, gtb. + destruct E.compare; intuition; try discriminate. + Qed. #[global] - Hint Resolve elements_spec2 : core. - #[global] - Hint Immediate - min_elt_spec1 min_elt_spec2 min_elt_spec3 - max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. - - (** First, a specialized version of SortA_equivlistA_eqlistA: *) - Lemma sort_equivlistA_eqlistA : forall l l' : list elt, - sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. - Proof. - apply SortA_equivlistA_eqlistA; eauto with *. - Qed. - - Definition gtb x y := match E.compare x y with Gt => true | _ => false end. - Definition leb x := fun y => negb (gtb x y). - - Definition elements_lt x s := List.filter (gtb x) (elements s). - Definition elements_ge x s := List.filter (leb x) (elements s). - - Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. - Proof. - intros; rewrite <- compare_gt_iff. unfold gtb. - destruct E.compare; intuition; try discriminate. - Qed. - - Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. - Proof. - intros; rewrite <- compare_gt_iff. unfold leb, gtb. - destruct E.compare; intuition; try discriminate. - Qed. - -#[global] - Instance gtb_compat x : Proper (E.eq==>Logic.eq) (gtb x). - Proof. - intros a b H. unfold gtb. rewrite H; auto. - Qed. + Instance gtb_compat x : Proper (E.eq==>Logic.eq) (gtb x). + Proof. + intros a b H. unfold gtb. rewrite H; auto. + Qed. -#[global] - Instance leb_compat x : Proper (E.eq==>Logic.eq) (leb x). - Proof. - intros a b H; unfold leb. rewrite H; auto. - Qed. #[global] - Hint Resolve gtb_compat leb_compat : core. - - Lemma elements_split : forall x s, - elements s = elements_lt x s ++ elements_ge x s. - Proof. - unfold elements_lt, elements_ge, leb; intros. - eapply (@filter_split _ E.eq); eauto with *. - intros. - rewrite gtb_1 in H. - assert (~E.lt y x). { - unfold gtb in *; elim_compare x y; intuition; - try discriminate; order. - } - order. - Qed. - - Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). - Proof. - intros; unfold elements_ge, elements_lt. - apply sort_equivlistA_eqlistA; auto with set. - - apply (@SortA_app _ E.eq); auto with *. - + apply (@filter_sort _ E.eq); auto with *; eauto with *. - + constructor; auto. - * apply (@filter_sort _ E.eq); auto with *; eauto with *. - * rewrite Inf_alt by (apply (@filter_sort _ E.eq); eauto with * ). + Instance leb_compat x : Proper (E.eq==>Logic.eq) (leb x). + Proof. + intros a b H; unfold leb. rewrite H; auto. + Qed. + #[global] + Hint Resolve gtb_compat leb_compat : core. + + Lemma elements_split : forall x s, + elements s = elements_lt x s ++ elements_ge x s. + Proof. + unfold elements_lt, elements_ge, leb; intros. + eapply (@filter_split _ E.eq); eauto with *. + intros. + rewrite gtb_1 in H. + assert (~E.lt y x). { + unfold gtb in *; elim_compare x y; intuition; + try discriminate; order. + } + order. + Qed. + + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Proof. + intros; unfold elements_ge, elements_lt. + apply sort_equivlistA_eqlistA; auto with set. + - apply (@SortA_app _ E.eq); auto with *. + + apply (@filter_sort _ E.eq); auto with *; eauto with *. + + constructor; auto. + * apply (@filter_sort _ E.eq); auto with *; eauto with *. + * rewrite Inf_alt by (apply (@filter_sort _ E.eq); eauto with * ). + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite leb_1 in H2. + rewrite <- elements_iff in H1. + assert (~E.eq x y). + { contradict H; rewrite H; auto. } + order. + + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite gtb_1 in H3. + inversion_clear H2. + * order. + * rewrite filter_InA in H4; auto with *; destruct H4. + rewrite leb_1 in H4. + order. + - red; intros a. + rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff, + leb_1, gtb_1, (H0 a) by (auto with * ). + intuition. + elim_compare a x; intuition. + right; right; split; auto. + order. + Qed. + + Definition Above x s := forall y, In y s -> E.lt y x. + Definition Below x s := forall y, In y s -> E.lt x y. + + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements s ++ x::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + - apply (@SortA_app _ E.eq); auto with *. intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite leb_1 in H2. + invlist InA. rewrite <- elements_iff in H1. - assert (~E.eq x y). - { contradict H; rewrite H; auto. } - order. - + intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite gtb_1 in H3. - inversion_clear H2. - * order. - * rewrite filter_InA in H4; auto with *; destruct H4. - rewrite leb_1 in H4. - order. - - red; intros a. - rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff, - leb_1, gtb_1, (H0 a) by (auto with * ). - intuition. - elim_compare a x; intuition. - right; right; split; auto. - order. - Qed. - - Definition Above x s := forall y, In y s -> E.lt y x. - Definition Below x s := forall y, In y s -> E.lt x y. - - Lemma elements_Add_Above : forall s s' x, - Above x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements s ++ x::nil). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with set. - - apply (@SortA_app _ E.eq); auto with *. - intros. - invlist InA. - rewrite <- elements_iff in H1. - setoid_replace y with x; auto. - - red; intros a. - rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a) - by (auto with * ). - intuition. - Qed. - - Lemma elements_Add_Below : forall s s' x, - Below x s -> Add x s s' -> - eqlistA E.eq (elements s') (x::elements s). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with set. - - change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq); auto with *. - intros. - invlist InA. - rewrite <- elements_iff in H2. - setoid_replace x0 with x; auto. - - red; intros a. - rewrite InA_cons, <- !elements_iff, (H0 a); intuition. - Qed. - - (** Two other induction principles on sets: we can be more restrictive + setoid_replace y with x; auto. + - red; intros a. + rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a) + by (auto with * ). + intuition. + Qed. + + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> + eqlistA E.eq (elements s') (x::elements s). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + - change (sort E.lt ((x::nil) ++ elements s)). + apply (@SortA_app _ E.eq); auto with *. + intros. + invlist InA. + rewrite <- elements_iff in H2. + setoid_replace x0 with x; auto. + - red; intros a. + rewrite InA_cons, <- !elements_iff, (H0 a); intuition. + Qed. + + (** Two other induction principles on sets: we can be more restrictive on the element we add at each step. *) - Lemma set_induction_max : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. - case_eq (max_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). { - rewrite Heqn; apply cardinal_2 with e; auto with set relations. - } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@max_elt_spec2 s e y H H0); order. - - - assert (H0:=max_elt_spec3 H). - rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. - Qed. - - Lemma set_induction_min : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. - case_eq (min_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). - { rewrite Heqn; apply cardinal_2 with e; auto with set relations. } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@min_elt_spec2 s e y H H0); order. - - - assert (H0:=min_elt_spec3 H). - rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. - Qed. - - (** More properties of [fold] : behavior with respect to Above/Below *) - - Lemma fold_3 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Proper (E.eq==>eqA==>eqA) f -> - Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - intros. - rewrite 2 fold_spec_right. - change (f x (fold_right f i (rev (elements s)))) with - (fold_right f i (rev (x::nil)++rev (elements s))). - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *. - rewrite <- distr_rev. - apply eqlistA_rev. - apply elements_Add_Above; auto. - Qed. - - Lemma fold_4 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Proper (E.eq==>eqA==>eqA) f -> - Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). - Proof. - intros. - rewrite !fold_spec. - change (eqA (fold_left (flip f) (elements s') i) - (fold_left (flip f) (x::elements s) i)). - unfold flip; rewrite <-!fold_left_rev_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply elements_Add_Below; auto. - Qed. - - (** The following results have already been proved earlier, + Lemma set_induction_max : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (max_elt s); intros. + - apply X0 with (remove e s) e; auto with set. + + apply IHn. + assert (S n = S (cardinal (remove e s))). { + rewrite Heqn; apply cardinal_2 with e; auto with set relations. + } + inversion H0; auto. + + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@max_elt_spec2 s e y H H0); order. + + - assert (H0:=max_elt_spec3 H). + rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. + Qed. + + Lemma set_induction_min : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (min_elt s); intros. + - apply X0 with (remove e s) e; auto with set. + + apply IHn. + assert (S n = S (cardinal (remove e s))). + { rewrite Heqn; apply cardinal_2 with e; auto with set relations. } + inversion H0; auto. + + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@min_elt_spec2 s e y H H0); order. + + - assert (H0:=min_elt_spec3 H). + rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. + Qed. + + (** More properties of [fold] : behavior with respect to Above/Below *) + + Lemma fold_3 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros. + rewrite 2 fold_spec_right. + change (f x (fold_right f i (rev (elements s)))) with + (fold_right f i (rev (x::nil)++rev (elements s))). + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *. + rewrite <- distr_rev. + apply eqlistA_rev. + apply elements_Add_Above; auto. + Qed. + + Lemma fold_4 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). + Proof. + intros. + rewrite !fold_spec. + change (eqA (fold_left (flip f) (elements s') i) + (fold_left (flip f) (x::elements s) i)). + unfold flip; rewrite <-!fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply elements_Add_Below; auto. + Qed. + + (** The following results have already been proved earlier, but we can now prove them with one hypothesis less: no need for [(transpose eqA f)]. *) - Section FoldOpt. - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f). - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros. - rewrite 2 fold_spec_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply sort_equivlistA_eqlistA; auto with set. - red; intro a; do 2 rewrite <- elements_iff; auto. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - End FoldOpt. - - (** An alternative version of [choose_3] *) - - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with - | Some x, Some x' => E.eq x x' - | None, None => True - | _, _ => False - end. - Proof. - intros s s' H; - generalize (@choose_spec1 s)(@choose_spec2 s) - (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s'); - destruct (choose s); destruct (choose s'); simpl; intuition. - - apply H5 with e; rewrite <-H; auto. - - apply H5 with e; rewrite H; auto. - Qed. + Section FoldOpt. + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f). + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros. + rewrite 2 fold_spec_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply sort_equivlistA_eqlistA; auto with set. + red; intro a; do 2 rewrite <- elements_iff; auto. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + End FoldOpt. + + (** An alternative version of [choose_3] *) + + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with + | Some x, Some x' => E.eq x x' + | None, None => True + | _, _ => False + end. + Proof. + intros s s' H; + generalize (@choose_spec1 s)(@choose_spec2 s) + (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s'); + destruct (choose s); destruct (choose s'); simpl; intuition. + - apply H5 with e; rewrite <-H; auto. + - apply H5 with e; rewrite H; auto. + Qed. End OrdProperties. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index 2a8119953a..b9f3f0b737 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -44,13 +44,13 @@ From Stdlib Require Import Bool List BinPos Pnat Setoid SetoidList PeanoNat. Module Type MSetRemoveMin (Import M:MSetInterface.S). - Parameter remove_min : t -> option (elt * t). + Parameter remove_min : t -> option (elt * t). - Axiom remove_min_spec1 : forall s k s', - remove_min s = Some (k,s') -> - min_elt s = Some k /\ remove k s [=] s'. + Axiom remove_min_spec1 : forall s k s', + remove_min s = Some (k,s') -> + min_elt s = Some k /\ remove k s [=] s'. - Axiom remove_min_spec2 : forall s, remove_min s = None -> Empty s. + Axiom remove_min_spec2 : forall s, remove_min s = None -> Empty s. End MSetRemoveMin. @@ -59,1419 +59,1419 @@ End MSetRemoveMin. Inductive color := Red | Black. Module Color. - Definition t := color. + Definition t := color. End Color. (** * Ops : the pure functions *) Module Ops (X:Orders.OrderedType) <: MSetInterface.Ops X. -(** ** Generic trees instantiated with color *) + (** ** Generic trees instantiated with color *) -(** We reuse a generic definition of trees where the information + (** We reuse a generic definition of trees where the information parameter is a color. Functions like mem or fold are also provided by this generic functor. *) -Include MSetGenTree.Ops X Color. + Include MSetGenTree.Ops X Color. -Definition t := tree. -#[local] Notation Rd := (Node Red). -#[local] Notation Bk := (Node Black). + Definition t := tree. + #[local] Notation Rd := (Node Red). + #[local] Notation Bk := (Node Black). -(** ** Basic tree *) + (** ** Basic tree *) -Definition singleton (k: elt) : tree := Bk Leaf k Leaf. + Definition singleton (k: elt) : tree := Bk Leaf k Leaf. -(** ** Changing root color *) + (** ** Changing root color *) -Definition makeBlack t := - match t with - | Leaf => Leaf - | Node _ a x b => Bk a x b - end. + Definition makeBlack t := + match t with + | Leaf => Leaf + | Node _ a x b => Bk a x b + end. -Definition makeRed t := - match t with - | Leaf => Leaf - | Node _ a x b => Rd a x b - end. + Definition makeRed t := + match t with + | Leaf => Leaf + | Node _ a x b => Rd a x b + end. -(** ** Balancing *) + (** ** Balancing *) -(** We adapt when one side is not a true red-black tree. + (** We adapt when one side is not a true red-black tree. Both sides have the same black depth. *) -Definition lbal l k r := - match l with - | Rd (Rd a x b) y c => Rd (Bk a x b) y (Bk c k r) - | Rd a x (Rd b y c) => Rd (Bk a x b) y (Bk c k r) - | _ => Bk l k r - end. - -Definition rbal l k r := - match r with - | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) - | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) - | _ => Bk l k r - end. - -(** A variant of [rbal], with reverse pattern order. + Definition lbal l k r := + match l with + | Rd (Rd a x b) y c => Rd (Bk a x b) y (Bk c k r) + | Rd a x (Rd b y c) => Rd (Bk a x b) y (Bk c k r) + | _ => Bk l k r + end. + + Definition rbal l k r := + match r with + | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) + | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) + | _ => Bk l k r + end. + + (** A variant of [rbal], with reverse pattern order. Is it really useful ? Should we always use it ? *) -Definition rbal' l k r := - match r with - | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) - | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) - | _ => Bk l k r - end. + Definition rbal' l k r := + match r with + | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) + | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) + | _ => Bk l k r + end. -(** Balancing with different black depth. + (** Balancing with different black depth. One side is almost a red-black tree, while the other is a true red-black tree, but with black depth + 1. Used in deletion. *) -Definition lbalS l k r := - match l with - | Rd a x b => Rd (Bk a x b) k r - | _ => - match r with - | Bk a y b => rbal' l k (Rd a y b) - | Rd (Bk a y b) z c => Rd (Bk l k a) y (rbal' b z (makeRed c)) - | _ => Rd l k r (* impossible *) - end - end. - -Definition rbalS l k r := - match r with - | Rd b y c => Rd l k (Bk b y c) - | _ => + Definition lbalS l k r := match l with - | Bk a x b => lbal (Rd a x b) k r - | Rd a x (Bk b y c) => Rd (lbal (makeRed a) x b) y (Bk c k r) - | _ => Rd l k r (* impossible *) - end - end. - -(** ** Insertion *) - -Fixpoint ins x s := - match s with - | Leaf => Rd Leaf x Leaf - | Node c l y r => - match X.compare x y with - | Eq => s - | Lt => - match c with - | Red => Rd (ins x l) y r - | Black => lbal (ins x l) y r + | Rd a x b => Rd (Bk a x b) k r + | _ => + match r with + | Bk a y b => rbal' l k (Rd a y b) + | Rd (Bk a y b) z c => Rd (Bk l k a) y (rbal' b z (makeRed c)) + | _ => Rd l k r (* impossible *) + end + end. + + Definition rbalS l k r := + match r with + | Rd b y c => Rd l k (Bk b y c) + | _ => + match l with + | Bk a x b => lbal (Rd a x b) k r + | Rd a x (Bk b y c) => Rd (lbal (makeRed a) x b) y (Bk c k r) + | _ => Rd l k r (* impossible *) end - | Gt => - match c with - | Red => Rd l y (ins x r) - | Black => rbal l y (ins x r) + end. + + (** ** Insertion *) + + Fixpoint ins x s := + match s with + | Leaf => Rd Leaf x Leaf + | Node c l y r => + match X.compare x y with + | Eq => s + | Lt => + match c with + | Red => Rd (ins x l) y r + | Black => lbal (ins x l) y r + end + | Gt => + match c with + | Red => Rd l y (ins x r) + | Black => rbal l y (ins x r) + end end - end - end. + end. -Definition add x s := makeBlack (ins x s). + Definition add x s := makeBlack (ins x s). -(** ** Deletion *) + (** ** Deletion *) -Fixpoint append (l:tree) : tree -> tree := - match l with - | Leaf => fun r => r - | Node lc ll lx lr => - fix append_l (r:tree) : tree := - match r with - | Leaf => l - | Node rc rl rx rr => - match lc, rc with - | Red, Red => - let lrl := append lr rl in - match lrl with - | Rd lr' x rl' => Rd (Rd ll lx lr') x (Rd rl' rx rr) - | _ => Rd ll lx (Rd lrl rx rr) - end - | Black, Black => - let lrl := append lr rl in - match lrl with - | Rd lr' x rl' => Rd (Bk ll lx lr') x (Bk rl' rx rr) - | _ => lbalS ll lx (Bk lrl rx rr) + Fixpoint append (l:tree) : tree -> tree := + match l with + | Leaf => fun r => r + | Node lc ll lx lr => + fix append_l (r:tree) : tree := + match r with + | Leaf => l + | Node rc rl rx rr => + match lc, rc with + | Red, Red => + let lrl := append lr rl in + match lrl with + | Rd lr' x rl' => Rd (Rd ll lx lr') x (Rd rl' rx rr) + | _ => Rd ll lx (Rd lrl rx rr) + end + | Black, Black => + let lrl := append lr rl in + match lrl with + | Rd lr' x rl' => Rd (Bk ll lx lr') x (Bk rl' rx rr) + | _ => lbalS ll lx (Bk lrl rx rr) + end + | Black, Red => Rd (append_l rl) rx rr + | Red, Black => Rd ll lx (append lr r) end - | Black, Red => Rd (append_l rl) rx rr - | Red, Black => Rd ll lx (append lr r) end - end - end. - -Fixpoint del x t := - match t with - | Leaf => Leaf - | Node _ a y b => - match X.compare x y with - | Eq => append a b - | Lt => - match a with - | Bk _ _ _ => lbalS (del x a) y b - | _ => Rd (del x a) y b + end. + + Fixpoint del x t := + match t with + | Leaf => Leaf + | Node _ a y b => + match X.compare x y with + | Eq => append a b + | Lt => + match a with + | Bk _ _ _ => lbalS (del x a) y b + | _ => Rd (del x a) y b + end + | Gt => + match b with + | Bk _ _ _ => rbalS a y (del x b) + | _ => Rd a y (del x b) + end end - | Gt => - match b with - | Bk _ _ _ => rbalS a y (del x b) - | _ => Rd a y (del x b) + end. + + Definition remove x t := makeBlack (del x t). + + (** ** Removing minimal element *) + + Fixpoint delmin l x r : (elt * tree) := + match l with + | Leaf => (x,r) + | Node lc ll lx lr => + let (k,l') := delmin ll lx lr in + match lc with + | Black => (k, lbalS l' x r) + | Red => (k, Rd l' x r) end - end - end. - -Definition remove x t := makeBlack (del x t). - -(** ** Removing minimal element *) - -Fixpoint delmin l x r : (elt * tree) := - match l with - | Leaf => (x,r) - | Node lc ll lx lr => - let (k,l') := delmin ll lx lr in - match lc with - | Black => (k, lbalS l' x r) - | Red => (k, Rd l' x r) - end - end. - -Definition remove_min t : option (elt * tree) := - match t with - | Leaf => None - | Node _ l x r => - let (k,t) := delmin l x r in - Some (k, makeBlack t) - end. - -(** ** Tree-ification + end. + + Definition remove_min t : option (elt * tree) := + match t with + | Leaf => None + | Node _ l x r => + let (k,t) := delmin l x r in + Some (k, makeBlack t) + end. + + (** ** Tree-ification We rebuild a tree of size [if pred then n-1 else n] as soon as the list [l] has enough elements *) -Definition bogus : tree * list elt := (Leaf, nil). - -Notation treeify_t := (list elt -> tree * list elt). - -Definition treeify_zero : treeify_t := - fun acc => (Leaf,acc). - -Definition treeify_one : treeify_t := - fun acc => match acc with - | x::acc => (Rd Leaf x Leaf, acc) - | _ => bogus - end. - -Definition treeify_cont (f g : treeify_t) : treeify_t := - fun acc => - match f acc with - | (l, x::acc) => - match g acc with - | (r, acc) => (Bk l x r, acc) - end - | _ => bogus - end. - -Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t := - match n with - | xH => if pred then treeify_zero else treeify_one - | xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n) - | xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n) - end. - -Fixpoint plength_aux (l:list elt)(p:positive) := match l with - | nil => p - | _::l => plength_aux l (Pos.succ p) -end. - -Definition plength l := plength_aux l 1. - -Definition treeify (l:list elt) := - fst (treeify_aux true (plength l) l). - -(** ** Filtering *) - -Fixpoint filter_aux (f: elt -> bool) s acc := - match s with - | Leaf => acc - | Node _ l k r => - let acc := filter_aux f r acc in - if f k then filter_aux f l (k::acc) - else filter_aux f l acc - end. - -Definition filter (f: elt -> bool) (s: t) : t := - treeify (filter_aux f s nil). - -Fixpoint partition_aux (f: elt -> bool) s acc1 acc2 := - match s with - | Leaf => (acc1,acc2) - | Node _ sl k sr => - let (acc1, acc2) := partition_aux f sr acc1 acc2 in - if f k then partition_aux f sl (k::acc1) acc2 - else partition_aux f sl acc1 (k::acc2) - end. - -Definition partition (f: elt -> bool) (s:t) : t*t := - let (ok,ko) := partition_aux f s nil nil in - (treeify ok, treeify ko). - -(** ** Union, intersection, difference *) - -(** union of the elements of [l1] and [l2] into a third [acc] list. *) - -Fixpoint union_list l1 : list elt -> list elt -> list elt := - match l1 with - | nil => @rev_append _ - | x::l1' => - fix union_l1 l2 acc := - match l2 with - | nil => rev_append l1 acc - | y::l2' => - match X.compare x y with - | Eq => union_list l1' l2' (x::acc) - | Lt => union_l1 l2' (y::acc) - | Gt => union_list l1' l2 (x::acc) - end - end - end. - -Definition linear_union s1 s2 := - treeify (union_list (rev_elements s1) (rev_elements s2) nil). - -Fixpoint inter_list l1 : list elt -> list elt -> list elt := - match l1 with - | nil => fun _ acc => acc - | x::l1' => - fix inter_l1 l2 acc := - match l2 with - | nil => acc - | y::l2' => - match X.compare x y with - | Eq => inter_list l1' l2' (x::acc) - | Lt => inter_l1 l2' acc - | Gt => inter_list l1' l2 acc - end - end - end. - -Definition linear_inter s1 s2 := - treeify (inter_list (rev_elements s1) (rev_elements s2) nil). - -Fixpoint diff_list l1 : list elt -> list elt -> list elt := - match l1 with - | nil => fun _ acc => acc - | x::l1' => - fix diff_l1 l2 acc := - match l2 with - | nil => rev_append l1 acc - | y::l2' => - match X.compare x y with - | Eq => diff_list l1' l2' acc - | Lt => diff_l1 l2' acc - | Gt => diff_list l1' l2 (x::acc) - end - end - end. + Definition bogus : tree * list elt := (Leaf, nil). -Definition linear_diff s1 s2 := - treeify (diff_list (rev_elements s1) (rev_elements s2) nil). + Notation treeify_t := (list elt -> tree * list elt). -(** [compare_height] returns: + Definition treeify_zero : treeify_t := + fun acc => (Leaf,acc). + + Definition treeify_one : treeify_t := + fun acc => match acc with + | x::acc => (Rd Leaf x Leaf, acc) + | _ => bogus + end. + + Definition treeify_cont (f g : treeify_t) : treeify_t := + fun acc => + match f acc with + | (l, x::acc) => + match g acc with + | (r, acc) => (Bk l x r, acc) + end + | _ => bogus + end. + + Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t := + match n with + | xH => if pred then treeify_zero else treeify_one + | xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n) + | xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n) + end. + + Fixpoint plength_aux (l:list elt)(p:positive) := match l with + | nil => p + | _::l => plength_aux l (Pos.succ p) + end. + + Definition plength l := plength_aux l 1. + + Definition treeify (l:list elt) := + fst (treeify_aux true (plength l) l). + + (** ** Filtering *) + + Fixpoint filter_aux (f: elt -> bool) s acc := + match s with + | Leaf => acc + | Node _ l k r => + let acc := filter_aux f r acc in + if f k then filter_aux f l (k::acc) + else filter_aux f l acc + end. + + Definition filter (f: elt -> bool) (s: t) : t := + treeify (filter_aux f s nil). + + Fixpoint partition_aux (f: elt -> bool) s acc1 acc2 := + match s with + | Leaf => (acc1,acc2) + | Node _ sl k sr => + let (acc1, acc2) := partition_aux f sr acc1 acc2 in + if f k then partition_aux f sl (k::acc1) acc2 + else partition_aux f sl acc1 (k::acc2) + end. + + Definition partition (f: elt -> bool) (s:t) : t*t := + let (ok,ko) := partition_aux f s nil nil in + (treeify ok, treeify ko). + + (** ** Union, intersection, difference *) + + (** union of the elements of [l1] and [l2] into a third [acc] list. *) + + Fixpoint union_list l1 : list elt -> list elt -> list elt := + match l1 with + | nil => @rev_append _ + | x::l1' => + fix union_l1 l2 acc := + match l2 with + | nil => rev_append l1 acc + | y::l2' => + match X.compare x y with + | Eq => union_list l1' l2' (x::acc) + | Lt => union_l1 l2' (y::acc) + | Gt => union_list l1' l2 (x::acc) + end + end + end. + + Definition linear_union s1 s2 := + treeify (union_list (rev_elements s1) (rev_elements s2) nil). + + Fixpoint inter_list l1 : list elt -> list elt -> list elt := + match l1 with + | nil => fun _ acc => acc + | x::l1' => + fix inter_l1 l2 acc := + match l2 with + | nil => acc + | y::l2' => + match X.compare x y with + | Eq => inter_list l1' l2' (x::acc) + | Lt => inter_l1 l2' acc + | Gt => inter_list l1' l2 acc + end + end + end. + + Definition linear_inter s1 s2 := + treeify (inter_list (rev_elements s1) (rev_elements s2) nil). + + Fixpoint diff_list l1 : list elt -> list elt -> list elt := + match l1 with + | nil => fun _ acc => acc + | x::l1' => + fix diff_l1 l2 acc := + match l2 with + | nil => rev_append l1 acc + | y::l2' => + match X.compare x y with + | Eq => diff_list l1' l2' acc + | Lt => diff_l1 l2' acc + | Gt => diff_list l1' l2 (x::acc) + end + end + end. + + Definition linear_diff s1 s2 := + treeify (diff_list (rev_elements s1) (rev_elements s2) nil). + + (** [compare_height] returns: - [Lt] if [height s2] is at least twice [height s1]; - [Gt] if [height s1] is at least twice [height s2]; - [Eq] if heights are approximately equal. Warning: this is not an equivalence relation! but who cares.... *) -Definition skip_red t := - match t with - | Rd t' _ _ => t' - | _ => t - end. - -Definition skip_black t := - match skip_red t with - | Bk t' _ _ => t' - | t' => t' - end. - -Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison := - match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with - | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => - compare_height (skip_black s1x') s1' s2' (skip_black s2x') - | _, Leaf, _, Node _ _ _ _ => Lt - | Node _ _ _ _, _, Leaf, _ => Gt - | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf => - compare_height (skip_black s1x') s1' s2' Leaf - | Leaf, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => - compare_height Leaf s1' s2' (skip_black s2x') - | _, _, _, _ => Eq - end. - -(** When one tree is quite smaller than the other, we simply + Definition skip_red t := + match t with + | Rd t' _ _ => t' + | _ => t + end. + + Definition skip_black t := + match skip_red t with + | Bk t' _ _ => t' + | t' => t' + end. + + Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison := + match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with + | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => + compare_height (skip_black s1x') s1' s2' (skip_black s2x') + | _, Leaf, _, Node _ _ _ _ => Lt + | Node _ _ _ _, _, Leaf, _ => Gt + | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf => + compare_height (skip_black s1x') s1' s2' Leaf + | Leaf, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => + compare_height Leaf s1' s2' (skip_black s2x') + | _, _, _, _ => Eq + end. + + (** When one tree is quite smaller than the other, we simply adds repeatively all its elements in the big one. For trees of comparable height, we rather use [linear_union]. *) -Definition union (t1 t2: t) : t := - match compare_height t1 t1 t2 t2 with - | Lt => fold add t1 t2 - | Gt => fold add t2 t1 - | Eq => linear_union t1 t2 - end. - -Definition diff (t1 t2: t) : t := - match compare_height t1 t1 t2 t2 with - | Lt => filter (fun k => negb (mem k t2)) t1 - | Gt => fold remove t2 t1 - | Eq => linear_diff t1 t2 - end. - -Definition inter (t1 t2: t) : t := - match compare_height t1 t1 t2 t2 with - | Lt => filter (fun k => mem k t2) t1 - | Gt => filter (fun k => mem k t1) t2 - | Eq => linear_inter t1 t2 - end. + Definition union (t1 t2: t) : t := + match compare_height t1 t1 t2 t2 with + | Lt => fold add t1 t2 + | Gt => fold add t2 t1 + | Eq => linear_union t1 t2 + end. + + Definition diff (t1 t2: t) : t := + match compare_height t1 t1 t2 t2 with + | Lt => filter (fun k => negb (mem k t2)) t1 + | Gt => fold remove t2 t1 + | Eq => linear_diff t1 t2 + end. + + Definition inter (t1 t2: t) : t := + match compare_height t1 t1 t2 t2 with + | Lt => filter (fun k => mem k t2) t1 + | Gt => filter (fun k => mem k t1) t2 + | Eq => linear_inter t1 t2 + end. End Ops. (** * MakeRaw : the pure functions and their specifications *) Module Type MakeRaw (X:Orders.OrderedType) <: MSetInterface.RawSets X. -Include Ops X. + Include Ops X. -(** Generic definition of binary-search-trees and proofs of + (** Generic definition of binary-search-trees and proofs of specifications for generic functions such as mem or fold. *) -Include MSetGenTree.Props X Color. - -#[local] Notation Rd := (Node Red). -#[local] Notation Bk := (Node Black). - -#[local] Hint Immediate MX.eq_sym : core. -#[local] Hint Unfold In lt_tree gt_tree Ok : core. -#[local] Hint Constructors InT bst : core. -#[local] Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. -#[local] Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. -#[local] Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. -#[local] Hint Resolve elements_spec2 : core. - -(** ** Singleton set *) - -Lemma singleton_spec x y : InT y (singleton x) <-> X.eq y x. -Proof. - unfold singleton; intuition_in. -Qed. - -#[global] -Instance singleton_ok x : Ok (singleton x). -Proof. - unfold singleton; auto. -Qed. - -(** ** makeBlack, MakeRed *) - -Lemma makeBlack_spec s x : InT x (makeBlack s) <-> InT x s. -Proof. - destruct s; simpl; intuition_in. -Qed. - -Lemma makeRed_spec s x : InT x (makeRed s) <-> InT x s. -Proof. - destruct s; simpl; intuition_in. -Qed. - -#[global] -Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s). -Proof. - destruct s; simpl; ok. -Qed. - -#[global] -Instance makeRed_ok s `{Ok s} : Ok (makeRed s). -Proof. - destruct s; simpl; ok. -Qed. - -(** ** Generic handling for red-matching and red-red-matching *) - -Definition isblack t := - match t with Bk _ _ _ => True | _ => False end. - -Definition notblack t := - match t with Bk _ _ _ => False | _ => True end. - -Definition notred t := - match t with Rd _ _ _ => False | _ => True end. - -Definition rcase {A} f g t : A := - match t with - | Rd a x b => f a x b - | _ => g t - end. - -Inductive rspec {A} f g : tree -> A -> Prop := - | rred a x b : rspec f g (Rd a x b) (f a x b) - | relse t : notred t -> rspec f g t (g t). - -Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t). -Proof. -destruct t as [|[|] l x r]; simpl; now constructor. -Qed. - -Definition rrcase {A} f g t : A := - match t with - | Rd (Rd a x b) y c => f a x b y c - | Rd a x (Rd b y c) => f a x b y c - | _ => g t - end. - -Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)). - -Inductive rrspec {A} f g : tree -> A -> Prop := - | rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c) - | rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c) - | rrelse t : notredred t -> rrspec f g t (g t). - -Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t). -Proof. -destruct t as [|[|] l x r]; simpl; try now constructor. -destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. -Qed. - -Definition rrcase' {A} f g t : A := - match t with - | Rd a x (Rd b y c) => f a x b y c - | Rd (Rd a x b) y c => f a x b y c - | _ => g t - end. - -Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t). -Proof. -destruct t as [|[|] l x r]; simpl; try now constructor. -destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. -Qed. - -(** Balancing operations are instances of generic match *) - -Fact lbal_match l k r : - rrspec - (fun a x b y c => Rd (Bk a x b) y (Bk c k r)) - (fun l => Bk l k r) - l - (lbal l k r). -Proof. - exact (rrmatch _ _ _). -Qed. - -Fact rbal_match l k r : - rrspec - (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) - (fun r => Bk l k r) - r - (rbal l k r). -Proof. - exact (rrmatch _ _ _). -Qed. - -Fact rbal'_match l k r : - rrspec - (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) - (fun r => Bk l k r) - r - (rbal' l k r). -Proof. - exact (rrmatch' _ _ _). -Qed. - -Fact lbalS_match l x r : - rspec - (fun a y b => Rd (Bk a y b) x r) - (fun l => - match r with - | Bk a y b => rbal' l x (Rd a y b) - | Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c)) - | _ => Rd l x r - end) - l - (lbalS l x r). -Proof. - exact (rmatch _ _ _). -Qed. - -Fact rbalS_match l x r : - rspec - (fun a y b => Rd l x (Bk a y b)) - (fun r => - match l with - | Bk a y b => lbal (Rd a y b) x r - | Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r) - | _ => Rd l x r - end) - r - (rbalS l x r). -Proof. - exact (rmatch _ _ _). -Qed. - -(** ** Balancing for insertion *) - -Lemma lbal_spec l x r y : - InT y (lbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case lbal_match; intuition_in. -Qed. - -#[global] -Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (lbal l x r). -Proof. - destruct (lbal_match l x r); ok. -Qed. - -Lemma rbal_spec l x r y : - InT y (rbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case rbal_match; intuition_in. -Qed. - -#[global] -Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (rbal l x r). -Proof. - destruct (rbal_match l x r); ok. -Qed. - -Lemma rbal'_spec l x r y : - InT y (rbal' l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case rbal'_match; intuition_in. -Qed. - -#[global] -Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (rbal' l x r). -Proof. - destruct (rbal'_match l x r); ok. -Qed. - -#[global] Hint Rewrite In_node_iff In_leaf_iff - makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb. - -Ltac descolor := destruct_all Color.t. -Ltac destree t := destruct t as [|[|] ? ? ?]. -Ltac autorew := autorewrite with rb. -Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H. - -(** ** Insertion *) - -Lemma ins_spec : forall s x y, - InT y (ins x s) <-> X.eq y x \/ InT y s. -Proof. - induct s x. - - intuition_in. - - intuition_in. setoid_replace y with x; eauto. - - descolor; autorew; rewrite IHl; intuition_in. - - descolor; autorew; rewrite IHr; intuition_in. -Qed. -#[global] Hint Rewrite ins_spec : rb. - -#[global] -Instance ins_ok s x `{Ok s} : Ok (ins x s). -Proof. - induct s x; auto; descolor; - (apply lbal_ok || apply rbal_ok || ok); auto; - intros y; autorew; intuition; order. -Qed. - -Lemma add_spec' s x y : - InT y (add x s) <-> X.eq y x \/ InT y s. -Proof. - unfold add. now autorew. -Qed. - -#[global] Hint Rewrite add_spec' : rb. - -Lemma add_spec s x y `{Ok s} : - InT y (add x s) <-> X.eq y x \/ InT y s. -Proof. - apply add_spec'. -Qed. - -#[global] -Instance add_ok s x `{Ok s} : Ok (add x s). -Proof. - unfold add; auto_tc. -Qed. - -(** ** Balancing for deletion *) - -Lemma lbalS_spec l x r y : - InT y (lbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case lbalS_match. - - intros; autorew; intuition_in. - - clear l. intros l _. - destruct r as [|[|] rl rx rr]. - * autorew. intuition_in. - * destree rl; autorew; intuition_in. - * autorew. intuition_in. -Qed. - -#[global] -Instance lbalS_ok l x r : - forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r). -Proof. - case lbalS_match; intros. - - ok. - - destruct r as [|[|] rl rx rr]. - * ok. - * destruct rl as [|[|] rll rlx rlr]; intros; ok. - + apply rbal'_ok; ok. - intros w; autorew; auto. - + intros w; autorew. - destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. - * ok. autorew. apply rbal'_ok; ok. -Qed. - -Lemma rbalS_spec l x r y : - InT y (rbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case rbalS_match. - - intros; autorew; intuition_in. - - intros t _. - destruct l as [|[|] ll lx lr]. - * autorew. intuition_in. - * destruct lr as [|[|] lrl lrx lrr]; autorew; intuition_in. - * autorew. intuition_in. -Qed. - -#[global] -Instance rbalS_ok l x r : - forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r). -Proof. - case rbalS_match; intros. - - ok. - - destruct l as [|[|] ll lx lr]. - * ok. - * destruct lr as [|[|] lrl lrx lrr]; intros; ok. - + apply lbal_ok; ok. - intros w; autorew; auto. - + intros w; autorew. - destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. - * ok. apply lbal_ok; ok. -Qed. - -#[global] Hint Rewrite lbalS_spec rbalS_spec : rb. - -(** ** Append for deletion *) - -Ltac append_tac l r := - induction l as [| lc ll _ lx lr IHlr]; - [intro r; simpl - |induction r as [| rc rl IHrl rx rr _]; - [simpl - |destruct lc, rc; - [specialize (IHlr rl); clear IHrl - |simpl; - assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial); - set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr; - specialize (IHlr r) - |change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr); - assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial); - set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr - |specialize (IHlr rl); clear IHrl]]]. - -Fact append_rr_match ll lx lr rl rx rr : - rspec - (fun a x b => Rd (Rd ll lx a) x (Rd b rx rr)) - (fun t => Rd ll lx (Rd t rx rr)) - (append lr rl) - (append (Rd ll lx lr) (Rd rl rx rr)). -Proof. - exact (rmatch _ _ _). -Qed. - -Fact append_bb_match ll lx lr rl rx rr : - rspec - (fun a x b => Rd (Bk ll lx a) x (Bk b rx rr)) - (fun t => lbalS ll lx (Bk t rx rr)) - (append lr rl) - (append (Bk ll lx lr) (Bk rl rx rr)). -Proof. - exact (rmatch _ _ _). -Qed. - -Lemma append_spec l r x : - InT x (append l r) <-> InT x l \/ InT x r. -Proof. - revert r. - append_tac l r; autorew; try tauto. - - (* Red / Red *) - revert IHlr; case append_rr_match; - [intros a y b | intros t Ht]; autorew; tauto. - - (* Black / Black *) - revert IHlr; case append_bb_match; - [intros a y b | intros t Ht]; autorew; tauto. -Qed. - -#[global] Hint Rewrite append_spec : rb. - -Lemma append_ok : forall x l r `{Ok l, Ok r}, - lt_tree x l -> gt_tree x r -> Ok (append l r). -Proof. - append_tac l r. - - (* Leaf / _ *) - trivial. - - (* _ / Leaf *) - trivial. - - (* Red / Red *) - intros; inv. - assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. - assert (X.lt lx rx) by (transitivity x; eauto). - assert (G : gt_tree lx (append lr rl)). - { intros w. autorew. destruct 1; [|transitivity x]; eauto. } - assert (L : lt_tree rx (append lr rl)). - { intros w. autorew. destruct 1; [transitivity x|]; eauto. } - revert IH G L; case append_rr_match; intros; ok. - - (* Red / Black *) - intros; ok. - intros w; autorew; destruct 1; eauto. - - (* Black / Red *) - intros; ok. - intros w; autorew; destruct 1; eauto. - - (* Black / Black *) - intros; inv. - assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. - assert (X.lt lx rx) by (transitivity x; eauto). - assert (G : gt_tree lx (append lr rl)). - { intros w. autorew. destruct 1; [|transitivity x]; eauto. } - assert (L : lt_tree rx (append lr rl)). - { intros w. autorew. destruct 1; [transitivity x|]; eauto. } - revert IH G L; case append_bb_match; intros; ok. - apply lbalS_ok; ok. -Qed. - -(** ** Deletion *) - -Lemma del_spec : forall s x y `{Ok s}, - InT y (del x s) <-> InT y s /\ ~X.eq y x. -Proof. -induct s x. -- intuition_in. -- autorew; intuition_in. - + assert (X.lt y x') by eauto. order. - + assert (X.lt x' y) by eauto. order. - + order. -- destruct l as [|[|] ll lx lr]; autorew; - rewrite ?IHl by trivial; intuition_in; order. -- destruct r as [|[|] rl rx rr]; autorew; - rewrite ?IHr by trivial; intuition_in; order. -Qed. - -#[global] Hint Rewrite del_spec : rb. - -#[global] -Instance del_ok s x `{Ok s} : Ok (del x s). -Proof. -induct s x. -- trivial. -- eapply append_ok; eauto. -- assert (lt_tree x' (del x l)). - { intro w. autorew; trivial. destruct 1. eauto. } - destruct l as [|[|] ll lx lr]; auto_tc. -- assert (gt_tree x' (del x r)). - { intro w. autorew; trivial. destruct 1. eauto. } - destruct r as [|[|] rl rx rr]; auto_tc. -Qed. - -Lemma remove_spec s x y `{Ok s} : - InT y (remove x s) <-> InT y s /\ ~X.eq y x. -Proof. -unfold remove. now autorew. -Qed. - -#[global] Hint Rewrite remove_spec : rb. - -#[global] -Instance remove_ok s x `{Ok s} : Ok (remove x s). -Proof. -unfold remove; auto_tc. -Qed. - -(** ** Removing the minimal element *) - -Lemma delmin_spec l y r c x s' `{O : Ok (Node c l y r)} : - delmin l y r = (x,s') -> - min_elt (Node c l y r) = Some x /\ del x (Node c l y r) = s'. -Proof. - revert y r c x s' O. - induction l as [|lc ll IH ly lr _]. - - simpl. intros y r _ x s' _. injection 1; intros; subst. - now rewrite MX.compare_refl. - - intros y r c x s' O. - simpl delmin. - specialize (IH ly lr). destruct delmin as (x0,s0). - destruct (IH lc x0 s0); clear IH; [ok|trivial|]. - remember (Node lc ll ly lr) as l. - simpl min_elt in *. - intros E. - replace x0 with x in * by (destruct lc; now injection E). - split. - * subst l; intuition. - * assert (X.lt x y). - { inversion_clear O. - assert (InT x l) by now apply min_elt_spec1. auto. } - simpl. case X.compare_spec; try order. - destruct lc; injection E; subst l s0; auto. -Qed. - -Lemma remove_min_spec1 s x s' `{Ok s}: - remove_min s = Some (x,s') -> - min_elt s = Some x /\ remove x s = s'. -Proof. - unfold remove_min. - destruct s as [|c l y r]; try easy. - generalize (delmin_spec l y r c). - destruct delmin as (x0,s0). intros D. - destruct (D x0 s0) as (->,<-); auto. - fold (remove x0 (Node c l y r)). - inversion_clear 1; auto. -Qed. - -Lemma remove_min_spec2 s : remove_min s = None -> Empty s. -Proof. - unfold remove_min. - destruct s as [|c l y r]. - - easy. - - now destruct delmin. -Qed. - -Lemma remove_min_ok (s:t) `{Ok s}: - match remove_min s with - | Some (_,s') => Ok s' - | None => True - end. -Proof. - generalize (remove_min_spec1 s). - destruct remove_min as [(x0,s0)|]; auto. - intros R. destruct (R x0 s0); auto. subst s0. auto_tc. -Qed. - -(** ** Treeify *) - -Notation ifpred p n := (if p then pred n else n%nat). - -Definition treeify_invariant size (f:treeify_t) := - forall acc, - size <= length acc -> - let (t,acc') := f acc in - cardinal t = size /\ acc = elements t ++ acc'. - -Lemma treeify_zero_spec : treeify_invariant 0 treeify_zero. -Proof. - intro. simpl. auto. -Qed. - -Lemma treeify_one_spec : treeify_invariant 1 treeify_one. -Proof. - intros [|x acc]; simpl; auto; inversion 1. -Qed. - -Lemma treeify_cont_spec f g size1 size2 size : - treeify_invariant size1 f -> - treeify_invariant size2 g -> - size = S (size1 + size2) -> - treeify_invariant size (treeify_cont f g). -Proof. - intros Hf Hg EQ acc LE. unfold treeify_cont. - specialize (Hf acc). - destruct (f acc) as (t1,acc1). - destruct Hf as (Hf1,Hf2). - { transitivity size; trivial. subst. rewrite <- Nat.add_succ_r. apply Nat.le_add_r. } - destruct acc1 as [|x acc1]. - { exfalso. revert LE. apply Nat.lt_nge. subst. - rewrite app_nil_r, <- elements_cardinal. - apply (Nat.succ_le_mono (cardinal t1)), Nat.le_add_r. } - specialize (Hg acc1). - destruct (g acc1) as (t2,acc2). - destruct Hg as (Hg1,Hg2). - { revert LE. subst. - rewrite length_app, <- elements_cardinal. simpl. - rewrite Nat.add_succ_r, <- Nat.succ_le_mono. - apply Nat.add_le_mono_l. } - rewrite elements_node, <- app_assoc. now subst. -Qed. - -Lemma treeify_aux_spec n (p:bool) : - treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n). -Proof. - revert p. - induction n as [n|n|]; intros p; simpl treeify_aux. - - eapply treeify_cont_spec; [ apply (IHn false) | apply (IHn p) | ]. - rewrite Pos2Nat.inj_xI. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - destruct p; simpl; intros; rewrite Nat.add_0_r; trivial. - now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. - - eapply treeify_cont_spec; [ apply (IHn p) | apply (IHn true) | ]. - rewrite Pos2Nat.inj_xO. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. - destruct p; simpl; intros; rewrite Nat.add_0_r; trivial. - symmetry. now apply Nat.add_pred_l. - - destruct p; [ apply treeify_zero_spec | apply treeify_one_spec ]. -Qed. - -Lemma plength_aux_spec l p : - Pos.to_nat (plength_aux l p) = length l + Pos.to_nat p. -Proof. - revert p. induction l; trivial. simpl plength_aux. - intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r. -Qed. - -Lemma plength_spec l : Pos.to_nat (plength l) = S (length l). -Proof. - unfold plength. rewrite plength_aux_spec. apply Nat.add_1_r. -Qed. - -Lemma treeify_elements l : elements (treeify l) = l. -Proof. - assert (H := treeify_aux_spec (plength l) true l). - unfold treeify. destruct treeify_aux as (t,acc); simpl in *. - destruct H as (H,H'). { now rewrite plength_spec. } - subst l. rewrite plength_spec, length_app, <- elements_cardinal in *. - destruct acc. - * now rewrite app_nil_r. - * exfalso. revert H. simpl. - rewrite Nat.add_succ_r, Nat.add_comm. - apply Nat.succ_add_discr. -Qed. - -Lemma treeify_spec x l : InT x (treeify l) <-> InA X.eq x l. -Proof. - intros. now rewrite <- elements_spec1, treeify_elements. -Qed. - -Lemma treeify_ok l : sort X.lt l -> Ok (treeify l). -Proof. - intros. apply elements_sort_ok. rewrite treeify_elements; auto. -Qed. - - -(** ** Filter *) - -Lemma filter_aux_elements s f acc : - filter_aux f s acc = List.filter f (elements s) ++ acc. -Proof. - revert acc. - induction s as [|c l IHl x r IHr]; trivial. - intros acc. - rewrite elements_node, List.filter_app. simpl. - destruct (f x); now rewrite IHl, IHr, <- app_assoc. -Qed. - -Lemma filter_elements s f : - elements (filter f s) = List.filter f (elements s). -Proof. - unfold filter. - now rewrite treeify_elements, filter_aux_elements, app_nil_r. -Qed. - -Lemma filter_spec s x f : - Proper (X.eq==>Logic.eq) f -> - (InT x (filter f s) <-> InT x s /\ f x = true). -Proof. - intros Hf. - rewrite <- elements_spec1, filter_elements, filter_InA, elements_spec1; - now auto_tc. -Qed. - -#[global] -Instance filter_ok s f `(Ok s) : Ok (filter f s). -Proof. - apply elements_sort_ok. - rewrite filter_elements. - apply filter_sort with X.eq; auto_tc. -Qed. - -(** ** Partition *) - -Lemma partition_aux_spec s f acc1 acc2 : - partition_aux f s acc1 acc2 = - (filter_aux f s acc1, filter_aux (fun x => negb (f x)) s acc2). -Proof. - revert acc1 acc2. - induction s as [ | c l Hl x r Hr ]; simpl. - - trivial. - - intros acc1 acc2. - destruct (f x); simpl; now rewrite Hr, Hl. -Qed. - -Lemma partition_spec s f : - partition f s = (filter f s, filter (fun x => negb (f x)) s). -Proof. - unfold partition, filter. now rewrite partition_aux_spec. -Qed. - -Lemma partition_spec1 s f : - Proper (X.eq==>Logic.eq) f -> - Equal (fst (partition f s)) (filter f s). -Proof. now rewrite partition_spec. Qed. - -Lemma partition_spec2 s f : - Proper (X.eq==>Logic.eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). -Proof. now rewrite partition_spec. Qed. - -#[global] -Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). -Proof. rewrite partition_spec; now apply filter_ok. Qed. - -#[global] -Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). -Proof. rewrite partition_spec; now apply filter_ok. Qed. - - -(** ** An invariant for binary list functions with accumulator. *) - -Ltac inA := - rewrite ?InA_app_iff, ?InA_cons, ?InA_nil, ?InA_rev in *; auto_tc. - -Record INV l1 l2 acc : Prop := { - l1_sorted : sort X.lt (rev l1); - l2_sorted : sort X.lt (rev l2); - acc_sorted : sort X.lt acc; - l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y; - l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}. -#[local] Hint Resolve l1_sorted l2_sorted acc_sorted : core. - -Lemma INV_init s1 s2 `(Ok s1, Ok s2) : - INV (rev_elements s1) (rev_elements s2) nil. -Proof. - rewrite !rev_elements_rev. - split; rewrite ?rev_involutive; auto; intros; now inA. -Qed. - -Lemma INV_sym l1 l2 acc : INV l1 l2 acc -> INV l2 l1 acc. -Proof. - destruct 1; now split. -Qed. - -Lemma INV_drop x1 l1 l2 acc : - INV (x1 :: l1) l2 acc -> INV l1 l2 acc. -Proof. - intros (l1s,l2s,accs,l1a,l2a). simpl in *. - destruct (sorted_app_inv _ _ l1s) as (U & V & W); auto. - split; auto. -Qed. - -Lemma INV_eq x1 x2 l1 l2 acc : - INV (x1 :: l1) (x2 :: l2) acc -> X.eq x1 x2 -> - INV l1 l2 (x1 :: acc). -Proof. - intros (U,V,W,X,Y) EQ. simpl in *. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - split; auto. - - constructor; auto. apply InA_InfA with X.eq; auto_tc. - - intros x y; inA; intros Hx [Hy|Hy]. - + apply U3; inA. - + apply X; inA. - - intros x y; inA; intros Hx [Hy|Hy]. - + rewrite Hy, EQ; apply V3; inA. - + apply Y; inA. -Qed. - -Lemma INV_lt x1 x2 l1 l2 acc : - INV (x1 :: l1) (x2 :: l2) acc -> X.lt x1 x2 -> - INV (x1 :: l1) l2 (x2 :: acc). -Proof. - intros (U,V,W,X,Y) EQ. simpl in *. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - split; auto. - - constructor; auto. apply InA_InfA with X.eq; auto_tc. - - intros x y; inA; intros Hx [Hy|Hy]. - + rewrite Hy; clear Hy. destruct Hx; [order|]. - transitivity x1; auto. apply U3; inA. - + apply X; inA. - - intros x y; inA; intros Hx [Hy|Hy]. - + rewrite Hy. apply V3; inA. - + apply Y; inA. -Qed. - -Lemma INV_rev l1 l2 acc : - INV l1 l2 acc -> Sorted X.lt (rev_append l1 acc). -Proof. - intros. rewrite rev_append_rev. - apply SortA_app with X.eq; eauto with *. - intros x y. inA. eapply @l1_lt_acc; eauto. -Qed. - -(** ** union *) - -Lemma union_list_ok l1 l2 acc : - INV l1 l2 acc -> sort X.lt (union_list l1 l2 acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]; - [intro l2|induction l2 as [|x2 l2 IH2]]; - intros acc inv. - - eapply INV_rev, INV_sym; eauto. - - eapply INV_rev; eauto. - - simpl. case X.compare_spec; intro C. - * apply IH1. eapply INV_eq; eauto. - * apply (IH2 (x2::acc)). eapply INV_lt; eauto. - * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. -Qed. - -#[global] -Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) : - Ok (linear_union s1 s2). -Proof. - unfold linear_union. now apply treeify_ok, union_list_ok, INV_init. -Qed. - -#[global] -Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) : - Ok (fold add s1 s2). -Proof. - rewrite fold_spec, <- fold_left_rev_right. - unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -#[global] -Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2). -Proof. - unfold union. destruct compare_height; auto_tc. -Qed. - -Lemma union_list_spec x l1 l2 acc : - InA X.eq x (union_list l1 l2 acc) <-> - InA X.eq x l1 \/ InA X.eq x l2 \/ InA X.eq x acc. -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]. - - intros l2 acc; simpl. rewrite rev_append_rev. inA. tauto. - - induction l2 as [|x2 l2 IH2]; intros acc; simpl. - * rewrite rev_append_rev. inA. tauto. - * case X.compare_spec; intro C. - + rewrite IH1, !InA_cons, C; tauto. - + rewrite (IH2 (x2::acc)), !InA_cons. tauto. - + rewrite IH1, !InA_cons; tauto. -Qed. - -Lemma linear_union_spec s1 s2 x : - InT x (linear_union s1 s2) <-> InT x s1 \/ InT x s2. -Proof. - unfold linear_union. - rewrite treeify_spec, union_list_spec, !rev_elements_rev. - rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. - tauto. -Qed. - -Lemma fold_add_spec s1 s2 x : - InT x (fold add s1 s2) <-> InT x s1 \/ InT x s2. -Proof. - rewrite fold_spec, <- fold_left_rev_right. - rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. - unfold elt in *. - induction (rev (elements s1)); simpl. - - rewrite InA_nil. tauto. - - unfold flip. rewrite add_spec', IHl, InA_cons. tauto. -Qed. - -Lemma union_spec' s1 s2 x : - InT x (union s1 s2) <-> InT x s1 \/ InT x s2. -Proof. - unfold union. destruct compare_height. - - apply linear_union_spec. - - apply fold_add_spec. - - rewrite fold_add_spec. tauto. -Qed. - -Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, - (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). -Proof. - intros; apply union_spec'. -Qed. - -(** ** inter *) - -Lemma inter_list_ok l1 l2 acc : - INV l1 l2 acc -> sort X.lt (inter_list l1 l2 acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]; [|induction l2 as [|x2 l2 IH2]]; simpl. - - eauto. - - eauto. - - intros acc inv. - case X.compare_spec; intro C. - * apply IH1. eapply INV_eq; eauto. - * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. - * apply IH1. eapply INV_drop; eauto. -Qed. - -#[global] -Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) : - Ok (linear_inter s1 s2). -Proof. - unfold linear_inter. now apply treeify_ok, inter_list_ok, INV_init. -Qed. - -#[global] -Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). -Proof. - unfold inter. destruct compare_height; auto_tc. -Qed. - -Lemma inter_list_spec x l1 l2 acc : - sort X.lt (rev l1) -> - sort X.lt (rev l2) -> - (InA X.eq x (inter_list l1 l2 acc) <-> - (InA X.eq x l1 /\ InA X.eq x l2) \/ InA X.eq x acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]. - - intros l2 acc; simpl. inA. tauto. - - induction l2 as [|x2 l2 IH2]; intros acc. - * simpl. inA. tauto. - * simpl. intros U V. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - case X.compare_spec; intro C. - + rewrite IH1, !InA_cons, C; tauto. - + rewrite (IH2 acc); auto. inA. intuition; try order. - assert (X.lt x x1) by (apply U3; inA). order. - + rewrite IH1; auto. inA. intuition; try order. - assert (X.lt x x2) by (apply V3; inA). order. -Qed. - -Lemma linear_inter_spec s1 s2 x `(Ok s1, Ok s2) : - InT x (linear_inter s1 s2) <-> InT x s1 /\ InT x s2. -Proof. - unfold linear_inter. - rewrite !rev_elements_rev, treeify_spec, inter_list_spec - by (rewrite rev_involutive; auto_tc). - rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. -Qed. - -#[local] Instance mem_proper s `(Ok s) : - Proper (X.eq ==> Logic.eq) (fun k => mem k s). -Proof. - intros x y EQ. apply Bool.eq_iff_eq_true; rewrite !mem_spec; auto. - now rewrite EQ. -Qed. - -Lemma inter_spec s1 s2 y `{Ok s1, Ok s2} : - InT y (inter s1 s2) <-> InT y s1 /\ InT y s2. -Proof. - unfold inter. destruct compare_height. - - now apply linear_inter_spec. - - rewrite filter_spec, mem_spec by auto_tc; tauto. - - rewrite filter_spec, mem_spec by auto_tc; tauto. -Qed. - -(** ** difference *) - -Lemma diff_list_ok l1 l2 acc : - INV l1 l2 acc -> sort X.lt (diff_list l1 l2 acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]; - [intro l2|induction l2 as [|x2 l2 IH2]]; - intros acc inv. - - eauto. - - unfold diff_list. eapply INV_rev; eauto. - - simpl. case X.compare_spec; intro C. - * apply IH1. eapply INV_drop, INV_sym, INV_drop, INV_sym; eauto. - * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. - * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. -Qed. - -#[global] -Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) : - Ok (linear_diff s1 s2). -Proof. - unfold linear_inter. now apply treeify_ok, diff_list_ok, INV_init. -Qed. - -#[global] -Instance fold_remove_ok s1 s2 `(Ok s2) : - Ok (fold remove s1 s2). -Proof. - rewrite fold_spec, <- fold_left_rev_right. - unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -#[global] -Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). -Proof. - unfold diff. destruct compare_height; auto_tc. -Qed. - -Lemma diff_list_spec x l1 l2 acc : - sort X.lt (rev l1) -> - sort X.lt (rev l2) -> - (InA X.eq x (diff_list l1 l2 acc) <-> - (InA X.eq x l1 /\ ~InA X.eq x l2) \/ InA X.eq x acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]. - - intros l2 acc; simpl. inA. tauto. - - induction l2 as [|x2 l2 IH2]; intros acc. - + intros; simpl. rewrite rev_append_rev. inA. tauto. - + simpl. intros U V. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - case X.compare_spec; intro C. - * rewrite IH1; auto. f_equiv. inA. intuition; try order. - assert (X.lt x x1) by (apply U3; inA). order. - * rewrite (IH2 acc); auto. f_equiv. inA. intuition; try order. - assert (X.lt x x1) by (apply U3; inA). order. - * rewrite IH1; auto. inA. intuition; try order. - left; split; auto. destruct 1. - -- order. - -- assert (X.lt x x2) by (apply V3; inA). order. -Qed. - -Lemma linear_diff_spec s1 s2 x `(Ok s1, Ok s2) : - InT x (linear_diff s1 s2) <-> InT x s1 /\ ~InT x s2. -Proof. - unfold linear_diff. - rewrite !rev_elements_rev, treeify_spec, diff_list_spec - by (rewrite rev_involutive; auto_tc). - rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. -Qed. - -Lemma fold_remove_spec s1 s2 x `(Ok s2) : - InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1. -Proof. - rewrite fold_spec, <- fold_left_rev_right. - rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. - unfold elt in *. - induction (rev (elements s1)); simpl; intros. - - rewrite InA_nil. intuition. - - unfold flip in *. rewrite remove_spec, IHl, InA_cons. - + tauto. - + clear IHl. induction l; simpl; auto_tc. -Qed. - -Lemma diff_spec s1 s2 y `{Ok s1, Ok s2} : - InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2. -Proof. - unfold diff. destruct compare_height. - - now apply linear_diff_spec. - - rewrite filter_spec, Bool.negb_true_iff, - <- Bool.not_true_iff_false, mem_spec; - intuition. - intros x1 x2 EQ. f_equal. now apply mem_proper. - - now apply fold_remove_spec. -Qed. + Include MSetGenTree.Props X Color. + + #[local] Notation Rd := (Node Red). + #[local] Notation Bk := (Node Black). + + #[local] Hint Immediate MX.eq_sym : core. + #[local] Hint Unfold In lt_tree gt_tree Ok : core. + #[local] Hint Constructors InT bst : core. + #[local] Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. + #[local] Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. + #[local] Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. + #[local] Hint Resolve elements_spec2 : core. + + (** ** Singleton set *) + + Lemma singleton_spec x y : InT y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; intuition_in. + Qed. + + #[global] + Instance singleton_ok x : Ok (singleton x). + Proof. + unfold singleton; auto. + Qed. + + (** ** makeBlack, MakeRed *) + + Lemma makeBlack_spec s x : InT x (makeBlack s) <-> InT x s. + Proof. + destruct s; simpl; intuition_in. + Qed. + + Lemma makeRed_spec s x : InT x (makeRed s) <-> InT x s. + Proof. + destruct s; simpl; intuition_in. + Qed. + + #[global] + Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s). + Proof. + destruct s; simpl; ok. + Qed. + + #[global] + Instance makeRed_ok s `{Ok s} : Ok (makeRed s). + Proof. + destruct s; simpl; ok. + Qed. + + (** ** Generic handling for red-matching and red-red-matching *) + + Definition isblack t := + match t with Bk _ _ _ => True | _ => False end. + + Definition notblack t := + match t with Bk _ _ _ => False | _ => True end. + + Definition notred t := + match t with Rd _ _ _ => False | _ => True end. + + Definition rcase {A} f g t : A := + match t with + | Rd a x b => f a x b + | _ => g t + end. + + Inductive rspec {A} f g : tree -> A -> Prop := + | rred a x b : rspec f g (Rd a x b) (f a x b) + | relse t : notred t -> rspec f g t (g t). + + Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t). + Proof. + destruct t as [|[|] l x r]; simpl; now constructor. + Qed. + + Definition rrcase {A} f g t : A := + match t with + | Rd (Rd a x b) y c => f a x b y c + | Rd a x (Rd b y c) => f a x b y c + | _ => g t + end. + + Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)). + + Inductive rrspec {A} f g : tree -> A -> Prop := + | rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c) + | rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c) + | rrelse t : notredred t -> rrspec f g t (g t). + + Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t). + Proof. + destruct t as [|[|] l x r]; simpl; try now constructor. + destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. + Qed. + + Definition rrcase' {A} f g t : A := + match t with + | Rd a x (Rd b y c) => f a x b y c + | Rd (Rd a x b) y c => f a x b y c + | _ => g t + end. + + Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t). + Proof. + destruct t as [|[|] l x r]; simpl; try now constructor. + destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. + Qed. + + (** Balancing operations are instances of generic match *) + + Fact lbal_match l k r : + rrspec + (fun a x b y c => Rd (Bk a x b) y (Bk c k r)) + (fun l => Bk l k r) + l + (lbal l k r). + Proof. + exact (rrmatch _ _ _). + Qed. + + Fact rbal_match l k r : + rrspec + (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) + (fun r => Bk l k r) + r + (rbal l k r). + Proof. + exact (rrmatch _ _ _). + Qed. + + Fact rbal'_match l k r : + rrspec + (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) + (fun r => Bk l k r) + r + (rbal' l k r). + Proof. + exact (rrmatch' _ _ _). + Qed. + + Fact lbalS_match l x r : + rspec + (fun a y b => Rd (Bk a y b) x r) + (fun l => + match r with + | Bk a y b => rbal' l x (Rd a y b) + | Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c)) + | _ => Rd l x r + end) + l + (lbalS l x r). + Proof. + exact (rmatch _ _ _). + Qed. + + Fact rbalS_match l x r : + rspec + (fun a y b => Rd l x (Bk a y b)) + (fun r => + match l with + | Bk a y b => lbal (Rd a y b) x r + | Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r) + | _ => Rd l x r + end) + r + (rbalS l x r). + Proof. + exact (rmatch _ _ _). + Qed. + + (** ** Balancing for insertion *) + + Lemma lbal_spec l x r y : + InT y (lbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. + Proof. + case lbal_match; intuition_in. + Qed. + + #[global] + Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (lbal l x r). + Proof. + destruct (lbal_match l x r); ok. + Qed. + + Lemma rbal_spec l x r y : + InT y (rbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. + Proof. + case rbal_match; intuition_in. + Qed. + + #[global] + Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (rbal l x r). + Proof. + destruct (rbal_match l x r); ok. + Qed. + + Lemma rbal'_spec l x r y : + InT y (rbal' l x r) <-> X.eq y x \/ InT y l \/ InT y r. + Proof. + case rbal'_match; intuition_in. + Qed. + + #[global] + Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (rbal' l x r). + Proof. + destruct (rbal'_match l x r); ok. + Qed. + + #[global] Hint Rewrite In_node_iff In_leaf_iff + makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb. + + Ltac descolor := destruct_all Color.t. + Ltac destree t := destruct t as [|[|] ? ? ?]. + Ltac autorew := autorewrite with rb. + Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H. + + (** ** Insertion *) + + Lemma ins_spec : forall s x y, + InT y (ins x s) <-> X.eq y x \/ InT y s. + Proof. + induct s x. + - intuition_in. + - intuition_in. setoid_replace y with x; eauto. + - descolor; autorew; rewrite IHl; intuition_in. + - descolor; autorew; rewrite IHr; intuition_in. + Qed. + #[global] Hint Rewrite ins_spec : rb. + + #[global] + Instance ins_ok s x `{Ok s} : Ok (ins x s). + Proof. + induct s x; auto; descolor; + (apply lbal_ok || apply rbal_ok || ok); auto; + intros y; autorew; intuition; order. + Qed. + + Lemma add_spec' s x y : + InT y (add x s) <-> X.eq y x \/ InT y s. + Proof. + unfold add. now autorew. + Qed. + + #[global] Hint Rewrite add_spec' : rb. + + Lemma add_spec s x y `{Ok s} : + InT y (add x s) <-> X.eq y x \/ InT y s. + Proof. + apply add_spec'. + Qed. + + #[global] + Instance add_ok s x `{Ok s} : Ok (add x s). + Proof. + unfold add; auto_tc. + Qed. + + (** ** Balancing for deletion *) + + Lemma lbalS_spec l x r y : + InT y (lbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. + Proof. + case lbalS_match. + - intros; autorew; intuition_in. + - clear l. intros l _. + destruct r as [|[|] rl rx rr]. + * autorew. intuition_in. + * destree rl; autorew; intuition_in. + * autorew. intuition_in. + Qed. + + #[global] + Instance lbalS_ok l x r : + forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r). + Proof. + case lbalS_match; intros. + - ok. + - destruct r as [|[|] rl rx rr]. + * ok. + * destruct rl as [|[|] rll rlx rlr]; intros; ok. + + apply rbal'_ok; ok. + intros w; autorew; auto. + + intros w; autorew. + destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. + * ok. autorew. apply rbal'_ok; ok. + Qed. + + Lemma rbalS_spec l x r y : + InT y (rbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. + Proof. + case rbalS_match. + - intros; autorew; intuition_in. + - intros t _. + destruct l as [|[|] ll lx lr]. + * autorew. intuition_in. + * destruct lr as [|[|] lrl lrx lrr]; autorew; intuition_in. + * autorew. intuition_in. + Qed. + + #[global] + Instance rbalS_ok l x r : + forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r). + Proof. + case rbalS_match; intros. + - ok. + - destruct l as [|[|] ll lx lr]. + * ok. + * destruct lr as [|[|] lrl lrx lrr]; intros; ok. + + apply lbal_ok; ok. + intros w; autorew; auto. + + intros w; autorew. + destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. + * ok. apply lbal_ok; ok. + Qed. + + #[global] Hint Rewrite lbalS_spec rbalS_spec : rb. + + (** ** Append for deletion *) + + Ltac append_tac l r := + induction l as [| lc ll _ lx lr IHlr]; + [intro r; simpl + |induction r as [| rc rl IHrl rx rr _]; + [simpl + |destruct lc, rc; + [specialize (IHlr rl); clear IHrl + |simpl; + assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial); + set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr; + specialize (IHlr r) + |change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr); + assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial); + set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr + |specialize (IHlr rl); clear IHrl]]]. + + Fact append_rr_match ll lx lr rl rx rr : + rspec + (fun a x b => Rd (Rd ll lx a) x (Rd b rx rr)) + (fun t => Rd ll lx (Rd t rx rr)) + (append lr rl) + (append (Rd ll lx lr) (Rd rl rx rr)). + Proof. + exact (rmatch _ _ _). + Qed. + + Fact append_bb_match ll lx lr rl rx rr : + rspec + (fun a x b => Rd (Bk ll lx a) x (Bk b rx rr)) + (fun t => lbalS ll lx (Bk t rx rr)) + (append lr rl) + (append (Bk ll lx lr) (Bk rl rx rr)). + Proof. + exact (rmatch _ _ _). + Qed. + + Lemma append_spec l r x : + InT x (append l r) <-> InT x l \/ InT x r. + Proof. + revert r. + append_tac l r; autorew; try tauto. + - (* Red / Red *) + revert IHlr; case append_rr_match; + [intros a y b | intros t Ht]; autorew; tauto. + - (* Black / Black *) + revert IHlr; case append_bb_match; + [intros a y b | intros t Ht]; autorew; tauto. + Qed. + + #[global] Hint Rewrite append_spec : rb. + + Lemma append_ok : forall x l r `{Ok l, Ok r}, + lt_tree x l -> gt_tree x r -> Ok (append l r). + Proof. + append_tac l r. + - (* Leaf / _ *) + trivial. + - (* _ / Leaf *) + trivial. + - (* Red / Red *) + intros; inv. + assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. + assert (X.lt lx rx) by (transitivity x; eauto). + assert (G : gt_tree lx (append lr rl)). + { intros w. autorew. destruct 1; [|transitivity x]; eauto. } + assert (L : lt_tree rx (append lr rl)). + { intros w. autorew. destruct 1; [transitivity x|]; eauto. } + revert IH G L; case append_rr_match; intros; ok. + - (* Red / Black *) + intros; ok. + intros w; autorew; destruct 1; eauto. + - (* Black / Red *) + intros; ok. + intros w; autorew; destruct 1; eauto. + - (* Black / Black *) + intros; inv. + assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. + assert (X.lt lx rx) by (transitivity x; eauto). + assert (G : gt_tree lx (append lr rl)). + { intros w. autorew. destruct 1; [|transitivity x]; eauto. } + assert (L : lt_tree rx (append lr rl)). + { intros w. autorew. destruct 1; [transitivity x|]; eauto. } + revert IH G L; case append_bb_match; intros; ok. + apply lbalS_ok; ok. + Qed. + + (** ** Deletion *) + + Lemma del_spec : forall s x y `{Ok s}, + InT y (del x s) <-> InT y s /\ ~X.eq y x. + Proof. + induct s x. + - intuition_in. + - autorew; intuition_in. + + assert (X.lt y x') by eauto. order. + + assert (X.lt x' y) by eauto. order. + + order. + - destruct l as [|[|] ll lx lr]; autorew; + rewrite ?IHl by trivial; intuition_in; order. + - destruct r as [|[|] rl rx rr]; autorew; + rewrite ?IHr by trivial; intuition_in; order. + Qed. + + #[global] Hint Rewrite del_spec : rb. + + #[global] + Instance del_ok s x `{Ok s} : Ok (del x s). + Proof. + induct s x. + - trivial. + - eapply append_ok; eauto. + - assert (lt_tree x' (del x l)). + { intro w. autorew; trivial. destruct 1. eauto. } + destruct l as [|[|] ll lx lr]; auto_tc. + - assert (gt_tree x' (del x r)). + { intro w. autorew; trivial. destruct 1. eauto. } + destruct r as [|[|] rl rx rr]; auto_tc. + Qed. + + Lemma remove_spec s x y `{Ok s} : + InT y (remove x s) <-> InT y s /\ ~X.eq y x. + Proof. + unfold remove. now autorew. + Qed. + + #[global] Hint Rewrite remove_spec : rb. + + #[global] + Instance remove_ok s x `{Ok s} : Ok (remove x s). + Proof. + unfold remove; auto_tc. + Qed. + + (** ** Removing the minimal element *) + + Lemma delmin_spec l y r c x s' `{O : Ok (Node c l y r)} : + delmin l y r = (x,s') -> + min_elt (Node c l y r) = Some x /\ del x (Node c l y r) = s'. + Proof. + revert y r c x s' O. + induction l as [|lc ll IH ly lr _]. + - simpl. intros y r _ x s' _. injection 1; intros; subst. + now rewrite MX.compare_refl. + - intros y r c x s' O. + simpl delmin. + specialize (IH ly lr). destruct delmin as (x0,s0). + destruct (IH lc x0 s0); clear IH; [ok|trivial|]. + remember (Node lc ll ly lr) as l. + simpl min_elt in *. + intros E. + replace x0 with x in * by (destruct lc; now injection E). + split. + * subst l; intuition. + * assert (X.lt x y). + { inversion_clear O. + assert (InT x l) by now apply min_elt_spec1. auto. } + simpl. case X.compare_spec; try order. + destruct lc; injection E; subst l s0; auto. + Qed. + + Lemma remove_min_spec1 s x s' `{Ok s}: + remove_min s = Some (x,s') -> + min_elt s = Some x /\ remove x s = s'. + Proof. + unfold remove_min. + destruct s as [|c l y r]; try easy. + generalize (delmin_spec l y r c). + destruct delmin as (x0,s0). intros D. + destruct (D x0 s0) as (->,<-); auto. + fold (remove x0 (Node c l y r)). + inversion_clear 1; auto. + Qed. + + Lemma remove_min_spec2 s : remove_min s = None -> Empty s. + Proof. + unfold remove_min. + destruct s as [|c l y r]. + - easy. + - now destruct delmin. + Qed. + + Lemma remove_min_ok (s:t) `{Ok s}: + match remove_min s with + | Some (_,s') => Ok s' + | None => True + end. + Proof. + generalize (remove_min_spec1 s). + destruct remove_min as [(x0,s0)|]; auto. + intros R. destruct (R x0 s0); auto. subst s0. auto_tc. + Qed. + + (** ** Treeify *) + + Notation ifpred p n := (if p then pred n else n%nat). + + Definition treeify_invariant size (f:treeify_t) := + forall acc, + size <= length acc -> + let (t,acc') := f acc in + cardinal t = size /\ acc = elements t ++ acc'. + + Lemma treeify_zero_spec : treeify_invariant 0 treeify_zero. + Proof. + intro. simpl. auto. + Qed. + + Lemma treeify_one_spec : treeify_invariant 1 treeify_one. + Proof. + intros [|x acc]; simpl; auto; inversion 1. + Qed. + + Lemma treeify_cont_spec f g size1 size2 size : + treeify_invariant size1 f -> + treeify_invariant size2 g -> + size = S (size1 + size2) -> + treeify_invariant size (treeify_cont f g). + Proof. + intros Hf Hg EQ acc LE. unfold treeify_cont. + specialize (Hf acc). + destruct (f acc) as (t1,acc1). + destruct Hf as (Hf1,Hf2). + { transitivity size; trivial. subst. rewrite <- Nat.add_succ_r. apply Nat.le_add_r. } + destruct acc1 as [|x acc1]. + { exfalso. revert LE. apply Nat.lt_nge. subst. + rewrite app_nil_r, <- elements_cardinal. + apply (Nat.succ_le_mono (cardinal t1)), Nat.le_add_r. } + specialize (Hg acc1). + destruct (g acc1) as (t2,acc2). + destruct Hg as (Hg1,Hg2). + { revert LE. subst. + rewrite length_app, <- elements_cardinal. simpl. + rewrite Nat.add_succ_r, <- Nat.succ_le_mono. + apply Nat.add_le_mono_l. } + rewrite elements_node, <- app_assoc. now subst. + Qed. + + Lemma treeify_aux_spec n (p:bool) : + treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n). + Proof. + revert p. + induction n as [n|n|]; intros p; simpl treeify_aux. + - eapply treeify_cont_spec; [ apply (IHn false) | apply (IHn p) | ]. + rewrite Pos2Nat.inj_xI. + assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. + destruct p; simpl; intros; rewrite Nat.add_0_r; trivial. + now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. + - eapply treeify_cont_spec; [ apply (IHn p) | apply (IHn true) | ]. + rewrite Pos2Nat.inj_xO. + assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. + rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. + destruct p; simpl; intros; rewrite Nat.add_0_r; trivial. + symmetry. now apply Nat.add_pred_l. + - destruct p; [ apply treeify_zero_spec | apply treeify_one_spec ]. + Qed. + + Lemma plength_aux_spec l p : + Pos.to_nat (plength_aux l p) = length l + Pos.to_nat p. + Proof. + revert p. induction l; trivial. simpl plength_aux. + intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r. + Qed. + + Lemma plength_spec l : Pos.to_nat (plength l) = S (length l). + Proof. + unfold plength. rewrite plength_aux_spec. apply Nat.add_1_r. + Qed. + + Lemma treeify_elements l : elements (treeify l) = l. + Proof. + assert (H := treeify_aux_spec (plength l) true l). + unfold treeify. destruct treeify_aux as (t,acc); simpl in *. + destruct H as (H,H'). { now rewrite plength_spec. } + subst l. rewrite plength_spec, length_app, <- elements_cardinal in *. + destruct acc. + * now rewrite app_nil_r. + * exfalso. revert H. simpl. + rewrite Nat.add_succ_r, Nat.add_comm. + apply Nat.succ_add_discr. + Qed. + + Lemma treeify_spec x l : InT x (treeify l) <-> InA X.eq x l. + Proof. + intros. now rewrite <- elements_spec1, treeify_elements. + Qed. + + Lemma treeify_ok l : sort X.lt l -> Ok (treeify l). + Proof. + intros. apply elements_sort_ok. rewrite treeify_elements; auto. + Qed. + + + (** ** Filter *) + + Lemma filter_aux_elements s f acc : + filter_aux f s acc = List.filter f (elements s) ++ acc. + Proof. + revert acc. + induction s as [|c l IHl x r IHr]; trivial. + intros acc. + rewrite elements_node, List.filter_app. simpl. + destruct (f x); now rewrite IHl, IHr, <- app_assoc. + Qed. + + Lemma filter_elements s f : + elements (filter f s) = List.filter f (elements s). + Proof. + unfold filter. + now rewrite treeify_elements, filter_aux_elements, app_nil_r. + Qed. + + Lemma filter_spec s x f : + Proper (X.eq==>Logic.eq) f -> + (InT x (filter f s) <-> InT x s /\ f x = true). + Proof. + intros Hf. + rewrite <- elements_spec1, filter_elements, filter_InA, elements_spec1; + now auto_tc. + Qed. + + #[global] + Instance filter_ok s f `(Ok s) : Ok (filter f s). + Proof. + apply elements_sort_ok. + rewrite filter_elements. + apply filter_sort with X.eq; auto_tc. + Qed. + + (** ** Partition *) + + Lemma partition_aux_spec s f acc1 acc2 : + partition_aux f s acc1 acc2 = + (filter_aux f s acc1, filter_aux (fun x => negb (f x)) s acc2). + Proof. + revert acc1 acc2. + induction s as [ | c l Hl x r Hr ]; simpl. + - trivial. + - intros acc1 acc2. + destruct (f x); simpl; now rewrite Hr, Hl. + Qed. + + Lemma partition_spec s f : + partition f s = (filter f s, filter (fun x => negb (f x)) s). + Proof. + unfold partition, filter. now rewrite partition_aux_spec. + Qed. + + Lemma partition_spec1 s f : + Proper (X.eq==>Logic.eq) f -> + Equal (fst (partition f s)) (filter f s). + Proof. now rewrite partition_spec. Qed. + + Lemma partition_spec2 s f : + Proper (X.eq==>Logic.eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. now rewrite partition_spec. Qed. + + #[global] + Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). + Proof. rewrite partition_spec; now apply filter_ok. Qed. + + #[global] + Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). + Proof. rewrite partition_spec; now apply filter_ok. Qed. + + + (** ** An invariant for binary list functions with accumulator. *) + + Ltac inA := + rewrite ?InA_app_iff, ?InA_cons, ?InA_nil, ?InA_rev in *; auto_tc. + + Record INV l1 l2 acc : Prop := { + l1_sorted : sort X.lt (rev l1); + l2_sorted : sort X.lt (rev l2); + acc_sorted : sort X.lt acc; + l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y; + l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}. + #[local] Hint Resolve l1_sorted l2_sorted acc_sorted : core. + + Lemma INV_init s1 s2 `(Ok s1, Ok s2) : + INV (rev_elements s1) (rev_elements s2) nil. + Proof. + rewrite !rev_elements_rev. + split; rewrite ?rev_involutive; auto; intros; now inA. + Qed. + + Lemma INV_sym l1 l2 acc : INV l1 l2 acc -> INV l2 l1 acc. + Proof. + destruct 1; now split. + Qed. + + Lemma INV_drop x1 l1 l2 acc : + INV (x1 :: l1) l2 acc -> INV l1 l2 acc. + Proof. + intros (l1s,l2s,accs,l1a,l2a). simpl in *. + destruct (sorted_app_inv _ _ l1s) as (U & V & W); auto. + split; auto. + Qed. + + Lemma INV_eq x1 x2 l1 l2 acc : + INV (x1 :: l1) (x2 :: l2) acc -> X.eq x1 x2 -> + INV l1 l2 (x1 :: acc). + Proof. + intros (U,V,W,X,Y) EQ. simpl in *. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + split; auto. + - constructor; auto. apply InA_InfA with X.eq; auto_tc. + - intros x y; inA; intros Hx [Hy|Hy]. + + apply U3; inA. + + apply X; inA. + - intros x y; inA; intros Hx [Hy|Hy]. + + rewrite Hy, EQ; apply V3; inA. + + apply Y; inA. + Qed. + + Lemma INV_lt x1 x2 l1 l2 acc : + INV (x1 :: l1) (x2 :: l2) acc -> X.lt x1 x2 -> + INV (x1 :: l1) l2 (x2 :: acc). + Proof. + intros (U,V,W,X,Y) EQ. simpl in *. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + split; auto. + - constructor; auto. apply InA_InfA with X.eq; auto_tc. + - intros x y; inA; intros Hx [Hy|Hy]. + + rewrite Hy; clear Hy. destruct Hx; [order|]. + transitivity x1; auto. apply U3; inA. + + apply X; inA. + - intros x y; inA; intros Hx [Hy|Hy]. + + rewrite Hy. apply V3; inA. + + apply Y; inA. + Qed. + + Lemma INV_rev l1 l2 acc : + INV l1 l2 acc -> Sorted X.lt (rev_append l1 acc). + Proof. + intros. rewrite rev_append_rev. + apply SortA_app with X.eq; eauto with *. + intros x y. inA. eapply @l1_lt_acc; eauto. + Qed. + + (** ** union *) + + Lemma union_list_ok l1 l2 acc : + INV l1 l2 acc -> sort X.lt (union_list l1 l2 acc). + Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]; + [intro l2|induction l2 as [|x2 l2 IH2]]; + intros acc inv. + - eapply INV_rev, INV_sym; eauto. + - eapply INV_rev; eauto. + - simpl. case X.compare_spec; intro C. + * apply IH1. eapply INV_eq; eauto. + * apply (IH2 (x2::acc)). eapply INV_lt; eauto. + * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. + Qed. + + #[global] + Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) : + Ok (linear_union s1 s2). + Proof. + unfold linear_union. now apply treeify_ok, union_list_ok, INV_init. + Qed. + + #[global] + Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) : + Ok (fold add s1 s2). + Proof. + rewrite fold_spec, <- fold_left_rev_right. + unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. + Qed. + + #[global] + Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2). + Proof. + unfold union. destruct compare_height; auto_tc. + Qed. + + Lemma union_list_spec x l1 l2 acc : + InA X.eq x (union_list l1 l2 acc) <-> + InA X.eq x l1 \/ InA X.eq x l2 \/ InA X.eq x acc. + Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]. + - intros l2 acc; simpl. rewrite rev_append_rev. inA. tauto. + - induction l2 as [|x2 l2 IH2]; intros acc; simpl. + * rewrite rev_append_rev. inA. tauto. + * case X.compare_spec; intro C. + + rewrite IH1, !InA_cons, C; tauto. + + rewrite (IH2 (x2::acc)), !InA_cons. tauto. + + rewrite IH1, !InA_cons; tauto. + Qed. + + Lemma linear_union_spec s1 s2 x : + InT x (linear_union s1 s2) <-> InT x s1 \/ InT x s2. + Proof. + unfold linear_union. + rewrite treeify_spec, union_list_spec, !rev_elements_rev. + rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. + tauto. + Qed. + + Lemma fold_add_spec s1 s2 x : + InT x (fold add s1 s2) <-> InT x s1 \/ InT x s2. + Proof. + rewrite fold_spec, <- fold_left_rev_right. + rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. + unfold elt in *. + induction (rev (elements s1)); simpl. + - rewrite InA_nil. tauto. + - unfold flip. rewrite add_spec', IHl, InA_cons. tauto. + Qed. + + Lemma union_spec' s1 s2 x : + InT x (union s1 s2) <-> InT x s1 \/ InT x s2. + Proof. + unfold union. destruct compare_height. + - apply linear_union_spec. + - apply fold_add_spec. + - rewrite fold_add_spec. tauto. + Qed. + + Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). + Proof. + intros; apply union_spec'. + Qed. + + (** ** inter *) + + Lemma inter_list_ok l1 l2 acc : + INV l1 l2 acc -> sort X.lt (inter_list l1 l2 acc). + Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]; [|induction l2 as [|x2 l2 IH2]]; simpl. + - eauto. + - eauto. + - intros acc inv. + case X.compare_spec; intro C. + * apply IH1. eapply INV_eq; eauto. + * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. + * apply IH1. eapply INV_drop; eauto. + Qed. + + #[global] + Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) : + Ok (linear_inter s1 s2). + Proof. + unfold linear_inter. now apply treeify_ok, inter_list_ok, INV_init. + Qed. + + #[global] + Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). + Proof. + unfold inter. destruct compare_height; auto_tc. + Qed. + + Lemma inter_list_spec x l1 l2 acc : + sort X.lt (rev l1) -> + sort X.lt (rev l2) -> + (InA X.eq x (inter_list l1 l2 acc) <-> + (InA X.eq x l1 /\ InA X.eq x l2) \/ InA X.eq x acc). + Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]. + - intros l2 acc; simpl. inA. tauto. + - induction l2 as [|x2 l2 IH2]; intros acc. + * simpl. inA. tauto. + * simpl. intros U V. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + case X.compare_spec; intro C. + + rewrite IH1, !InA_cons, C; tauto. + + rewrite (IH2 acc); auto. inA. intuition; try order. + assert (X.lt x x1) by (apply U3; inA). order. + + rewrite IH1; auto. inA. intuition; try order. + assert (X.lt x x2) by (apply V3; inA). order. + Qed. + + Lemma linear_inter_spec s1 s2 x `(Ok s1, Ok s2) : + InT x (linear_inter s1 s2) <-> InT x s1 /\ InT x s2. + Proof. + unfold linear_inter. + rewrite !rev_elements_rev, treeify_spec, inter_list_spec + by (rewrite rev_involutive; auto_tc). + rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. + Qed. + + #[local] Instance mem_proper s `(Ok s) : + Proper (X.eq ==> Logic.eq) (fun k => mem k s). + Proof. + intros x y EQ. apply Bool.eq_iff_eq_true; rewrite !mem_spec; auto. + now rewrite EQ. + Qed. + + Lemma inter_spec s1 s2 y `{Ok s1, Ok s2} : + InT y (inter s1 s2) <-> InT y s1 /\ InT y s2. + Proof. + unfold inter. destruct compare_height. + - now apply linear_inter_spec. + - rewrite filter_spec, mem_spec by auto_tc; tauto. + - rewrite filter_spec, mem_spec by auto_tc; tauto. + Qed. + + (** ** difference *) + + Lemma diff_list_ok l1 l2 acc : + INV l1 l2 acc -> sort X.lt (diff_list l1 l2 acc). + Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]; + [intro l2|induction l2 as [|x2 l2 IH2]]; + intros acc inv. + - eauto. + - unfold diff_list. eapply INV_rev; eauto. + - simpl. case X.compare_spec; intro C. + * apply IH1. eapply INV_drop, INV_sym, INV_drop, INV_sym; eauto. + * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. + * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. + Qed. + + #[global] + Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) : + Ok (linear_diff s1 s2). + Proof. + unfold linear_inter. now apply treeify_ok, diff_list_ok, INV_init. + Qed. + + #[global] + Instance fold_remove_ok s1 s2 `(Ok s2) : + Ok (fold remove s1 s2). + Proof. + rewrite fold_spec, <- fold_left_rev_right. + unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. + Qed. + + #[global] + Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). + Proof. + unfold diff. destruct compare_height; auto_tc. + Qed. + + Lemma diff_list_spec x l1 l2 acc : + sort X.lt (rev l1) -> + sort X.lt (rev l2) -> + (InA X.eq x (diff_list l1 l2 acc) <-> + (InA X.eq x l1 /\ ~InA X.eq x l2) \/ InA X.eq x acc). + Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]. + - intros l2 acc; simpl. inA. tauto. + - induction l2 as [|x2 l2 IH2]; intros acc. + + intros; simpl. rewrite rev_append_rev. inA. tauto. + + simpl. intros U V. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + case X.compare_spec; intro C. + * rewrite IH1; auto. f_equiv. inA. intuition; try order. + assert (X.lt x x1) by (apply U3; inA). order. + * rewrite (IH2 acc); auto. f_equiv. inA. intuition; try order. + assert (X.lt x x1) by (apply U3; inA). order. + * rewrite IH1; auto. inA. intuition; try order. + left; split; auto. destruct 1. + -- order. + -- assert (X.lt x x2) by (apply V3; inA). order. + Qed. + + Lemma linear_diff_spec s1 s2 x `(Ok s1, Ok s2) : + InT x (linear_diff s1 s2) <-> InT x s1 /\ ~InT x s2. + Proof. + unfold linear_diff. + rewrite !rev_elements_rev, treeify_spec, diff_list_spec + by (rewrite rev_involutive; auto_tc). + rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. + Qed. + + Lemma fold_remove_spec s1 s2 x `(Ok s2) : + InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1. + Proof. + rewrite fold_spec, <- fold_left_rev_right. + rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. + unfold elt in *. + induction (rev (elements s1)); simpl; intros. + - rewrite InA_nil. intuition. + - unfold flip in *. rewrite remove_spec, IHl, InA_cons. + + tauto. + + clear IHl. induction l; simpl; auto_tc. + Qed. + + Lemma diff_spec s1 s2 y `{Ok s1, Ok s2} : + InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2. + Proof. + unfold diff. destruct compare_height. + - now apply linear_diff_spec. + - rewrite filter_spec, Bool.negb_true_iff, + <- Bool.not_true_iff_false, mem_spec; + intuition. + intros x1 x2 EQ. f_equal. now apply mem_proper. + - now apply fold_remove_spec. + Qed. End MakeRaw. @@ -1483,465 +1483,465 @@ End MakeRaw. Module BalanceProps(X:Orders.OrderedType)(Import M : MakeRaw X). -#[local] Notation Rd := (Node Red). -#[local] Notation Bk := (Node Black). -Import M.MX. + #[local] Notation Rd := (Node Red). + #[local] Notation Bk := (Node Black). + Import M.MX. -(** ** Red-Black invariants *) + (** ** Red-Black invariants *) -(** In a red-black tree : + (** In a red-black tree : - a red node has no red children - the black depth at each node is the same along all paths. The black depth is here an argument of the predicate. *) -Inductive rbt : nat -> tree -> Prop := - | RB_Leaf : rbt 0 Leaf - | RB_Rd n l k r : - notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r) - | RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r). + Inductive rbt : nat -> tree -> Prop := + | RB_Leaf : rbt 0 Leaf + | RB_Rd n l k r : + notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r) + | RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r). -(** A red-red tree is almost a red-black tree, except that it has + (** A red-red tree is almost a red-black tree, except that it has a _red_ root node which _may_ have red children. Note that a red-red tree is hence non-empty, and all its strict subtrees are red-black. *) -Inductive rrt (n:nat) : tree -> Prop := - | RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r). + Inductive rrt (n:nat) : tree -> Prop := + | RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r). -(** An almost-red-black tree is almost a red-black tree, except that + (** An almost-red-black tree is almost a red-black tree, except that it's permitted to have two red nodes in a row at the very root (only). We implement this notion by saying that a quasi-red-black tree is either a red-black tree or a red-red tree. *) -Inductive arbt (n:nat)(t:tree) : Prop := - | ARB_RB : rbt n t -> arbt n t - | ARB_RR : rrt n t -> arbt n t. + Inductive arbt (n:nat)(t:tree) : Prop := + | ARB_RB : rbt n t -> arbt n t + | ARB_RR : rrt n t -> arbt n t. -(** The main exported invariant : being a red-black tree for some + (** The main exported invariant : being a red-black tree for some black depth. *) -Class Rbt (t:tree) := RBT : exists d, rbt d t. - -(** ** Basic tactics and results about red-black *) - -Scheme rbt_ind := Induction for rbt Sort Prop. -#[local] Hint Constructors rbt rrt arbt : core. -#[local] Hint Extern 0 (notred _) => (exact I) : core. -Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction. -Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. -Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. - -Lemma rr_nrr_rb n t : - rrt n t -> notredred t -> rbt n t. -Proof. - destruct 1 as [l x r Hl Hr]. - destruct l, r; descolor; invrb; auto. -Qed. - -#[local] Hint Resolve rr_nrr_rb : core. - -Lemma arb_nrr_rb n t : - arbt n t -> notredred t -> rbt n t. -Proof. - destruct 1; auto. -Qed. - -Lemma arb_nr_rb n t : - arbt n t -> notred t -> rbt n t. -Proof. - destruct 1; destruct t; descolor; invrb; auto. -Qed. - -#[local] Hint Resolve arb_nrr_rb arb_nr_rb : core. - -(** ** A Red-Black tree has indeed a logarithmic depth *) - -Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s. - -Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s. -Proof. - induction 1. - - simpl; auto. - - replace (redcarac l) with 0 in * by now destree l. - replace (redcarac r) with 0 in * by now destree r. - simpl maxdepth. simpl redcarac. - rewrite Nat.add_succ_r, <- Nat.succ_le_mono. - now apply Nat.max_lub. - - simpl. rewrite <- Nat.succ_le_mono. - apply Nat.max_lub; eapply Nat.le_trans; eauto; - [destree l | destree r]; simpl; - rewrite !Nat.add_0_r, ?Nat.add_1_r, ?Nat.add_succ_r; auto. -Qed. - -Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s. -Proof. - induction 1; simpl. - - trivial. - - rewrite Nat.add_succ_r. - apply -> Nat.succ_le_mono. - replace (redcarac l) with 0 in * by now destree l. - replace (redcarac r) with 0 in * by now destree r. - now apply Nat.min_glb. - - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r. - apply Nat.min_glb. - + refine (Nat.le_trans _ _ _ _ IHrbt1). - apply Nat.le_add_r. - + refine (Nat.le_trans _ _ _ _ IHrbt2). - apply Nat.le_add_r. -Qed. - -Lemma maxdepth_upperbound s : Rbt s -> - maxdepth s <= 2 * Nat.log2 (S (cardinal s)). -Proof. - intros (n,H). - eapply Nat.le_trans; [eapply rb_maxdepth; eauto|]. - transitivity (2*(n+redcarac s)). - - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l. - rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r. - auto. - - apply Nat.mul_le_mono_l. - transitivity (mindepth s). - + now apply rb_mindepth. - + apply mindepth_log_cardinal. -Qed. - -Lemma maxdepth_lowerbound s : s<>Leaf -> - Nat.log2 (cardinal s) < maxdepth s. -Proof. - apply maxdepth_log_cardinal. -Qed. - - -(** ** Singleton *) - -Lemma singleton_rb x : Rbt (singleton x). -Proof. - unfold singleton. exists 1; auto. -Qed. - -(** ** [makeBlack] and [makeRed] *) - -Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t). -Proof. - destruct t as [|[|] l x r]. - - exists 0; auto. - - destruct 1; invrb; exists (S n); simpl; auto. - - exists n; auto. -Qed. - -Lemma makeRed_rr t n : - rbt (S n) t -> notred t -> rrt n (makeRed t). -Proof. - destruct t as [|[|] l x r]; invrb; simpl; auto. -Qed. - -(** ** Balancing *) - -Lemma lbal_rb n l k r : - arbt n l -> rbt n r -> rbt (S n) (lbal l k r). -Proof. -case lbal_match; intros; desarb; invrb; auto. -Qed. - -Lemma rbal_rb n l k r : - rbt n l -> arbt n r -> rbt (S n) (rbal l k r). -Proof. -case rbal_match; intros; desarb; invrb; auto. -Qed. - -Lemma rbal'_rb n l k r : - rbt n l -> arbt n r -> rbt (S n) (rbal' l k r). -Proof. -case rbal'_match; intros; desarb; invrb; auto. -Qed. - -Lemma lbalS_rb n l x r : - arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x r). -Proof. - intros Hl Hr Hr'. - destruct r as [|[|] rl rx rr]; invrb. clear Hr'. - revert Hl. - case lbalS_match. - - destruct 1; invrb; auto. - - intros. apply rbal'_rb; auto. -Qed. - -Lemma lbalS_arb n l x r : - arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x r). -Proof. - case lbalS_match. - - destruct 1; invrb; auto. - - clear l. intros l Hl Hl' Hr. - destruct r as [|[|] rl rx rr]; invrb. - * destruct rl as [|[|] rll rlx rlr]; invrb. - right; auto using rbal'_rb, makeRed_rr. - * left; apply rbal'_rb; auto. -Qed. - -Lemma rbalS_rb n l x r : - rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x r). -Proof. - intros Hl Hl' Hr. - destruct l as [|[|] ll lx lr]; invrb. clear Hl'. - revert Hr. - case rbalS_match. - - destruct 1; invrb; auto. - - intros. apply lbal_rb; auto. -Qed. - -Lemma rbalS_arb n l x r : - rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x r). -Proof. - case rbalS_match. - - destruct 2; invrb; auto. - - clear r. intros r Hr Hr' Hl. - destruct l as [|[|] ll lx lr]; invrb. - * destruct lr as [|[|] lrl lrx lrr]; invrb. - right; auto using lbal_rb, makeRed_rr. - * left; apply lbal_rb; auto. -Qed. - - -(** ** Insertion *) - -(** The next lemmas combine simultaneous results about rbt and arbt. + Class Rbt (t:tree) := RBT : exists d, rbt d t. + + (** ** Basic tactics and results about red-black *) + + Scheme rbt_ind := Induction for rbt Sort Prop. + #[local] Hint Constructors rbt rrt arbt : core. + #[local] Hint Extern 0 (notred _) => (exact I) : core. + Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction. + Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. + Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. + + Lemma rr_nrr_rb n t : + rrt n t -> notredred t -> rbt n t. + Proof. + destruct 1 as [l x r Hl Hr]. + destruct l, r; descolor; invrb; auto. + Qed. + + #[local] Hint Resolve rr_nrr_rb : core. + + Lemma arb_nrr_rb n t : + arbt n t -> notredred t -> rbt n t. + Proof. + destruct 1; auto. + Qed. + + Lemma arb_nr_rb n t : + arbt n t -> notred t -> rbt n t. + Proof. + destruct 1; destruct t; descolor; invrb; auto. + Qed. + + #[local] Hint Resolve arb_nrr_rb arb_nr_rb : core. + + (** ** A Red-Black tree has indeed a logarithmic depth *) + + Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s. + + Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s. + Proof. + induction 1. + - simpl; auto. + - replace (redcarac l) with 0 in * by now destree l. + replace (redcarac r) with 0 in * by now destree r. + simpl maxdepth. simpl redcarac. + rewrite Nat.add_succ_r, <- Nat.succ_le_mono. + now apply Nat.max_lub. + - simpl. rewrite <- Nat.succ_le_mono. + apply Nat.max_lub; eapply Nat.le_trans; eauto; + [destree l | destree r]; simpl; + rewrite !Nat.add_0_r, ?Nat.add_1_r, ?Nat.add_succ_r; auto. + Qed. + + Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s. + Proof. + induction 1; simpl. + - trivial. + - rewrite Nat.add_succ_r. + apply -> Nat.succ_le_mono. + replace (redcarac l) with 0 in * by now destree l. + replace (redcarac r) with 0 in * by now destree r. + now apply Nat.min_glb. + - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r. + apply Nat.min_glb. + + refine (Nat.le_trans _ _ _ _ IHrbt1). + apply Nat.le_add_r. + + refine (Nat.le_trans _ _ _ _ IHrbt2). + apply Nat.le_add_r. + Qed. + + Lemma maxdepth_upperbound s : Rbt s -> + maxdepth s <= 2 * Nat.log2 (S (cardinal s)). + Proof. + intros (n,H). + eapply Nat.le_trans; [eapply rb_maxdepth; eauto|]. + transitivity (2*(n+redcarac s)). + - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l. + rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r. + auto. + - apply Nat.mul_le_mono_l. + transitivity (mindepth s). + + now apply rb_mindepth. + + apply mindepth_log_cardinal. + Qed. + + Lemma maxdepth_lowerbound s : s<>Leaf -> + Nat.log2 (cardinal s) < maxdepth s. + Proof. + apply maxdepth_log_cardinal. + Qed. + + + (** ** Singleton *) + + Lemma singleton_rb x : Rbt (singleton x). + Proof. + unfold singleton. exists 1; auto. + Qed. + + (** ** [makeBlack] and [makeRed] *) + + Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t). + Proof. + destruct t as [|[|] l x r]. + - exists 0; auto. + - destruct 1; invrb; exists (S n); simpl; auto. + - exists n; auto. + Qed. + + Lemma makeRed_rr t n : + rbt (S n) t -> notred t -> rrt n (makeRed t). + Proof. + destruct t as [|[|] l x r]; invrb; simpl; auto. + Qed. + + (** ** Balancing *) + + Lemma lbal_rb n l k r : + arbt n l -> rbt n r -> rbt (S n) (lbal l k r). + Proof. + case lbal_match; intros; desarb; invrb; auto. + Qed. + + Lemma rbal_rb n l k r : + rbt n l -> arbt n r -> rbt (S n) (rbal l k r). + Proof. + case rbal_match; intros; desarb; invrb; auto. + Qed. + + Lemma rbal'_rb n l k r : + rbt n l -> arbt n r -> rbt (S n) (rbal' l k r). + Proof. + case rbal'_match; intros; desarb; invrb; auto. + Qed. + + Lemma lbalS_rb n l x r : + arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x r). + Proof. + intros Hl Hr Hr'. + destruct r as [|[|] rl rx rr]; invrb. clear Hr'. + revert Hl. + case lbalS_match. + - destruct 1; invrb; auto. + - intros. apply rbal'_rb; auto. + Qed. + + Lemma lbalS_arb n l x r : + arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x r). + Proof. + case lbalS_match. + - destruct 1; invrb; auto. + - clear l. intros l Hl Hl' Hr. + destruct r as [|[|] rl rx rr]; invrb. + * destruct rl as [|[|] rll rlx rlr]; invrb. + right; auto using rbal'_rb, makeRed_rr. + * left; apply rbal'_rb; auto. + Qed. + + Lemma rbalS_rb n l x r : + rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x r). + Proof. + intros Hl Hl' Hr. + destruct l as [|[|] ll lx lr]; invrb. clear Hl'. + revert Hr. + case rbalS_match. + - destruct 1; invrb; auto. + - intros. apply lbal_rb; auto. + Qed. + + Lemma rbalS_arb n l x r : + rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x r). + Proof. + case rbalS_match. + - destruct 2; invrb; auto. + - clear r. intros r Hr Hr' Hl. + destruct l as [|[|] ll lx lr]; invrb. + * destruct lr as [|[|] lrl lrx lrr]; invrb. + right; auto using lbal_rb, makeRed_rr. + * left; apply lbal_rb; auto. + Qed. + + + (** ** Insertion *) + + (** The next lemmas combine simultaneous results about rbt and arbt. A first solution here: statement with [if ... then ... else] *) -Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s. - -Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B). -Proof. - destruct s; descolor; simpl; intuition. -Qed. - -Lemma ifred_or s A B : ifred s A B -> A\/B. -Proof. - destruct s; descolor; simpl; intuition. -Qed. - -Lemma ins_rr_rb x s n : rbt n s -> - ifred s (rrt n (ins x s)) (rbt n (ins x s)). -Proof. -induction 1 as [ | n l k r | n l k r Hl IHl Hr IHr ]. -- simpl; auto. -- simpl. rewrite ifred_notred in * by trivial. - elim_compare x k; auto. -- rewrite ifred_notred by trivial. - unfold ins; fold ins. (* simpl is too much here ... *) - elim_compare x k. - * auto. - * apply lbal_rb; trivial. apply ifred_or in IHl; intuition. - * apply rbal_rb; trivial. apply ifred_or in IHr; intuition. -Qed. - -Lemma ins_arb x s n : rbt n s -> arbt n (ins x s). -Proof. - intros H. apply (ins_rr_rb x), ifred_or in H. intuition. -Qed. - -#[global] -Instance add_rb x s : Rbt s -> Rbt (add x s). -Proof. - intros (n,H). unfold add. now apply (makeBlack_rb n), ins_arb. -Qed. - -(** ** Deletion *) - -(** A second approach here: statement with ... /\ ... *) - -Lemma append_arb_rb n l r : rbt n l -> rbt n r -> - (arbt n (append l r)) /\ - (notred l -> notred r -> rbt n (append l r)). -Proof. -revert r n. -append_tac l r. -- split; auto. -- split; auto. -- (* Red / Red *) - intros n. invrb. - case (IHlr n); auto; clear IHlr. - case append_rr_match. - + intros a x b _ H; split; invrb. - assert (rbt n (Rd a x b)) by auto. invrb. auto. - + split; invrb; auto. -- (* Red / Black *) - split; invrb. destruct (IHlr n) as (_,IH); auto. -- (* Black / Red *) - split; invrb. destruct (IHrl n) as (_,IH); auto. -- (* Black / Black *) - nonzero n. - invrb. - destruct (IHlr n) as (IH,_); auto; clear IHlr. - revert IH. - case append_bb_match. - + intros a x b IH; split; destruct IH; invrb; auto. - + split; [left | invrb]; auto using lbalS_rb. -Qed. - -(** A third approach : Lemma ... with ... *) - -Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s) -with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s). -Proof. -{ revert n. - induct s x; try destruct c; try contradiction; invrb. - - apply append_arb_rb; assumption. - - assert (IHl' := del_rb l x). clear IHr del_arb del_rb. - destruct l as [|[|] ll lx lr]; auto. - nonzero n. apply lbalS_arb; auto. - - assert (IHr' := del_rb r x). clear IHl del_arb del_rb. - destruct r as [|[|] rl rx rr]; auto. - nonzero n. apply rbalS_arb; auto. } -{ revert n. - induct s x; try assumption; try destruct c; try contradiction; invrb. - - apply append_arb_rb; assumption. - - assert (IHl' := del_arb l x). clear IHr del_arb del_rb. - destruct l as [|[|] ll lx lr]; auto. - nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; auto. - - assert (IHr' := del_arb r x). clear IHl del_arb del_rb. - destruct r as [|[|] rl rx rr]; auto. - nonzero n. apply rbalS_rb; auto. } -Qed. - -#[global] -Instance remove_rb s x : Rbt s -> Rbt (remove x s). -Proof. - intros (n,H). unfold remove. - destruct s as [|[|] l y r]. - - apply (makeBlack_rb n). auto. - - apply (makeBlack_rb n). left. apply del_rb; simpl; auto. - - nonzero n. apply (makeBlack_rb n). apply del_arb; simpl; auto. -Qed. - -(** ** Treeify *) - -Definition treeify_rb_invariant size depth (f:treeify_t) := - forall acc, - size <= length acc -> - rbt depth (fst (f acc)) /\ - size + length (snd (f acc)) = length acc. - -Lemma treeify_zero_rb : treeify_rb_invariant 0 0 treeify_zero. -Proof. - intros acc _; simpl; auto. -Qed. - -Lemma treeify_one_rb : treeify_rb_invariant 1 0 treeify_one. -Proof. - intros [|x acc]; simpl; auto; inversion 1. -Qed. - -Lemma treeify_cont_rb f g size1 size2 size d : - treeify_rb_invariant size1 d f -> - treeify_rb_invariant size2 d g -> - size = S (size1 + size2) -> - treeify_rb_invariant size (S d) (treeify_cont f g). -Proof. - intros Hf Hg H acc Hacc. - unfold treeify_cont. - specialize (Hf acc). - destruct (f acc) as (l, acc1). simpl in *. - destruct Hf as (Hf1, Hf2). - { subst. refine (Nat.le_trans _ _ _ _ Hacc). - rewrite <- Nat.add_succ_r. apply Nat.le_add_r. } - destruct acc1 as [|x acc2]; simpl in *. - - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2. - rewrite Nat.add_0_r. apply (Nat.succ_le_mono size1), Nat.le_add_r. - - specialize (Hg acc2). - destruct (g acc2) as (r, acc3). simpl in *. - destruct Hg as (Hg1, Hg2). - { revert Hacc. - rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono. - apply Nat.add_le_mono_l. } - split; auto. - now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc. -Qed. - -Lemma treeify_aux_rb n : - exists d, forall (b:bool), - treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n). -Proof. - induction n as [n (d,IHn)|n (d,IHn)| ]. - - exists (S d). intros b. - eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ]. - rewrite Pos2Nat.inj_xI. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. - now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. - - exists (S d). intros b. - eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ]. - rewrite Pos2Nat.inj_xO. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. - destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. - symmetry. now apply Nat.add_pred_l. - - exists 0; destruct b; - [ apply treeify_zero_rb | apply treeify_one_rb ]. -Qed. - -(** The black depth of [treeify l] is actually a log2, but + Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s. + + Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B). + Proof. + destruct s; descolor; simpl; intuition. + Qed. + + Lemma ifred_or s A B : ifred s A B -> A\/B. + Proof. + destruct s; descolor; simpl; intuition. + Qed. + + Lemma ins_rr_rb x s n : rbt n s -> + ifred s (rrt n (ins x s)) (rbt n (ins x s)). + Proof. + induction 1 as [ | n l k r | n l k r Hl IHl Hr IHr ]. + - simpl; auto. + - simpl. rewrite ifred_notred in * by trivial. + elim_compare x k; auto. + - rewrite ifred_notred by trivial. + unfold ins; fold ins. (* simpl is too much here ... *) + elim_compare x k. + * auto. + * apply lbal_rb; trivial. apply ifred_or in IHl; intuition. + * apply rbal_rb; trivial. apply ifred_or in IHr; intuition. + Qed. + + Lemma ins_arb x s n : rbt n s -> arbt n (ins x s). + Proof. + intros H. apply (ins_rr_rb x), ifred_or in H. intuition. + Qed. + + #[global] + Instance add_rb x s : Rbt s -> Rbt (add x s). + Proof. + intros (n,H). unfold add. now apply (makeBlack_rb n), ins_arb. + Qed. + + (** ** Deletion *) + + (** A second approach here: statement with ... /\ ... *) + + Lemma append_arb_rb n l r : rbt n l -> rbt n r -> + (arbt n (append l r)) /\ + (notred l -> notred r -> rbt n (append l r)). + Proof. + revert r n. + append_tac l r. + - split; auto. + - split; auto. + - (* Red / Red *) + intros n. invrb. + case (IHlr n); auto; clear IHlr. + case append_rr_match. + + intros a x b _ H; split; invrb. + assert (rbt n (Rd a x b)) by auto. invrb. auto. + + split; invrb; auto. + - (* Red / Black *) + split; invrb. destruct (IHlr n) as (_,IH); auto. + - (* Black / Red *) + split; invrb. destruct (IHrl n) as (_,IH); auto. + - (* Black / Black *) + nonzero n. + invrb. + destruct (IHlr n) as (IH,_); auto; clear IHlr. + revert IH. + case append_bb_match. + + intros a x b IH; split; destruct IH; invrb; auto. + + split; [left | invrb]; auto using lbalS_rb. + Qed. + + (** A third approach : Lemma ... with ... *) + + Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s) + with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s). + Proof. + { revert n. + induct s x; try destruct c; try contradiction; invrb. + - apply append_arb_rb; assumption. + - assert (IHl' := del_rb l x). clear IHr del_arb del_rb. + destruct l as [|[|] ll lx lr]; auto. + nonzero n. apply lbalS_arb; auto. + - assert (IHr' := del_rb r x). clear IHl del_arb del_rb. + destruct r as [|[|] rl rx rr]; auto. + nonzero n. apply rbalS_arb; auto. } + { revert n. + induct s x; try assumption; try destruct c; try contradiction; invrb. + - apply append_arb_rb; assumption. + - assert (IHl' := del_arb l x). clear IHr del_arb del_rb. + destruct l as [|[|] ll lx lr]; auto. + nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; auto. + - assert (IHr' := del_arb r x). clear IHl del_arb del_rb. + destruct r as [|[|] rl rx rr]; auto. + nonzero n. apply rbalS_rb; auto. } + Qed. + + #[global] + Instance remove_rb s x : Rbt s -> Rbt (remove x s). + Proof. + intros (n,H). unfold remove. + destruct s as [|[|] l y r]. + - apply (makeBlack_rb n). auto. + - apply (makeBlack_rb n). left. apply del_rb; simpl; auto. + - nonzero n. apply (makeBlack_rb n). apply del_arb; simpl; auto. + Qed. + + (** ** Treeify *) + + Definition treeify_rb_invariant size depth (f:treeify_t) := + forall acc, + size <= length acc -> + rbt depth (fst (f acc)) /\ + size + length (snd (f acc)) = length acc. + + Lemma treeify_zero_rb : treeify_rb_invariant 0 0 treeify_zero. + Proof. + intros acc _; simpl; auto. + Qed. + + Lemma treeify_one_rb : treeify_rb_invariant 1 0 treeify_one. + Proof. + intros [|x acc]; simpl; auto; inversion 1. + Qed. + + Lemma treeify_cont_rb f g size1 size2 size d : + treeify_rb_invariant size1 d f -> + treeify_rb_invariant size2 d g -> + size = S (size1 + size2) -> + treeify_rb_invariant size (S d) (treeify_cont f g). + Proof. + intros Hf Hg H acc Hacc. + unfold treeify_cont. + specialize (Hf acc). + destruct (f acc) as (l, acc1). simpl in *. + destruct Hf as (Hf1, Hf2). + { subst. refine (Nat.le_trans _ _ _ _ Hacc). + rewrite <- Nat.add_succ_r. apply Nat.le_add_r. } + destruct acc1 as [|x acc2]; simpl in *. + - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2. + rewrite Nat.add_0_r. apply (Nat.succ_le_mono size1), Nat.le_add_r. + - specialize (Hg acc2). + destruct (g acc2) as (r, acc3). simpl in *. + destruct Hg as (Hg1, Hg2). + { revert Hacc. + rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono. + apply Nat.add_le_mono_l. } + split; auto. + now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc. + Qed. + + Lemma treeify_aux_rb n : + exists d, forall (b:bool), + treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n). + Proof. + induction n as [n (d,IHn)|n (d,IHn)| ]. + - exists (S d). intros b. + eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ]. + rewrite Pos2Nat.inj_xI. + assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. + destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. + now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. + - exists (S d). intros b. + eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ]. + rewrite Pos2Nat.inj_xO. + assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. + rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. + destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. + symmetry. now apply Nat.add_pred_l. + - exists 0; destruct b; + [ apply treeify_zero_rb | apply treeify_one_rb ]. + Qed. + + (** The black depth of [treeify l] is actually a log2, but we don't need to mention that. *) -#[global] -Instance treeify_rb l : Rbt (treeify l). -Proof. - unfold treeify. - destruct (treeify_aux_rb (plength l)) as (d,H). - exists d. - apply H. - now rewrite plength_spec. -Qed. - -(** ** Filtering *) - -#[global] -Instance filter_rb f s : Rbt (filter f s). -Proof. - unfold filter; auto_tc. -Qed. - -#[global] -Instance partition_rb1 f s : Rbt (fst (partition f s)). -Proof. - unfold partition. destruct partition_aux. simpl. auto_tc. -Qed. - -#[global] -Instance partition_rb2 f s : Rbt (snd (partition f s)). -Proof. - unfold partition. destruct partition_aux. simpl. auto_tc. -Qed. - -(** ** Union, intersection, difference *) - -#[global] -Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2). -Proof. - intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -#[global] -Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2). -Proof. - intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2). -Proof. - intros. unfold union, linear_union. destruct compare_height; auto_tc. -Qed. - -Lemma inter_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (inter s1 s2). -Proof. - intros. unfold inter, linear_inter. destruct compare_height; auto_tc. -Qed. - -Lemma diff_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (diff s1 s2). -Proof. - intros. unfold diff, linear_diff. destruct compare_height; auto_tc. -Qed. + #[global] + Instance treeify_rb l : Rbt (treeify l). + Proof. + unfold treeify. + destruct (treeify_aux_rb (plength l)) as (d,H). + exists d. + apply H. + now rewrite plength_spec. + Qed. + + (** ** Filtering *) + + #[global] + Instance filter_rb f s : Rbt (filter f s). + Proof. + unfold filter; auto_tc. + Qed. + + #[global] + Instance partition_rb1 f s : Rbt (fst (partition f s)). + Proof. + unfold partition. destruct partition_aux. simpl. auto_tc. + Qed. + + #[global] + Instance partition_rb2 f s : Rbt (snd (partition f s)). + Proof. + unfold partition. destruct partition_aux. simpl. auto_tc. + Qed. + + (** ** Union, intersection, difference *) + + #[global] + Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2). + Proof. + intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. + Qed. + + #[global] + Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2). + Proof. + intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. + Qed. + + Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2). + Proof. + intros. unfold union, linear_union. destruct compare_height; auto_tc. + Qed. + + Lemma inter_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (inter s1 s2). + Proof. + intros. unfold inter, linear_inter. destruct compare_height; auto_tc. + Qed. + + Lemma diff_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (diff s1 s2). + Proof. + intros. unfold diff, linear_diff. destruct compare_height; auto_tc. + Qed. End BalanceProps. @@ -1957,43 +1957,43 @@ End BalanceProps. Module Type MSetInterface_S_Ext := MSetInterface.S <+ MSetRemoveMin. Module Make (X: Orders.OrderedType) <: - MSetInterface_S_Ext with Module E := X. - Module Raw. Include MakeRaw X. End Raw. - Include MSetInterface.Raw2Sets X Raw. - - Definition opt_ok (x:option (elt * Raw.t)) := - match x with Some (_,s) => Raw.Ok s | None => True end. - - Definition mk_opt_t (x: option (elt * Raw.t))(P: opt_ok x) : - option (elt * t) := - match x as o return opt_ok o -> option (elt * t) with - | Some (k,s') => fun P : Raw.Ok s' => Some (k, Mkt s') - | None => fun _ => None - end P. - - Definition remove_min s : option (elt * t) := - mk_opt_t (Raw.remove_min (this s)) (Raw.remove_min_ok s). - - Lemma remove_min_spec1 s x s' : - remove_min s = Some (x,s') -> - min_elt s = Some x /\ Equal (remove x s) s'. - Proof. - destruct s as (s,Hs). - unfold remove_min, mk_opt_t, min_elt, remove, Equal, In; simpl. - generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs). - set (P := Raw.remove_min_ok s). clearbody P. - destruct (Raw.remove_min s) as [(x0,s0)|]; try easy. - intros H [= -> <-]. simpl. - destruct (H x s0); auto. subst; intuition. - Qed. - - Lemma remove_min_spec2 s : remove_min s = None -> Empty s. - Proof. - destruct s as (s,Hs). - unfold remove_min, mk_opt_t, Empty, In; simpl. - generalize (Raw.remove_min_spec2 s). - set (P := Raw.remove_min_ok s). clearbody P. - destruct (Raw.remove_min s) as [(x0,s0)|]; now intuition. - Qed. + MSetInterface_S_Ext with Module E := X. + Module Raw. Include MakeRaw X. End Raw. + Include MSetInterface.Raw2Sets X Raw. + + Definition opt_ok (x:option (elt * Raw.t)) := + match x with Some (_,s) => Raw.Ok s | None => True end. + + Definition mk_opt_t (x: option (elt * Raw.t))(P: opt_ok x) : + option (elt * t) := + match x as o return opt_ok o -> option (elt * t) with + | Some (k,s') => fun P : Raw.Ok s' => Some (k, Mkt s') + | None => fun _ => None + end P. + + Definition remove_min s : option (elt * t) := + mk_opt_t (Raw.remove_min (this s)) (Raw.remove_min_ok s). + + Lemma remove_min_spec1 s x s' : + remove_min s = Some (x,s') -> + min_elt s = Some x /\ Equal (remove x s) s'. + Proof. + destruct s as (s,Hs). + unfold remove_min, mk_opt_t, min_elt, remove, Equal, In; simpl. + generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs). + set (P := Raw.remove_min_ok s). clearbody P. + destruct (Raw.remove_min s) as [(x0,s0)|]; try easy. + intros H [= -> <-]. simpl. + destruct (H x s0); auto. subst; intuition. + Qed. + + Lemma remove_min_spec2 s : remove_min s = None -> Empty s. + Proof. + destruct s as (s,Hs). + unfold remove_min, mk_opt_t, Empty, In; simpl. + generalize (Raw.remove_min_spec2 s). + set (P := Raw.remove_min_ok s). clearbody P. + destruct (Raw.remove_min s) as [(x0,s0)|]; now intuition. + Qed. End Make. diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v index 1bd89bfc97..6b25316732 100644 --- a/theories/MSets/MSetToFiniteSet.v +++ b/theories/MSets/MSetToFiniteSet.v @@ -17,137 +17,137 @@ From Stdlib Require Import MSetInterface MSetProperties OrdersEx. to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSetsOn U). - Module MP:= WPropertiesOn U M. - Import M MP FM Ensembles Finite_sets. - - Definition mkEns : M.t -> Ensemble M.elt := - fun s x => M.In x s. - - Notation " !! " := mkEns. - - Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. - Proof. - unfold In; compute; auto with extcore. - Qed. - - Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). - Proof. - unfold Subset, Included, In, mkEns; intuition. - Qed. - - Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). - - Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. - Proof. - intros. - rewrite double_inclusion. - unfold Subset, Included, Same_set, In, mkEns; intuition. - Qed. - - Lemma empty_Empty_Set : !!M.empty === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1. - Qed. - - Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - destruct(H x H0). - - inversion H0. - Qed. - - Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. - Qed. - - Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - - inversion H0. - constructor 2; constructor. - - constructor 1; auto. - Qed. - - Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - red in H; rewrite H in H0. - destruct H0. - + inversion H0. - constructor 2; constructor. - + constructor 1; auto. - - red in H; rewrite H. - inversion H0; auto. - inversion H1; auto. - Qed. - - Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - split; auto. - contradict H1. - inversion H1; auto. - Qed. - - Lemma mkEns_Finite : forall s, Finite _ (!!s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + constructor 2; auto. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - + rewrite MP.cardinal_1; auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + rewrite (cardinal_2 H0 H1); auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - (** we can even build a function from Finite Ensemble to MSet + Module MP:= WPropertiesOn U M. + Import M MP FM Ensembles Finite_sets. + + Definition mkEns : M.t -> Ensemble M.elt := + fun s x => M.In x s. + + Notation " !! " := mkEns. + + Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. + Proof. + unfold In; compute; auto with extcore. + Qed. + + Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). + Proof. + unfold Subset, Included, In, mkEns; intuition. + Qed. + + Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). + + Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. + Proof. + intros. + rewrite double_inclusion. + unfold Subset, Included, Same_set, In, mkEns; intuition. + Qed. + + Lemma empty_Empty_Set : !!M.empty === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1. + Qed. + + Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + - destruct(H x H0). + - inversion H0. + Qed. + + Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. + Qed. + + Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + - inversion H0. + constructor 2; constructor. + - constructor 1; auto. + Qed. + + Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + - red in H; rewrite H in H0. + destruct H0. + + inversion H0. + constructor 2; constructor. + + constructor 1; auto. + - red in H; rewrite H. + inversion H0; auto. + inversion H1; auto. + Qed. + + Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + split; auto. + contradict H1. + inversion H1; auto. + Qed. + + Lemma mkEns_Finite : forall s, Finite _ (!!s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + - intros; replace (!!s) with (Empty_set elt); auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + - replace (!!s') with (Add _ (!!s) x). + + constructor 2; auto. + + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + - intros; replace (!!s) with (Empty_set elt); auto with sets. + + rewrite MP.cardinal_1; auto with sets. + + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + - replace (!!s') with (Add _ (!!s) x). + + rewrite (cardinal_2 H0 H1); auto with sets. + + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + (** we can even build a function from Finite Ensemble to MSet ... at least in Prop. *) - Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e -> - exists s:M.t, !!s === e. - Proof. - induction 1. - - exists M.empty. - apply empty_Empty_Set. - - destruct IHFinite as (s,Hs). - exists (M.add x s). - apply Extensionality_Ensembles in Hs. - rewrite <- Hs. - apply add_Add. - Qed. + Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e -> + exists s:M.t, !!s === e. + Proof. + induction 1. + - exists M.empty. + apply empty_Empty_Set. + - destruct IHFinite as (s,Hs). + exists (M.add x s). + apply Extensionality_Ensembles in Hs. + rewrite <- Hs. + apply add_Add. + Qed. End WS_to_Finite_set. diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index a0ecffd778..e409d39edb 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -115,424 +115,424 @@ End Ops. (** ** Proofs of set operation specifications. *) Module MakeRaw (X:DecidableType) <: WRawSets X. - Include Ops X. - - Section ForNotations. - Notation NoDup := (NoDupA X.eq). - Notation In := (InA X.eq). - - (* TODO: modify proofs in order to avoid these hints *) - Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). - Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). - Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). - #[local] - Hint Resolve eqr eqtrans : core. - #[local] - Hint Immediate eqsym : core. - - Definition IsOk := NoDup. - - Class Ok (s:t) : Prop := ok : NoDup s. - - #[local] - Hint Unfold Ok : core. - #[local] - Hint Resolve ok : core. - - Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. - - Ltac inv_ok := match goal with - | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok - | H:Ok nil |- _ => clear H; inv_ok - | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok - | _ => idtac - end. - - Ltac inv := invlist InA; inv_ok. - Ltac constructors := repeat constructor. - - Fixpoint isok l := match l with - | nil => true - | a::l => negb (mem a l) && isok l - end. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Lemma In_compat : Proper (X.eq==>eq==>iff) In. - Proof. - repeat red; intros. subst. rewrite H; auto. - Qed. - - Lemma mem_spec : forall s x `{Ok s}, - mem x s = true <-> In x s. - Proof. - induction s; intros. - - split; intros; inv. discriminate. - - simpl; destruct (X.eq_dec x a); split; intros; inv; auto. - + right; rewrite <- IHs; auto. - + rewrite IHs; auto. - Qed. - - Lemma isok_iff : forall l, Ok l <-> isok l = true. - Proof. - induction l. - - intuition. - - simpl. - rewrite andb_true_iff. - rewrite negb_true_iff. - rewrite <- IHl. - split; intros H. - + inv. - split; auto. - apply not_true_is_false. rewrite mem_spec; auto. - + destruct H; constructors; auto. - rewrite <- mem_spec; auto; congruence. - Qed. - - #[global] Instance isok_Ok l : isok l = true -> Ok l | 10. - Proof. - intros. apply <- isok_iff; auto. - Qed. - - Lemma add_spec : - forall (s : t) (x y : elt) {Hs : Ok s}, - In y (add x s) <-> X.eq y x \/ In y s. - Proof. - induction s; simpl; intros. - - intuition; inv; auto. - - destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition. - + left; eauto. - + inv; auto. - Qed. - - #[global] Instance add_ok s x `(Ok s) : Ok (add x s). - Proof. - induction s. - - simpl; intuition. - - intros; inv. simpl. - destruct X.eq_dec; auto. - constructors; auto. - intro; inv; auto. - rewrite add_spec in *; intuition. - Qed. - - Lemma remove_spec : - forall (s : t) (x y : elt) {Hs : Ok s}, - In y (remove x s) <-> In y s /\ ~X.eq y x. - Proof. - induction s; simpl; intros. - - intuition; inv; auto. - - destruct X.eq_dec as [|Hnot]; inv; rewrite !InA_cons, ?IHs; intuition. - + elim H. setoid_replace a with y; eauto. - + elim H3. setoid_replace x with y; eauto. - + elim Hnot. eauto. - Qed. - - #[global] Instance remove_ok s x `(Ok s) : Ok (remove x s). - Proof. - induction s; simpl; intros. - - auto. - - destruct X.eq_dec; inv; auto. - constructors; auto. - rewrite remove_spec; intuition. - Qed. - - Lemma singleton_ok : forall x : elt, Ok (singleton x). - Proof. - unfold singleton; simpl; constructors; auto. intro; inv. - Qed. - - Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. - Proof. - unfold singleton; simpl; split; intros. - - inv; auto. - - left; auto. - Qed. - - Lemma empty_ok : Ok empty. - Proof. - unfold empty; constructors. - Qed. - - Lemma empty_spec : Empty empty. - Proof. - unfold Empty, empty; red; intros; inv. - Qed. - - Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. - Proof. - unfold Empty; destruct s; simpl; split; intros; auto. - - intro; inv. - - discriminate. - - elim (H e); auto. - Qed. - - Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. - Proof. - unfold elements; intuition. - Qed. - - Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma fold_spec : - forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Proof. - reflexivity. - Qed. - - #[global] Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s'). - Proof. - induction s; simpl; auto; intros; inv; unfold flip; auto with *. - Qed. - - Lemma union_spec : - forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, - In x (union s s') <-> In x s \/ In x s'. - Proof. - induction s; simpl in *; unfold flip; intros; auto; inv. - - intuition; inv. - - rewrite IHs, add_spec, InA_cons; intuition. - Qed. - - #[global] Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). - Proof. - unfold inter, fold, flip. - set (acc := nil (A:=elt)). - assert (Hacc : Ok acc) by constructors. - clearbody acc; revert acc Hacc. - induction s; simpl; auto; intros. inv. - apply IHs; auto. - destruct (mem a s'); auto with *. - Qed. - - Lemma inter_spec : - forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, - In x (inter s s') <-> In x s /\ In x s'. - Proof. - unfold inter, fold, flip; intros. - set (acc := nil (A:=elt)) in *. - assert (Hacc : Ok acc) by constructors. - assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc). { - intuition; unfold acc in *; inv. - } - rewrite IFF; clear IFF. clearbody acc. - revert acc Hacc x s' Hs Hs'. - induction s; simpl; intros. - - intuition; inv. - - inv. - case_eq (mem a s'); intros Hm. - + rewrite IHs, add_spec, InA_cons; intuition. - rewrite mem_spec in Hm; auto. - left; split; auto. rewrite H1; auto. - + rewrite IHs, InA_cons; intuition. - rewrite H2, <- mem_spec in H3; auto. congruence. - Qed. - - #[global] Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s'). - Proof. - unfold diff; intros s s'; revert s. - induction s'; simpl; unfold flip; auto; intros. inv; auto with *. - Qed. - - Lemma diff_spec : - forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, - In x (diff s s') <-> In x s /\ ~In x s'. - Proof. - unfold diff; intros s s'; revert s. - induction s'; simpl; unfold flip. - - intuition; inv. - - intros. inv. - rewrite IHs', remove_spec, InA_cons; intuition. - Qed. - - Lemma subset_spec : - forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, - subset s s' = true <-> Subset s s'. - Proof. - unfold subset, Subset; intros. - rewrite is_empty_spec. - unfold Empty; intros. - intuition. - - specialize (H a). rewrite diff_spec in H; intuition. - rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition auto with bool. - - rewrite diff_spec in H0; intuition. - Qed. - - Lemma equal_spec : - forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, - equal s s' = true <-> Equal s s'. - Proof. - unfold Equal, equal; intros. - rewrite andb_true_iff, !subset_spec. - unfold Subset; intuition. - - rewrite <- H; auto. - - rewrite H; auto. - Qed. - - Lemma choose_spec1 : - forall (s : t) (x : elt), choose s = Some x -> In x s. - Proof. - destruct s; simpl; intros; inversion H; auto. - Qed. - - Lemma choose_spec2 : forall s : t, choose s = None -> Empty s. - Proof. - destruct s; simpl; intros. - - intros x H0; inversion H0. - - inversion H. - Qed. - - Lemma cardinal_spec : - forall (s : t) {Hs : Ok s}, cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_spec' : forall s x f, - In x (filter f s) -> In x s. - Proof. - induction s; simpl. - - intuition; inv. - - intros; destruct (f a); inv; intuition; right; eauto. - Qed. - - Lemma filter_spec : - forall (s : t) (x : elt) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. - induction s; simpl. - - intuition; inv. - - intros. - destruct (f a) eqn:E; rewrite ?InA_cons, IHs; intuition. - + setoid_replace x with a; auto. - + setoid_replace a with x in E; auto. congruence. - Qed. - - #[global] Instance filter_ok s f `(Ok s) : Ok (filter f s). - Proof. - induction s; simpl. - - auto. - - intros; inv. - case (f a); auto. - constructors; auto. - contradict H0. - eapply filter_spec'; eauto. - Qed. - - Lemma for_all_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. - unfold For_all; induction s; simpl. - - intuition. inv. - - intros; inv. - destruct (f a) eqn:F. - + rewrite IHs; intuition. inv; auto. - setoid_replace x with a; auto. - + split; intros H'; try discriminate. - intros. - rewrite <- F, <- (H' a); auto. - Qed. - - Lemma exists_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. - unfold Exists; induction s; simpl. - - split; [discriminate| intros (x & Hx & _); inv]. - - intros. - destruct (f a) eqn:F. - + split; auto. - exists a; auto. - + rewrite IHs; firstorder. - inv. - * setoid_replace a with x in F; auto; congruence. - * exists x; auto. - Qed. - - Lemma partition_spec1 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - firstorder. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_spec2 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - firstorder. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_ok1' : - forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), - In x (fst (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. inv. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Lemma partition_ok2' : - forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), - In x (snd (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. inv. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - #[global] Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)). - Proof. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (@partition_ok1' _ _ f x). - generalize (Hrec f H0). - case (f x); case (partition f l); simpl; constructors; auto. - Qed. - - #[global] Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)). - Proof. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (@partition_ok2' _ _ f x). - generalize (Hrec f H0). - case (f x); case (partition f l); simpl; constructors; auto. - Qed. - - End ForNotations. - - Definition In := InA X.eq. - Definition eq := Equal. -#[global] - Instance eq_equiv : Equivalence eq := _. + Include Ops X. + + Section ForNotations. + Notation NoDup := (NoDupA X.eq). + Notation In := (InA X.eq). + + (* TODO: modify proofs in order to avoid these hints *) + Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). + Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). + Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). + #[local] + Hint Resolve eqr eqtrans : core. + #[local] + Hint Immediate eqsym : core. + + Definition IsOk := NoDup. + + Class Ok (s:t) : Prop := ok : NoDup s. + + #[local] + Hint Unfold Ok : core. + #[local] + Hint Resolve ok : core. + + Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. + + Ltac inv_ok := match goal with + | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok + | H:Ok nil |- _ => clear H; inv_ok + | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok + | _ => idtac + end. + + Ltac inv := invlist InA; inv_ok. + Ltac constructors := repeat constructor. + + Fixpoint isok l := match l with + | nil => true + | a::l => negb (mem a l) && isok l + end. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Lemma In_compat : Proper (X.eq==>eq==>iff) In. + Proof. + repeat red; intros. subst. rewrite H; auto. + Qed. + + Lemma mem_spec : forall s x `{Ok s}, + mem x s = true <-> In x s. + Proof. + induction s; intros. + - split; intros; inv. discriminate. + - simpl; destruct (X.eq_dec x a); split; intros; inv; auto. + + right; rewrite <- IHs; auto. + + rewrite IHs; auto. + Qed. + + Lemma isok_iff : forall l, Ok l <-> isok l = true. + Proof. + induction l. + - intuition. + - simpl. + rewrite andb_true_iff. + rewrite negb_true_iff. + rewrite <- IHl. + split; intros H. + + inv. + split; auto. + apply not_true_is_false. rewrite mem_spec; auto. + + destruct H; constructors; auto. + rewrite <- mem_spec; auto; congruence. + Qed. + + #[global] Instance isok_Ok l : isok l = true -> Ok l | 10. + Proof. + intros. apply <- isok_iff; auto. + Qed. + + Lemma add_spec : + forall (s : t) (x y : elt) {Hs : Ok s}, + In y (add x s) <-> X.eq y x \/ In y s. + Proof. + induction s; simpl; intros. + - intuition; inv; auto. + - destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition. + + left; eauto. + + inv; auto. + Qed. + + #[global] Instance add_ok s x `(Ok s) : Ok (add x s). + Proof. + induction s. + - simpl; intuition. + - intros; inv. simpl. + destruct X.eq_dec; auto. + constructors; auto. + intro; inv; auto. + rewrite add_spec in *; intuition. + Qed. + + Lemma remove_spec : + forall (s : t) (x y : elt) {Hs : Ok s}, + In y (remove x s) <-> In y s /\ ~X.eq y x. + Proof. + induction s; simpl; intros. + - intuition; inv; auto. + - destruct X.eq_dec as [|Hnot]; inv; rewrite !InA_cons, ?IHs; intuition. + + elim H. setoid_replace a with y; eauto. + + elim H3. setoid_replace x with y; eauto. + + elim Hnot. eauto. + Qed. + + #[global] Instance remove_ok s x `(Ok s) : Ok (remove x s). + Proof. + induction s; simpl; intros. + - auto. + - destruct X.eq_dec; inv; auto. + constructors; auto. + rewrite remove_spec; intuition. + Qed. + + Lemma singleton_ok : forall x : elt, Ok (singleton x). + Proof. + unfold singleton; simpl; constructors; auto. intro; inv. + Qed. + + Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; simpl; split; intros. + - inv; auto. + - left; auto. + Qed. + + Lemma empty_ok : Ok empty. + Proof. + unfold empty; constructors. + Qed. + + Lemma empty_spec : Empty empty. + Proof. + unfold Empty, empty; red; intros; inv. + Qed. + + Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. + Proof. + unfold Empty; destruct s; simpl; split; intros; auto. + - intro; inv. + - discriminate. + - elim (H e); auto. + Qed. + + Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. + Proof. + unfold elements; intuition. + Qed. + + Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s). + Proof. + unfold elements; auto. + Qed. + + Lemma fold_spec : + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Proof. + reflexivity. + Qed. + + #[global] Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s'). + Proof. + induction s; simpl; auto; intros; inv; unfold flip; auto with *. + Qed. + + Lemma union_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (union s s') <-> In x s \/ In x s'. + Proof. + induction s; simpl in *; unfold flip; intros; auto; inv. + - intuition; inv. + - rewrite IHs, add_spec, InA_cons; intuition. + Qed. + + #[global] Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + Proof. + unfold inter, fold, flip. + set (acc := nil (A:=elt)). + assert (Hacc : Ok acc) by constructors. + clearbody acc; revert acc Hacc. + induction s; simpl; auto; intros. inv. + apply IHs; auto. + destruct (mem a s'); auto with *. + Qed. + + Lemma inter_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold inter, fold, flip; intros. + set (acc := nil (A:=elt)) in *. + assert (Hacc : Ok acc) by constructors. + assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc). { + intuition; unfold acc in *; inv. + } + rewrite IFF; clear IFF. clearbody acc. + revert acc Hacc x s' Hs Hs'. + induction s; simpl; intros. + - intuition; inv. + - inv. + case_eq (mem a s'); intros Hm. + + rewrite IHs, add_spec, InA_cons; intuition. + rewrite mem_spec in Hm; auto. + left; split; auto. rewrite H1; auto. + + rewrite IHs, InA_cons; intuition. + rewrite H2, <- mem_spec in H3; auto. congruence. + Qed. + + #[global] Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s'). + Proof. + unfold diff; intros s s'; revert s. + induction s'; simpl; unfold flip; auto; intros. inv; auto with *. + Qed. + + Lemma diff_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (diff s s') <-> In x s /\ ~In x s'. + Proof. + unfold diff; intros s s'; revert s. + induction s'; simpl; unfold flip. + - intuition; inv. + - intros. inv. + rewrite IHs', remove_spec, InA_cons; intuition. + Qed. + + Lemma subset_spec : + forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, + subset s s' = true <-> Subset s s'. + Proof. + unfold subset, Subset; intros. + rewrite is_empty_spec. + unfold Empty; intros. + intuition. + - specialize (H a). rewrite diff_spec in H; intuition. + rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition auto with bool. + - rewrite diff_spec in H0; intuition. + Qed. + + Lemma equal_spec : + forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, + equal s s' = true <-> Equal s s'. + Proof. + unfold Equal, equal; intros. + rewrite andb_true_iff, !subset_spec. + unfold Subset; intuition. + - rewrite <- H; auto. + - rewrite H; auto. + Qed. + + Lemma choose_spec1 : + forall (s : t) (x : elt), choose s = Some x -> In x s. + Proof. + destruct s; simpl; intros; inversion H; auto. + Qed. + + Lemma choose_spec2 : forall s : t, choose s = None -> Empty s. + Proof. + destruct s; simpl; intros. + - intros x H0; inversion H0. + - inversion H. + Qed. + + Lemma cardinal_spec : + forall (s : t) {Hs : Ok s}, cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_spec' : forall s x f, + In x (filter f s) -> In x s. + Proof. + induction s; simpl. + - intuition; inv. + - intros; destruct (f a); inv; intuition; right; eauto. + Qed. + + Lemma filter_spec : + forall (s : t) (x : elt) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. + induction s; simpl. + - intuition; inv. + - intros. + destruct (f a) eqn:E; rewrite ?InA_cons, IHs; intuition. + + setoid_replace x with a; auto. + + setoid_replace a with x in E; auto. congruence. + Qed. + + #[global] Instance filter_ok s f `(Ok s) : Ok (filter f s). + Proof. + induction s; simpl. + - auto. + - intros; inv. + case (f a); auto. + constructors; auto. + contradict H0. + eapply filter_spec'; eauto. + Qed. + + Lemma for_all_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + unfold For_all; induction s; simpl. + - intuition. inv. + - intros; inv. + destruct (f a) eqn:F. + + rewrite IHs; intuition. inv; auto. + setoid_replace x with a; auto. + + split; intros H'; try discriminate. + intros. + rewrite <- F, <- (H' a); auto. + Qed. + + Lemma exists_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + unfold Exists; induction s; simpl. + - split; [discriminate| intros (x & Hx & _); inv]. + - intros. + destruct (f a) eqn:F. + + split; auto. + exists a; auto. + + rewrite IHs; firstorder. + inv. + * setoid_replace a with x in F; auto; congruence. + * exists x; auto. + Qed. + + Lemma partition_spec1 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + Equal (fst (partition f s)) (filter f s). + Proof. + simple induction s; simpl; auto; unfold Equal. + - firstorder. + - intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + case (partition f l); intros s1 s2; simpl; intros. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. + Qed. + + Lemma partition_spec2 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + simple induction s; simpl; auto; unfold Equal. + - firstorder. + - intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + case (partition f l); intros s1 s2; simpl; intros. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. + Qed. + + Lemma partition_ok1' : + forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), + In x (fst (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. inv. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Lemma partition_ok2' : + forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), + In x (snd (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. inv. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + #[global] Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)). + Proof. + simple induction s; simpl. + - auto. + - intros x l Hrec f Hs; inv. + generalize (@partition_ok1' _ _ f x). + generalize (Hrec f H0). + case (f x); case (partition f l); simpl; constructors; auto. + Qed. + + #[global] Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)). + Proof. + simple induction s; simpl. + - auto. + - intros x l Hrec f Hs; inv. + generalize (@partition_ok2' _ _ f x). + generalize (Hrec f H0). + case (f x); case (partition f l); simpl; constructors; auto. + Qed. + + End ForNotations. + + Definition In := InA X.eq. + Definition eq := Equal. + #[global] + Instance eq_equiv : Equivalence eq := _. End MakeRaw. @@ -542,6 +542,6 @@ End MakeRaw. need to encapsulate everything into a type of lists without redundancy. *) Module Make (X: DecidableType) <: WSets with Module E := X. - Module Raw := MakeRaw X. - Include WRaw2Sets X Raw. + Module Raw := MakeRaw X. + Include WRaw2Sets X Raw. End Make. diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index c4a3ce478c..223f915ba7 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -29,1047 +29,1047 @@ From Stdlib Require BinNatDef. are placed in a module [N] for qualification purpose. *) Module N - <: NAxiomsSig - <: UsualOrderedTypeFull - <: UsualDecidableTypeFull - <: TotalOrder. - -(** Definitions of operations, now in a separate file *) - -Include BinNatDef.N. - -(** When including property functors, only inline t eq zero one two *) - -Set Inline Level 30. - -(** Logical predicates *) - -Definition eq := @Logic.eq N. -Definition eq_equiv := @eq_equivalence N. - -Definition lt x y := (x ?= y) = Lt. -Definition gt x y := (x ?= y) = Gt. -Definition le x y := (x ?= y) <> Gt. -Definition ge x y := (x ?= y) <> Lt. - -Infix "<=" := le : N_scope. -Infix "<" := lt : N_scope. -Infix ">=" := ge : N_scope. -Infix ">" := gt : N_scope. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : N_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : N_scope. -Notation "x < y < z" := (x < y /\ y < z) : N_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : N_scope. - -Definition divide p q := exists r, q = r*p. -Notation "( p | q )" := (divide p q) (at level 0) : N_scope. - -Definition Even n := exists m, n = 2*m. -Definition Odd n := exists m, n = 2*m+1. - -(** Proofs of morphisms, obvious since eq is Leibniz *) - -#[local] Obligation Tactic := simpl_relation. -Program Definition succ_wd : Proper (eq==>eq) succ := _. -Program Definition pred_wd : Proper (eq==>eq) pred := _. -Program Definition add_wd : Proper (eq==>eq==>eq) add := _. -Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _. -Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _. -Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _. -Program Definition div_wd : Proper (eq==>eq==>eq) div := _. -Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _. -Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _. -Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _. - -(** Decidability of equality. *) - -Definition eq_dec : forall n m : N, { n = m } + { n <> m }. -Proof. - decide equality. - apply Pos.eq_dec. -Defined. - -(** Discrimination principle *) - -Definition discr n : { p:positive | n = pos p } + { n = 0 }. -Proof. - destruct n as [|p]; auto. - left; exists p; auto. -Defined. - -(** Convenient induction principles *) - -Definition binary_rect (P:N -> Type) (f0 : P 0) - (f2 : forall n, P n -> P (double n)) - (fS2 : forall n, P n -> P (succ_double n)) (n : N) : P n := - let P' p := P (pos p) in - let f2' p := f2 (pos p) in - let fS2' p := fS2 (pos p) in - match n with - | 0 => f0 - | pos p => positive_rect P' fS2' f2' (fS2 0 f0) p - end. - -Definition binary_rec (P:N -> Set) := binary_rect P. -Definition binary_ind (P:N -> Prop) := binary_rect P. - -(** Peano induction on binary natural numbers *) - -Definition peano_rect - (P : N -> Type) (f0 : P 0) - (f : forall n : N, P n -> P (succ n)) (n : N) : P n := -let P' p := P (pos p) in -let f' p := f (pos p) in -match n with -| 0 => f0 -| pos p => Pos.peano_rect P' (f 0 f0) f' p -end. - -Theorem peano_rect_base P a f : peano_rect P a f 0 = a. -Proof. -reflexivity. -Qed. - -Theorem peano_rect_succ P a f n : - peano_rect P a f (succ n) = f n (peano_rect P a f n). -Proof. -destruct n; simpl. -- trivial. -- now rewrite Pos.peano_rect_succ. -Qed. - -Definition peano_ind (P : N -> Prop) := peano_rect P. - -Definition peano_rec (P : N -> Set) := peano_rect P. - -Theorem peano_rec_base P a f : peano_rec P a f 0 = a. -Proof. -apply peano_rect_base. -Qed. - -Theorem peano_rec_succ P a f n : - peano_rec P a f (succ n) = f n (peano_rec P a f n). -Proof. -apply peano_rect_succ. -Qed. - -(** Generic induction / recursion *) - -Theorem bi_induction : - forall A : N -> Prop, Proper (Logic.eq==>iff) A -> - A 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n. -Proof. - intros A A_wd A0 AS. apply peano_rect. - - assumption. - - intros; now apply -> AS. -Qed. - -Definition recursion {A} : A -> (N -> A -> A) -> N -> A := - peano_rect (fun _ => A). - -#[global] -Instance recursion_wd {A} (Aeq : relation A) : - Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion. -Proof. -intros a a' Ea f f' Ef x x' Ex. subst x'. -induction x using peano_ind. -- trivial. -- unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef. -Qed. - -Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a. -Proof. reflexivity. Qed. - -Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A): - Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f -> - forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)). -Proof. -unfold recursion; intros a_wd f_wd n. induction n using peano_ind. -- rewrite peano_rect_succ. now apply f_wd. -- rewrite !peano_rect_succ in *. now apply f_wd. -Qed. - -(** Specification of constants *) - -Lemma one_succ : 1 = succ 0. -Proof. reflexivity. Qed. - -Lemma two_succ : 2 = succ 1. -Proof. reflexivity. Qed. - -Lemma pred_0 : pred 0 = 0. -Proof. reflexivity. Qed. - -(** Properties of mixed successor and predecessor. *) - -Lemma pos_pred_spec p : Pos.pred_N p = pred (pos p). -Proof. - now destruct p. -Qed. - -Lemma succ_pos_spec n : pos (succ_pos n) = succ n. -Proof. - now destruct n. -Qed. - -Lemma pos_pred_succ n : Pos.pred_N (succ_pos n) = n. -Proof. - destruct n. - - trivial. - - apply Pos.pred_N_succ. -Qed. - -Lemma succ_pos_pred p : succ (Pos.pred_N p) = pos p. -Proof. - destruct p; simpl; trivial. f_equal. apply Pos.succ_pred_double. -Qed. - -(** Properties of successor and predecessor *) - -Theorem pred_succ n : pred (succ n) = n. -Proof. -destruct n; trivial. simpl. apply Pos.pred_N_succ. -Qed. - -Theorem pred_sub n : pred n = sub n 1. -Proof. - now destruct n as [|[p|p|]]. -Qed. - -Theorem succ_0_discr n : succ n <> 0. -Proof. -now destruct n. -Qed. - -(** Specification of addition *) - -Theorem add_0_l n : 0 + n = n. -Proof. -reflexivity. -Qed. - -Theorem add_succ_l n m : succ n + m = succ (n + m). -Proof. -destruct n, m; unfold succ, add; now rewrite ?Pos.add_1_l, ?Pos.add_succ_l. -Qed. - -(** Specification of subtraction. *) - -Theorem sub_0_r n : n - 0 = n. -Proof. -now destruct n. -Qed. - -Theorem sub_succ_r n m : n - succ m = pred (n - m). -Proof. -destruct n as [|p], m as [|q]; trivial. -- now destruct p. -- simpl. rewrite Pos.sub_mask_succ_r, Pos.sub_mask_carry_spec. - now destruct (Pos.sub_mask p q) as [|[r|r|]|]. -Qed. - -(** Specification of multiplication *) - -Theorem mul_0_l n : 0 * n = 0. -Proof. -reflexivity. -Qed. - -Theorem mul_succ_l n m : (succ n) * m = n * m + m. -Proof. -destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm. -apply Pos.mul_succ_l. -Qed. - -(** Specification of boolean comparisons. *) - -Lemma eqb_eq n m : eqb n m = true <-> n=m. -Proof. -destruct n as [|n], m as [|m]; simpl; try easy'. -rewrite Pos.eqb_eq. split; intro H. -- now subst. -- now destr_eq H. -Qed. - -Lemma ltb_lt n m : (n n < m. -Proof. - unfold ltb, lt. destruct compare; easy'. -Qed. - -Lemma leb_le n m : (n <=? m) = true <-> n <= m. -Proof. - unfold leb, le. destruct compare; easy'. -Qed. - -(** Basic properties of comparison *) - -Theorem compare_eq_iff n m : (n ?= m) = Eq <-> n = m. -Proof. -destruct n, m; simpl; rewrite ?Pos.compare_eq_iff; split; congruence. -Qed. - -Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m. -Proof. -reflexivity. -Qed. - -Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. -Proof. -reflexivity. -Qed. - -Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m). -Proof. -destruct n, m; simpl; trivial. apply Pos.compare_antisym. -Qed. - -(** Some more advanced properties of comparison and orders, + <: NAxiomsSig + <: UsualOrderedTypeFull + <: UsualDecidableTypeFull + <: TotalOrder. + + (** Definitions of operations, now in a separate file *) + + Include BinNatDef.N. + + (** When including property functors, only inline t eq zero one two *) + + Set Inline Level 30. + + (** Logical predicates *) + + Definition eq := @Logic.eq N. + Definition eq_equiv := @eq_equivalence N. + + Definition lt x y := (x ?= y) = Lt. + Definition gt x y := (x ?= y) = Gt. + Definition le x y := (x ?= y) <> Gt. + Definition ge x y := (x ?= y) <> Lt. + + Infix "<=" := le : N_scope. + Infix "<" := lt : N_scope. + Infix ">=" := ge : N_scope. + Infix ">" := gt : N_scope. + + Notation "x <= y <= z" := (x <= y /\ y <= z) : N_scope. + Notation "x <= y < z" := (x <= y /\ y < z) : N_scope. + Notation "x < y < z" := (x < y /\ y < z) : N_scope. + Notation "x < y <= z" := (x < y /\ y <= z) : N_scope. + + Definition divide p q := exists r, q = r*p. + Notation "( p | q )" := (divide p q) (at level 0) : N_scope. + + Definition Even n := exists m, n = 2*m. + Definition Odd n := exists m, n = 2*m+1. + + (** Proofs of morphisms, obvious since eq is Leibniz *) + + #[local] Obligation Tactic := simpl_relation. + Program Definition succ_wd : Proper (eq==>eq) succ := _. + Program Definition pred_wd : Proper (eq==>eq) pred := _. + Program Definition add_wd : Proper (eq==>eq==>eq) add := _. + Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _. + Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _. + Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _. + Program Definition div_wd : Proper (eq==>eq==>eq) div := _. + Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _. + Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _. + Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _. + + (** Decidability of equality. *) + + Definition eq_dec : forall n m : N, { n = m } + { n <> m }. + Proof. + decide equality. + apply Pos.eq_dec. + Defined. + + (** Discrimination principle *) + + Definition discr n : { p:positive | n = pos p } + { n = 0 }. + Proof. + destruct n as [|p]; auto. + left; exists p; auto. + Defined. + + (** Convenient induction principles *) + + Definition binary_rect (P:N -> Type) (f0 : P 0) + (f2 : forall n, P n -> P (double n)) + (fS2 : forall n, P n -> P (succ_double n)) (n : N) : P n := + let P' p := P (pos p) in + let f2' p := f2 (pos p) in + let fS2' p := fS2 (pos p) in + match n with + | 0 => f0 + | pos p => positive_rect P' fS2' f2' (fS2 0 f0) p + end. + + Definition binary_rec (P:N -> Set) := binary_rect P. + Definition binary_ind (P:N -> Prop) := binary_rect P. + + (** Peano induction on binary natural numbers *) + + Definition peano_rect + (P : N -> Type) (f0 : P 0) + (f : forall n : N, P n -> P (succ n)) (n : N) : P n := + let P' p := P (pos p) in + let f' p := f (pos p) in + match n with + | 0 => f0 + | pos p => Pos.peano_rect P' (f 0 f0) f' p + end. + + Theorem peano_rect_base P a f : peano_rect P a f 0 = a. + Proof. + reflexivity. + Qed. + + Theorem peano_rect_succ P a f n : + peano_rect P a f (succ n) = f n (peano_rect P a f n). + Proof. + destruct n; simpl. + - trivial. + - now rewrite Pos.peano_rect_succ. + Qed. + + Definition peano_ind (P : N -> Prop) := peano_rect P. + + Definition peano_rec (P : N -> Set) := peano_rect P. + + Theorem peano_rec_base P a f : peano_rec P a f 0 = a. + Proof. + apply peano_rect_base. + Qed. + + Theorem peano_rec_succ P a f n : + peano_rec P a f (succ n) = f n (peano_rec P a f n). + Proof. + apply peano_rect_succ. + Qed. + + (** Generic induction / recursion *) + + Theorem bi_induction : + forall A : N -> Prop, Proper (Logic.eq==>iff) A -> + A 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n. + Proof. + intros A A_wd A0 AS. apply peano_rect. + - assumption. + - intros; now apply -> AS. + Qed. + + Definition recursion {A} : A -> (N -> A -> A) -> N -> A := + peano_rect (fun _ => A). + + #[global] + Instance recursion_wd {A} (Aeq : relation A) : + Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion. + Proof. + intros a a' Ea f f' Ef x x' Ex. subst x'. + induction x using peano_ind. + - trivial. + - unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef. + Qed. + + Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a. + Proof. reflexivity. Qed. + + Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A): + Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f -> + forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)). + Proof. + unfold recursion; intros a_wd f_wd n. induction n using peano_ind. + - rewrite peano_rect_succ. now apply f_wd. + - rewrite !peano_rect_succ in *. now apply f_wd. + Qed. + + (** Specification of constants *) + + Lemma one_succ : 1 = succ 0. + Proof. reflexivity. Qed. + + Lemma two_succ : 2 = succ 1. + Proof. reflexivity. Qed. + + Lemma pred_0 : pred 0 = 0. + Proof. reflexivity. Qed. + + (** Properties of mixed successor and predecessor. *) + + Lemma pos_pred_spec p : Pos.pred_N p = pred (pos p). + Proof. + now destruct p. + Qed. + + Lemma succ_pos_spec n : pos (succ_pos n) = succ n. + Proof. + now destruct n. + Qed. + + Lemma pos_pred_succ n : Pos.pred_N (succ_pos n) = n. + Proof. + destruct n. + - trivial. + - apply Pos.pred_N_succ. + Qed. + + Lemma succ_pos_pred p : succ (Pos.pred_N p) = pos p. + Proof. + destruct p; simpl; trivial. f_equal. apply Pos.succ_pred_double. + Qed. + + (** Properties of successor and predecessor *) + + Theorem pred_succ n : pred (succ n) = n. + Proof. + destruct n; trivial. simpl. apply Pos.pred_N_succ. + Qed. + + Theorem pred_sub n : pred n = sub n 1. + Proof. + now destruct n as [|[p|p|]]. + Qed. + + Theorem succ_0_discr n : succ n <> 0. + Proof. + now destruct n. + Qed. + + (** Specification of addition *) + + Theorem add_0_l n : 0 + n = n. + Proof. + reflexivity. + Qed. + + Theorem add_succ_l n m : succ n + m = succ (n + m). + Proof. + destruct n, m; unfold succ, add; now rewrite ?Pos.add_1_l, ?Pos.add_succ_l. + Qed. + + (** Specification of subtraction. *) + + Theorem sub_0_r n : n - 0 = n. + Proof. + now destruct n. + Qed. + + Theorem sub_succ_r n m : n - succ m = pred (n - m). + Proof. + destruct n as [|p], m as [|q]; trivial. + - now destruct p. + - simpl. rewrite Pos.sub_mask_succ_r, Pos.sub_mask_carry_spec. + now destruct (Pos.sub_mask p q) as [|[r|r|]|]. + Qed. + + (** Specification of multiplication *) + + Theorem mul_0_l n : 0 * n = 0. + Proof. + reflexivity. + Qed. + + Theorem mul_succ_l n m : (succ n) * m = n * m + m. + Proof. + destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm. + apply Pos.mul_succ_l. + Qed. + + (** Specification of boolean comparisons. *) + + Lemma eqb_eq n m : eqb n m = true <-> n=m. + Proof. + destruct n as [|n], m as [|m]; simpl; try easy'. + rewrite Pos.eqb_eq. split; intro H. + - now subst. + - now destr_eq H. + Qed. + + Lemma ltb_lt n m : (n n < m. + Proof. + unfold ltb, lt. destruct compare; easy'. + Qed. + + Lemma leb_le n m : (n <=? m) = true <-> n <= m. + Proof. + unfold leb, le. destruct compare; easy'. + Qed. + + (** Basic properties of comparison *) + + Theorem compare_eq_iff n m : (n ?= m) = Eq <-> n = m. + Proof. + destruct n, m; simpl; rewrite ?Pos.compare_eq_iff; split; congruence. + Qed. + + Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m. + Proof. + reflexivity. + Qed. + + Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. + Proof. + reflexivity. + Qed. + + Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m). + Proof. + destruct n, m; simpl; trivial. apply Pos.compare_antisym. + Qed. + + (** Some more advanced properties of comparison and orders, including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) -Include BoolOrderFacts. + Include BoolOrderFacts. -(** Specification of minimum and maximum *) + (** Specification of minimum and maximum *) -Theorem min_l n m : n <= m -> min n m = n. -Proof. -unfold min, le. case compare; trivial. now destruct 1. -Qed. + Theorem min_l n m : n <= m -> min n m = n. + Proof. + unfold min, le. case compare; trivial. now destruct 1. + Qed. -Theorem min_r n m : m <= n -> min n m = m. -Proof. -unfold min, le. rewrite compare_antisym. -case compare_spec; trivial. now destruct 2. -Qed. + Theorem min_r n m : m <= n -> min n m = m. + Proof. + unfold min, le. rewrite compare_antisym. + case compare_spec; trivial. now destruct 2. + Qed. -Theorem max_l n m : m <= n -> max n m = n. -Proof. -unfold max, le. rewrite compare_antisym. -case compare_spec; auto. now destruct 2. -Qed. + Theorem max_l n m : m <= n -> max n m = n. + Proof. + unfold max, le. rewrite compare_antisym. + case compare_spec; auto. now destruct 2. + Qed. -Theorem max_r n m : n <= m -> max n m = m. -Proof. -unfold max, le. case compare; trivial. now destruct 1. -Qed. + Theorem max_r n m : n <= m -> max n m = m. + Proof. + unfold max, le. case compare; trivial. now destruct 1. + Qed. -(** Specification of lt and le. *) + (** Specification of lt and le. *) -Lemma lt_succ_r n m : n < succ m <-> n<=m. -Proof. -destruct n as [|p], m as [|q]; simpl; try easy'. -- split. - + now destruct p. - + now destruct 1. -- apply Pos.lt_succ_r. -Qed. + Lemma lt_succ_r n m : n < succ m <-> n<=m. + Proof. + destruct n as [|p], m as [|q]; simpl; try easy'. + - split. + + now destruct p. + + now destruct 1. + - apply Pos.lt_succ_r. + Qed. -(** We can now derive all properties of basic functions and orders, + (** We can now derive all properties of basic functions and orders, and use these properties for proving the specs of more advanced functions. *) -Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -Lemma strong_induction_le (A : N -> Prop) : - A 0 -> (forall n, (forall m, m <= n -> A m) -> A (succ n)) -> forall n, A n. -Proof. apply Private_strong_induction_le; intros x y ->; reflexivity. Qed. - -(** Properties of [double] and [succ_double] *) - -Lemma double_spec n : double n = 2 * n. -Proof. - reflexivity. -Qed. - -Lemma succ_double_spec n : succ_double n = 2 * n + 1. -Proof. - now destruct n. -Qed. - -Lemma double_add n m : double (n+m) = double n + double m. -Proof. - now destruct n, m. -Qed. - -Lemma succ_double_add n m : succ_double (n+m) = double n + succ_double m. -Proof. - now destruct n, m. -Qed. - -Lemma double_mul n m : double (n*m) = double n * m. -Proof. - now destruct n, m. -Qed. - -Lemma succ_double_mul n m : - succ_double n * m = double n * m + m. -Proof. - destruct n; simpl; destruct m; trivial. - now rewrite Pos.add_comm. -Qed. - -Lemma div2_double n : div2 (double n) = n. -Proof. -now destruct n. -Qed. - -Lemma div2_succ_double n : div2 (succ_double n) = n. -Proof. -now destruct n. -Qed. - -Lemma double_inj n m : double n = double m -> n = m. -Proof. -intro H. rewrite <- (div2_double n), H. apply div2_double. -Qed. - -Lemma succ_double_inj n m : succ_double n = succ_double m -> n = m. -Proof. -intro H. rewrite <- (div2_succ_double n), H. apply div2_succ_double. -Qed. - -Lemma succ_double_lt n m : n succ_double n < double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. - unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H. -Qed. - -Lemma double_lt_mono n m : n < m -> double n < double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -Lemma double_le_mono n m : n <= m -> double n <= double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -Lemma succ_double_lt_mono n m : n < m -> succ_double n < succ_double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -Lemma succ_double_le_mono n m : n <= m -> succ_double n <= succ_double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -(** 0 is the least natural number *) - -Theorem compare_0_r n : (n ?= 0) <> Lt. -Proof. -now destruct n. -Qed. - -(** Specifications of power *) - -Lemma pow_0_r n : n ^ 0 = 1. -Proof. reflexivity. Qed. - -Lemma pow_succ_r n p : 0<=p -> n^(succ p) = n * n^p. -Proof. - intros _. - destruct n, p; simpl; trivial; f_equal. apply Pos.pow_succ_r. -Qed. - -Lemma pow_neg_r n p : p<0 -> n^p = 0. -Proof. - now destruct p. -Qed. - -(** Specification of square *) - -Lemma square_spec n : square n = n * n. -Proof. - destruct n; trivial. simpl. f_equal. apply Pos.square_spec. -Qed. - -(** Specification of Base-2 logarithm *) - -Lemma size_log2 n : n<>0 -> size n = succ (log2 n). -Proof. - destruct n as [|[n|n| ]]; trivial. now destruct 1. -Qed. - -Lemma size_gt n : n < 2^(size n). -Proof. - destruct n. - - reflexivity. - - simpl. apply Pos.size_gt. -Qed. - -Lemma size_le n : 2^(size n) <= succ_double n. -Proof. - destruct n as [|p]. - - discriminate. - - simpl. - change (2^Pos.size p <= Pos.succ (p~0))%positive. - apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le. -Qed. - -Lemma log2_spec n : 0 < n -> - 2^(log2 n) <= n < 2^(succ (log2 n)). -Proof. - destruct n as [|[p|p|]]; discriminate || intros _; simpl; split. - - apply (size_le (pos p)). - - apply Pos.size_gt. - - apply Pos.size_le. - - apply Pos.size_gt. - - discriminate. - - reflexivity. -Qed. - -Lemma log2_nonpos n : n<=0 -> log2 n = 0. -Proof. - destruct n; intros Hn. - - reflexivity. - - now destruct Hn. -Qed. - -(** Specification of parity functions *) - -Lemma even_spec n : even n = true <-> Even n. -Proof. - destruct n as [|p]. - - split. - + now exists 0. - + trivial. - - destruct p as [p|p|]; simpl; split; try easy. - + intros (m,H). now destruct m. - + now exists (pos p). - + intros (m,H). now destruct m. -Qed. - -Lemma odd_spec n : odd n = true <-> Odd n. -Proof. - destruct n as [|p]. - - split. - + discriminate. - + intros (m,H). now destruct m. - - destruct p as [p|p|]; simpl; split; try easy. - + now exists (pos p). - + intros (m,H). now destruct m. - + now exists 0. -Qed. - -(** Specification of the euclidean division *) - -Theorem pos_div_eucl_spec (a:positive)(b:N) : - let (q,r) := pos_div_eucl a b in pos a = q * b + r. -Proof. - induction a as [a IHa|a IHa|]; - cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. - - (* a~1 *) - destruct pos_div_eucl as (q,r). - change (pos a~1) with (succ_double (pos a)). - rewrite IHa, succ_double_add, double_mul. - case leb_spec; intros H; trivial. - rewrite succ_double_mul, <- add_assoc. f_equal. - now rewrite (add_comm b), sub_add. - - (* a~0 *) - destruct pos_div_eucl as (q,r). - change (pos a~0) with (double (pos a)). - rewrite IHa, double_add, double_mul. - case leb_spec; intros H; trivial. - rewrite succ_double_mul, <- add_assoc. f_equal. - now rewrite (add_comm b), sub_add. - - (* 1 *) - now destruct b as [|[ | | ]]. -Qed. - -Theorem div_eucl_spec a b : - let (q,r) := div_eucl a b in a = b * q + r. -Proof. - destruct a as [|a], b as [|b]; unfold div_eucl; trivial. - generalize (pos_div_eucl_spec a (pos b)). - destruct pos_div_eucl. now rewrite mul_comm. -Qed. - -Theorem div_mod' a b : a = b * (a/b) + (a mod b). -Proof. - generalize (div_eucl_spec a b). - unfold div, modulo. now destruct div_eucl. -Qed. - -Theorem div_mod a b : b<>0 -> a = b * (a/b) + (a mod b). -Proof. - intros _. apply div_mod'. -Qed. - -Theorem pos_div_eucl_remainder (a:positive) (b:N) : - b<>0 -> snd (pos_div_eucl a b) < b. -Proof. - intros Hb. - induction a as [a IHa|a IHa|]; - cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. - - (* a~1 *) - destruct pos_div_eucl as (q,r); simpl in *. - case leb_spec; intros H; simpl; trivial. - apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial. - destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ]. - apply (succ_double_lt _ _ IHa). - - (* a~0 *) - destruct pos_div_eucl as (q,r); simpl in *. - case leb_spec; intros H; simpl; trivial. - apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial. - destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ]. - now destruct r. - - (* 1 *) - destruct b as [|[ | | ]]; easy || (now destruct Hb). -Qed. - -Theorem mod_lt a b : b<>0 -> a mod b < b. -Proof. - destruct b as [ |b]. { now destruct 1. } - destruct a as [ |a]. { reflexivity. } - unfold modulo. simpl. apply pos_div_eucl_remainder. -Qed. - -Theorem mod_bound_pos a b : 0<=a -> 0 0 <= a mod b < b. -Proof. - intros _ H. split. - - apply le_0_l. - - apply mod_lt. now destruct b. -Qed. - -(** Specification of square root *) - -Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. -Proof. - destruct n as [|p]. - - reflexivity. - - unfold sqrtrem, sqrt, Pos.sqrt. - destruct (Pos.sqrtrem p) as (s,r). now destruct r. -Qed. - -Lemma sqrtrem_spec n : - let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s. -Proof. - destruct n as [|p]. - - now split. - - generalize (Pos.sqrtrem_spec p). simpl. - destruct 1; simpl; subst; now split. -Qed. - -Lemma sqrt_spec n : 0<=n -> - let s := sqrt n in s*s <= n < (succ s)*(succ s). -Proof. - intros _. destruct n as [|p]. - - now split. - - apply (Pos.sqrt_spec p). -Qed. - -Lemma sqrt_neg n : n<0 -> sqrt n = 0. -Proof. - now destruct n. -Qed. - -(** Specification of gcd *) - -(** The first component of ggcd is gcd *) - -Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b. -Proof. - destruct a as [|p], b as [|q]; simpl; auto. - assert (H := Pos.ggcd_gcd p q). - destruct Pos.ggcd as (g,(aa,bb)); simpl; now f_equal. -Qed. - -(** The other components of ggcd are indeed the correct factors. *) - -Lemma ggcd_correct_divisors a b : - let '(g,(aa,bb)) := ggcd a b in - a=g*aa /\ b=g*bb. -Proof. - destruct a as [|p], b as [|q]; simpl; auto. - - now rewrite Pos.mul_1_r. - - now rewrite Pos.mul_1_r. - - generalize (Pos.ggcd_correct_divisors p q). - destruct Pos.ggcd as (g,(aa,bb)); simpl. - destruct 1; split; now f_equal. -Qed. - -(** We can use this fact to prove a part of the gcd correctness *) - -Lemma gcd_divide_l a b : (gcd a b | a). -Proof. - rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. - now rewrite mul_comm. -Qed. - -Lemma gcd_divide_r a b : (gcd a b | b). -Proof. - rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. - now rewrite mul_comm. -Qed. - -(** We now prove directly that gcd is the greatest amongst common divisors *) - -Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c|gcd a b). -Proof. - destruct a as [ |p], b as [ |q]; simpl; trivial. - destruct c as [ |r]. - - intros (s,H). destruct s; discriminate. - - intros ([ |s],Hs) ([ |t],Ht); try discriminate; simpl in *. - destruct (Pos.gcd_greatest p q r) as (u,H). - + exists s. now inversion Hs. - + exists t. now inversion Ht. - + exists (pos u). simpl; now f_equal. -Qed. - -Lemma gcd_nonneg a b : 0 <= gcd a b. -Proof. apply le_0_l. Qed. - -(** Specification of bitwise functions *) - -(** Correctness proofs for [testbit]. *) - -Lemma testbit_even_0 a : testbit (2*a) 0 = false. -Proof. - now destruct a. -Qed. - -Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. -Proof. - now destruct a. -Qed. - -Lemma testbit_succ_r_div2 a n : 0<=n -> - testbit a (succ n) = testbit (div2 a) n. -Proof. - intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial; - f_equal; apply Pos.pred_N_succ. -Qed. - -Lemma testbit_odd_succ a n : 0<=n -> - testbit (2*a+1) (succ n) = testbit a n. -Proof. - intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. -Qed. - -Lemma testbit_even_succ a n : 0<=n -> - testbit (2*a) (succ n) = testbit a n. -Proof. - intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. -Qed. - -Lemma testbit_neg_r a n : n<0 -> testbit a n = false. -Proof. - now destruct n. -Qed. - -(** Correctness proofs for shifts *) - -Lemma shiftr_succ_r a n : - shiftr a (succ n) = div2 (shiftr a n). -Proof. - destruct n; simpl; trivial. apply Pos.iter_succ. -Qed. - -Lemma shiftl_succ_r a n : - shiftl a (succ n) = double (shiftl a n). -Proof. - destruct n, a; simpl; trivial. f_equal. apply Pos.iter_succ. -Qed. - -Lemma shiftr_spec a n m : 0<=m -> - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros _. revert a m. - induction n as [|n IHn] using peano_ind; intros a m. - - now rewrite add_0_r. - - rewrite add_comm, add_succ_l, add_comm, <- add_succ_l. - now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l. -Qed. - -Lemma shiftl_spec_high a n m : 0<=m -> n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros _ H. - rewrite <- (sub_add n m H) at 1. - set (m' := m-n). clearbody m'. clear H m. revert a m'. - induction n using peano_ind; intros a m. - - rewrite add_0_r; now destruct a. - - rewrite shiftl_succ_r. - rewrite add_comm, add_succ_l, add_comm. - now rewrite testbit_succ_r_div2, div2_double by apply le_0_l. -Qed. - -Lemma shiftl_spec_low a n m : m - testbit (shiftl a n) m = false. -Proof. - revert a m. - induction n as [|n IHn] using peano_ind; intros a m H. - - elim (le_0_l m). now rewrite compare_antisym, H. - - rewrite shiftl_succ_r. - destruct m as [|p]. - + now destruct (shiftl a n). - + rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l. - apply IHn. - apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl. - now rewrite succ_pos_pred. -Qed. - -Lemma div2_spec a : div2 a = shiftr a 1. -Proof. - reflexivity. -Qed. - -(** Semantics of bitwise operations *) - -Lemma pos_lxor_spec p p' n : - testbit (Pos.lxor p p') n = xorb (Pos.testbit p n) (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - (specialize (IH p'); destruct Pos.lxor; trivial; now rewrite <-IH) || - (now destruct Pos.testbit). -Qed. - -Lemma lxor_spec a a' n : - testbit (lxor a a') n = xorb (testbit a n) (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now destruct Pos.testbit. - - apply pos_lxor_spec. -Qed. - -Lemma pos_lor_spec p p' n : - Pos.testbit (Pos.lor p p') n = (Pos.testbit p n) || (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - apply IH || now rewrite orb_false_r. -Qed. - -Lemma lor_spec a a' n : - testbit (lor a a') n = (testbit a n) || (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now rewrite orb_false_r. - - apply pos_lor_spec. -Qed. - -Lemma pos_land_spec p p' n : - testbit (Pos.land p p') n = (Pos.testbit p n) && (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - (specialize (IH p'); destruct Pos.land; trivial; now rewrite <-IH) || - (now rewrite andb_false_r). -Qed. - -Lemma land_spec a a' n : - testbit (land a a') n = (testbit a n) && (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now rewrite andb_false_r. - - apply pos_land_spec. -Qed. - -Lemma pos_ldiff_spec p p' n : - testbit (Pos.ldiff p p') n = (Pos.testbit p n) && negb (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - (specialize (IH p'); destruct Pos.ldiff; trivial; now rewrite <-IH) || - (now rewrite andb_true_r). -Qed. - -Lemma ldiff_spec a a' n : - testbit (ldiff a a') n = (testbit a n) && negb (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now rewrite andb_true_r. - - apply pos_ldiff_spec. -Qed. - -Lemma div_0_r a : a / 0 = 0. -Proof. now destruct a. Qed. - -Lemma mod_0_r a : a mod 0 = a. -Proof. now destruct a. Qed. - -(** Instantiation of generic properties of advanced functions + Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + + Lemma strong_induction_le (A : N -> Prop) : + A 0 -> (forall n, (forall m, m <= n -> A m) -> A (succ n)) -> forall n, A n. + Proof. apply Private_strong_induction_le; intros x y ->; reflexivity. Qed. + + (** Properties of [double] and [succ_double] *) + + Lemma double_spec n : double n = 2 * n. + Proof. + reflexivity. + Qed. + + Lemma succ_double_spec n : succ_double n = 2 * n + 1. + Proof. + now destruct n. + Qed. + + Lemma double_add n m : double (n+m) = double n + double m. + Proof. + now destruct n, m. + Qed. + + Lemma succ_double_add n m : succ_double (n+m) = double n + succ_double m. + Proof. + now destruct n, m. + Qed. + + Lemma double_mul n m : double (n*m) = double n * m. + Proof. + now destruct n, m. + Qed. + + Lemma succ_double_mul n m : + succ_double n * m = double n * m + m. + Proof. + destruct n; simpl; destruct m; trivial. + now rewrite Pos.add_comm. + Qed. + + Lemma div2_double n : div2 (double n) = n. + Proof. + now destruct n. + Qed. + + Lemma div2_succ_double n : div2 (succ_double n) = n. + Proof. + now destruct n. + Qed. + + Lemma double_inj n m : double n = double m -> n = m. + Proof. + intro H. rewrite <- (div2_double n), H. apply div2_double. + Qed. + + Lemma succ_double_inj n m : succ_double n = succ_double m -> n = m. + Proof. + intro H. rewrite <- (div2_succ_double n), H. apply div2_succ_double. + Qed. + + Lemma succ_double_lt n m : n succ_double n < double m. + Proof. + destruct n as [|n], m as [|m]; intros H; try easy. + unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H. + Qed. + + Lemma double_lt_mono n m : n < m -> double n < double m. + Proof. + destruct n as [|n], m as [|m]; intros H; try easy. + Qed. + + Lemma double_le_mono n m : n <= m -> double n <= double m. + Proof. + destruct n as [|n], m as [|m]; intros H; try easy. + Qed. + + Lemma succ_double_lt_mono n m : n < m -> succ_double n < succ_double m. + Proof. + destruct n as [|n], m as [|m]; intros H; try easy. + Qed. + + Lemma succ_double_le_mono n m : n <= m -> succ_double n <= succ_double m. + Proof. + destruct n as [|n], m as [|m]; intros H; try easy. + Qed. + + (** 0 is the least natural number *) + + Theorem compare_0_r n : (n ?= 0) <> Lt. + Proof. + now destruct n. + Qed. + + (** Specifications of power *) + + Lemma pow_0_r n : n ^ 0 = 1. + Proof. reflexivity. Qed. + + Lemma pow_succ_r n p : 0<=p -> n^(succ p) = n * n^p. + Proof. + intros _. + destruct n, p; simpl; trivial; f_equal. apply Pos.pow_succ_r. + Qed. + + Lemma pow_neg_r n p : p<0 -> n^p = 0. + Proof. + now destruct p. + Qed. + + (** Specification of square *) + + Lemma square_spec n : square n = n * n. + Proof. + destruct n; trivial. simpl. f_equal. apply Pos.square_spec. + Qed. + + (** Specification of Base-2 logarithm *) + + Lemma size_log2 n : n<>0 -> size n = succ (log2 n). + Proof. + destruct n as [|[n|n| ]]; trivial. now destruct 1. + Qed. + + Lemma size_gt n : n < 2^(size n). + Proof. + destruct n. + - reflexivity. + - simpl. apply Pos.size_gt. + Qed. + + Lemma size_le n : 2^(size n) <= succ_double n. + Proof. + destruct n as [|p]. + - discriminate. + - simpl. + change (2^Pos.size p <= Pos.succ (p~0))%positive. + apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le. + Qed. + + Lemma log2_spec n : 0 < n -> + 2^(log2 n) <= n < 2^(succ (log2 n)). + Proof. + destruct n as [|[p|p|]]; discriminate || intros _; simpl; split. + - apply (size_le (pos p)). + - apply Pos.size_gt. + - apply Pos.size_le. + - apply Pos.size_gt. + - discriminate. + - reflexivity. + Qed. + + Lemma log2_nonpos n : n<=0 -> log2 n = 0. + Proof. + destruct n; intros Hn. + - reflexivity. + - now destruct Hn. + Qed. + + (** Specification of parity functions *) + + Lemma even_spec n : even n = true <-> Even n. + Proof. + destruct n as [|p]. + - split. + + now exists 0. + + trivial. + - destruct p as [p|p|]; simpl; split; try easy. + + intros (m,H). now destruct m. + + now exists (pos p). + + intros (m,H). now destruct m. + Qed. + + Lemma odd_spec n : odd n = true <-> Odd n. + Proof. + destruct n as [|p]. + - split. + + discriminate. + + intros (m,H). now destruct m. + - destruct p as [p|p|]; simpl; split; try easy. + + now exists (pos p). + + intros (m,H). now destruct m. + + now exists 0. + Qed. + + (** Specification of the euclidean division *) + + Theorem pos_div_eucl_spec (a:positive)(b:N) : + let (q,r) := pos_div_eucl a b in pos a = q * b + r. + Proof. + induction a as [a IHa|a IHa|]; + cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + - (* a~1 *) + destruct pos_div_eucl as (q,r). + change (pos a~1) with (succ_double (pos a)). + rewrite IHa, succ_double_add, double_mul. + case leb_spec; intros H; trivial. + rewrite succ_double_mul, <- add_assoc. f_equal. + now rewrite (add_comm b), sub_add. + - (* a~0 *) + destruct pos_div_eucl as (q,r). + change (pos a~0) with (double (pos a)). + rewrite IHa, double_add, double_mul. + case leb_spec; intros H; trivial. + rewrite succ_double_mul, <- add_assoc. f_equal. + now rewrite (add_comm b), sub_add. + - (* 1 *) + now destruct b as [|[ | | ]]. + Qed. + + Theorem div_eucl_spec a b : + let (q,r) := div_eucl a b in a = b * q + r. + Proof. + destruct a as [|a], b as [|b]; unfold div_eucl; trivial. + generalize (pos_div_eucl_spec a (pos b)). + destruct pos_div_eucl. now rewrite mul_comm. + Qed. + + Theorem div_mod' a b : a = b * (a/b) + (a mod b). + Proof. + generalize (div_eucl_spec a b). + unfold div, modulo. now destruct div_eucl. + Qed. + + Theorem div_mod a b : b<>0 -> a = b * (a/b) + (a mod b). + Proof. + intros _. apply div_mod'. + Qed. + + Theorem pos_div_eucl_remainder (a:positive) (b:N) : + b<>0 -> snd (pos_div_eucl a b) < b. + Proof. + intros Hb. + induction a as [a IHa|a IHa|]; + cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + - (* a~1 *) + destruct pos_div_eucl as (q,r); simpl in *. + case leb_spec; intros H; simpl; trivial. + apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial. + destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ]. + apply (succ_double_lt _ _ IHa). + - (* a~0 *) + destruct pos_div_eucl as (q,r); simpl in *. + case leb_spec; intros H; simpl; trivial. + apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial. + destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ]. + now destruct r. + - (* 1 *) + destruct b as [|[ | | ]]; easy || (now destruct Hb). + Qed. + + Theorem mod_lt a b : b<>0 -> a mod b < b. + Proof. + destruct b as [ |b]. { now destruct 1. } + destruct a as [ |a]. { reflexivity. } + unfold modulo. simpl. apply pos_div_eucl_remainder. + Qed. + + Theorem mod_bound_pos a b : 0<=a -> 0 0 <= a mod b < b. + Proof. + intros _ H. split. + - apply le_0_l. + - apply mod_lt. now destruct b. + Qed. + + (** Specification of square root *) + + Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. + Proof. + destruct n as [|p]. + - reflexivity. + - unfold sqrtrem, sqrt, Pos.sqrt. + destruct (Pos.sqrtrem p) as (s,r). now destruct r. + Qed. + + Lemma sqrtrem_spec n : + let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s. + Proof. + destruct n as [|p]. + - now split. + - generalize (Pos.sqrtrem_spec p). simpl. + destruct 1; simpl; subst; now split. + Qed. + + Lemma sqrt_spec n : 0<=n -> + let s := sqrt n in s*s <= n < (succ s)*(succ s). + Proof. + intros _. destruct n as [|p]. + - now split. + - apply (Pos.sqrt_spec p). + Qed. + + Lemma sqrt_neg n : n<0 -> sqrt n = 0. + Proof. + now destruct n. + Qed. + + (** Specification of gcd *) + + (** The first component of ggcd is gcd *) + + Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b. + Proof. + destruct a as [|p], b as [|q]; simpl; auto. + assert (H := Pos.ggcd_gcd p q). + destruct Pos.ggcd as (g,(aa,bb)); simpl; now f_equal. + Qed. + + (** The other components of ggcd are indeed the correct factors. *) + + Lemma ggcd_correct_divisors a b : + let '(g,(aa,bb)) := ggcd a b in + a=g*aa /\ b=g*bb. + Proof. + destruct a as [|p], b as [|q]; simpl; auto. + - now rewrite Pos.mul_1_r. + - now rewrite Pos.mul_1_r. + - generalize (Pos.ggcd_correct_divisors p q). + destruct Pos.ggcd as (g,(aa,bb)); simpl. + destruct 1; split; now f_equal. + Qed. + + (** We can use this fact to prove a part of the gcd correctness *) + + Lemma gcd_divide_l a b : (gcd a b | a). + Proof. + rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). + destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. + now rewrite mul_comm. + Qed. + + Lemma gcd_divide_r a b : (gcd a b | b). + Proof. + rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). + destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. + now rewrite mul_comm. + Qed. + + (** We now prove directly that gcd is the greatest amongst common divisors *) + + Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c|gcd a b). + Proof. + destruct a as [ |p], b as [ |q]; simpl; trivial. + destruct c as [ |r]. + - intros (s,H). destruct s; discriminate. + - intros ([ |s],Hs) ([ |t],Ht); try discriminate; simpl in *. + destruct (Pos.gcd_greatest p q r) as (u,H). + + exists s. now inversion Hs. + + exists t. now inversion Ht. + + exists (pos u). simpl; now f_equal. + Qed. + + Lemma gcd_nonneg a b : 0 <= gcd a b. + Proof. apply le_0_l. Qed. + + (** Specification of bitwise functions *) + + (** Correctness proofs for [testbit]. *) + + Lemma testbit_even_0 a : testbit (2*a) 0 = false. + Proof. + now destruct a. + Qed. + + Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. + Proof. + now destruct a. + Qed. + + Lemma testbit_succ_r_div2 a n : 0<=n -> + testbit a (succ n) = testbit (div2 a) n. + Proof. + intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial; + f_equal; apply Pos.pred_N_succ. + Qed. + + Lemma testbit_odd_succ a n : 0<=n -> + testbit (2*a+1) (succ n) = testbit a n. + Proof. + intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. + Qed. + + Lemma testbit_even_succ a n : 0<=n -> + testbit (2*a) (succ n) = testbit a n. + Proof. + intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. + Qed. + + Lemma testbit_neg_r a n : n<0 -> testbit a n = false. + Proof. + now destruct n. + Qed. + + (** Correctness proofs for shifts *) + + Lemma shiftr_succ_r a n : + shiftr a (succ n) = div2 (shiftr a n). + Proof. + destruct n; simpl; trivial. apply Pos.iter_succ. + Qed. + + Lemma shiftl_succ_r a n : + shiftl a (succ n) = double (shiftl a n). + Proof. + destruct n, a; simpl; trivial. f_equal. apply Pos.iter_succ. + Qed. + + Lemma shiftr_spec a n m : 0<=m -> + testbit (shiftr a n) m = testbit a (m+n). + Proof. + intros _. revert a m. + induction n as [|n IHn] using peano_ind; intros a m. + - now rewrite add_0_r. + - rewrite add_comm, add_succ_l, add_comm, <- add_succ_l. + now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l. + Qed. + + Lemma shiftl_spec_high a n m : 0<=m -> n<=m -> + testbit (shiftl a n) m = testbit a (m-n). + Proof. + intros _ H. + rewrite <- (sub_add n m H) at 1. + set (m' := m-n). clearbody m'. clear H m. revert a m'. + induction n using peano_ind; intros a m. + - rewrite add_0_r; now destruct a. + - rewrite shiftl_succ_r. + rewrite add_comm, add_succ_l, add_comm. + now rewrite testbit_succ_r_div2, div2_double by apply le_0_l. + Qed. + + Lemma shiftl_spec_low a n m : m + testbit (shiftl a n) m = false. + Proof. + revert a m. + induction n as [|n IHn] using peano_ind; intros a m H. + - elim (le_0_l m). now rewrite compare_antisym, H. + - rewrite shiftl_succ_r. + destruct m as [|p]. + + now destruct (shiftl a n). + + rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l. + apply IHn. + apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl. + now rewrite succ_pos_pred. + Qed. + + Lemma div2_spec a : div2 a = shiftr a 1. + Proof. + reflexivity. + Qed. + + (** Semantics of bitwise operations *) + + Lemma pos_lxor_spec p p' n : + testbit (Pos.lxor p p') n = xorb (Pos.testbit p n) (Pos.testbit p' n). + Proof. + revert p' n. + induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; + (specialize (IH p'); destruct Pos.lxor; trivial; now rewrite <-IH) || + (now destruct Pos.testbit). + Qed. + + Lemma lxor_spec a a' n : + testbit (lxor a a') n = xorb (testbit a n) (testbit a' n). + Proof. + destruct a, a'; simpl; trivial. + - now destruct Pos.testbit. + - apply pos_lxor_spec. + Qed. + + Lemma pos_lor_spec p p' n : + Pos.testbit (Pos.lor p p') n = (Pos.testbit p n) || (Pos.testbit p' n). + Proof. + revert p' n. + induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; + apply IH || now rewrite orb_false_r. + Qed. + + Lemma lor_spec a a' n : + testbit (lor a a') n = (testbit a n) || (testbit a' n). + Proof. + destruct a, a'; simpl; trivial. + - now rewrite orb_false_r. + - apply pos_lor_spec. + Qed. + + Lemma pos_land_spec p p' n : + testbit (Pos.land p p') n = (Pos.testbit p n) && (Pos.testbit p' n). + Proof. + revert p' n. + induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; + (specialize (IH p'); destruct Pos.land; trivial; now rewrite <-IH) || + (now rewrite andb_false_r). + Qed. + + Lemma land_spec a a' n : + testbit (land a a') n = (testbit a n) && (testbit a' n). + Proof. + destruct a, a'; simpl; trivial. + - now rewrite andb_false_r. + - apply pos_land_spec. + Qed. + + Lemma pos_ldiff_spec p p' n : + testbit (Pos.ldiff p p') n = (Pos.testbit p n) && negb (Pos.testbit p' n). + Proof. + revert p' n. + induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; + (specialize (IH p'); destruct Pos.ldiff; trivial; now rewrite <-IH) || + (now rewrite andb_true_r). + Qed. + + Lemma ldiff_spec a a' n : + testbit (ldiff a a') n = (testbit a n) && negb (testbit a' n). + Proof. + destruct a, a'; simpl; trivial. + - now rewrite andb_true_r. + - apply pos_ldiff_spec. + Qed. + + Lemma div_0_r a : a / 0 = 0. + Proof. now destruct a. Qed. + + Lemma mod_0_r a : a mod 0 = a. + Proof. now destruct a. Qed. + + (** Instantiation of generic properties of advanced functions (pow, sqrt, log2, div, gcd, ...) *) -Include NExtraPreProp <+ NExtraProp0. + Include NExtraPreProp <+ NExtraProp0. -Lemma binary_induction (A : N -> Prop) : - A 0 -> (forall n, A n -> A (2 * n)) -> (forall n, A n -> A (2 * n + 1)) - -> forall n, A n. -Proof. apply Private_binary_induction; intros x y ->; reflexivity. Qed. + Lemma binary_induction (A : N -> Prop) : + A 0 -> (forall n, A n -> A (2 * n)) -> (forall n, A n -> A (2 * n + 1)) + -> forall n, A n. + Proof. apply Private_binary_induction; intros x y ->; reflexivity. Qed. -(** In generic statements, the predicates [lt] and [le] have been + (** In generic statements, the predicates [lt] and [le] have been favored, whereas [gt] and [ge] don't even exist in the abstract layers. The use of [gt] and [ge] is hence not recommended. We provide here the bare minimal results to related them with [lt] and [le]. *) -Lemma gt_lt_iff n m : n > m <-> m < n. -Proof. - unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma gt_lt n m : n > m -> m < n. -Proof. - apply gt_lt_iff. -Qed. - -Lemma lt_gt n m : n < m -> m > n. -Proof. - apply gt_lt_iff. -Qed. - -Lemma ge_le_iff n m : n >= m <-> m <= n. -Proof. - unfold le, ge. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma ge_le n m : n >= m -> m <= n. -Proof. - apply ge_le_iff. -Qed. - -Lemma le_ge n m : n <= m -> m >= n. -Proof. - apply ge_le_iff. -Qed. - -(** Auxiliary results about right shift on positive numbers, + Lemma gt_lt_iff n m : n > m <-> m < n. + Proof. + unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. + Qed. + + Lemma gt_lt n m : n > m -> m < n. + Proof. + apply gt_lt_iff. + Qed. + + Lemma lt_gt n m : n < m -> m > n. + Proof. + apply gt_lt_iff. + Qed. + + Lemma ge_le_iff n m : n >= m <-> m <= n. + Proof. + unfold le, ge. now rewrite compare_antisym, CompOpp_iff. + Qed. + + Lemma ge_le n m : n >= m -> m <= n. + Proof. + apply ge_le_iff. + Qed. + + Lemma le_ge n m : n <= m -> m >= n. + Proof. + apply ge_le_iff. + Qed. + + (** Auxiliary results about right shift on positive numbers, used in BinInt *) -Lemma pos_pred_shiftl_low : forall p n m, m - testbit (Pos.pred_N (Pos.shiftl p n)) m = true. -Proof. - intros p n; induction n as [|n IHn] using peano_ind. - - now intro m; destruct m. - - intros m H. unfold Pos.shiftl. - destruct n as [|n]; simpl in *. - + destruct m. - * now destruct p. - * elim (Pos.nlt_1_r _ H). - + rewrite Pos.iter_succ. simpl. - set (u:=Pos.iter xO p n) in *; clearbody u. - destruct m as [|m]. - * now destruct u. - * rewrite <- (IHn (Pos.pred_N m)). - -- rewrite <- (testbit_odd_succ _ (Pos.pred_N m)). - ++ rewrite succ_pos_pred. now destruct u. - ++ apply le_0_l. - -- apply succ_lt_mono. now rewrite succ_pos_pred. -Qed. - -Lemma pos_pred_shiftl_high : forall p n m, n<=m -> - testbit (Pos.pred_N (Pos.shiftl p n)) m = - testbit (shiftl (Pos.pred_N p) n) m. -Proof. - intros p n; induction n as [|n IHn] using peano_ind; intros m H. - - unfold shiftl. simpl. now destruct (Pos.pred_N p). - - rewrite shiftl_succ_r. - destruct n as [|n]. - + destruct m as [|m]. - * now destruct H. - * now destruct p. - + destruct m as [|m]. - * now destruct H. - * rewrite <- (succ_pos_pred m). - rewrite double_spec, testbit_even_succ by apply le_0_l. - rewrite <- IHn. - -- rewrite testbit_succ_r_div2 by apply le_0_l. - f_equal. simpl. rewrite Pos.iter_succ. - now destruct (Pos.iter xO p n). - -- apply succ_le_mono. now rewrite succ_pos_pred. -Qed. - -Lemma pred_div2_up p : Pos.pred_N (Pos.div2_up p) = div2 (Pos.pred_N p). -Proof. - destruct p as [p|p| ]; trivial. - - simpl. apply Pos.pred_N_succ. - - destruct p; simpl; trivial. -Qed. - -(** ** Properties of [iter] *) - -Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : - (forall a, f (g a) = h (f a)) -> forall n a, - f (iter n g a) = iter n h (f a). -Proof. - intros H n; destruct n; simpl; intros; rewrite ?H; trivial. - now apply Pos.iter_swap_gen. -Qed. - -Theorem iter_swap : - forall n (A:Type) (f:A -> A) (x:A), - iter n f (f x) = f (iter n f x). -Proof. - intros. symmetry. now apply iter_swap_gen. -Qed. - -Theorem iter_succ : - forall n (A:Type) (f:A -> A) (x:A), - iter (succ n) f x = f (iter n f x). -Proof. - intro n; destruct n; intros; simpl; trivial. - now apply Pos.iter_succ. -Qed. - -Theorem iter_succ_r : - forall n (A:Type) (f:A -> A) (x:A), - iter (succ n) f x = iter n f (f x). -Proof. - intros; now rewrite iter_succ, iter_swap. -Qed. - -Theorem iter_add : - forall p q (A:Type) (f:A -> A) (x:A), - iter (p+q) f x = iter p f (iter q f x). -Proof. - intro p; induction p as [|p IHp] using peano_ind; intros; trivial. - now rewrite add_succ_l, !iter_succ, IHp. -Qed. - -Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop) : - P 0 a -> - (forall n a', P n a' -> P (succ n) (f a')) -> - forall n, P n (iter n f a). -Proof. - intros ? ? n; induction n using peano_ind; trivial. - rewrite iter_succ; auto. -Qed. - -Theorem iter_invariant : - forall (n:N) (A:Type) (f:A -> A) (Inv:A -> Prop), - (forall x:A, Inv x -> Inv (f x)) -> - forall x:A, Inv x -> Inv (iter n f x). -Proof. - intros; apply iter_ind; trivial. -Qed. - -(** Properties of [iter_op] *) - -Lemma iter_op_0_r {A} op z x : @N.iter_op A op z x N0 = z. Proof. trivial. Qed. - -Lemma iter_op_1_r {A} op z x : @N.iter_op A op z x (N.pos xH) = x. Proof. trivial. Qed. - -Lemma iter_op_succ_r {A} op z x n - (opp_z_r : x = op x z) - (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) - : @N.iter_op A op z x (N.succ n) = op x (N.iter_op op z x n). -Proof. case n; cbn; auto using Pos.iter_op_succ. Qed. - -Lemma iter_op_add_r {A} op z x n - (opp_z_r : x = op x z) - (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) - : @N.iter_op A op z x (N.succ n) = op x (N.iter_op op z x n). -Proof. induction n using N.peano_ind; cbn; rewrite ?iter_op_succ_r; auto. Qed. - -Lemma iter_op_correct {A} op z x n - (opp_z_r : x = op x z) - (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) - : @N.iter_op A op z x n = N.iter n (op x) z. -Proof. case n; cbn; auto using Pos.iter_op_correct. Qed. + Lemma pos_pred_shiftl_low : forall p n m, m + testbit (Pos.pred_N (Pos.shiftl p n)) m = true. + Proof. + intros p n; induction n as [|n IHn] using peano_ind. + - now intro m; destruct m. + - intros m H. unfold Pos.shiftl. + destruct n as [|n]; simpl in *. + + destruct m. + * now destruct p. + * elim (Pos.nlt_1_r _ H). + + rewrite Pos.iter_succ. simpl. + set (u:=Pos.iter xO p n) in *; clearbody u. + destruct m as [|m]. + * now destruct u. + * rewrite <- (IHn (Pos.pred_N m)). + -- rewrite <- (testbit_odd_succ _ (Pos.pred_N m)). + ++ rewrite succ_pos_pred. now destruct u. + ++ apply le_0_l. + -- apply succ_lt_mono. now rewrite succ_pos_pred. + Qed. + + Lemma pos_pred_shiftl_high : forall p n m, n<=m -> + testbit (Pos.pred_N (Pos.shiftl p n)) m = + testbit (shiftl (Pos.pred_N p) n) m. + Proof. + intros p n; induction n as [|n IHn] using peano_ind; intros m H. + - unfold shiftl. simpl. now destruct (Pos.pred_N p). + - rewrite shiftl_succ_r. + destruct n as [|n]. + + destruct m as [|m]. + * now destruct H. + * now destruct p. + + destruct m as [|m]. + * now destruct H. + * rewrite <- (succ_pos_pred m). + rewrite double_spec, testbit_even_succ by apply le_0_l. + rewrite <- IHn. + -- rewrite testbit_succ_r_div2 by apply le_0_l. + f_equal. simpl. rewrite Pos.iter_succ. + now destruct (Pos.iter xO p n). + -- apply succ_le_mono. now rewrite succ_pos_pred. + Qed. + + Lemma pred_div2_up p : Pos.pred_N (Pos.div2_up p) = div2 (Pos.pred_N p). + Proof. + destruct p as [p|p| ]; trivial. + - simpl. apply Pos.pred_N_succ. + - destruct p; simpl; trivial. + Qed. + + (** ** Properties of [iter] *) + + Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : + (forall a, f (g a) = h (f a)) -> forall n a, + f (iter n g a) = iter n h (f a). + Proof. + intros H n; destruct n; simpl; intros; rewrite ?H; trivial. + now apply Pos.iter_swap_gen. + Qed. + + Theorem iter_swap : + forall n (A:Type) (f:A -> A) (x:A), + iter n f (f x) = f (iter n f x). + Proof. + intros. symmetry. now apply iter_swap_gen. + Qed. + + Theorem iter_succ : + forall n (A:Type) (f:A -> A) (x:A), + iter (succ n) f x = f (iter n f x). + Proof. + intro n; destruct n; intros; simpl; trivial. + now apply Pos.iter_succ. + Qed. + + Theorem iter_succ_r : + forall n (A:Type) (f:A -> A) (x:A), + iter (succ n) f x = iter n f (f x). + Proof. + intros; now rewrite iter_succ, iter_swap. + Qed. + + Theorem iter_add : + forall p q (A:Type) (f:A -> A) (x:A), + iter (p+q) f x = iter p f (iter q f x). + Proof. + intro p; induction p as [|p IHp] using peano_ind; intros; trivial. + now rewrite add_succ_l, !iter_succ, IHp. + Qed. + + Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop) : + P 0 a -> + (forall n a', P n a' -> P (succ n) (f a')) -> + forall n, P n (iter n f a). + Proof. + intros ? ? n; induction n using peano_ind; trivial. + rewrite iter_succ; auto. + Qed. + + Theorem iter_invariant : + forall (n:N) (A:Type) (f:A -> A) (Inv:A -> Prop), + (forall x:A, Inv x -> Inv (f x)) -> + forall x:A, Inv x -> Inv (iter n f x). + Proof. + intros; apply iter_ind; trivial. + Qed. + + (** Properties of [iter_op] *) + + Lemma iter_op_0_r {A} op z x : @N.iter_op A op z x N0 = z. Proof. trivial. Qed. + + Lemma iter_op_1_r {A} op z x : @N.iter_op A op z x (N.pos xH) = x. Proof. trivial. Qed. + + Lemma iter_op_succ_r {A} op z x n + (opp_z_r : x = op x z) + (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) + : @N.iter_op A op z x (N.succ n) = op x (N.iter_op op z x n). + Proof. case n; cbn; auto using Pos.iter_op_succ. Qed. + + Lemma iter_op_add_r {A} op z x n + (opp_z_r : x = op x z) + (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) + : @N.iter_op A op z x (N.succ n) = op x (N.iter_op op z x n). + Proof. induction n using N.peano_ind; cbn; rewrite ?iter_op_succ_r; auto. Qed. + + Lemma iter_op_correct {A} op z x n + (opp_z_r : x = op x z) + (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) + : @N.iter_op A op z x n = N.iter n (op x) z. + Proof. case n; cbn; auto using Pos.iter_op_correct. Qed. End N. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 3fdb67e900..ce9e4daf89 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -24,326 +24,326 @@ From Stdlib Require Export BinNums.NatDef. Module N. -Include BinNums.NatDef.N. + Include BinNums.NatDef.N. -Definition t := N. + Definition t := N. -(** ** Nicer name [N.pos] for constructor [Npos] *) + (** ** Nicer name [N.pos] for constructor [Npos] *) -#[global] Notation pos := Npos. + #[global] Notation pos := Npos. -(** ** Constants *) + (** ** Constants *) -Definition zero := 0. -Definition one := 1. -Definition two := 2. + Definition zero := 0. + Definition one := 1. + Definition two := 2. -(** ** Successor *) + (** ** Successor *) -Definition succ n := - match n with - | 0 => 1 - | pos p => pos (Pos.succ p) - end. + Definition succ n := + match n with + | 0 => 1 + | pos p => pos (Pos.succ p) + end. -(** ** Predecessor *) + (** ** Predecessor *) -Definition pred n := - match n with - | 0 => 0 - | pos p => Pos.pred_N p - end. + Definition pred n := + match n with + | 0 => 0 + | pos p => Pos.pred_N p + end. -(** ** Addition *) + (** ** Addition *) -Definition add n m := - match n, m with - | 0, _ => m - | _, 0 => n - | pos p, pos q => pos (p + q) - end. + Definition add n m := + match n, m with + | 0, _ => m + | _, 0 => n + | pos p, pos q => pos (p + q) + end. -Infix "+" := add : N_scope. + Infix "+" := add : N_scope. -Infix "-" := sub : N_scope. + Infix "-" := sub : N_scope. -(** Multiplication *) + (** Multiplication *) -Definition mul n m := - match n, m with - | 0, _ => 0 - | _, 0 => 0 - | pos p, pos q => pos (p * q) - end. + Definition mul n m := + match n, m with + | 0, _ => 0 + | _, 0 => 0 + | pos p, pos q => pos (p * q) + end. -Infix "*" := mul : N_scope. + Infix "*" := mul : N_scope. -Infix "?=" := compare (at level 70, no associativity) : N_scope. + Infix "?=" := compare (at level 70, no associativity) : N_scope. -(** Boolean equality and comparison *) + (** Boolean equality and comparison *) -Definition eqb n m := - match n, m with - | 0, 0 => true - | pos p, pos q => Pos.eqb p q - | _, _ => false - end. + Definition eqb n m := + match n, m with + | 0, 0 => true + | pos p, pos q => Pos.eqb p q + | _, _ => false + end. -Definition ltb x y := - match x ?= y with Lt => true | _ => false end. + Definition ltb x y := + match x ?= y with Lt => true | _ => false end. -Infix "=?" := eqb (at level 70, no associativity) : N_scope. -Infix "<=?" := leb (at level 70, no associativity) : N_scope. -Infix " n - | Gt => n' - end. + Definition min n n' := match n ?= n' with + | Lt | Eq => n + | Gt => n' + end. -Definition max n n' := match n ?= n' with - | Lt | Eq => n' - | Gt => n - end. + Definition max n n' := match n ?= n' with + | Lt | Eq => n' + | Gt => n + end. -(** Dividing by 2 *) + (** Dividing by 2 *) -Definition div2 n := - match n with - | 0 => 0 - | 1 => 0 - | pos (p~0) => pos p - | pos (p~1) => pos p - end. + Definition div2 n := + match n with + | 0 => 0 + | 1 => 0 + | pos (p~0) => pos p + | pos (p~1) => pos p + end. -(** Parity *) + (** Parity *) -Definition even n := - match n with - | 0 => true - | pos (xO _) => true - | _ => false - end. + Definition even n := + match n with + | 0 => true + | pos (xO _) => true + | _ => false + end. -Definition odd n := negb (even n). + Definition odd n := negb (even n). -(** Power *) + (** Power *) -Definition pow n p := - match p, n with - | 0, _ => 1 - | _, 0 => 0 - | pos p, pos q => pos (q^p) - end. + Definition pow n p := + match p, n with + | 0, _ => 1 + | _, 0 => 0 + | pos p, pos q => pos (q^p) + end. -Infix "^" := pow : N_scope. + Infix "^" := pow : N_scope. -(** Square *) + (** Square *) -Definition square n := - match n with - | 0 => 0 - | pos p => pos (Pos.square p) - end. + Definition square n := + match n with + | 0 => 0 + | pos p => pos (Pos.square p) + end. -(** Base-2 logarithm *) + (** Base-2 logarithm *) -Definition log2 n := - match n with - | 0 => 0 - | 1 => 0 - | pos (p~0) => pos (Pos.size p) - | pos (p~1) => pos (Pos.size p) - end. + Definition log2 n := + match n with + | 0 => 0 + | 1 => 0 + | pos (p~0) => pos (Pos.size p) + | pos (p~1) => pos (Pos.size p) + end. -(** How many digits in a number ? + (** How many digits in a number ? Number 0 is said to have no digits at all. *) -Definition size n := - match n with - | 0 => 0 - | pos p => pos (Pos.size p) - end. + Definition size n := + match n with + | 0 => 0 + | pos p => pos (Pos.size p) + end. -Definition size_nat n := - match n with - | 0 => O - | pos p => Pos.size_nat p - end. + Definition size_nat n := + match n with + | 0 => O + | pos p => Pos.size_nat p + end. -(** Euclidean division *) + (** Euclidean division *) -Definition div_eucl (a b:N) : N * N := - match a, b with - | 0, _ => (0, 0) - | _, 0 => (0, a) - | pos na, _ => pos_div_eucl na b - end. + Definition div_eucl (a b:N) : N * N := + match a, b with + | 0, _ => (0, 0) + | _, 0 => (0, a) + | pos na, _ => pos_div_eucl na b + end. -Definition div a b := fst (div_eucl a b). -Definition modulo a b := snd (div_eucl a b). + Definition div a b := fst (div_eucl a b). + Definition modulo a b := snd (div_eucl a b). -Infix "/" := div : N_scope. -Infix "mod" := modulo (at level 40, no associativity) : N_scope. + Infix "/" := div : N_scope. + Infix "mod" := modulo (at level 40, no associativity) : N_scope. -(** Greatest common divisor *) + (** Greatest common divisor *) -Definition gcd a b := - match a, b with - | 0, _ => b - | _, 0 => a - | pos p, pos q => pos (Pos.gcd p q) - end. + Definition gcd a b := + match a, b with + | 0, _ => b + | _, 0 => a + | pos p, pos q => pos (Pos.gcd p q) + end. -(** Generalized Gcd, also computing rests of [a] and [b] after + (** Generalized Gcd, also computing rests of [a] and [b] after division by gcd. *) -Definition ggcd a b := - match a, b with - | 0, _ => (b,(0,1)) - | _, 0 => (a,(1,0)) - | pos p, pos q => - let '(g,(aa,bb)) := Pos.ggcd p q in - (pos g, (pos aa, pos bb)) - end. - -(** Square root *) - -Definition sqrtrem n := - match n with - | 0 => (0, 0) - | pos p => - match Pos.sqrtrem p with - | (s, IsPos r) => (pos s, pos r) - | (s, _) => (pos s, 0) - end - end. - -Definition sqrt n := - match n with - | 0 => 0 - | pos p => pos (Pos.sqrt p) - end. - -(** Shifts *) - -Definition shiftl_nat (a:N) := nat_rect _ a (fun _ => double). -Definition shiftr_nat (a:N) := nat_rect _ a (fun _ => div2). - -Definition shiftl a n := - match a with + Definition ggcd a b := + match a, b with + | 0, _ => (b,(0,1)) + | _, 0 => (a,(1,0)) + | pos p, pos q => + let '(g,(aa,bb)) := Pos.ggcd p q in + (pos g, (pos aa, pos bb)) + end. + + (** Square root *) + + Definition sqrtrem n := + match n with + | 0 => (0, 0) + | pos p => + match Pos.sqrtrem p with + | (s, IsPos r) => (pos s, pos r) + | (s, _) => (pos s, 0) + end + end. + + Definition sqrt n := + match n with | 0 => 0 - | pos a => pos (Pos.shiftl a n) - end. + | pos p => pos (Pos.sqrt p) + end. + + (** Shifts *) + + Definition shiftl_nat (a:N) := nat_rect _ a (fun _ => double). + Definition shiftr_nat (a:N) := nat_rect _ a (fun _ => div2). + + Definition shiftl a n := + match a with + | 0 => 0 + | pos a => pos (Pos.shiftl a n) + end. -Definition shiftr a n := - match n with - | 0 => a - | pos p => Pos.iter div2 a p - end. + Definition shiftr a n := + match n with + | 0 => a + | pos p => Pos.iter div2 a p + end. -(** Checking whether a particular bit is set or not *) + (** Checking whether a particular bit is set or not *) -Definition testbit_nat (a:N) := - match a with - | 0 => fun _ => false - | pos p => Pos.testbit_nat p - end. + Definition testbit_nat (a:N) := + match a with + | 0 => fun _ => false + | pos p => Pos.testbit_nat p + end. -(** Same, but with index in N *) + (** Same, but with index in N *) -Definition testbit a n := - match a with - | 0 => false - | pos p => Pos.testbit p n - end. + Definition testbit a n := + match a with + | 0 => false + | pos p => Pos.testbit p n + end. -(** Translation from [N] to [nat] and back. *) + (** Translation from [N] to [nat] and back. *) -Definition to_nat (a:N) := - match a with - | 0 => O - | pos p => Pos.to_nat p - end. + Definition to_nat (a:N) := + match a with + | 0 => O + | pos p => Pos.to_nat p + end. -Definition of_nat (n:nat) := - match n with - | O => 0 - | S n' => pos (Pos.of_succ_nat n') - end. + Definition of_nat (n:nat) := + match n with + | O => 0 + | S n' => pos (Pos.of_succ_nat n') + end. -(** Iteration of a function *) + (** Iteration of a function *) -Definition iter (n:N) {A} (f:A->A) (x:A) : A := - match n with - | 0 => x - | pos p => Pos.iter f x p - end. + Definition iter (n:N) {A} (f:A->A) (x:A) : A := + match n with + | 0 => x + | pos p => Pos.iter f x p + end. -(** Iteration of an associative operator *) + (** Iteration of an associative operator *) -Definition iter_op {A} (op : A -> A -> A) (z x : A) (n : N) := - match n with N0 => z | Npos p => Pos.iter_op op p x end. + Definition iter_op {A} (op : A -> A -> A) (z x : A) (n : N) := + match n with N0 => z | Npos p => Pos.iter_op op p x end. -(** Conversion with a decimal representation for printing/parsing *) + (** Conversion with a decimal representation for printing/parsing *) -Definition of_uint (d:Decimal.uint) := Pos.of_uint d. + Definition of_uint (d:Decimal.uint) := Pos.of_uint d. -Definition of_hex_uint (d:Hexadecimal.uint) := Pos.of_hex_uint d. + Definition of_hex_uint (d:Hexadecimal.uint) := Pos.of_hex_uint d. -Definition of_num_uint (d:Number.uint) := - match d with - | Number.UIntDecimal d => of_uint d - | Number.UIntHexadecimal d => of_hex_uint d - end. + Definition of_num_uint (d:Number.uint) := + match d with + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d + end. -Definition of_int (d:Decimal.int) := - match Decimal.norm d with - | Decimal.Pos d => Some (Pos.of_uint d) - | Decimal.Neg _ => None - end. + Definition of_int (d:Decimal.int) := + match Decimal.norm d with + | Decimal.Pos d => Some (Pos.of_uint d) + | Decimal.Neg _ => None + end. -Definition of_hex_int (d:Hexadecimal.int) := - match Hexadecimal.norm d with - | Hexadecimal.Pos d => Some (Pos.of_hex_uint d) - | Hexadecimal.Neg _ => None - end. + Definition of_hex_int (d:Hexadecimal.int) := + match Hexadecimal.norm d with + | Hexadecimal.Pos d => Some (Pos.of_hex_uint d) + | Hexadecimal.Neg _ => None + end. -Definition of_num_int (d:Number.int) := - match d with - | Number.IntDecimal d => of_int d - | Number.IntHexadecimal d => of_hex_int d - end. + Definition of_num_int (d:Number.int) := + match d with + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d + end. -Definition to_uint n := - match n with - | 0 => Decimal.zero - | pos p => Pos.to_uint p - end. + Definition to_uint n := + match n with + | 0 => Decimal.zero + | pos p => Pos.to_uint p + end. -Definition to_hex_uint n := - match n with - | 0 => Hexadecimal.zero - | pos p => Pos.to_hex_uint p - end. + Definition to_hex_uint n := + match n with + | 0 => Hexadecimal.zero + | pos p => Pos.to_hex_uint p + end. -Definition to_num_uint n := Number.UIntDecimal (to_uint n). + Definition to_num_uint n := Number.UIntDecimal (to_uint n). -Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). + Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). -Definition to_int n := Decimal.Pos (to_uint n). + Definition to_int n := Decimal.Pos (to_uint n). -Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). + Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Number.IntDecimal (to_int n). + Definition to_num_int n := Number.IntDecimal (to_int n). -Definition to_num_hex_int n := Number.IntHexadecimal (to_hex_int n). + Definition to_num_hex_int n := Number.IntHexadecimal (to_hex_int n). -Number Notation N of_num_uint to_num_hex_uint : hex_N_scope. -Number Notation N of_num_uint to_num_uint : N_scope. + Number Notation N of_num_uint to_num_hex_uint : hex_N_scope. + Number Notation N of_num_uint to_num_uint : N_scope. End N. diff --git a/theories/NArith/NArith_base.v b/theories/NArith/NArith_base.v index c60b2c7aa2..e2f4020ed3 100644 --- a/theories/NArith/NArith_base.v +++ b/theories/NArith/NArith_base.v @@ -26,8 +26,8 @@ From Stdlib Require Export Ngcd_def. #[local] Open Scope N_scope. Section TestOrder. - Let test : forall x y, x<=y -> y<=x -> x=y. - Proof. - N.order. - Defined. + Let test : forall x y, x<=y -> y<=x -> x=y. + Proof. + N.order. + Defined. End TestOrder. diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index c4c64c2cb0..b994071573 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -141,8 +141,8 @@ Definition Nleb (a b:N) := leb (N.to_nat a) (N.to_nat b). Lemma Nleb_alt a b : Nleb a b = N.leb a b. Proof. - unfold Nleb. - now rewrite eq_iff_eq_true, N.leb_le, leb_compare, <- N2Nat.inj_compare. + unfold Nleb. + now rewrite eq_iff_eq_true, N.leb_le, leb_compare, <- N2Nat.inj_compare. Qed. Lemma Nleb_Nle a b : Nleb a b = true <-> a <= b. @@ -275,7 +275,7 @@ Proof. apply <- Nltb_Ncompare; auto. Qed. Lemma Ncompare_Lt_Nltb a b : N.compare a b = Lt -> Nleb b a = false. Proof. - intros H. rewrite Nltb_Ncompare, N.compare_antisym, H; auto. + intros H. rewrite Nltb_Ncompare, N.compare_antisym, H; auto. Qed. (* Old results about [N.min] *) diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 07f18ec04a..a677684ebe 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -14,150 +14,150 @@ From Stdlib Require Import BinPos BinNat PeanoNat Pnat. Module N2Nat. -(** [N.to_nat] is a bijection between [N] and [nat], + (** [N.to_nat] is a bijection between [N] and [nat], with [N.of_nat] as reciprocal. See [Nat2N.id] below for the dual equation. *) -Lemma id a : N.of_nat (N.to_nat a) = a. -Proof. - destruct a as [| p]; simpl; trivial. - destruct (Pos2Nat.is_succ p) as (n,H). rewrite H. simpl. f_equal. - apply Pos2Nat.inj. rewrite H. apply SuccNat2Pos.id_succ. -Qed. - -(** [N.to_nat] is hence injective *) - -Lemma inj a a' : N.to_nat a = N.to_nat a' -> a = a'. -Proof. - intro H. rewrite <- (id a), <- (id a'). now f_equal. -Qed. - -Lemma inj_iff a a' : N.to_nat a = N.to_nat a' <-> a = a'. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. - -(** Interaction of this translation and usual operations. *) - -Lemma inj_0 : N.to_nat 0 = 0. -Proof. reflexivity. Qed. - -Lemma inj_double a : N.to_nat (N.double a) = 2*(N.to_nat a). -Proof. - destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xO. -Qed. - -Lemma inj_succ_double a : N.to_nat (N.succ_double a) = S (2*(N.to_nat a)). -Proof. - destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xI. -Qed. - -Lemma inj_succ a : N.to_nat (N.succ a) = S (N.to_nat a). -Proof. - destruct a; simpl; trivial. apply Pos2Nat.inj_succ. -Qed. - -Lemma inj_add a a' : - N.to_nat (a + a') = N.to_nat a + N.to_nat a'. -Proof. - destruct a, a'; simpl; trivial. apply Pos2Nat.inj_add. -Qed. - -Lemma inj_mul a a' : - N.to_nat (a * a') = N.to_nat a * N.to_nat a'. -Proof. - destruct a, a'; simpl; trivial. apply Pos2Nat.inj_mul. -Qed. - -Lemma inj_sub a a' : - N.to_nat (a - a') = N.to_nat a - N.to_nat a'. -Proof. - destruct a as [|a], a' as [|a']; simpl; rewrite ?Nat.sub_0_r; trivial. - destruct (Pos.compare_spec a a') as [H|H|H]. - - subst. now rewrite Pos.sub_mask_diag, Nat.sub_diag. - - rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H. - simpl; symmetry; apply Nat.sub_0_le. now apply Nat.lt_le_incl. - - destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq). - simpl; symmetry; apply Nat.add_sub_eq_l. now rewrite <- Hq, Pos2Nat.inj_add. -Qed. - -Lemma inj_pred a : N.to_nat (N.pred a) = Nat.pred (N.to_nat a). -Proof. - rewrite <- Nat.sub_1_r, N.pred_sub. apply inj_sub. -Qed. - -Lemma inj_div2 a : N.to_nat (N.div2 a) = Nat.div2 (N.to_nat a). -Proof. - destruct a as [|[p|p| ]]; trivial. - - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xI, Nat.div2_succ_double. - - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xO, Nat.div2_double. -Qed. - -Lemma inj_compare a a' : - (a ?= a')%N = (N.to_nat a ?= N.to_nat a'). -Proof. - destruct a as [|p], a' as [|p']; simpl; trivial. - - now destruct (Pos2Nat.is_succ p') as (n,->). - - now destruct (Pos2Nat.is_succ p) as (n,->). - - apply Pos2Nat.inj_compare. -Qed. - -Lemma inj_div n m : - N.to_nat (n / m) = N.to_nat n / N.to_nat m. -Proof. - destruct m as [|m]; [now destruct n|]. - apply Nat.div_unique with (N.to_nat (n mod (N.pos m))). - - apply Nat.compare_lt_iff. rewrite <- inj_compare. - now apply N.mod_lt. - - now rewrite <- inj_mul, <- inj_add, <- N.div_mod. -Qed. - -Lemma inj_mod a a' : - N.to_nat (a mod a') = N.to_nat a mod N.to_nat a'. -Proof. - destruct a' as [|a']; [now destruct a|]. - apply Nat.mod_unique with (N.to_nat (a / (N.pos a'))). - - apply Nat.compare_lt_iff. rewrite <- inj_compare. - now apply N.mod_lt. - - now rewrite <- inj_mul, <- inj_add, <- N.div_mod. -Qed. - -Lemma inj_pow a a' : - N.to_nat (a ^ a') = N.to_nat a ^ N.to_nat a'. -Proof. - destruct a, a'; [easy| |easy|apply Pos2Nat.inj_pow]. - now rewrite N.pow_0_l, Nat.pow_0_l; [|rewrite <- inj_0; intros ? %inj|]. -Qed. - -Lemma inj_max a a' : - N.to_nat (N.max a a') = Nat.max (N.to_nat a) (N.to_nat a'). -Proof. - unfold N.max. rewrite inj_compare; symmetry. - case Nat.compare_spec; intros. - - now apply Nat.max_r, Nat.eq_le_incl. - - now apply Nat.max_r, Nat.lt_le_incl. - - now apply Nat.max_l, Nat.lt_le_incl. -Qed. - -Lemma inj_min a a' : - N.to_nat (N.min a a') = Nat.min (N.to_nat a) (N.to_nat a'). -Proof. - unfold N.min; rewrite inj_compare. symmetry. - case Nat.compare_spec; intros. - - now apply Nat.min_l, Nat.eq_le_incl. - - now apply Nat.min_l, Nat.lt_le_incl. - - now apply Nat.min_r, Nat.lt_le_incl. -Qed. - -Lemma inj_iter a {A} (f:A->A) (x:A) : - N.iter a f x = Nat.iter (N.to_nat a) f x. -Proof. - destruct a as [|a]. - - trivial. - - apply Pos2Nat.inj_iter. -Qed. + Lemma id a : N.of_nat (N.to_nat a) = a. + Proof. + destruct a as [| p]; simpl; trivial. + destruct (Pos2Nat.is_succ p) as (n,H). rewrite H. simpl. f_equal. + apply Pos2Nat.inj. rewrite H. apply SuccNat2Pos.id_succ. + Qed. + + (** [N.to_nat] is hence injective *) + + Lemma inj a a' : N.to_nat a = N.to_nat a' -> a = a'. + Proof. + intro H. rewrite <- (id a), <- (id a'). now f_equal. + Qed. + + Lemma inj_iff a a' : N.to_nat a = N.to_nat a' <-> a = a'. + Proof. + split. + - apply inj. + - intros; now subst. + Qed. + + (** Interaction of this translation and usual operations. *) + + Lemma inj_0 : N.to_nat 0 = 0. + Proof. reflexivity. Qed. + + Lemma inj_double a : N.to_nat (N.double a) = 2*(N.to_nat a). + Proof. + destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xO. + Qed. + + Lemma inj_succ_double a : N.to_nat (N.succ_double a) = S (2*(N.to_nat a)). + Proof. + destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xI. + Qed. + + Lemma inj_succ a : N.to_nat (N.succ a) = S (N.to_nat a). + Proof. + destruct a; simpl; trivial. apply Pos2Nat.inj_succ. + Qed. + + Lemma inj_add a a' : + N.to_nat (a + a') = N.to_nat a + N.to_nat a'. + Proof. + destruct a, a'; simpl; trivial. apply Pos2Nat.inj_add. + Qed. + + Lemma inj_mul a a' : + N.to_nat (a * a') = N.to_nat a * N.to_nat a'. + Proof. + destruct a, a'; simpl; trivial. apply Pos2Nat.inj_mul. + Qed. + + Lemma inj_sub a a' : + N.to_nat (a - a') = N.to_nat a - N.to_nat a'. + Proof. + destruct a as [|a], a' as [|a']; simpl; rewrite ?Nat.sub_0_r; trivial. + destruct (Pos.compare_spec a a') as [H|H|H]. + - subst. now rewrite Pos.sub_mask_diag, Nat.sub_diag. + - rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H. + simpl; symmetry; apply Nat.sub_0_le. now apply Nat.lt_le_incl. + - destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq). + simpl; symmetry; apply Nat.add_sub_eq_l. now rewrite <- Hq, Pos2Nat.inj_add. + Qed. + + Lemma inj_pred a : N.to_nat (N.pred a) = Nat.pred (N.to_nat a). + Proof. + rewrite <- Nat.sub_1_r, N.pred_sub. apply inj_sub. + Qed. + + Lemma inj_div2 a : N.to_nat (N.div2 a) = Nat.div2 (N.to_nat a). + Proof. + destruct a as [|[p|p| ]]; trivial. + - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xI, Nat.div2_succ_double. + - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xO, Nat.div2_double. + Qed. + + Lemma inj_compare a a' : + (a ?= a')%N = (N.to_nat a ?= N.to_nat a'). + Proof. + destruct a as [|p], a' as [|p']; simpl; trivial. + - now destruct (Pos2Nat.is_succ p') as (n,->). + - now destruct (Pos2Nat.is_succ p) as (n,->). + - apply Pos2Nat.inj_compare. + Qed. + + Lemma inj_div n m : + N.to_nat (n / m) = N.to_nat n / N.to_nat m. + Proof. + destruct m as [|m]; [now destruct n|]. + apply Nat.div_unique with (N.to_nat (n mod (N.pos m))). + - apply Nat.compare_lt_iff. rewrite <- inj_compare. + now apply N.mod_lt. + - now rewrite <- inj_mul, <- inj_add, <- N.div_mod. + Qed. + + Lemma inj_mod a a' : + N.to_nat (a mod a') = N.to_nat a mod N.to_nat a'. + Proof. + destruct a' as [|a']; [now destruct a|]. + apply Nat.mod_unique with (N.to_nat (a / (N.pos a'))). + - apply Nat.compare_lt_iff. rewrite <- inj_compare. + now apply N.mod_lt. + - now rewrite <- inj_mul, <- inj_add, <- N.div_mod. + Qed. + + Lemma inj_pow a a' : + N.to_nat (a ^ a') = N.to_nat a ^ N.to_nat a'. + Proof. + destruct a, a'; [easy| |easy|apply Pos2Nat.inj_pow]. + now rewrite N.pow_0_l, Nat.pow_0_l; [|rewrite <- inj_0; intros ? %inj|]. + Qed. + + Lemma inj_max a a' : + N.to_nat (N.max a a') = Nat.max (N.to_nat a) (N.to_nat a'). + Proof. + unfold N.max. rewrite inj_compare; symmetry. + case Nat.compare_spec; intros. + - now apply Nat.max_r, Nat.eq_le_incl. + - now apply Nat.max_r, Nat.lt_le_incl. + - now apply Nat.max_l, Nat.lt_le_incl. + Qed. + + Lemma inj_min a a' : + N.to_nat (N.min a a') = Nat.min (N.to_nat a) (N.to_nat a'). + Proof. + unfold N.min; rewrite inj_compare. symmetry. + case Nat.compare_spec; intros. + - now apply Nat.min_l, Nat.eq_le_incl. + - now apply Nat.min_l, Nat.lt_le_incl. + - now apply Nat.min_r, Nat.lt_le_incl. + Qed. + + Lemma inj_iter a {A} (f:A->A) (x:A) : + N.iter a f x = Nat.iter (N.to_nat a) f x. + Proof. + destruct a as [|a]. + - trivial. + - apply Pos2Nat.inj_iter. + Qed. End N2Nat. @@ -173,85 +173,85 @@ End N2Nat. Module Nat2N. -(** [N.of_nat] is an bijection between [nat] and [N], + (** [N.of_nat] is an bijection between [nat] and [N], with [N.to_nat] as reciprocal. See [N2Nat.id] above for the dual equation. *) -Lemma id n : N.to_nat (N.of_nat n) = n. -Proof. - induction n; simpl; trivial. apply SuccNat2Pos.id_succ. -Qed. + Lemma id n : N.to_nat (N.of_nat n) = n. + Proof. + induction n; simpl; trivial. apply SuccNat2Pos.id_succ. + Qed. -#[global] Hint Rewrite id : Nnat. -Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat. + #[global] Hint Rewrite id : Nnat. + Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat. -(** [N.of_nat] is hence injective *) + (** [N.of_nat] is hence injective *) -Lemma inj n n' : N.of_nat n = N.of_nat n' -> n = n'. -Proof. - intros H. rewrite <- (id n), <- (id n'). now f_equal. -Qed. + Lemma inj n n' : N.of_nat n = N.of_nat n' -> n = n'. + Proof. + intros H. rewrite <- (id n), <- (id n'). now f_equal. + Qed. -Lemma inj_iff n n' : N.of_nat n = N.of_nat n' <-> n = n'. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. + Lemma inj_iff n n' : N.of_nat n = N.of_nat n' <-> n = n'. + Proof. + split. + - apply inj. + - intros; now subst. + Qed. -(** Interaction of this translation and usual operations. *) + (** Interaction of this translation and usual operations. *) -Lemma inj_double n : N.of_nat (2*n) = N.double (N.of_nat n). -Proof. nat2N. Qed. + Lemma inj_double n : N.of_nat (2*n) = N.double (N.of_nat n). + Proof. nat2N. Qed. -Lemma inj_succ_double n : N.of_nat (S (2*n)) = N.succ_double (N.of_nat n). -Proof. nat2N. Qed. + Lemma inj_succ_double n : N.of_nat (S (2*n)) = N.succ_double (N.of_nat n). + Proof. nat2N. Qed. -Lemma inj_succ n : N.of_nat (S n) = N.succ (N.of_nat n). -Proof. nat2N. Qed. + Lemma inj_succ n : N.of_nat (S n) = N.succ (N.of_nat n). + Proof. nat2N. Qed. -Lemma inj_pred n : N.of_nat (Nat.pred n) = N.pred (N.of_nat n). -Proof. nat2N. Qed. + Lemma inj_pred n : N.of_nat (Nat.pred n) = N.pred (N.of_nat n). + Proof. nat2N. Qed. -Lemma inj_add n n' : N.of_nat (n+n') = (N.of_nat n + N.of_nat n')%N. -Proof. nat2N. Qed. + Lemma inj_add n n' : N.of_nat (n+n') = (N.of_nat n + N.of_nat n')%N. + Proof. nat2N. Qed. -Lemma inj_sub n n' : N.of_nat (n-n') = (N.of_nat n - N.of_nat n')%N. -Proof. nat2N. Qed. + Lemma inj_sub n n' : N.of_nat (n-n') = (N.of_nat n - N.of_nat n')%N. + Proof. nat2N. Qed. -Lemma inj_mul n n' : N.of_nat (n*n') = (N.of_nat n * N.of_nat n')%N. -Proof. nat2N. Qed. + Lemma inj_mul n n' : N.of_nat (n*n') = (N.of_nat n * N.of_nat n')%N. + Proof. nat2N. Qed. -Lemma inj_div2 n : N.of_nat (Nat.div2 n) = N.div2 (N.of_nat n). -Proof. nat2N. Qed. + Lemma inj_div2 n : N.of_nat (Nat.div2 n) = N.div2 (N.of_nat n). + Proof. nat2N. Qed. -Lemma inj_compare n n' : - (n ?= n') = (N.of_nat n ?= N.of_nat n')%N. -Proof. now rewrite N2Nat.inj_compare, !id. Qed. + Lemma inj_compare n n' : + (n ?= n') = (N.of_nat n ?= N.of_nat n')%N. + Proof. now rewrite N2Nat.inj_compare, !id. Qed. -Lemma inj_div n n' : - N.of_nat (n / n') = (N.of_nat n / N.of_nat n')%N. -Proof. nat2N. Qed. + Lemma inj_div n n' : + N.of_nat (n / n') = (N.of_nat n / N.of_nat n')%N. + Proof. nat2N. Qed. -Lemma inj_mod n n' : - N.of_nat (n mod n') = (N.of_nat n mod N.of_nat n')%N. -Proof. nat2N. Qed. + Lemma inj_mod n n' : + N.of_nat (n mod n') = (N.of_nat n mod N.of_nat n')%N. + Proof. nat2N. Qed. -Lemma inj_pow n n' : - N.of_nat (n ^ n') = (N.of_nat n ^ N.of_nat n')%N. -Proof. nat2N. Qed. + Lemma inj_pow n n' : + N.of_nat (n ^ n') = (N.of_nat n ^ N.of_nat n')%N. + Proof. nat2N. Qed. -Lemma inj_min n n' : - N.of_nat (Nat.min n n') = N.min (N.of_nat n) (N.of_nat n'). -Proof. nat2N. Qed. + Lemma inj_min n n' : + N.of_nat (Nat.min n n') = N.min (N.of_nat n) (N.of_nat n'). + Proof. nat2N. Qed. -Lemma inj_max n n' : - N.of_nat (Nat.max n n') = N.max (N.of_nat n) (N.of_nat n'). -Proof. nat2N. Qed. + Lemma inj_max n n' : + N.of_nat (Nat.max n n') = N.max (N.of_nat n) (N.of_nat n'). + Proof. nat2N. Qed. -Lemma inj_iter n {A} (f:A->A) (x:A) : - Nat.iter n f x = N.iter (N.of_nat n) f x. -Proof. now rewrite N2Nat.inj_iter, !id. Qed. + Lemma inj_iter n {A} (f:A->A) (x:A) : + Nat.iter n f x = N.iter (N.of_nat n) f x. + Proof. now rewrite N2Nat.inj_iter, !id. Qed. End Nat2N. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 74b07bb106..320fe01b17 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -28,307 +28,307 @@ From Stdlib Require Import DoubleType. Module ZnZ. - #[universes(template)] - Class Ops (t:Type) := MkOps { - - (* Conversion functions with Z *) - digits : positive; - zdigits: t; - to_Z : t -> Z; - of_pos : positive -> N * t; (* Euclidean division by [2^digits] *) - head0 : t -> t; (* number of digits 0 in front of the number *) - tail0 : t -> t; (* number of digits 0 at the bottom of the number *) - - (* Basic numbers *) - zero : t; - one : t; - minus_one : t; (* [2^digits-1], which is equivalent to [-1] *) - - (* Comparison *) - compare : t -> t -> comparison; - eq0 : t -> bool; - - (* Basic arithmetic operations *) - opp_c : t -> carry t; - opp : t -> t; - opp_carry : t -> t; (* the carry is known to be -1 *) - - succ_c : t -> carry t; - add_c : t -> t -> carry t; - add_carry_c : t -> t -> carry t; - succ : t -> t; - add : t -> t -> t; - add_carry : t -> t -> t; - - pred_c : t -> carry t; - sub_c : t -> t -> carry t; - sub_carry_c : t -> t -> carry t; - pred : t -> t; - sub : t -> t -> t; - sub_carry : t -> t -> t; - - mul_c : t -> t -> zn2z t; - mul : t -> t -> t; - square_c : t -> zn2z t; - - (* Special divisions operations *) - div21 : t -> t -> t -> t*t; - div_gt : t -> t -> t * t; (* specialized version of [div] *) - div : t -> t -> t * t; - - modulo_gt : t -> t -> t; (* specialized version of [mod] *) - modulo : t -> t -> t; - - gcd_gt : t -> t -> t; (* specialized version of [gcd] *) - gcd : t -> t -> t; - (* [add_mul_div p i j] is a combination of the [(digits-p)] + #[universes(template)] + Class Ops (t:Type) := MkOps { + + (* Conversion functions with Z *) + digits : positive; + zdigits: t; + to_Z : t -> Z; + of_pos : positive -> N * t; (* Euclidean division by [2^digits] *) + head0 : t -> t; (* number of digits 0 in front of the number *) + tail0 : t -> t; (* number of digits 0 at the bottom of the number *) + + (* Basic numbers *) + zero : t; + one : t; + minus_one : t; (* [2^digits-1], which is equivalent to [-1] *) + + (* Comparison *) + compare : t -> t -> comparison; + eq0 : t -> bool; + + (* Basic arithmetic operations *) + opp_c : t -> carry t; + opp : t -> t; + opp_carry : t -> t; (* the carry is known to be -1 *) + + succ_c : t -> carry t; + add_c : t -> t -> carry t; + add_carry_c : t -> t -> carry t; + succ : t -> t; + add : t -> t -> t; + add_carry : t -> t -> t; + + pred_c : t -> carry t; + sub_c : t -> t -> carry t; + sub_carry_c : t -> t -> carry t; + pred : t -> t; + sub : t -> t -> t; + sub_carry : t -> t -> t; + + mul_c : t -> t -> zn2z t; + mul : t -> t -> t; + square_c : t -> zn2z t; + + (* Special divisions operations *) + div21 : t -> t -> t -> t*t; + div_gt : t -> t -> t * t; (* specialized version of [div] *) + div : t -> t -> t * t; + + modulo_gt : t -> t -> t; (* specialized version of [mod] *) + modulo : t -> t -> t; + + gcd_gt : t -> t -> t; (* specialized version of [gcd] *) + gcd : t -> t -> t; + (* [add_mul_div p i j] is a combination of the [(digits-p)] low bits of [i] above the [p] high bits of [j]: [add_mul_div p i j = i*2^p+j/2^(digits-p)] *) - add_mul_div : t -> t -> t -> t; - (* [pos_mod p i] is [i mod 2^p] *) - pos_mod : t -> t -> t; + add_mul_div : t -> t -> t -> t; + (* [pos_mod p i] is [i mod 2^p] *) + pos_mod : t -> t -> t; - is_even : t -> bool; - (* square root *) - sqrt2 : t -> t -> t * carry t; - sqrt : t -> t; - (* bitwise operations *) - lor : t -> t -> t; - land : t -> t -> t; - lxor : t -> t -> t }. + is_even : t -> bool; + (* square root *) + sqrt2 : t -> t -> t * carry t; + sqrt : t -> t; + (* bitwise operations *) + lor : t -> t -> t; + land : t -> t -> t; + lxor : t -> t -> t }. - Section Specs. - Context {t : Set}{ops : Ops t}. + Section Specs. + Context {t : Set}{ops : Ops t}. - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - Let wB := base digits. + Let wB := base digits. - Notation "[+| c |]" := - (interp_carry 1 wB to_Z c) (at level 0, c at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB to_Z c) (at level 0, c at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB to_Z c) (at level 0, c at level 99). - Notation "[|| x ||]" := - (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). + Notation "[|| x ||]" := + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). - Class Specs := MkSpecs { + Class Specs := MkSpecs { - (* Conversion functions with Z *) - spec_to_Z : forall x, 0 <= [| x |] < wB; - spec_of_pos : forall p, - Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]; - spec_zdigits : [| zdigits |] = Zpos digits; - spec_more_than_1_digit: 1 < Zpos digits; + (* Conversion functions with Z *) + spec_to_Z : forall x, 0 <= [| x |] < wB; + spec_of_pos : forall p, + Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]; + spec_zdigits : [| zdigits |] = Zpos digits; + spec_more_than_1_digit: 1 < Zpos digits; - (* Basic numbers *) - spec_0 : [|zero|] = 0; - spec_1 : [|one|] = 1; - spec_m1 : [|minus_one|] = wB - 1; + (* Basic numbers *) + spec_0 : [|zero|] = 0; + spec_1 : [|one|] = 1; + spec_m1 : [|minus_one|] = wB - 1; - (* Comparison *) - spec_compare : forall x y, compare x y = ([|x|] ?= [|y|]); - (* NB: the spec of [eq0] is deliberately partial, + (* Comparison *) + spec_compare : forall x y, compare x y = ([|x|] ?= [|y|]); + (* NB: the spec of [eq0] is deliberately partial, see DoubleCyclic where [eq0 x = true <-> x = W0] *) - spec_eq0 : forall x, eq0 x = true -> [|x|] = 0; - (* Basic arithmetic operations *) - spec_opp_c : forall x, [-|opp_c x|] = -[|x|]; - spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB; - spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1; - - spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1; - spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]; - spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1; - spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB; - spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB; - spec_add_carry : - forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; - - spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1; - spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]; - spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1; - spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB; - spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB; - spec_sub_carry : - forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; - - spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]; - spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB; - spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]; - - (* Special divisions operations *) - spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - spec_div : forall a b, 0 < [|b|] -> - let (q,r) := div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - - spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|modulo_gt a b|] = [|a|] mod [|b|]; - spec_modulo : forall a b, 0 < [|b|] -> - [|modulo a b|] = [|a|] mod [|b|]; - - spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|gcd_gt a b|]; - spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]; - - - (* shift operations *) - spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits; - spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB; - spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits; - spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ; - spec_add_mul_div : forall x y p, - [|p|] <= Zpos digits -> - [| add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB; - spec_pos_mod : forall w p, - [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]); - (* sqrt *) - spec_is_even : forall x, - if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; - spec_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]; - spec_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2; - spec_lor : forall x y, [|lor x y|] = Z.lor [|x|] [|y|]; - spec_land : forall x y, [|land x y|] = Z.land [|x|] [|y|]; - spec_lxor : forall x y, [|lxor x y|] = Z.lxor [|x|] [|y|] - }. - - End Specs. - - Arguments Specs {t} ops. - - (** Generic construction of double words *) - - Section WW. - - Context {t : Set}{ops : Ops t}{specs : Specs ops}. - - Let wB := base digits. - - Definition WO' (eq0:t->bool) zero h := - if eq0 h then W0 else WW h zero. - - Definition WO := Eval lazy beta delta [WO'] in - let eq0 := ZnZ.eq0 in - let zero := ZnZ.zero in - WO' eq0 zero. - - Definition OW' (eq0:t->bool) zero l := - if eq0 l then W0 else WW zero l. - - Definition OW := Eval lazy beta delta [OW'] in - let eq0 := ZnZ.eq0 in - let zero := ZnZ.zero in - OW' eq0 zero. - - Definition WW' (eq0:t->bool) zero h l := - if eq0 h then OW' eq0 zero l else WW h l. - - Definition WW := Eval lazy beta delta [WW' OW'] in - let eq0 := ZnZ.eq0 in - let zero := ZnZ.zero in - WW' eq0 zero. - - Lemma spec_WO : forall h, - zn2z_to_Z wB to_Z (WO h) = (to_Z h)*wB. - Proof. - unfold zn2z_to_Z, WO; simpl; intros. - case_eq (eq0 h); intros. - - rewrite (spec_eq0 _ H); auto. - - rewrite spec_0; auto with zarith. - Qed. - - Lemma spec_OW : forall l, - zn2z_to_Z wB to_Z (OW l) = to_Z l. - Proof. - unfold zn2z_to_Z, OW; simpl; intros. - case_eq (eq0 l); intros. - - rewrite (spec_eq0 _ H); auto. - - rewrite spec_0; auto with zarith. - Qed. - - Lemma spec_WW : forall h l, - zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l. - Proof. - unfold WW; simpl; intros. - case_eq (eq0 h); intros. - - rewrite (spec_eq0 _ H); auto. - fold (OW l). - rewrite spec_OW; auto. - - simpl; auto. - Qed. - - End WW. - - (** Injecting [Z] numbers into a cyclic structure *) - - Section Of_Z. - - Context {t : Set}{ops : Ops t}{specs : Specs ops}. - - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - Theorem of_pos_correct: - forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p. - Proof. - intros p Hp. - generalize (spec_of_pos p). - case (of_pos p); intros n w1; simpl. - case n; auto with zarith. - intros p1 Hp1; contradict Hp; apply Z.le_ngt. - replace (base digits) with (1 * base digits + 0) by ring. - rewrite Hp1. - apply Z.add_le_mono. - - apply Z.mul_le_mono_nonneg. 1-2, 4: lia. - unfold base; auto with zarith. - - case (spec_to_Z w1); auto with zarith. - Qed. - - Definition of_Z z := - match z with - | Zpos p => snd (of_pos p) - | _ => zero - end. - - Theorem of_Z_correct: - forall p, 0 <= p < base digits -> [|of_Z p|] = p. - Proof. - intros p; case p; simpl; try rewrite spec_0; auto. - - intros; rewrite of_pos_correct; lia. - - intros p1 (H1, _); contradict H1; apply Z.lt_nge; red; simpl; auto. - Qed. - - End Of_Z. + spec_eq0 : forall x, eq0 x = true -> [|x|] = 0; + (* Basic arithmetic operations *) + spec_opp_c : forall x, [-|opp_c x|] = -[|x|]; + spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB; + spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1; + + spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1; + spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]; + spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1; + spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB; + spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB; + spec_add_carry : + forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; + + spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1; + spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]; + spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1; + spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB; + spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB; + spec_sub_carry : + forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; + + spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]; + spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB; + spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]; + + (* Special divisions operations *) + spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div : forall a b, 0 < [|b|] -> + let (q,r) := div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + + spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|modulo_gt a b|] = [|a|] mod [|b|]; + spec_modulo : forall a b, 0 < [|b|] -> + [|modulo a b|] = [|a|] mod [|b|]; + + spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|gcd_gt a b|]; + spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]; + + + (* shift operations *) + spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits; + spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB; + spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits; + spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ; + spec_add_mul_div : forall x y p, + [|p|] <= Zpos digits -> + [| add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB; + spec_pos_mod : forall w p, + [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]); + (* sqrt *) + spec_is_even : forall x, + if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; + spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]; + spec_sqrt : forall x, + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2; + spec_lor : forall x y, [|lor x y|] = Z.lor [|x|] [|y|]; + spec_land : forall x y, [|land x y|] = Z.land [|x|] [|y|]; + spec_lxor : forall x y, [|lxor x y|] = Z.lxor [|x|] [|y|] + }. + + End Specs. + + Arguments Specs {t} ops. + + (** Generic construction of double words *) + + Section WW. + + Context {t : Set}{ops : Ops t}{specs : Specs ops}. + + Let wB := base digits. + + Definition WO' (eq0:t->bool) zero h := + if eq0 h then W0 else WW h zero. + + Definition WO := Eval lazy beta delta [WO'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + WO' eq0 zero. + + Definition OW' (eq0:t->bool) zero l := + if eq0 l then W0 else WW zero l. + + Definition OW := Eval lazy beta delta [OW'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + OW' eq0 zero. + + Definition WW' (eq0:t->bool) zero h l := + if eq0 h then OW' eq0 zero l else WW h l. + + Definition WW := Eval lazy beta delta [WW' OW'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + WW' eq0 zero. + + Lemma spec_WO : forall h, + zn2z_to_Z wB to_Z (WO h) = (to_Z h)*wB. + Proof. + unfold zn2z_to_Z, WO; simpl; intros. + case_eq (eq0 h); intros. + - rewrite (spec_eq0 _ H); auto. + - rewrite spec_0; auto with zarith. + Qed. + + Lemma spec_OW : forall l, + zn2z_to_Z wB to_Z (OW l) = to_Z l. + Proof. + unfold zn2z_to_Z, OW; simpl; intros. + case_eq (eq0 l); intros. + - rewrite (spec_eq0 _ H); auto. + - rewrite spec_0; auto with zarith. + Qed. + + Lemma spec_WW : forall h l, + zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l. + Proof. + unfold WW; simpl; intros. + case_eq (eq0 h); intros. + - rewrite (spec_eq0 _ H); auto. + fold (OW l). + rewrite spec_OW; auto. + - simpl; auto. + Qed. + + End WW. + + (** Injecting [Z] numbers into a cyclic structure *) + + Section Of_Z. + + Context {t : Set}{ops : Ops t}{specs : Specs ops}. + + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + + Theorem of_pos_correct: + forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p. + Proof. + intros p Hp. + generalize (spec_of_pos p). + case (of_pos p); intros n w1; simpl. + case n; auto with zarith. + intros p1 Hp1; contradict Hp; apply Z.le_ngt. + replace (base digits) with (1 * base digits + 0) by ring. + rewrite Hp1. + apply Z.add_le_mono. + - apply Z.mul_le_mono_nonneg. 1-2, 4: lia. + unfold base; auto with zarith. + - case (spec_to_Z w1); auto with zarith. + Qed. + + Definition of_Z z := + match z with + | Zpos p => snd (of_pos p) + | _ => zero + end. + + Theorem of_Z_correct: + forall p, 0 <= p < base digits -> [|of_Z p|] = p. + Proof. + intros p; case p; simpl; try rewrite spec_0; auto. + - intros; rewrite of_pos_correct; lia. + - intros p1 (H1, _); contradict H1; apply Z.lt_nge; red; simpl; auto. + Qed. + + End Of_Z. End ZnZ. (** A modular specification grouping the earlier records. *) Module Type CyclicType. - Parameter t : Set. -#[global] - Declare Instance ops : ZnZ.Ops t. -#[global] - Declare Instance specs : ZnZ.Specs ops. + Parameter t : Set. + #[global] + Declare Instance ops : ZnZ.Ops t. + #[global] + Declare Instance specs : ZnZ.Specs ops. End CyclicType. @@ -336,102 +336,102 @@ End CyclicType. Module CyclicRing (Import Cyclic : CyclicType). -#[local] Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). - -Definition eq (n m : t) := [| n |] = [| m |]. - -#[local] Infix "==" := eq (at level 70). -#[local] Notation "0" := ZnZ.zero. -#[local] Notation "1" := ZnZ.one. -#[local] Infix "+" := ZnZ.add. -#[local] Infix "-" := ZnZ.sub. -#[local] Notation "- x" := (ZnZ.opp x). -#[local] Infix "*" := ZnZ.mul. -#[local] Notation wB := (base ZnZ.digits). - -#[global] Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul - ZnZ.spec_opp ZnZ.spec_sub - : cyclic. - -Ltac zify := unfold eq in *; autorewrite with cyclic. - -Lemma add_0_l : forall x, 0 + x == x. -Proof. -intros. zify. rewrite Z.add_0_l. -apply Zmod_small. apply ZnZ.spec_to_Z. -Qed. - -Lemma add_comm : forall x y, x + y == y + x. -Proof. -intros. zify. now rewrite Z.add_comm. -Qed. - -Lemma add_assoc : forall x y z, x + (y + z) == x + y + z. -Proof. -intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Z.add_assoc. -Qed. - -Lemma mul_1_l : forall x, 1 * x == x. -Proof. -intros. zify. rewrite Z.mul_1_l. -apply Zmod_small. apply ZnZ.spec_to_Z. -Qed. - -Lemma mul_comm : forall x y, x * y == y * x. -Proof. -intros. zify. now rewrite Z.mul_comm. -Qed. - -Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z. -Proof. -intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Z.mul_assoc. -Qed. - -Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. -Proof. -intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Z.mul_add_distr_r. -Qed. - -Lemma add_opp_r : forall x y, x + - y == x-y. -Proof. -intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Z.sub. -destruct (Z.eq_dec ([|y|] mod wB) 0) as [EQ|NEQ]. -- rewrite Z_mod_zero_opp_full, EQ, 2 Z.add_0_r; auto. -- rewrite Z_mod_nz_opp_full by auto. - rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l. - rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r. -Qed. - -Lemma add_opp_diag_r : forall x, x + - x == 0. -Proof. -intros. red. rewrite add_opp_r. zify. now rewrite Z.sub_diag, Zmod_0_l. -Qed. - -Lemma CyclicRing : ring_theory 0 1 ZnZ.add ZnZ.mul ZnZ.sub ZnZ.opp eq. -Proof. -constructor. -- exact add_0_l. -- exact add_comm. -- exact add_assoc. -- exact mul_1_l. -- exact mul_comm. -- exact mul_assoc. -- exact mul_add_distr_r. -- symmetry. apply add_opp_r. -- exact add_opp_diag_r. -Qed. - -Definition eqb x y := - match ZnZ.compare x y with Eq => true | _ => false end. - -Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. -Proof. - intros. unfold eqb, eq. - rewrite ZnZ.spec_compare. - case Z.compare_spec; split; (easy || lia). -Qed. - -Lemma eqb_correct : forall x y, eqb x y = true -> x==y. -Proof. now apply eqb_eq. Qed. + #[local] Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). + + Definition eq (n m : t) := [| n |] = [| m |]. + + #[local] Infix "==" := eq (at level 70). + #[local] Notation "0" := ZnZ.zero. + #[local] Notation "1" := ZnZ.one. + #[local] Infix "+" := ZnZ.add. + #[local] Infix "-" := ZnZ.sub. + #[local] Notation "- x" := (ZnZ.opp x). + #[local] Infix "*" := ZnZ.mul. + #[local] Notation wB := (base ZnZ.digits). + + #[global] Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul + ZnZ.spec_opp ZnZ.spec_sub + : cyclic. + + Ltac zify := unfold eq in *; autorewrite with cyclic. + + Lemma add_0_l : forall x, 0 + x == x. + Proof. + intros. zify. rewrite Z.add_0_l. + apply Zmod_small. apply ZnZ.spec_to_Z. + Qed. + + Lemma add_comm : forall x y, x + y == y + x. + Proof. + intros. zify. now rewrite Z.add_comm. + Qed. + + Lemma add_assoc : forall x y z, x + (y + z) == x + y + z. + Proof. + intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Z.add_assoc. + Qed. + + Lemma mul_1_l : forall x, 1 * x == x. + Proof. + intros. zify. rewrite Z.mul_1_l. + apply Zmod_small. apply ZnZ.spec_to_Z. + Qed. + + Lemma mul_comm : forall x y, x * y == y * x. + Proof. + intros. zify. now rewrite Z.mul_comm. + Qed. + + Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z. + Proof. + intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Z.mul_assoc. + Qed. + + Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. + Proof. + intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Z.mul_add_distr_r. + Qed. + + Lemma add_opp_r : forall x y, x + - y == x-y. + Proof. + intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Z.sub. + destruct (Z.eq_dec ([|y|] mod wB) 0) as [EQ|NEQ]. + - rewrite Z_mod_zero_opp_full, EQ, 2 Z.add_0_r; auto. + - rewrite Z_mod_nz_opp_full by auto. + rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l. + rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r. + Qed. + + Lemma add_opp_diag_r : forall x, x + - x == 0. + Proof. + intros. red. rewrite add_opp_r. zify. now rewrite Z.sub_diag, Zmod_0_l. + Qed. + + Lemma CyclicRing : ring_theory 0 1 ZnZ.add ZnZ.mul ZnZ.sub ZnZ.opp eq. + Proof. + constructor. + - exact add_0_l. + - exact add_comm. + - exact add_assoc. + - exact mul_1_l. + - exact mul_comm. + - exact mul_assoc. + - exact mul_add_distr_r. + - symmetry. apply add_opp_r. + - exact add_opp_diag_r. + Qed. + + Definition eqb x y := + match ZnZ.compare x y with Eq => true | _ => false end. + + Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. + Proof. + intros. unfold eqb, eq. + rewrite ZnZ.spec_compare. + case Z.compare_spec; split; (easy || lia). + Qed. + + Lemma eqb_correct : forall x y, eqb x y = true -> x==y. + Proof. now apply eqb_eq. Qed. End CyclicRing. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 4270701e7d..d387c61244 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -27,216 +27,216 @@ From Stdlib Require Import Lia. Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig. -#[local] Open Scope Z_scope. - -#[local] Notation wB := (base ZnZ.digits). - -#[local] Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). - -Definition eq (n m : t) := [| n |] = [| m |]. -Definition zero := ZnZ.zero. -Definition one := ZnZ.one. -Definition two := ZnZ.succ ZnZ.one. -Definition succ := ZnZ.succ. -Definition pred := ZnZ.pred. -Definition add := ZnZ.add. -Definition sub := ZnZ.sub. -Definition mul := ZnZ.mul. - -#[local] Infix "==" := eq (at level 70). -#[local] Notation "0" := zero. -#[local] Notation S := succ. -#[local] Notation P := pred. -#[local] Infix "+" := add. -#[local] Infix "-" := sub. -#[local] Infix "*" := mul. - -#[global] Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred - ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic. -Ltac zify := - unfold eq, zero, one, two, succ, pred, add, sub, mul in *; - autorewrite with cyclic. -Ltac zcongruence := repeat red; intros; zify; congruence. - -#[global] -Instance eq_equiv : Equivalence eq. -Proof. - split. 1-2: firstorder auto with crelations. - intros x y z; apply eq_trans. -Qed. - -#[local] Obligation Tactic := zcongruence. - -#[global] -Program Instance succ_wd : Proper (eq ==> eq) succ. -#[global] -Program Instance pred_wd : Proper (eq ==> eq) pred. -#[global] -Program Instance add_wd : Proper (eq ==> eq ==> eq) add. -#[global] -Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. -#[global] -Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. - -Theorem gt_wB_1 : 1 < wB. -Proof. -unfold base. apply Zpower_gt_1; unfold Z.lt; auto with zarith. -Qed. - -Theorem gt_wB_0 : 0 < wB. -Proof. -pose proof gt_wB_1; lia. -Qed. - -Lemma one_mod_wB : 1 mod wB = 1. -Proof. - rewrite Zmod_small. - - reflexivity. - - split. - + auto with zarith. - + apply gt_wB_1. -Qed. - -Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB. -Proof. -intro n. rewrite <- one_mod_wB at 2. now rewrite <- Zplus_mod. -Qed. - -Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB. -Proof. -intro n. rewrite <- one_mod_wB at 2. now rewrite Zminus_mod. -Qed. - -Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |]. -Proof. - intro n; rewrite Zmod_small. - - reflexivity. - - apply ZnZ.spec_to_Z. -Qed. - -Theorem pred_succ : forall n, P (S n) == n. -Proof. -intro n. zify. -rewrite <- pred_mod_wB. -replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod. -Qed. - -Theorem one_succ : one == succ zero. -Proof. -zify; simpl Z.add. now rewrite one_mod_wB. -Qed. - -Theorem two_succ : two == succ one. -Proof. -reflexivity. -Qed. - -Section Induction. - -Variable A : t -> Prop. -Hypothesis A_wd : Proper (eq ==> iff) A. -Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (S n). - (* Below, we use only -> direction *) - -Let B (n : Z) := A (ZnZ.of_Z n). - -Lemma B0 : B 0. -Proof. -unfold B. apply A0. -Qed. - -Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1). -Proof. -intros n H1 H2 H3. -unfold B in *. apply AS in H3. -setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). -- assumption. -- zify. - rewrite 2 ZnZ.of_Z_correct. 2-3: lia. - symmetry; apply Zmod_small; lia. -Qed. - -Theorem Zbounded_induction : - (forall Q : Z -> Prop, forall b : Z, - Q 0 -> - (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> - forall n, 0 <= n -> n < b -> Q n)%Z. -Proof. -intros Q b Q0 QS. -set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). -assert (H : forall n, 0 <= n -> Q' n). -- apply natlike_rec2; unfold Q'. - + destruct (Z.le_gt_cases b 0) as [H | H]. - * now right. - * left; now split. - + intros n H IH. destruct IH as [[IH1 IH2] | IH]. - * destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. - -- right; lia. - -- left. split; [ lia | now apply (QS n)]. - * right; auto with zarith. -- unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. - + assumption. - + now apply Z.le_ngt in H3. -Qed. - -Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. -Proof. -intros n [H1 H2]. -apply Zbounded_induction with wB. -- apply B0. -- apply BS. -- assumption. -- assumption. -Qed. - -Theorem bi_induction : forall n, A n. -Proof. -intro n. setoid_replace n with (ZnZ.of_Z (ZnZ.to_Z n)). -- apply B_holds. apply ZnZ.spec_to_Z. -- red. symmetry. apply ZnZ.of_Z_correct. - apply ZnZ.spec_to_Z. -Qed. - -End Induction. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intro n. zify. -rewrite Z.add_0_l. apply Zmod_small. apply ZnZ.spec_to_Z. -Qed. - -Theorem add_succ_l : forall n m, (S n) + m == S (n + m). -Proof. -intros n m. zify. -rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. -rewrite <- (Z.add_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l. -rewrite (Z.add_comm 1 [| m |]); now rewrite Z.add_assoc. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intro n. zify. rewrite Z.sub_0_r. apply NZ_to_Z_mod. -Qed. - -Theorem sub_succ_r : forall n m, n - (S m) == P (n - m). -Proof. -intros n m. zify. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l. -now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z - by ring. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intro n. now zify. -Qed. - -Theorem mul_succ_l : forall n m, (S n) * m == n * m + m. -Proof. -intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. -now rewrite Z.mul_add_distr_r, Z.mul_1_l. -Qed. - -Definition t := t. + #[local] Open Scope Z_scope. + + #[local] Notation wB := (base ZnZ.digits). + + #[local] Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). + + Definition eq (n m : t) := [| n |] = [| m |]. + Definition zero := ZnZ.zero. + Definition one := ZnZ.one. + Definition two := ZnZ.succ ZnZ.one. + Definition succ := ZnZ.succ. + Definition pred := ZnZ.pred. + Definition add := ZnZ.add. + Definition sub := ZnZ.sub. + Definition mul := ZnZ.mul. + + #[local] Infix "==" := eq (at level 70). + #[local] Notation "0" := zero. + #[local] Notation S := succ. + #[local] Notation P := pred. + #[local] Infix "+" := add. + #[local] Infix "-" := sub. + #[local] Infix "*" := mul. + + #[global] Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred + ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic. + Ltac zify := + unfold eq, zero, one, two, succ, pred, add, sub, mul in *; + autorewrite with cyclic. + Ltac zcongruence := repeat red; intros; zify; congruence. + + #[global] + Instance eq_equiv : Equivalence eq. + Proof. + split. 1-2: firstorder auto with crelations. + intros x y z; apply eq_trans. + Qed. + + #[local] Obligation Tactic := zcongruence. + + #[global] + Program Instance succ_wd : Proper (eq ==> eq) succ. + #[global] + Program Instance pred_wd : Proper (eq ==> eq) pred. + #[global] + Program Instance add_wd : Proper (eq ==> eq ==> eq) add. + #[global] + Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. + #[global] + Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. + + Theorem gt_wB_1 : 1 < wB. + Proof. + unfold base. apply Zpower_gt_1; unfold Z.lt; auto with zarith. + Qed. + + Theorem gt_wB_0 : 0 < wB. + Proof. + pose proof gt_wB_1; lia. + Qed. + + Lemma one_mod_wB : 1 mod wB = 1. + Proof. + rewrite Zmod_small. + - reflexivity. + - split. + + auto with zarith. + + apply gt_wB_1. + Qed. + + Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB. + Proof. + intro n. rewrite <- one_mod_wB at 2. now rewrite <- Zplus_mod. + Qed. + + Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB. + Proof. + intro n. rewrite <- one_mod_wB at 2. now rewrite Zminus_mod. + Qed. + + Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |]. + Proof. + intro n; rewrite Zmod_small. + - reflexivity. + - apply ZnZ.spec_to_Z. + Qed. + + Theorem pred_succ : forall n, P (S n) == n. + Proof. + intro n. zify. + rewrite <- pred_mod_wB. + replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod. + Qed. + + Theorem one_succ : one == succ zero. + Proof. + zify; simpl Z.add. now rewrite one_mod_wB. + Qed. + + Theorem two_succ : two == succ one. + Proof. + reflexivity. + Qed. + + Section Induction. + + Variable A : t -> Prop. + Hypothesis A_wd : Proper (eq ==> iff) A. + Hypothesis A0 : A 0. + Hypothesis AS : forall n, A n <-> A (S n). + (* Below, we use only -> direction *) + + Let B (n : Z) := A (ZnZ.of_Z n). + + Lemma B0 : B 0. + Proof. + unfold B. apply A0. + Qed. + + Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1). + Proof. + intros n H1 H2 H3. + unfold B in *. apply AS in H3. + setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). + - assumption. + - zify. + rewrite 2 ZnZ.of_Z_correct. 2-3: lia. + symmetry; apply Zmod_small; lia. + Qed. + + Theorem Zbounded_induction : + (forall Q : Z -> Prop, forall b : Z, + Q 0 -> + (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> + forall n, 0 <= n -> n < b -> Q n)%Z. + Proof. + intros Q b Q0 QS. + set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). + assert (H : forall n, 0 <= n -> Q' n). + - apply natlike_rec2; unfold Q'. + + destruct (Z.le_gt_cases b 0) as [H | H]. + * now right. + * left; now split. + + intros n H IH. destruct IH as [[IH1 IH2] | IH]. + * destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. + -- right; lia. + -- left. split; [ lia | now apply (QS n)]. + * right; auto with zarith. + - unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. + + assumption. + + now apply Z.le_ngt in H3. + Qed. + + Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. + Proof. + intros n [H1 H2]. + apply Zbounded_induction with wB. + - apply B0. + - apply BS. + - assumption. + - assumption. + Qed. + + Theorem bi_induction : forall n, A n. + Proof. + intro n. setoid_replace n with (ZnZ.of_Z (ZnZ.to_Z n)). + - apply B_holds. apply ZnZ.spec_to_Z. + - red. symmetry. apply ZnZ.of_Z_correct. + apply ZnZ.spec_to_Z. + Qed. + + End Induction. + + Theorem add_0_l : forall n, 0 + n == n. + Proof. + intro n. zify. + rewrite Z.add_0_l. apply Zmod_small. apply ZnZ.spec_to_Z. + Qed. + + Theorem add_succ_l : forall n m, (S n) + m == S (n + m). + Proof. + intros n m. zify. + rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. + rewrite <- (Z.add_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l. + rewrite (Z.add_comm 1 [| m |]); now rewrite Z.add_assoc. + Qed. + + Theorem sub_0_r : forall n, n - 0 == n. + Proof. + intro n. zify. rewrite Z.sub_0_r. apply NZ_to_Z_mod. + Qed. + + Theorem sub_succ_r : forall n m, n - (S m) == P (n - m). + Proof. + intros n m. zify. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l. + now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z + by ring. + Qed. + + Theorem mul_0_l : forall n, 0 * n == 0. + Proof. + intro n. now zify. + Qed. + + Theorem mul_succ_l : forall n m, (S n) * m == n * m + m. + Proof. + intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. + now rewrite Z.mul_add_distr_r, Z.mul_1_l. + Qed. + + Definition t := t. End NZCyclicAxiomsMod. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index f687e1d53c..b62a9f434b 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -112,7 +112,7 @@ Instance int_ops : ZnZ.Ops int := Lemma is_zero_spec_aux : forall x : int, is_zero x = true -> φ x = 0%Z. Proof. - intros x;rewrite is_zero_spec;intros H;rewrite H;trivial. + intros x;rewrite is_zero_spec;intros H;rewrite H;trivial. Qed. Lemma positive_to_int_spec : @@ -120,47 +120,47 @@ Lemma positive_to_int_spec : Zpos p = Z_of_N (fst (positive_to_int p)) * wB + to_Z (snd (positive_to_int p)). Proof. - assert (H: (wB <= wB) -> forall p : positive, - Zpos p = Z_of_N (fst (positive_to_int p)) * wB + φ (snd (positive_to_int p)) /\ - φ (snd (positive_to_int p)) < wB). - 2: intros p; case (H (Z.le_refl wB) p); auto. - unfold positive_to_int, wB at 1 3 4. - elim size. - - intros _ p; simpl; - rewrite to_Z_0, Pmult_1_r; split; auto with zarith; apply refl_equal. - - intros n; rewrite inj_S; unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. - intros IH Hle p. - assert (F1: 2 ^ Z_of_nat n <= wB); auto with zarith. - assert (0 <= 2 ^ Z_of_nat n); auto with zarith. - case p; simpl. - + intros p1. - generalize (IH F1 p1); case positive_to_int_rec; simpl. - intros n1 i (H1,H2). - rewrite Zpos_xI, H1. - replace (φ (i << 1 + 1)) with (φ i * 2 + 1). - * split; auto with zarith; ring. - * rewrite add_spec, lsl_spec, Zplus_mod_idemp_l, to_Z_1, Z.pow_1_r, Zmod_small; auto. - case (to_Z_bounded i); split; auto with zarith. - + intros p1. - generalize (IH F1 p1); case positive_to_int_rec; simpl. - intros n1 i (H1,H2). - rewrite Zpos_xO, H1. - replace (φ (i << 1)) with (φ i * 2). - * split; auto with zarith; ring. - * rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto. - case (to_Z_bounded i); split; auto with zarith. - + rewrite to_Z_1; assert (0 < 2^ Z_of_nat n); auto with zarith. + assert (H: (wB <= wB) -> forall p : positive, + Zpos p = Z_of_N (fst (positive_to_int p)) * wB + φ (snd (positive_to_int p)) /\ + φ (snd (positive_to_int p)) < wB). + 2: intros p; case (H (Z.le_refl wB) p); auto. + unfold positive_to_int, wB at 1 3 4. + elim size. + - intros _ p; simpl; + rewrite to_Z_0, Pmult_1_r; split; auto with zarith; apply refl_equal. + - intros n; rewrite inj_S; unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + intros IH Hle p. + assert (F1: 2 ^ Z_of_nat n <= wB); auto with zarith. + assert (0 <= 2 ^ Z_of_nat n); auto with zarith. + case p; simpl. + + intros p1. + generalize (IH F1 p1); case positive_to_int_rec; simpl. + intros n1 i (H1,H2). + rewrite Zpos_xI, H1. + replace (φ (i << 1 + 1)) with (φ i * 2 + 1). + * split; auto with zarith; ring. + * rewrite add_spec, lsl_spec, Zplus_mod_idemp_l, to_Z_1, Z.pow_1_r, Zmod_small; auto. + case (to_Z_bounded i); split; auto with zarith. + + intros p1. + generalize (IH F1 p1); case positive_to_int_rec; simpl. + intros n1 i (H1,H2). + rewrite Zpos_xO, H1. + replace (φ (i << 1)) with (φ i * 2). + * split; auto with zarith; ring. + * rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto. + case (to_Z_bounded i); split; auto with zarith. + + rewrite to_Z_1; assert (0 < 2^ Z_of_nat n); auto with zarith. Qed. Lemma mulc_WW_spec : forall x y, Φ ( x *c y ) = φ x * φ y. Proof. - intros x y;unfold mulc_WW. - generalize (mulc_spec x y);destruct (mulc x y);simpl;intros Heq;rewrite Heq. - case_eq (is_zero i);intros;trivial. - apply is_zero_spec in H;rewrite H, to_Z_0. - case_eq (is_zero i0);intros;trivial. - apply is_zero_spec in H0;rewrite H0, to_Z_0, Zmult_comm;trivial. + intros x y;unfold mulc_WW. + generalize (mulc_spec x y);destruct (mulc x y);simpl;intros Heq;rewrite Heq. + case_eq (is_zero i);intros;trivial. + apply is_zero_spec in H;rewrite H, to_Z_0. + case_eq (is_zero i0);intros;trivial. + apply is_zero_spec in H0;rewrite H0, to_Z_0, Zmult_comm;trivial. Qed. Lemma squarec_spec : @@ -175,11 +175,11 @@ Lemma diveucl_spec_aux : forall a b, 0 < φ b -> φ a = φ q * φ b + φ r /\ 0 <= φ r < φ b. Proof. - intros a b H;assert (W:= diveucl_spec a b). - assert (φ b>0) by (auto with zarith). - generalize (Z_div_mod (φ a) (φ b) H0). - destruct (diveucl a b);destruct (Z.div_eucl (φ a) (φ b)). - inversion W;rewrite Zmult_comm;trivial. + intros a b H;assert (W:= diveucl_spec a b). + assert (φ b>0) by (auto with zarith). + generalize (Z_div_mod (φ a) (φ b) H0). + destruct (diveucl a b);destruct (Z.div_eucl (φ a) (φ b)). + inversion W;rewrite Zmult_comm;trivial. Qed. Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> @@ -208,22 +208,22 @@ Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. Proof. - intros p x Hle;destruct (Z_le_gt_dec 0 p). - - apply Zdiv_le_lower_bound;auto with zarith. - - replace (2^p) with 0. - + destruct x;compute;intro;discriminate. - + destruct p;trivial;discriminate. + intros p x Hle;destruct (Z_le_gt_dec 0 p). + - apply Zdiv_le_lower_bound;auto with zarith. + - replace (2^p) with 0. + + destruct x;compute;intro;discriminate. + + destruct p;trivial;discriminate. Qed. Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. Proof. - intros p x y H;destruct (Z_le_gt_dec 0 p). - - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with y;auto with zarith. - rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. - - replace (2^p) with 0. - + destruct x;change (0 (a * 2 ^ (n - p)) mod 2 ^ n / 2 ^ (n - p) = a mod 2 ^ p. Proof. - intros;rewrite <- (shift_unshift_mod_2 n p a);[ | auto with zarith]. - symmetry;apply Zmod_small. - generalize (a * 2 ^ (n - p));intros w. - generalize (2 ^ (n - p)) (pow2_pos (n - p)); intros x; apply P. - - lia. - - intros hx. - generalize (2 ^ n) (pow2_pos n); intros y; apply P. - + lia. - + intros hy. - elim_div. intros q r. apply P. - * lia. - * elim_div. intros z t. refine (P _ _ _ _ _). - -- lia. - -- intros [ ? [ ht | ] ]; [ | lia ]; subst w. - intros [ ? [ hr | ] ]; [ | lia ]; subst t. - nia. + intros;rewrite <- (shift_unshift_mod_2 n p a);[ | auto with zarith]. + symmetry;apply Zmod_small. + generalize (a * 2 ^ (n - p));intros w. + generalize (2 ^ (n - p)) (pow2_pos (n - p)); intros x; apply P. + - lia. + - intros hx. + generalize (2 ^ n) (pow2_pos n); intros y; apply P. + + lia. + + intros hy. + elim_div. intros q r. apply P. + * lia. + * elim_div. intros z t. refine (P _ _ _ _ _). + -- lia. + -- intros [ ? [ ht | ] ]; [ | lia ]; subst w. + intros [ ? [ hr | ] ]; [ | lia ]; subst t. + nia. Qed. Lemma pos_mod_spec w p : φ(pos_mod p w) = φ(w) mod (2 ^ φ(p)). diff --git a/theories/Numbers/Cyclic/Int63/Ring63.v b/theories/Numbers/Cyclic/Int63/Ring63.v index fe2b742fbb..3c414313a8 100644 --- a/theories/Numbers/Cyclic/Int63/Ring63.v +++ b/theories/Numbers/Cyclic/Int63/Ring63.v @@ -46,13 +46,13 @@ Lemma ring_theory_switch_eq : ring_theory zero one add mul sub opp R -> ring_theory zero one add mul sub opp R'. Proof. -intros A R R' zero one add mul sub opp Impl Ring. -constructor; intros; apply Impl; apply Ring. + intros A R R' zero one add mul sub opp Impl Ring. + constructor; intros; apply Impl; apply Ring. Qed. Lemma Uint63Ring : ring_theory 0 1 add mul sub opp Logic.eq. Proof. -exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Uint63_canonic Uint63ring.CyclicRing). + exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Uint63_canonic Uint63ring.CyclicRing). Qed. Lemma eq31_correct : forall x y, eqb x y = true -> x=y. @@ -63,7 +63,8 @@ Add Ring Uint63Ring : Uint63Ring constants [Uint63cst]). Section TestRing. -Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. -intros. ring. -Defined. + Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. + Proof. + intros. ring. + Defined. End TestRing. diff --git a/theories/Numbers/Cyclic/Int63/Sint63.v b/theories/Numbers/Cyclic/Int63/Sint63.v index 25e5e1ee14..c99e468e63 100644 --- a/theories/Numbers/Cyclic/Int63/Sint63.v +++ b/theories/Numbers/Cyclic/Int63/Sint63.v @@ -38,29 +38,29 @@ Number Notation int parser printer : sint63_scope. Module Import Sint63NotationsInternalA. -Delimit Scope sint63_scope with sint63. -Bind Scope sint63_scope with int. + Delimit Scope sint63_scope with sint63. + Bind Scope sint63_scope with int. End Sint63NotationsInternalA. Module Import Sint63NotationsInternalB. -Infix "<<" := PrimInt63.lsl (at level 30, no associativity) : sint63_scope. -(* TODO do we want >> to be asr or lsr? And is there a notation for the other one? *) -Infix ">>" := asr (at level 30, no associativity) : sint63_scope. -Infix "land" := PrimInt63.land (at level 40, left associativity) : sint63_scope. -Infix "lor" := PrimInt63.lor (at level 40, left associativity) : sint63_scope. -Infix "lxor" := PrimInt63.lxor (at level 40, left associativity) : sint63_scope. -Infix "+" := PrimInt63.add : sint63_scope. -Infix "-" := PrimInt63.sub : sint63_scope. -Infix "*" := PrimInt63.mul : sint63_scope. -Infix "/" := divs : sint63_scope. -Infix "mod" := mods (at level 40, no associativity) : sint63_scope. -Infix "=?" := PrimInt63.eqb (at level 70, no associativity) : sint63_scope. -Infix "> to be asr or lsr? And is there a notation for the other one? *) + Infix ">>" := asr (at level 30, no associativity) : sint63_scope. + Infix "land" := PrimInt63.land (at level 40, left associativity) : sint63_scope. + Infix "lor" := PrimInt63.lor (at level 40, left associativity) : sint63_scope. + Infix "lxor" := PrimInt63.lxor (at level 40, left associativity) : sint63_scope. + Infix "+" := PrimInt63.add : sint63_scope. + Infix "-" := PrimInt63.sub : sint63_scope. + Infix "*" := PrimInt63.mul : sint63_scope. + Infix "/" := divs : sint63_scope. + Infix "mod" := mods (at level 40, no associativity) : sint63_scope. + Infix "=?" := PrimInt63.eqb (at level 70, no associativity) : sint63_scope. + Infix ">" := lsr (at level 30, no associativity) : uint63_scope. -Infix "land" := land (at level 40, left associativity) : uint63_scope. -Infix "lor" := lor (at level 40, left associativity) : uint63_scope. -Infix "lxor" := lxor (at level 40, left associativity) : uint63_scope. -Infix "+" := add : uint63_scope. -Infix "-" := sub : uint63_scope. -Infix "*" := mul : uint63_scope. -Infix "/" := div : uint63_scope. -Infix "mod" := mod (at level 40, no associativity) : uint63_scope. -Infix "=?" := eqb (at level 70, no associativity) : uint63_scope. -Infix ">" := lsr (at level 30, no associativity) : uint63_scope. + Infix "land" := land (at level 40, left associativity) : uint63_scope. + Infix "lor" := lor (at level 40, left associativity) : uint63_scope. + Infix "lxor" := lxor (at level 40, left associativity) : uint63_scope. + Infix "+" := add : uint63_scope. + Infix "-" := sub : uint63_scope. + Infix "*" := mul : uint63_scope. + Infix "/" := div : uint63_scope. + Infix "mod" := mod (at level 40, no associativity) : uint63_scope. + Infix "=?" := eqb (at level 70, no associativity) : uint63_scope. + Infix " (x =? y) = true. Proof. - now intros x y H; rewrite H, Uint63Axioms.eqb_refl. + now intros x y H; rewrite H, Uint63Axioms.eqb_refl. Qed. Lemma eqb_spec : forall x y, (x =? y) = true <-> x = y. Proof. - split;auto using eqb_correct, eqb_complete. + split;auto using eqb_correct, eqb_complete. Qed. Lemma eqb_false_spec : forall x y, (x =? y) = false <-> x <> y. Proof. - intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. + intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. Qed. Lemma eqb_false_complete : forall x y, x <> y -> (x =? y) = false. Proof. - intros x y;rewrite eqb_false_spec;trivial. + intros x y;rewrite eqb_false_spec;trivial. Qed. Lemma eqb_false_correct : forall x y, (x =? y) = false -> x <> y. Proof. - intros x y;rewrite eqb_false_spec;trivial. + intros x y;rewrite eqb_false_spec;trivial. Qed. Definition eqs (i j : int) : {i = j} + { i <> j } := @@ -334,7 +334,7 @@ Definition eqs (i j : int) : {i = j} + { i <> j } := Lemma eq_dec : forall i j:int, i = j \/ i <> j. Proof. - intros i j;destruct (eqs i j);auto. + intros i j;destruct (eqs i j);auto. Qed. (* Extra function on equality *) @@ -351,16 +351,16 @@ Definition cast i j := Lemma cast_refl : forall i, cast i i = Some (fun P H => H). Proof. - unfold cast;intros i. - generalize (eqb_correct i i). - rewrite Uint63Axioms.eqb_refl;intros e. - rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. + unfold cast;intros i. + generalize (eqb_correct i i). + rewrite Uint63Axioms.eqb_refl;intros e. + rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. Lemma cast_diff : forall i j, (i =? j) = false -> cast i j = None. Proof. - intros i j H;unfold cast;intros; generalize (eqb_correct i j). - rewrite H;trivial. + intros i j H;unfold cast;intros; generalize (eqb_correct i j). + rewrite H;trivial. Qed. Definition eqo i j := @@ -371,16 +371,16 @@ Definition eqo i j := Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). Proof. - unfold eqo;intros i. - generalize (eqb_correct i i). - rewrite Uint63Axioms.eqb_refl;intros e. - rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. + unfold eqo;intros i. + generalize (eqb_correct i i). + rewrite Uint63Axioms.eqb_refl;intros e. + rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. Lemma eqo_diff : forall i j, (i =? j) = false -> eqo i j = None. Proof. - unfold eqo;intros i j H; generalize (eqb_correct i j). - rewrite H;trivial. + unfold eqo;intros i j H; generalize (eqb_correct i j). + rewrite H;trivial. Qed. (** Comparison *) @@ -409,8 +409,8 @@ Lemma diveucl_spec x y : let (q,r) := diveucl x y in (φ q , φ r ) = Z.div_eucl (φ x) (φ y). Proof. - rewrite diveucl_def_spec; unfold diveucl_def; rewrite div_spec, mod_spec; unfold Z.div, Z.modulo. - destruct (Z.div_eucl (φ x) (φ y)); trivial. + rewrite diveucl_def_spec; unfold diveucl_def; rewrite div_spec, mod_spec; unfold Z.div, Z.modulo. + destruct (Z.div_eucl (φ x) (φ y)); trivial. Qed. #[local] Open Scope Z_scope. @@ -474,10 +474,10 @@ Proof. unfold opp; rewrite -> sub_spec, to_Z_0; trivial. Qed. Lemma oppcarry_spec x : φ (oppcarry x) = wB - φ x - 1. Proof. - unfold oppcarry; rewrite sub_spec. - rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. - apply Zmod_small. - generalize (to_Z_bounded x); auto with zarith. + unfold oppcarry; rewrite sub_spec. + rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. + apply Zmod_small. + generalize (to_Z_bounded x); auto with zarith. Qed. Lemma subcarry_spec x y : φ (subcarry x y) = (φ x - φ y - 1) mod wB. @@ -485,40 +485,40 @@ Proof. unfold subcarry; rewrite !sub_spec, Zminus_mod_idemp_l; trivial. Qed. Lemma subcarryc_spec x y : [-| subcarryc x y |] = φ x - φ y - 1. Proof. - rewrite subcarryc_def_spec; unfold subcarryc_def, interp_carry; fold (subcarry x y). - pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). - case ltbP; rewrite subcarry_spec. - - intros hlt; rewrite Zmod_small; lia. - - intros hge; rewrite <- (Zmod_unique _ _ (-1) (φ x - φ y - 1 + wB)); lia. + rewrite subcarryc_def_spec; unfold subcarryc_def, interp_carry; fold (subcarry x y). + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case ltbP; rewrite subcarry_spec. + - intros hlt; rewrite Zmod_small; lia. + - intros hge; rewrite <- (Zmod_unique _ _ (-1) (φ x - φ y - 1 + wB)); lia. Qed. (** GCD *) Lemma to_Z_gcd : forall i j, φ (gcd i j) = Zgcdn (2 * size) (φ j) (φ i). Proof. - unfold gcd. - elim (2*size)%nat. - - reflexivity. - - intros n ih i j; simpl. - pose proof (to_Z_bounded j) as hj; pose proof (to_Z_bounded i). - case eqbP; rewrite to_Z_0. - + intros ->; rewrite Z.abs_eq; lia. - + intros hne; rewrite ih; clear ih. - rewrite <- mod_spec. - revert hj hne; case (φ j); intros; lia. + unfold gcd. + elim (2*size)%nat. + - reflexivity. + - intros n ih i j; simpl. + pose proof (to_Z_bounded j) as hj; pose proof (to_Z_bounded i). + case eqbP; rewrite to_Z_0. + + intros ->; rewrite Z.abs_eq; lia. + + intros hne; rewrite ih; clear ih. + rewrite <- mod_spec. + revert hj hne; case (φ j); intros; lia. Qed. Lemma gcd_spec a b : Zis_gcd (φ a) (φ b) (φ (gcd a b)). Proof. - rewrite to_Z_gcd. - apply Zis_gcd_sym. - apply Zgcdn_is_gcd. - unfold Zgcd_bound. - generalize (to_Z_bounded b). - destruct (φ b) as [|p|p]. - - unfold size; auto with zarith. - - intros (_,H). - cut (Psize p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. - - intros (H,_); compute in H; elim H; auto. + rewrite to_Z_gcd. + apply Zis_gcd_sym. + apply Zgcdn_is_gcd. + unfold Zgcd_bound. + generalize (to_Z_bounded b). + destruct (φ b) as [|p|p]. + - unfold size; auto with zarith. + - intros (_,H). + cut (Psize p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. + - intros (H,_); compute in H; elim H; auto. Qed. (** Head0, Tail0 *) @@ -568,34 +568,34 @@ Qed. (* ADD *) Lemma add_assoc x y z: (x + (y + z) = (x + y) + z)%uint63. Proof. - apply to_Z_inj; rewrite !add_spec. - rewrite -> Zplus_mod_idemp_l, Zplus_mod_idemp_r, Zplus_assoc; auto. + apply to_Z_inj; rewrite !add_spec. + rewrite -> Zplus_mod_idemp_l, Zplus_mod_idemp_r, Zplus_assoc; auto. Qed. Lemma add_comm x y: (x + y = y + x)%uint63. Proof. - apply to_Z_inj; rewrite -> !add_spec, Zplus_comm; auto. + apply to_Z_inj; rewrite -> !add_spec, Zplus_comm; auto. Qed. Lemma add_le_r m n: if (n <=? m + n)%uint63 then (φ m + φ n < wB)%Z else (wB <= φ m + φ n)%Z. Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (Zle_or_lt wB (φ m + φ n)); intros H. - - assert (H1: (φ (m + n) = φ m + φ n - wB)%Z). { - rewrite add_spec. - replace ((φ m + φ n) mod wB)%Z with ((((φ m + φ n) - wB) + wB) mod wB)%Z. - - rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. - rewrite !Zmod_small; auto with zarith. - - apply (f_equal2 Z.modulo); auto with zarith. - } - case_eq (n <=? m + n)%uint63; auto. - rewrite leb_spec, H1; auto with zarith. - - assert (H1: (φ (m + n) = φ m + φ n)%Z). - { rewrite add_spec, Zmod_small; auto with zarith. } - replace (n <=? m + n)%uint63 with true; auto. - apply sym_equal; rewrite leb_spec, H1; auto with zarith. + case (to_Z_bounded m); intros H1m H2m. + case (to_Z_bounded n); intros H1n H2n. + case (Zle_or_lt wB (φ m + φ n)); intros H. + - assert (H1: (φ (m + n) = φ m + φ n - wB)%Z). { + rewrite add_spec. + replace ((φ m + φ n) mod wB)%Z with ((((φ m + φ n) - wB) + wB) mod wB)%Z. + - rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. + rewrite !Zmod_small; auto with zarith. + - apply (f_equal2 Z.modulo); auto with zarith. + } + case_eq (n <=? m + n)%uint63; auto. + rewrite leb_spec, H1; auto with zarith. + - assert (H1: (φ (m + n) = φ m + φ n)%Z). + { rewrite add_spec, Zmod_small; auto with zarith. } + replace (n <=? m + n)%uint63 with true; auto. + apply sym_equal; rewrite leb_spec, H1; auto with zarith. Qed. Lemma add_cancel_l x y z : (x + y = x + z)%uint63 -> y = z. @@ -637,94 +637,94 @@ Qed. Lemma lsr_add i m n: ((i >> m) >> n = if n <=? m + n then i >> (m + n) else 0)%uint63. Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (to_Z_bounded i); intros H1i H2i. - generalize (add_le_r m n); case (n <=? m + n)%uint63; intros H. - - apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. - rewrite add_spec, Zmod_small; auto with zarith. - - apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. - apply Zdiv_small. split; [ auto with zarith | ]. - eapply Z.lt_le_trans; [ | apply Zpower2_le_lin ]; auto with zarith. + case (to_Z_bounded m); intros H1m H2m. + case (to_Z_bounded n); intros H1n H2n. + case (to_Z_bounded i); intros H1i H2i. + generalize (add_le_r m n); case (n <=? m + n)%uint63; intros H. + - apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. + rewrite add_spec, Zmod_small; auto with zarith. + - apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. + apply Zdiv_small. split; [ auto with zarith | ]. + eapply Z.lt_le_trans; [ | apply Zpower2_le_lin ]; auto with zarith. Qed. (* LSL *) Lemma lsl0 i: 0 << i = 0%uint63. Proof. - apply to_Z_inj. - generalize (lsl_spec 0 i). - rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. + apply to_Z_inj. + generalize (lsl_spec 0 i). + rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. Qed. Lemma lsl0_r i : i << 0 = i. Proof. - apply to_Z_inj. - rewrite -> lsl_spec, to_Z_0, Z.mul_1_r. - apply Zmod_small; apply (to_Z_bounded i). + apply to_Z_inj. + rewrite -> lsl_spec, to_Z_0, Z.mul_1_r. + apply Zmod_small; apply (to_Z_bounded i). Qed. Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%uint63. Proof. - apply to_Z_inj; rewrite -> !lsl_spec, !add_spec, Zmult_mod_idemp_l. - rewrite -> !lsl_spec, <-Zplus_mod. - apply (f_equal2 Z.modulo); auto with zarith. + apply to_Z_inj; rewrite -> !lsl_spec, !add_spec, Zmult_mod_idemp_l. + rewrite -> !lsl_spec, <-Zplus_mod. + apply (f_equal2 Z.modulo); auto with zarith. Qed. Lemma lsr_M_r x i (H: ((digits <=? i) = true)%uint63) : x >> i = 0%uint63. Proof. - apply to_Z_inj. - rewrite lsr_spec, to_Z_0. - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded digits); intros H1d H2d. - rewrite -> leb_spec in H. - apply Zdiv_small; split; [ auto | ]. - apply (Z.lt_le_trans _ _ _ H2x). - unfold wB; change (Z_of_nat size) with (φ digits). - apply Zpower_le_monotone; auto with zarith. + apply to_Z_inj. + rewrite lsr_spec, to_Z_0. + case (to_Z_bounded x); intros H1x H2x. + case (to_Z_bounded digits); intros H1d H2d. + rewrite -> leb_spec in H. + apply Zdiv_small; split; [ auto | ]. + apply (Z.lt_le_trans _ _ _ H2x). + unfold wB; change (Z_of_nat size) with (φ digits). + apply Zpower_le_monotone; auto with zarith. Qed. (* BIT *) Lemma bit_0_spec i: φ (bit i 0) = φ i mod 2. Proof. - unfold bit, is_zero. rewrite lsr_0_r. - assert (Hbi: (φ i mod 2 < 2)%Z). - { apply Z_mod_lt; auto with zarith. } - case (to_Z_bounded i); intros H1i H2i. - case (Z.mod_bound_pos_le (φ i) 2); auto with zarith; intros H3i H4i. - assert (H2b: (0 < 2 ^ φ (digits - 1))%Z). { - apply Zpower_gt_0; auto with zarith. - case (to_Z_bounded (digits -1)); auto with zarith. - } - assert (H: φ (i << (digits -1)) = (φ i mod 2 * 2^ φ (digits -1))%Z). { - rewrite lsl_spec. - rewrite -> (Z_div_mod_eq_full (φ i) 2) at 1. - rewrite -> Zmult_plus_distr_l, <-Zplus_mod_idemp_l. - rewrite -> (Zmult_comm 2), <-Zmult_assoc. - replace (2 * 2 ^ φ (digits - 1))%Z with wB; auto. - rewrite Z_mod_mult, Zplus_0_l; apply Zmod_small. - split; auto with zarith. - replace wB with (2 * 2 ^ φ (digits -1))%Z; auto. - apply Zmult_lt_compat_r; auto with zarith. - } - case (Zle_lt_or_eq 0 (φ i mod 2)); auto with zarith; intros Hi. - 2: generalize H; rewrite <-Hi, Zmult_0_l. - 2: replace 0%Z with (φ 0); auto. - 2: now case eqbP. - generalize H; replace (φ i mod 2) with 1%Z; auto with zarith. - rewrite Zmult_1_l. - intros H1. - assert (H2: φ (i << (digits - 1)) <> φ 0). - { replace (φ 0) with 0%Z; auto with zarith. } - now case eqbP. + unfold bit, is_zero. rewrite lsr_0_r. + assert (Hbi: (φ i mod 2 < 2)%Z). + { apply Z_mod_lt; auto with zarith. } + case (to_Z_bounded i); intros H1i H2i. + case (Z.mod_bound_pos_le (φ i) 2); auto with zarith; intros H3i H4i. + assert (H2b: (0 < 2 ^ φ (digits - 1))%Z). { + apply Zpower_gt_0; auto with zarith. + case (to_Z_bounded (digits -1)); auto with zarith. + } + assert (H: φ (i << (digits -1)) = (φ i mod 2 * 2^ φ (digits -1))%Z). { + rewrite lsl_spec. + rewrite -> (Z_div_mod_eq_full (φ i) 2) at 1. + rewrite -> Zmult_plus_distr_l, <-Zplus_mod_idemp_l. + rewrite -> (Zmult_comm 2), <-Zmult_assoc. + replace (2 * 2 ^ φ (digits - 1))%Z with wB; auto. + rewrite Z_mod_mult, Zplus_0_l; apply Zmod_small. + split; auto with zarith. + replace wB with (2 * 2 ^ φ (digits -1))%Z; auto. + apply Zmult_lt_compat_r; auto with zarith. + } + case (Zle_lt_or_eq 0 (φ i mod 2)); auto with zarith; intros Hi. + 2: generalize H; rewrite <-Hi, Zmult_0_l. + 2: replace 0%Z with (φ 0); auto. + 2: now case eqbP. + generalize H; replace (φ i mod 2) with 1%Z; auto with zarith. + rewrite Zmult_1_l. + intros H1. + assert (H2: φ (i << (digits - 1)) <> φ 0). + { replace (φ 0) with 0%Z; auto with zarith. } + now case eqbP. Qed. Lemma bit_split i : ( i = (i >> 1 ) << 1 + bit i 0)%uint63. Proof. - apply to_Z_inj. - rewrite -> add_spec, lsl_spec, lsr_spec, bit_0_spec, Zplus_mod_idemp_l. - replace (2 ^ φ 1) with 2%Z; auto with zarith. - rewrite -> Zmult_comm, <-Z_div_mod_eq_full. - rewrite Zmod_small; auto; case (to_Z_bounded i); auto. + apply to_Z_inj. + rewrite -> add_spec, lsl_spec, lsr_spec, bit_0_spec, Zplus_mod_idemp_l. + replace (2 ^ φ 1) with 2%Z; auto with zarith. + rewrite -> Zmult_comm, <-Z_div_mod_eq_full. + rewrite Zmod_small; auto; case (to_Z_bounded i); auto. Qed. Lemma bit_lsr x i j : @@ -735,15 +735,15 @@ Qed. Lemma bit_b2i (b: bool) i : bit b i = (i =? 0)%uint63 && b. Proof. - case b; unfold bit; simpl b2i. - - rewrite lsr_1; case (i =? 0)%uint63; auto. - - rewrite lsr0, lsl0, andb_false_r; auto. + case b; unfold bit; simpl b2i. + - rewrite lsr_1; case (i =? 0)%uint63; auto. + - rewrite lsr0, lsl0, andb_false_r; auto. Qed. Lemma bit_1 n : bit 1 n = (n =? 0)%uint63. Proof. - unfold bit; rewrite lsr_1. - case (_ =? _)%uint63; simpl; auto. + unfold bit; rewrite lsr_1. + case (_ =? _)%uint63; simpl; auto. Qed. #[local] Hint Resolve Z.lt_gt Z.div_pos : zarith. @@ -774,19 +774,19 @@ Proof. unfold bit; rewrite lsr_M_r; auto. Qed. Lemma bit_half i n (H: ((n >1) n = bit i (n+1). Proof. - unfold bit. - rewrite lsr_add. - case_eq (n <=? (1 + n))%uint63. - - replace (1+n)%uint63 with (n+1)%uint63; [auto|idtac]. - apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. - - intros H1; assert (H2: n = max_int). - 2: generalize H; rewrite H2; discriminate. - case (to_Z_bounded n); intros H1n H2n. - case (Zle_lt_or_eq (φ n) (wB - 1)); auto with zarith; - intros H2; apply to_Z_inj; auto. - generalize (add_le_r 1 n); rewrite H1. - change (φ max_int) with (wB - 1)%Z. - replace (φ 1) with 1%Z; auto with zarith. + unfold bit. + rewrite lsr_add. + case_eq (n <=? (1 + n))%uint63. + - replace (1+n)%uint63 with (n+1)%uint63; [auto|idtac]. + apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. + - intros H1; assert (H2: n = max_int). + 2: generalize H; rewrite H2; discriminate. + case (to_Z_bounded n); intros H1n H2n. + case (Zle_lt_or_eq (φ n) (wB - 1)); auto with zarith; + intros H2; apply to_Z_inj; auto. + generalize (add_le_r 1 n); rewrite H1. + change (φ max_int) with (wB - 1)%Z. + replace (φ 1) with 1%Z; auto with zarith. Qed. Lemma bit_ext i j : (forall n, bit i n = bit j n) -> i = j. @@ -878,33 +878,33 @@ Qed. (* LOR *) Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). Proof. - apply bit_ext; intros n. - rewrite -> lor_spec, !bit_lsr, lor_spec. - case (_ <=? _)%uint63; auto. + apply bit_ext; intros n. + rewrite -> lor_spec, !bit_lsr, lor_spec. + case (_ <=? _)%uint63; auto. Qed. Lemma lor_le x y : (y <=? x lor y)%uint63 = true. Proof. - generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. - unfold wB; elim size. - - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. - intros x y Hx Hy; replace x with 0%uint63. - + replace y with 0%uint63; auto. - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - + apply to_Z_inj; rewrite to_Z_0; auto with zarith. - - intros n IH x y; rewrite inj_S. - unfold Z.succ; rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. - intros Hx Hy. - rewrite leb_spec. - rewrite -> (to_Z_split y) at 1; rewrite (to_Z_split (x lor y)). - assert (φ (y>>1) <= φ ((x lor y) >> 1)). - + rewrite -> lor_lsr, <-leb_spec; apply IH. - * rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - * rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - + assert (φ (bit y 0) <= φ (bit (x lor y) 0)); auto with zarith. - rewrite lor_spec; do 2 case bit; try discriminate. + generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. + unfold wB; elim size. + - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. + intros x y Hx Hy; replace x with 0%uint63. + + replace y with 0%uint63; auto. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + - intros n IH x y; rewrite inj_S. + unfold Z.succ; rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. + intros Hx Hy. + rewrite leb_spec. + rewrite -> (to_Z_split y) at 1; rewrite (to_Z_split (x lor y)). + assert (φ (y>>1) <= φ ((x lor y) >> 1)). + + rewrite -> lor_lsr, <-leb_spec; apply IH. + * rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + * rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + + assert (φ (bit y 0) <= φ (bit (x lor y) 0)); auto with zarith. + rewrite lor_spec; do 2 case bit; try discriminate. Qed. Lemma bit_0 n : bit 0 n = false. @@ -913,146 +913,146 @@ Proof. unfold bit; rewrite lsr0; auto. Qed. Lemma bit_add_or x y: (forall n, bit x n = true -> bit y n = true -> False) <-> (x + y)%uint63= x lor y. Proof. - generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. - unfold wB; elim size. - - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. - intros x y Hx Hy; replace x with 0%uint63. - + replace y with 0%uint63. - { split; auto; intros _ n; rewrite !bit_0; discriminate. } - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - + apply to_Z_inj; rewrite to_Z_0; auto with zarith. - - intros n IH x y; rewrite inj_S. - unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. - intros Hx Hy. - split. - + intros Hn. - assert (F1: ((x >> 1) + (y >> 1))%uint63 = (x >> 1) lor (y >> 1)). { - apply IH. - - rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - - rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - - intros m H1 H2. - case_eq (digits <=? m)%uint63; [idtac | rewrite <- not_true_iff_false]; - intros Heq. - + rewrite bit_M in H1; auto; discriminate. - + rewrite leb_spec in Heq. - apply (Hn (m + 1)%uint63); - rewrite <-bit_half; auto; rewrite ltb_spec; auto with zarith. - } - rewrite (bit_split (x lor y)), lor_lsr, <- F1, lor_spec. - replace (b2i (bit x 0 || bit y 0)) with (bit x 0 + bit y 0)%uint63. - 2: generalize (Hn 0%uint63); do 2 case bit; auto; intros [ ]; auto. - rewrite lsl_add_distr. - rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. - rewrite <-!add_assoc; apply (f_equal2 add); auto. - rewrite add_comm, <-!add_assoc; apply (f_equal2 add); auto. - rewrite add_comm; auto. - + intros Heq. - generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. - generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. - rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, - <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsl_add_distr. - rewrite (bit_split (x lor y)), lor_spec. - intros Heq. - assert (F: (bit x 0 + bit y 0)%uint63 = (bit x 0 || bit y 0)). { - assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). - assert (F2: 0 < wB) by (apply refl_equal). - assert (F3: φ (bit x 0 + bit y 0) mod 2 = φ (bit x 0 || bit y 0) mod 2). { - apply trans_equal with ((φ ((x>>1 + y>>1) << 1) + φ (bit x 0 + bit y 0)) mod 2). - - rewrite lsl_spec, Zplus_mod, Z.mod_mod_divide; auto with zarith. - rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. - - assert (forall a, a mod 2 = (a mod wB) mod 2) as ->. - { intros. rewrite Z.mod_mod_divide; trivial. } - rewrite <-add_spec, Heq; auto with zarith. - rewrite add_spec, Z.mod_mod_divide; auto with zarith. - rewrite lsl_spec, Zplus_mod, Z.mod_mod_divide; auto with zarith. - rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. - } - generalize F3; do 2 case bit; try discriminate; auto. - } - case (IH (x >> 1) (y >> 1)). - * rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - * rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - * intros _ HH m; case (to_Z_bounded m); intros H1m H2m. - case_eq (digits <=? m)%uint63. - -- intros Hlm; rewrite bit_M; auto; discriminate. - -- rewrite <- not_true_iff_false, leb_spec; intros Hlm. - case (Zle_lt_or_eq 0 (φ m)); auto; intros Hm. - ++ replace m with ((m -1) + 1)%uint63. { - rewrite <-(bit_half x), <-(bit_half y); auto with zarith. - - apply HH. - rewrite <-lor_lsr. - assert (0 <= φ (bit (x lor y) 0) <= 1) by (case bit; split; discriminate). - rewrite F in Heq; generalize (add_cancel_r _ _ _ Heq). - intros Heq1; apply to_Z_inj. - generalize (f_equal to_Z Heq1); rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small. - + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. - case (to_Z_bounded (x lor y)); intros H1xy H2xy. - rewrite lsr_spec, to_Z_1, Z.pow_1_r; auto with zarith. - change wB with ((wB/2)*2); split; auto with zarith. - assert (φ (x lor y) / 2 < wB / 2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - + split. - * case (to_Z_bounded (x >> 1 + y >> 1)); auto with zarith. - * rewrite add_spec. - apply Z.le_lt_trans with ((φ (x >> 1) + φ (y >> 1)) * 2); auto with zarith. - -- case (Z.mod_bound_pos_le (φ (x >> 1) + φ (y >> 1)) wB); auto with zarith. - case (to_Z_bounded (x >> 1)); case (to_Z_bounded (y >> 1)); auto with zarith. - -- generalize Hb; rewrite (to_Z_split x) at 1; rewrite (to_Z_split y) at 1. - case (to_Z_bounded (bit x 0)); case (to_Z_bounded (bit y 0)); auto with zarith. - - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. - - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. - } - apply to_Z_inj. - rewrite add_spec, sub_spec, Zplus_mod_idemp_l, to_Z_1, Zmod_small; auto with zarith. - ++ pose proof (to_Z_inj 0 _ Hm); clear Hm; subst m. - intros hx hy; revert F; rewrite hx, hy; intros F. - generalize (f_equal to_Z F). vm_compute. lia. + generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. + unfold wB; elim size. + - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. + intros x y Hx Hy; replace x with 0%uint63. + + replace y with 0%uint63. + { split; auto; intros _ n; rewrite !bit_0; discriminate. } + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + - intros n IH x y; rewrite inj_S. + unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + intros Hx Hy. + split. + + intros Hn. + assert (F1: ((x >> 1) + (y >> 1))%uint63 = (x >> 1) lor (y >> 1)). { + apply IH. + - rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + - rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + - intros m H1 H2. + case_eq (digits <=? m)%uint63; [idtac | rewrite <- not_true_iff_false]; + intros Heq. + + rewrite bit_M in H1; auto; discriminate. + + rewrite leb_spec in Heq. + apply (Hn (m + 1)%uint63); + rewrite <-bit_half; auto; rewrite ltb_spec; auto with zarith. + } + rewrite (bit_split (x lor y)), lor_lsr, <- F1, lor_spec. + replace (b2i (bit x 0 || bit y 0)) with (bit x 0 + bit y 0)%uint63. + 2: generalize (Hn 0%uint63); do 2 case bit; auto; intros [ ]; auto. + rewrite lsl_add_distr. + rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. + rewrite <-!add_assoc; apply (f_equal2 add); auto. + rewrite add_comm, <-!add_assoc; apply (f_equal2 add); auto. + rewrite add_comm; auto. + + intros Heq. + generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. + generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. + rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, + <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsl_add_distr. + rewrite (bit_split (x lor y)), lor_spec. + intros Heq. + assert (F: (bit x 0 + bit y 0)%uint63 = (bit x 0 || bit y 0)). { + assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). + assert (F2: 0 < wB) by (apply refl_equal). + assert (F3: φ (bit x 0 + bit y 0) mod 2 = φ (bit x 0 || bit y 0) mod 2). { + apply trans_equal with ((φ ((x>>1 + y>>1) << 1) + φ (bit x 0 + bit y 0)) mod 2). + - rewrite lsl_spec, Zplus_mod, Z.mod_mod_divide; auto with zarith. + rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. + - assert (forall a, a mod 2 = (a mod wB) mod 2) as ->. + { intros. rewrite Z.mod_mod_divide; trivial. } + rewrite <-add_spec, Heq; auto with zarith. + rewrite add_spec, Z.mod_mod_divide; auto with zarith. + rewrite lsl_spec, Zplus_mod, Z.mod_mod_divide; auto with zarith. + rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. + } + generalize F3; do 2 case bit; try discriminate; auto. + } + case (IH (x >> 1) (y >> 1)). + * rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + * rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + * intros _ HH m; case (to_Z_bounded m); intros H1m H2m. + case_eq (digits <=? m)%uint63. + -- intros Hlm; rewrite bit_M; auto; discriminate. + -- rewrite <- not_true_iff_false, leb_spec; intros Hlm. + case (Zle_lt_or_eq 0 (φ m)); auto; intros Hm. + ++ replace m with ((m -1) + 1)%uint63. { + rewrite <-(bit_half x), <-(bit_half y); auto with zarith. + - apply HH. + rewrite <-lor_lsr. + assert (0 <= φ (bit (x lor y) 0) <= 1) by (case bit; split; discriminate). + rewrite F in Heq; generalize (add_cancel_r _ _ _ Heq). + intros Heq1; apply to_Z_inj. + generalize (f_equal to_Z Heq1); rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small. + + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + case (to_Z_bounded (x lor y)); intros H1xy H2xy. + rewrite lsr_spec, to_Z_1, Z.pow_1_r; auto with zarith. + change wB with ((wB/2)*2); split; auto with zarith. + assert (φ (x lor y) / 2 < wB / 2); auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + + split. + * case (to_Z_bounded (x >> 1 + y >> 1)); auto with zarith. + * rewrite add_spec. + apply Z.le_lt_trans with ((φ (x >> 1) + φ (y >> 1)) * 2); auto with zarith. + -- case (Z.mod_bound_pos_le (φ (x >> 1) + φ (y >> 1)) wB); auto with zarith. + case (to_Z_bounded (x >> 1)); case (to_Z_bounded (y >> 1)); auto with zarith. + -- generalize Hb; rewrite (to_Z_split x) at 1; rewrite (to_Z_split y) at 1. + case (to_Z_bounded (bit x 0)); case (to_Z_bounded (bit y 0)); auto with zarith. + - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. + - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. + } + apply to_Z_inj. + rewrite add_spec, sub_spec, Zplus_mod_idemp_l, to_Z_1, Zmod_small; auto with zarith. + ++ pose proof (to_Z_inj 0 _ Hm); clear Hm; subst m. + intros hx hy; revert F; rewrite hx, hy; intros F. + generalize (f_equal to_Z F). vm_compute. lia. Qed. Lemma addmuldiv_spec x y p : φ p <= φ digits -> φ (addmuldiv p x y) = (φ x * (2 ^ φ p) + φ y / (2 ^ (φ digits - φ p))) mod wB. Proof. - intros H. - assert (Fp := to_Z_bounded p); assert (Fd := to_Z_bounded digits). - rewrite addmuldiv_def_spec; unfold addmuldiv_def. - case (bit_add_or (x << p) (y >> (digits - p))); intros HH _. - rewrite <-HH, add_spec, lsl_spec, lsr_spec, Zplus_mod_idemp_l, sub_spec. - - rewrite (fun x y => Zmod_small (x - y)); auto with zarith. - - intros n; rewrite -> bit_lsl, bit_lsr. - generalize (add_le_r (digits - p) n). - case (_ ≤? _); try discriminate. - rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. - case_eq (n leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. - rewrite -> sub_spec, Zmod_small; auto with zarith. + intros H. + assert (Fp := to_Z_bounded p); assert (Fd := to_Z_bounded digits). + rewrite addmuldiv_def_spec; unfold addmuldiv_def. + case (bit_add_or (x << p) (y >> (digits - p))); intros HH _. + rewrite <-HH, add_spec, lsl_spec, lsr_spec, Zplus_mod_idemp_l, sub_spec. + - rewrite (fun x y => Zmod_small (x - y)); auto with zarith. + - intros n; rewrite -> bit_lsl, bit_lsr. + generalize (add_le_r (digits - p) n). + case (_ ≤? _); try discriminate. + rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. + case_eq (n leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. + rewrite -> sub_spec, Zmod_small; auto with zarith. Qed. (* is_even *) Lemma is_even_bit i : is_even i = negb (bit i 0). Proof. - unfold is_even. - replace (i land 1) with (b2i (bit i 0)). - - case bit; auto. - - apply bit_ext; intros n. - rewrite bit_b2i, land_spec, bit_1. - generalize (eqb_spec n 0). - case (n =? 0)%uint63; auto. - + intros(H,_); rewrite andb_true_r, H; auto. - + rewrite andb_false_r; auto. + unfold is_even. + replace (i land 1) with (b2i (bit i 0)). + - case bit; auto. + - apply bit_ext; intros n. + rewrite bit_b2i, land_spec, bit_1. + generalize (eqb_spec n 0). + case (n =? 0)%uint63; auto. + + intros(H,_); rewrite andb_true_r, H; auto. + + rewrite andb_false_r; auto. Qed. Lemma is_even_spec x : if is_even x then φ x mod 2 = 0 else φ x mod 2 = 1. Proof. -rewrite is_even_bit. -generalize (bit_0_spec x); case bit; simpl; auto. + rewrite is_even_bit. + generalize (bit_0_spec x); case bit; simpl; auto. Qed. Lemma is_even_0 : is_even 0 = true. @@ -1060,7 +1060,7 @@ Proof. apply refl_equal. Qed. Lemma is_even_lsl_1 i : is_even (i << 1) = true. Proof. - rewrite is_even_bit, bit_lsl; auto. + rewrite is_even_bit, bit_lsl; auto. Qed. (* Sqrt *) @@ -1079,40 +1079,40 @@ Ltac elim_div := Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). Proof. - case (Z_mod_lt a 2); auto with zarith. - intros H1; rewrite Zmod_eq_full; auto with zarith. + case (Z_mod_lt a 2); auto with zarith. + intros H1; rewrite Zmod_eq_full; auto with zarith. Qed. Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> (j * k) + j <= ((j + k)/2 + 1) ^ 2. Proof. - intros Hj; generalize Hj k; pattern j; apply natlike_ind; - auto; clear k j Hj. - - intros _ k Hk; repeat rewrite Zplus_0_l. - apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. - - intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. - + rewrite -> Zmult_0_r, Zplus_0_r, Zplus_0_l. - generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); - unfold Z.succ. - rewrite Z.pow_2_r, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - auto with zarith. - + intros k Hk _. - replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). - * generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). - unfold Z.succ; repeat rewrite Z.pow_2_r; - repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. - auto with zarith. - * rewrite -> Zplus_comm, <- Z_div_plus_full_l; auto with zarith. - apply f_equal2; auto with zarith. + intros Hj; generalize Hj k; pattern j; apply natlike_ind; + auto; clear k j Hj. + - intros _ k Hk; repeat rewrite Zplus_0_l. + apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. + - intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. + + rewrite -> Zmult_0_r, Zplus_0_r, Zplus_0_l. + generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); + unfold Z.succ. + rewrite Z.pow_2_r, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + + intros k Hk _. + replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). + * generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). + unfold Z.succ; repeat rewrite Z.pow_2_r; + repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. + auto with zarith. + * rewrite -> Zplus_comm, <- Z_div_plus_full_l; auto with zarith. + apply f_equal2; auto with zarith. Qed. Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. Proof. - intros Hi Hj. - assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). - refine (Z.lt_le_trans _ _ _ _ (sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij)). - pattern i at 1; rewrite -> (Z_div_mod_eq_full i j); case (Z_mod_lt i j); auto with zarith. + intros Hi Hj. + assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). + refine (Z.lt_le_trans _ _ _ _ (sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij)). + pattern i at 1; rewrite -> (Z_div_mod_eq_full i j); case (Z_mod_lt i j); auto with zarith. Qed. Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. @@ -1123,9 +1123,9 @@ Qed. Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. Proof. - intros Hi Hj Hd; rewrite Z.pow_2_r. - apply Z.le_trans with (j * (i/j)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. + intros Hi Hj Hd; rewrite Z.pow_2_r. + apply Z.le_trans with (j * (i/j)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. Qed. Lemma sqrt_step_correct rec i j: @@ -1136,24 +1136,24 @@ Lemma sqrt_step_correct rec i j: φ (rec i j1) ^ 2 <= φ i < (φ (rec i j1) + 1) ^ 2) -> φ (sqrt_step rec i j) ^ 2 <= φ i < (φ (sqrt_step rec i j) + 1) ^ 2. Proof. - assert (Hp2: 0 < φ 2) by exact (refl_equal Lt). - intros Hi Hj Hij H31 Hrec. - unfold sqrt_step. - case ltbP; rewrite div_spec. - - intros hlt. - assert (φ (j + i / j) = φ j + φ i/φ j) as hj. - { rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. } - apply Hrec; rewrite lsr_spec, hj, to_Z_1; change (2 ^ 1) with 2. - + split; [ | apply sqrt_test_false;auto with zarith]. - replace (φ j + φ i/φ j) with (1 * 2 + ((φ j - 2) + φ i / φ j)) by ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= φ i/ φ j) by (apply Z_div_pos; auto with zarith). - assert (0 <= (φ j - 2 + φ i / φ j) / 2) ; auto with zarith. - apply Z.div_pos; [ | lia ]. - case (Zle_lt_or_eq 1 (φ j)); auto with zarith; intros Hj1. - rewrite <- Hj1, Zdiv_1_r; lia. - + apply sqrt_main;auto with zarith. - - split;[apply sqrt_test_true | ];auto with zarith. + assert (Hp2: 0 < φ 2) by exact (refl_equal Lt). + intros Hi Hj Hij H31 Hrec. + unfold sqrt_step. + case ltbP; rewrite div_spec. + - intros hlt. + assert (φ (j + i / j) = φ j + φ i/φ j) as hj. + { rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. } + apply Hrec; rewrite lsr_spec, hj, to_Z_1; change (2 ^ 1) with 2. + + split; [ | apply sqrt_test_false;auto with zarith]. + replace (φ j + φ i/φ j) with (1 * 2 + ((φ j - 2) + φ i / φ j)) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= φ i/ φ j) by (apply Z_div_pos; auto with zarith). + assert (0 <= (φ j - 2 + φ i / φ j) / 2) ; auto with zarith. + apply Z.div_pos; [ | lia ]. + case (Zle_lt_or_eq 1 (φ j)); auto with zarith; intros Hj1. + rewrite <- Hj1, Zdiv_1_r; lia. + + apply sqrt_main;auto with zarith. + - split;[apply sqrt_test_true | ];auto with zarith. Qed. Lemma iter_sqrt_correct n rec i j: 0 < φ i -> 0 < φ j -> @@ -1163,60 +1163,60 @@ Lemma iter_sqrt_correct n rec i j: 0 < φ i -> 0 < φ j -> φ (rec i j1) ^ 2 <= φ i < (φ (rec i j1) + 1) ^ 2) -> φ (iter_sqrt n rec i j) ^ 2 <= φ i < (φ (iter_sqrt n rec i j) + 1) ^ 2. Proof. - revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. - - intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct. 1-4: lia. - intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. - - intros n Hrec rec i j Hi Hj Hij H31 HHrec. - apply sqrt_step_correct; auto. - intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. - intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. - intros j3 Hj3 Hpj3. - apply HHrec; auto. - rewrite -> inj_S, Z.pow_succ_r. - + apply Z.le_trans with (2 ^Z_of_nat n + φ j2); auto with zarith. - + apply Zle_0_nat. + revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. + - intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct. 1-4: lia. + intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. + - intros n Hrec rec i j Hi Hj Hij H31 HHrec. + apply sqrt_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite -> inj_S, Z.pow_succ_r. + + apply Z.le_trans with (2 ^Z_of_nat n + φ j2); auto with zarith. + + apply Zle_0_nat. Qed. Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. Proof. - intros Hi. - assert (H1: 0 <= i - 2) by auto with zarith. - assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. { - replace i with (1* 2 + (i - 2)); auto with zarith. - rewrite Z.pow_2_r, Z_div_plus_full_l; [|auto with zarith]. - generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). - rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - auto with zarith. - } - generalize (quotient_by_2 i). - rewrite -> Z.pow_2_r in H2 |- *; - repeat (rewrite Zmult_plus_distr_l || - rewrite Zmult_plus_distr_r || - rewrite Zmult_1_l || rewrite Zmult_1_r). - auto with zarith. + intros Hi. + assert (H1: 0 <= i - 2) by auto with zarith. + assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. { + replace i with (1* 2 + (i - 2)); auto with zarith. + rewrite Z.pow_2_r, Z_div_plus_full_l; [|auto with zarith]. + generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). + rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + } + generalize (quotient_by_2 i). + rewrite -> Z.pow_2_r in H2 |- *; + repeat (rewrite Zmult_plus_distr_l || + rewrite Zmult_plus_distr_r || + rewrite Zmult_1_l || rewrite Zmult_1_r). + auto with zarith. Qed. Lemma sqrt_spec : forall x, φ (sqrt x) ^ 2 <= φ x < (φ (sqrt x) + 1) ^ 2. Proof. - intros i; unfold sqrt. - rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; - intros Hi. - - lia. - - apply iter_sqrt_correct; auto with zarith; - rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. - + replace (φ i) with (1 * 2 + (φ i - 2))%Z; try ring. - assert (0 <= (φ i - 2)/2)%Z by (apply Z_div_pos; auto with zarith). - rewrite Z_div_plus_full_l; auto with zarith. - + apply sqrt_init; auto. - + assert (W:= Z_mult_div_ge (φ i) 2);assert (W':= to_Z_bounded i);auto with zarith. - + intros j2 H1 H2; contradict H2; apply Zlt_not_le. - fold wB;assert (W:=to_Z_bounded i). - apply Z.le_lt_trans with (φ i); auto with zarith. - assert (0 <= φ i/2)%Z by (apply Z_div_pos; auto with zarith). - apply Z.le_trans with (2 * (φ i/2)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. - - case (to_Z_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. + intros i; unfold sqrt. + rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; + intros Hi. + - lia. + - apply iter_sqrt_correct; auto with zarith; + rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. + + replace (φ i) with (1 * 2 + (φ i - 2))%Z; try ring. + assert (0 <= (φ i - 2)/2)%Z by (apply Z_div_pos; auto with zarith). + rewrite Z_div_plus_full_l; auto with zarith. + + apply sqrt_init; auto. + + assert (W:= Z_mult_div_ge (φ i) 2);assert (W':= to_Z_bounded i);auto with zarith. + + intros j2 H1 H2; contradict H2; apply Zlt_not_le. + fold wB;assert (W:=to_Z_bounded i). + apply Z.le_lt_trans with (φ i); auto with zarith. + assert (0 <= φ i/2)%Z by (apply Z_div_pos; auto with zarith). + apply Z.le_trans with (2 * (φ i/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + - case (to_Z_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. Qed. (* sqrt2 *) @@ -1234,23 +1234,23 @@ Lemma sqrt2_step_def rec ih il j: else j else j. Proof. - unfold sqrt2_step; case diveucl_21; intros i j';simpl. - case (j +c i);trivial. + unfold sqrt2_step; case diveucl_21; intros i j';simpl. + case (j +c i);trivial. Qed. Lemma sqrt2_lower_bound ih il j: Φ (WW ih il) < (φ j + 1) ^ 2 -> φ ih <= φ j. Proof. - intros H1. - case (to_Z_bounded j); intros Hbj _. - case (to_Z_bounded il); intros Hbil _. - case (to_Z_bounded ih); intros Hbih Hbih1. - assert ((φ ih < φ j + 1)%Z); auto with zarith. - apply Zlt_square_simpl; auto with zarith. - simpl zn2z_to_Z in H1. - repeat rewrite <-Z.pow_2_r. - refine (Z.le_lt_trans _ _ _ _ H1). - apply Z.le_trans with (φ ih * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. + intros H1. + case (to_Z_bounded j); intros Hbj _. + case (to_Z_bounded il); intros Hbil _. + case (to_Z_bounded ih); intros Hbih Hbih1. + assert ((φ ih < φ j + 1)%Z); auto with zarith. + apply Zlt_square_simpl; auto with zarith. + simpl zn2z_to_Z in H1. + repeat rewrite <-Z.pow_2_r. + refine (Z.le_lt_trans _ _ _ _ H1). + apply Z.le_trans with (φ ih * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. Qed. Lemma diveucl_21_spec_aux : forall a1 a2 b, @@ -1260,27 +1260,27 @@ Lemma diveucl_21_spec_aux : forall a1 a2 b, φ a1 *wB+ φ a2 = φ q * φ b + φ r /\ 0 <= φ r < φ b. Proof. - intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). - assert (W1:= to_Z_bounded a1). - assert (W2:= to_Z_bounded a2). - assert (Wb:= to_Z_bounded b). - assert (φ b>0) as H by (auto with zarith). - generalize (Z_div_mod (φ a1*wB+φ a2) (φ b) H). - revert W. - destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl (φ a1*wB+φ a2) (φ b)). - intros (H', H''); auto; rewrite H', H''; clear H' H''. - intros (H', H''); split; [ |exact H'']. - now rewrite H', Zmult_comm. + intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). + assert (W1:= to_Z_bounded a1). + assert (W2:= to_Z_bounded a2). + assert (Wb:= to_Z_bounded b). + assert (φ b>0) as H by (auto with zarith). + generalize (Z_div_mod (φ a1*wB+φ a2) (φ b) H). + revert W. + destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl (φ a1*wB+φ a2) (φ b)). + intros (H', H''); auto; rewrite H', H''; clear H' H''. + intros (H', H''); split; [ |exact H'']. + now rewrite H', Zmult_comm. Qed. Lemma div2_phi ih il j: (2^62 <= φ j -> φ ih < φ j -> φ (fst (diveucl_21 ih il j)) = Φ (WW ih il) / φ j)%Z. Proof. - intros Hj Hj1. - generalize (diveucl_21_spec_aux ih il j Hj Hj1). - case diveucl_21; intros q r (Hq, Hr). - apply Zdiv_unique with (φ r); auto with zarith. - simpl @fst; apply eq_trans with (1 := Hq); ring. + intros Hj Hj1. + generalize (diveucl_21_spec_aux ih il j Hj Hj1). + case diveucl_21; intros q r (Hq, Hr). + apply Zdiv_unique with (φ r); auto with zarith. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt2_step_correct rec ih il j: @@ -1291,69 +1291,69 @@ Lemma sqrt2_step_correct rec ih il j: φ (sqrt2_step rec ih il j) ^ 2 <= Φ (WW ih il) < (φ (sqrt2_step rec ih il j) + 1) ^ 2. Proof. - assert (Hp2: (0 < φ 2)%Z) by exact (refl_equal Lt). - intros Hih Hj Hij Hrec; rewrite sqrt2_step_def. - assert (H1: (φ ih <= φ j)%Z) by (apply sqrt2_lower_bound with il; auto). - case (to_Z_bounded ih); intros Hih1 _. - case (to_Z_bounded il); intros Hil1 _. - case (to_Z_bounded j); intros _ Hj1. - assert (Hp3: (0 < Φ (WW ih il))). - {simpl zn2z_to_Z;apply Z.lt_le_trans with (φ ih * wB)%Z; auto with zarith. - apply Zmult_lt_0_compat; auto with zarith. - } - cbv zeta. - case_eq (ih ltb_spec in Heq. - case (Zle_or_lt (2^(Z_of_nat size -1)) (φ j)); intros Hjj. - 1: case_eq (fst (diveucl_21 ih il j) ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. - match goal with |- context[rec _ _ ?X] => - set (u := X) - end. - assert (H: φ u = (φ j + (Φ (WW ih il))/(φ j))/2). - { unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); - case addc;unfold interp_carry;rewrite (div2_phi _ _ _ Hjj Heq);simpl zn2z_to_Z. - { intros i H;rewrite lsr_spec, H;trivial. } - intros i H;rewrite <- H. - case (to_Z_bounded i); intros H1i H2i. - rewrite -> add_spec, Zmod_small, lsr_spec. - { change (1 * wB) with (φ (1 << (digits -1)) * 2)%Z. - rewrite Z_div_plus_full_l; auto with zarith. } - change wB with (2 * (wB/2))%Z; auto. - replace (φ (1 << (digits - 1))) with (wB/2); auto. - rewrite lsr_spec; auto. - replace (2^φ 1) with 2%Z; auto. - split; auto with zarith. - assert (φ i/2 < wB/2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. } - apply Hrec; rewrite H; clear u H. - + assert (Hf1: 0 <= Φ (WW ih il) / φ j) by (apply Z_div_pos; auto with zarith). - case (Zle_lt_or_eq 1 (φ j)); auto with zarith; intros Hf2. - split. - * replace (φ j + Φ (WW ih il) / φ j)%Z with - (1 * 2 + ((φ j - 2) + Φ (WW ih il) / φ j)) by lia. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= (φ j - 2 + Φ (WW ih il) / φ j) / 2) ; auto with zarith. - * apply sqrt_test_false; auto with zarith. - + apply sqrt_main; auto with zarith. - - contradict Hij; apply Zle_not_lt. - assert ((1 + φ j) <= 2 ^ (Z_of_nat size - 1)); auto with zarith. - apply Z.le_trans with ((2 ^ (Z_of_nat size - 1)) ^2); auto with zarith. - + assert (0 <= 1 + φ j); auto with zarith. - apply Zmult_le_compat; auto with zarith. - + change ((2 ^ (Z_of_nat size - 1))^2) with (2 ^ (Z_of_nat size - 2) * wB). - apply Z.le_trans with (φ ih * wB); auto with zarith. - unfold zn2z_to_Z, wB; auto with zarith. + assert (Hp2: (0 < φ 2)%Z) by exact (refl_equal Lt). + intros Hih Hj Hij Hrec; rewrite sqrt2_step_def. + assert (H1: (φ ih <= φ j)%Z) by (apply sqrt2_lower_bound with il; auto). + case (to_Z_bounded ih); intros Hih1 _. + case (to_Z_bounded il); intros Hil1 _. + case (to_Z_bounded j); intros _ Hj1. + assert (Hp3: (0 < Φ (WW ih il))). + {simpl zn2z_to_Z;apply Z.lt_le_trans with (φ ih * wB)%Z; auto with zarith. + apply Zmult_lt_0_compat; auto with zarith. + } + cbv zeta. + case_eq (ih ltb_spec in Heq. + case (Zle_or_lt (2^(Z_of_nat size -1)) (φ j)); intros Hjj. + 1: case_eq (fst (diveucl_21 ih il j) ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. + match goal with |- context[rec _ _ ?X] => + set (u := X) + end. + assert (H: φ u = (φ j + (Φ (WW ih il))/(φ j))/2). + { unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); + case addc;unfold interp_carry;rewrite (div2_phi _ _ _ Hjj Heq);simpl zn2z_to_Z. + { intros i H;rewrite lsr_spec, H;trivial. } + intros i H;rewrite <- H. + case (to_Z_bounded i); intros H1i H2i. + rewrite -> add_spec, Zmod_small, lsr_spec. + { change (1 * wB) with (φ (1 << (digits -1)) * 2)%Z. + rewrite Z_div_plus_full_l; auto with zarith. } + change wB with (2 * (wB/2))%Z; auto. + replace (φ (1 << (digits - 1))) with (wB/2); auto. + rewrite lsr_spec; auto. + replace (2^φ 1) with 2%Z; auto. + split; auto with zarith. + assert (φ i/2 < wB/2); auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. } + apply Hrec; rewrite H; clear u H. + + assert (Hf1: 0 <= Φ (WW ih il) / φ j) by (apply Z_div_pos; auto with zarith). + case (Zle_lt_or_eq 1 (φ j)); auto with zarith; intros Hf2. + split. + * replace (φ j + Φ (WW ih il) / φ j)%Z with + (1 * 2 + ((φ j - 2) + Φ (WW ih il) / φ j)) by lia. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= (φ j - 2 + Φ (WW ih il) / φ j) / 2) ; auto with zarith. + * apply sqrt_test_false; auto with zarith. + + apply sqrt_main; auto with zarith. + - contradict Hij; apply Zle_not_lt. + assert ((1 + φ j) <= 2 ^ (Z_of_nat size - 1)); auto with zarith. + apply Z.le_trans with ((2 ^ (Z_of_nat size - 1)) ^2); auto with zarith. + + assert (0 <= 1 + φ j); auto with zarith. + apply Zmult_le_compat; auto with zarith. + + change ((2 ^ (Z_of_nat size - 1))^2) with (2 ^ (Z_of_nat size - 2) * wB). + apply Z.le_trans with (φ ih * wB); auto with zarith. + unfold zn2z_to_Z, wB; auto with zarith. Qed. Lemma iter2_sqrt_correct n rec ih il j: @@ -1364,18 +1364,18 @@ Lemma iter2_sqrt_correct n rec ih il j: φ (iter2_sqrt n rec ih il j) ^ 2 <= Φ (WW ih il) < (φ (iter2_sqrt n rec ih il j) + 1) ^ 2. Proof. - revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. - - intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct. 1-3: lia. - intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. - - intros n Hrec rec ih il j Hi Hj Hij HHrec. - apply sqrt2_step_correct; auto. - intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. - intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. - intros j3 Hj3 Hpj3. - apply HHrec; auto. - rewrite -> inj_S, Z.pow_succ_r. - + apply Z.le_trans with (2 ^Z_of_nat n + φ j2)%Z; auto with zarith. - + apply Zle_0_nat. + revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. + - intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct. 1-3: lia. + intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. + - intros n Hrec rec ih il j Hi Hj Hij HHrec. + apply sqrt2_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite -> inj_S, Z.pow_succ_r. + + apply Z.le_trans with (2 ^Z_of_nat n + φ j2)%Z; auto with zarith. + + apply Zle_0_nat. Qed. Lemma sqrt2_spec : forall x y, @@ -1384,134 +1384,134 @@ Lemma sqrt2_spec : forall x y, Φ (WW x y) = φ s ^ 2 + [+|r|] /\ [+|r|] <= 2 * φ s. Proof. - intros ih il Hih; unfold sqrt2. - change (Φ (WW ih il)) with (Φ(WW ih il)). - assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by - (intros s; ring). - assert (Hb: 0 <= wB) by (red; intros HH; discriminate). - assert (Hi2: Φ(WW ih il ) < (φ max_int + 1) ^ 2). { - apply Z.le_lt_trans with ((wB - 1) * wB + (wB - 1)); auto with zarith. - case (to_Z_bounded ih); case (to_Z_bounded il); intros H1 H2 H3 H4. - unfold zn2z_to_Z; auto with zarith. - } - case (iter2_sqrt_correct size (fun _ _ j => j) ih il max_int); auto with zarith. - - apply refl_equal. - - intros j1 _ HH; contradict HH. - apply Zlt_not_le. - case (to_Z_bounded j1); auto with zarith. - change (2 ^ Z_of_nat size) with (φ max_int+1)%Z; auto with zarith. - - set (s := iter2_sqrt size (fun _ _ j : int=> j) ih il max_int). - intros Hs1 Hs2. - generalize (mulc_spec s s); case mulc. - simpl fst; simpl snd; intros ih1 il1 Hihl1. - generalize (subc_spec il il1). - case subc; intros il2 Hil2. - + simpl interp_carry in Hil2. - case_eq (ih1 Z.pow_2_r, Hihl1, Hil2. - case (Zle_lt_or_eq (φ ih1 + 1) (φ ih)); auto with zarith. - -- intros H2; contradict Hs2; apply Zle_not_lt. - replace ((φ s + 1) ^ 2) with (Φ(WW ih1 il1) + 2 * φ s + 1). - ++ unfold zn2z_to_Z. - case (to_Z_bounded il); intros Hpil _. - assert (Hl1l: φ il1 <= φ il). - ** case (to_Z_bounded il2); rewrite Hil2; auto with zarith. - ** enough (φ ih1 * wB + 2 * φ s + 1 <= φ ih * wB) by lia. - case (to_Z_bounded s); intros _ Hps. - case (to_Z_bounded ih1); intros Hpih1 _. - apply Z.le_trans with ((φ ih1 + 2) * wB). { lia. } - auto with zarith. - ++ unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. - -- intros H2; split. - ++ unfold zn2z_to_Z; rewrite <- H2; ring. - ++ replace (wB + (φ il - φ il1)) with (Φ(WW ih il) - (φ s * φ s)). - { rewrite <-Hbin in Hs2; auto with zarith. } - rewrite Hihl1; unfold zn2z_to_Z; rewrite <- H2; ring. - * unfold interp_carry. - case (Zle_lt_or_eq (φ ih) (φ ih1)); auto with zarith; intros H. - -- contradict Hs1. - apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. - unfold zn2z_to_Z. - case (to_Z_bounded il); intros _ H2. - apply Z.lt_le_trans with ((φ ih + 1) * wB + 0). - ++ rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. - ++ case (to_Z_bounded il1); intros H3 _. - apply Zplus_le_compat; auto with zarith. - -- split. - ++ rewrite Z.pow_2_r, Hihl1. - unfold zn2z_to_Z; ring[Hil2 H]. - ++ replace (φ il2) with (Φ(WW ih il) - Φ(WW ih1 il1)). - { unfold zn2z_to_Z at 2; rewrite <-Hihl1. - rewrite <-Hbin in Hs2; auto with zarith. } - unfold zn2z_to_Z; rewrite H, Hil2; ring. - + unfold interp_carry in Hil2 |- *. - assert (Hsih: φ (ih - 1) = φ ih - 1). - { rewrite sub_spec, Zmod_small; auto; replace (φ 1) with 1; auto. - case (to_Z_bounded ih); intros H1 H2. - split; auto with zarith. - apply Z.le_trans with (wB/4 - 1); auto with zarith. } - case_eq (ih1 j) ih il max_int); auto with zarith. + - apply refl_equal. + - intros j1 _ HH; contradict HH. + apply Zlt_not_le. + case (to_Z_bounded j1); auto with zarith. + change (2 ^ Z_of_nat size) with (φ max_int+1)%Z; auto with zarith. + - set (s := iter2_sqrt size (fun _ _ j : int=> j) ih il max_int). + intros Hs1 Hs2. + generalize (mulc_spec s s); case mulc. + simpl fst; simpl snd; intros ih1 il1 Hihl1. + generalize (subc_spec il il1). + case subc; intros il2 Hil2. + + simpl interp_carry in Hil2. + case_eq (ih1 Z.pow_2_r, Hihl1, Hil2. + case (Zle_lt_or_eq (φ ih1 + 1) (φ ih)); auto with zarith. + -- intros H2; contradict Hs2; apply Zle_not_lt. + replace ((φ s + 1) ^ 2) with (Φ(WW ih1 il1) + 2 * φ s + 1). + ++ unfold zn2z_to_Z. + case (to_Z_bounded il); intros Hpil _. + assert (Hl1l: φ il1 <= φ il). + ** case (to_Z_bounded il2); rewrite Hil2; auto with zarith. + ** enough (φ ih1 * wB + 2 * φ s + 1 <= φ ih * wB) by lia. + case (to_Z_bounded s); intros _ Hps. + case (to_Z_bounded ih1); intros Hpih1 _. + apply Z.le_trans with ((φ ih1 + 2) * wB). { lia. } + auto with zarith. + ++ unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. + -- intros H2; split. + ++ unfold zn2z_to_Z; rewrite <- H2; ring. + ++ replace (wB + (φ il - φ il1)) with (Φ(WW ih il) - (φ s * φ s)). + { rewrite <-Hbin in Hs2; auto with zarith. } + rewrite Hihl1; unfold zn2z_to_Z; rewrite <- H2; ring. + * unfold interp_carry. + case (Zle_lt_or_eq (φ ih) (φ ih1)); auto with zarith; intros H. + -- contradict Hs1. + apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. unfold zn2z_to_Z. - case (to_Z_bounded il); intros _ Hpil1. - apply Z.lt_le_trans with ((φ ih + 1) * wB). - - rewrite Zmult_plus_distr_l, Zmult_1_l; auto with zarith. - - case (to_Z_bounded il1); intros Hpil2 _. - apply Z.le_trans with ((φ ih1) * wB); auto with zarith. - } - contradict Hs1; apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. - unfold zn2z_to_Z; rewrite He. - assert (φ il - φ il1 < 0); auto with zarith. - rewrite <-Hil2. - case (to_Z_bounded il2); auto with zarith. - -- split. - ++ rewrite Z.pow_2_r, Hihl1. - unfold zn2z_to_Z; rewrite <-H1. - apply trans_equal with (φ ih * wB + φ il1 + (φ il - φ il1)). - ** ring. - ** rewrite <-Hil2; ring. - ++ replace (φ il2) with (Φ(WW ih il) - Φ(WW ih1 il1)). - ** unfold zn2z_to_Z at 2; rewrite <- Hihl1. - rewrite <-Hbin in Hs2; auto with zarith. - ** unfold zn2z_to_Z. - rewrite <-H1. - ring_simplify. - apply trans_equal with (wB + (φ il - φ il1)). - 1:ring. - rewrite <-Hil2; ring. + case (to_Z_bounded il); intros _ H2. + apply Z.lt_le_trans with ((φ ih + 1) * wB + 0). + ++ rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. + ++ case (to_Z_bounded il1); intros H3 _. + apply Zplus_le_compat; auto with zarith. + -- split. + ++ rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; ring[Hil2 H]. + ++ replace (φ il2) with (Φ(WW ih il) - Φ(WW ih1 il1)). + { unfold zn2z_to_Z at 2; rewrite <-Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. } + unfold zn2z_to_Z; rewrite H, Hil2; ring. + + unfold interp_carry in Hil2 |- *. + assert (Hsih: φ (ih - 1) = φ ih - 1). + { rewrite sub_spec, Zmod_small; auto; replace (φ 1) with 1; auto. + case (to_Z_bounded ih); intros H1 H2. + split; auto with zarith. + apply Z.le_trans with (wB/4 - 1); auto with zarith. } + case_eq (ih1 nzhead d' = Nil. Proof. -now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. + now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. Qed. Lemma nzhead_app_nil d d' : diff --git a/theories/Numbers/DecimalN.v b/theories/Numbers/DecimalN.v index f046178608..8f3e66d1cb 100644 --- a/theories/Numbers/DecimalN.v +++ b/theories/Numbers/DecimalN.v @@ -17,46 +17,46 @@ From Stdlib Require Import Decimal DecimalFacts DecimalPos BinPos BinNat. Module Unsigned. -Lemma of_to (n:N) : N.of_uint (N.to_uint n) = n. -Proof. - destruct n. - - reflexivity. - - apply DecimalPos.Unsigned.of_to. -Qed. - -Lemma to_of (d:uint) : N.to_uint (N.of_uint d) = unorm d. -Proof. - exact (DecimalPos.Unsigned.to_of d). -Qed. - -Lemma to_uint_inj n n' : N.to_uint n = N.to_uint n' -> n = n'. -Proof. - intros E. now rewrite <- (of_to n), <- (of_to n'), E. -Qed. - -Lemma to_uint_surj d : exists p, N.to_uint p = unorm d. -Proof. - exists (N.of_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : N.of_uint (unorm d) = N.of_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - N.of_uint d = N.of_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : N.of_uint d = N.of_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. + Lemma of_to (n:N) : N.of_uint (N.to_uint n) = n. + Proof. + destruct n. + - reflexivity. + - apply DecimalPos.Unsigned.of_to. + Qed. + + Lemma to_of (d:uint) : N.to_uint (N.of_uint d) = unorm d. + Proof. + exact (DecimalPos.Unsigned.to_of d). + Qed. + + Lemma to_uint_inj n n' : N.to_uint n = N.to_uint n' -> n = n'. + Proof. + intros E. now rewrite <- (of_to n), <- (of_to n'), E. + Qed. + + Lemma to_uint_surj d : exists p, N.to_uint p = unorm d. + Proof. + exists (N.of_uint d). apply to_of. + Qed. + + Lemma of_uint_norm d : N.of_uint (unorm d) = N.of_uint d. + Proof. + now induction d. + Qed. + + Lemma of_inj d d' : + N.of_uint d = N.of_uint d' -> unorm d = unorm d'. + Proof. + intros. rewrite <- !to_of. now f_equal. + Qed. + + Lemma of_iff d d' : N.of_uint d = N.of_uint d' <-> unorm d = unorm d'. + Proof. + split. + - apply of_inj. + - intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. + Qed. End Unsigned. @@ -64,46 +64,46 @@ End Unsigned. Module Signed. -Lemma of_to (n:N) : N.of_int (N.to_int n) = Some n. -Proof. - unfold N.to_int, N.of_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:N) : N.of_int d = Some n -> N.to_int n = norm d. -Proof. - unfold N.of_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold N.to_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : N.to_int n = N.to_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, N.to_int n = norm (Pos d). -Proof. - exists (N.of_uint d). unfold N.to_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. -Proof. - unfold N.of_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - N.of_int (Pos d) = N.of_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold N.of_int. simpl. intros [= H]. apply Unsigned.of_inj. - change Pos.of_uint with N.of_uint in H. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. + Lemma of_to (n:N) : N.of_int (N.to_int n) = Some n. + Proof. + unfold N.to_int, N.of_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. + Qed. + + Lemma to_of (d:int)(n:N) : N.of_int d = Some n -> N.to_int n = norm d. + Proof. + unfold N.of_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold N.to_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_involutive. + - destruct (nzhead d); now intros [= <-]. + Qed. + + Lemma to_int_inj n n' : N.to_int n = N.to_int n' -> n = n'. + Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. + Qed. + + Lemma to_int_pos_surj d : exists n, N.to_int n = norm (Pos d). + Proof. + exists (N.of_uint d). unfold N.to_int. now rewrite Unsigned.to_of. + Qed. + + Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. + Proof. + unfold N.of_int. now rewrite norm_involutive. + Qed. + + Lemma of_inj_pos d d' : + N.of_int (Pos d) = N.of_int (Pos d') -> unorm d = unorm d'. + Proof. + unfold N.of_int. simpl. intros [= H]. apply Unsigned.of_inj. + change Pos.of_uint with N.of_uint in H. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. + Qed. End Signed. diff --git a/theories/Numbers/DecimalNat.v b/theories/Numbers/DecimalNat.v index a964f97433..ac5ef68ee8 100644 --- a/theories/Numbers/DecimalNat.v +++ b/theories/Numbers/DecimalNat.v @@ -17,242 +17,242 @@ From Stdlib Require Import Decimal DecimalFacts PeanoNat. Module Unsigned. -(** A few helper functions used during proofs *) - -Definition hd d := - match d with - | Nil => 0 - | D0 _ => 0 - | D1 _ => 1 - | D2 _ => 2 - | D3 _ => 3 - | D4 _ => 4 - | D5 _ => 5 - | D6 _ => 6 - | D7 _ => 7 - | D8 _ => 8 - | D9 _ => 9 - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d - end. - -Fixpoint usize (d:uint) : nat := - match d with - | Nil => 0 - | D0 d => S (usize d) - | D1 d => S (usize d) - | D2 d => S (usize d) - | D3 d => S (usize d) - | D4 d => S (usize d) - | D5 d => S (usize d) - | D6 d => S (usize d) - | D7 d => S (usize d) - | D8 d => S (usize d) - | D9 d => S (usize d) - end. - -(** A direct version of [to_little_uint], not tail-recursive *) -Fixpoint to_lu n := - match n with - | 0 => Decimal.zero - | S n => Little.succ (to_lu n) - end. - -(** A direct version of [of_little_uint] *) -Fixpoint of_lu (d:uint) : nat := - match d with - | Nil => 0 - | D0 d => 10 * of_lu d - | D1 d => 1 + 10 * of_lu d - | D2 d => 2 + 10 * of_lu d - | D3 d => 3 + 10 * of_lu d - | D4 d => 4 + 10 * of_lu d - | D5 d => 5 + 10 * of_lu d - | D6 d => 6 + 10 * of_lu d - | D7 d => 7 + 10 * of_lu d - | D8 d => 8 + 10 * of_lu d - | D9 d => 9 + 10 * of_lu d - end. - -(** Properties of [to_lu] *) - -Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). -Proof. - reflexivity. -Qed. - -Lemma to_little_uint_succ n d : - Nat.to_little_uint n (Little.succ d) = - Little.succ (Nat.to_little_uint n d). -Proof. - revert d; induction n; simpl; trivial. -Qed. - -Lemma to_lu_equiv n : - to_lu n = Nat.to_little_uint n zero. -Proof. - induction n; simpl; trivial. - now rewrite IHn, <- to_little_uint_succ. -Qed. - -Lemma to_uint_alt n : - Nat.to_uint n = rev (to_lu n). -Proof. - unfold Nat.to_uint. f_equal. symmetry. apply to_lu_equiv. -Qed. - -(** Properties of [of_lu] *) - -Lemma of_lu_eqn d : - of_lu d = hd d + 10 * of_lu (tl d). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Lemma of_lu_succ d : - of_lu (Little.succ d) = S (of_lu d). -Proof. - induction d; trivial. - simpl_of_lu. rewrite IHd. simpl_of_lu. - now rewrite Nat.mul_succ_r, <- (Nat.add_comm 10). -Qed. - -Lemma of_to_lu n : - of_lu (to_lu n) = n. -Proof. - induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. -Qed. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 10^usize d. -Proof. - revert d'. - induction d; intro d'; simpl usize; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite ?Nat.pow_succ_r', ?Nat.mul_assoc, ?Nat.mul_add_distr_r, ?(Nat.mul_comm 10); trivial. -Qed. - -Lemma of_uint_acc_spec n d : - Nat.of_uint_acc d n = of_lu (rev d) + n * 10^usize d. -Proof. - revert n. induction d; intros; - simpl Nat.of_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; - simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev at 2; simpl revapp; rewrite of_lu_revapp; simpl of_lu; - rewrite ?Nat.mul_assoc, <-?Nat.add_assoc, <-?Nat.mul_add_distr_r, ?(Nat.mul_comm _ 10); trivial. -Qed. - -Lemma of_uint_alt d : Nat.of_uint d = of_lu (rev d). -Proof. - unfold Nat.of_uint. now rewrite of_uint_acc_spec. -Qed. - -(** First main bijection result *) - -Lemma of_to (n:nat) : Nat.of_uint (Nat.to_uint n) = n. -Proof. - rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. -Qed. - -(** The other direction *) - -Lemma to_lu_tenfold n : n<>0 -> - to_lu (10 * n) = D0 (to_lu n). -Proof. - induction n. - - simpl. now destruct 1. - - intros _. - destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. - rewrite !Nat.add_succ_r. - simpl in *. rewrite (IHn H). now destruct (to_lu n). -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; try easy. - rewrite Nat.add_0_l. - split; intros H. - - apply Nat.eq_mul_0_r in H; auto. - rewrite IHd in H. simpl. now rewrite H. - - simpl in H. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. -Qed. - -Lemma to_of_lu_tenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - rewrite (to_lu_tenfold _ H), IH. - rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [ reflexivity | .. ]; - simpl_of_lu; - rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_tenfold - by assumption; - unfold lnorm; simpl; now destruct nztail. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : Nat.to_uint (Nat.of_uint d) = unorm d. -Proof. - rewrite to_uint_alt, of_uint_alt, to_of_lu. - apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_inj n n' : Nat.to_uint n = Nat.to_uint n' -> n = n'. -Proof. - intro EQ. - now rewrite <- (of_to n), <- (of_to n'), EQ. -Qed. - -Lemma to_uint_surj d : exists n, Nat.to_uint n = unorm d. -Proof. - exists (Nat.of_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : Nat.of_uint (unorm d) = Nat.of_uint d. -Proof. - unfold Nat.of_uint. now induction d. -Qed. - -Lemma of_inj d d' : - Nat.of_uint d = Nat.of_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Nat.of_uint d = Nat.of_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. + (** A few helper functions used during proofs *) + + Definition hd d := + match d with + | Nil => 0 + | D0 _ => 0 + | D1 _ => 1 + | D2 _ => 2 + | D3 _ => 3 + | D4 _ => 4 + | D5 _ => 5 + | D6 _ => 6 + | D7 _ => 7 + | D8 _ => 8 + | D9 _ => 9 + end. + + Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d + end. + + Fixpoint usize (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => S (usize d) + | D1 d => S (usize d) + | D2 d => S (usize d) + | D3 d => S (usize d) + | D4 d => S (usize d) + | D5 d => S (usize d) + | D6 d => S (usize d) + | D7 d => S (usize d) + | D8 d => S (usize d) + | D9 d => S (usize d) + end. + + (** A direct version of [to_little_uint], not tail-recursive *) + Fixpoint to_lu n := + match n with + | 0 => Decimal.zero + | S n => Little.succ (to_lu n) + end. + + (** A direct version of [of_little_uint] *) + Fixpoint of_lu (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => 10 * of_lu d + | D1 d => 1 + 10 * of_lu d + | D2 d => 2 + 10 * of_lu d + | D3 d => 3 + 10 * of_lu d + | D4 d => 4 + 10 * of_lu d + | D5 d => 5 + 10 * of_lu d + | D6 d => 6 + 10 * of_lu d + | D7 d => 7 + 10 * of_lu d + | D8 d => 8 + 10 * of_lu d + | D9 d => 9 + 10 * of_lu d + end. + + (** Properties of [to_lu] *) + + Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). + Proof. + reflexivity. + Qed. + + Lemma to_little_uint_succ n d : + Nat.to_little_uint n (Little.succ d) = + Little.succ (Nat.to_little_uint n d). + Proof. + revert d; induction n; simpl; trivial. + Qed. + + Lemma to_lu_equiv n : + to_lu n = Nat.to_little_uint n zero. + Proof. + induction n; simpl; trivial. + now rewrite IHn, <- to_little_uint_succ. + Qed. + + Lemma to_uint_alt n : + Nat.to_uint n = rev (to_lu n). + Proof. + unfold Nat.to_uint. f_equal. symmetry. apply to_lu_equiv. + Qed. + + (** Properties of [of_lu] *) + + Lemma of_lu_eqn d : + of_lu d = hd d + 10 * of_lu (tl d). + Proof. + induction d; simpl; trivial. + Qed. + + Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + + Lemma of_lu_succ d : + of_lu (Little.succ d) = S (of_lu d). + Proof. + induction d; trivial. + simpl_of_lu. rewrite IHd. simpl_of_lu. + now rewrite Nat.mul_succ_r, <- (Nat.add_comm 10). + Qed. + + Lemma of_to_lu n : + of_lu (to_lu n) = n. + Proof. + induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. + Qed. + + Lemma of_lu_revapp d d' : + of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 10^usize d. + Proof. + revert d'. + induction d; intro d'; simpl usize; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite ?Nat.pow_succ_r', ?Nat.mul_assoc, ?Nat.mul_add_distr_r, ?(Nat.mul_comm 10); trivial. + Qed. + + Lemma of_uint_acc_spec n d : + Nat.of_uint_acc d n = of_lu (rev d) + n * 10^usize d. + Proof. + revert n. induction d; intros; + simpl Nat.of_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; + simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev at 2; simpl revapp; rewrite of_lu_revapp; simpl of_lu; + rewrite ?Nat.mul_assoc, <-?Nat.add_assoc, <-?Nat.mul_add_distr_r, ?(Nat.mul_comm _ 10); trivial. + Qed. + + Lemma of_uint_alt d : Nat.of_uint d = of_lu (rev d). + Proof. + unfold Nat.of_uint. now rewrite of_uint_acc_spec. + Qed. + + (** First main bijection result *) + + Lemma of_to (n:nat) : Nat.of_uint (Nat.to_uint n) = n. + Proof. + rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. + Qed. + + (** The other direction *) + + Lemma to_lu_tenfold n : n<>0 -> + to_lu (10 * n) = D0 (to_lu n). + Proof. + induction n. + - simpl. now destruct 1. + - intros _. + destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. + rewrite !Nat.add_succ_r. + simpl in *. rewrite (IHn H). now destruct (to_lu n). + Qed. + + Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. + Proof. + induction d; try simpl_of_lu; try easy. + rewrite Nat.add_0_l. + split; intros H. + - apply Nat.eq_mul_0_r in H; auto. + rewrite IHd in H. simpl. now rewrite H. + - simpl in H. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. + Qed. + + Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (10 * of_lu d) = lnorm (D0 d). + Proof. + intro IH. + destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - rewrite (to_lu_tenfold _ H), IH. + rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). + Qed. + + Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. + Proof. + induction d; [ reflexivity | .. ]; + simpl_of_lu; + rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_tenfold + by assumption; + unfold lnorm; simpl; now destruct nztail. + Qed. + + (** Second bijection result *) + + Lemma to_of (d:uint) : Nat.to_uint (Nat.of_uint d) = unorm d. + Proof. + rewrite to_uint_alt, of_uint_alt, to_of_lu. + apply rev_lnorm_rev. + Qed. + + (** Some consequences *) + + Lemma to_uint_inj n n' : Nat.to_uint n = Nat.to_uint n' -> n = n'. + Proof. + intro EQ. + now rewrite <- (of_to n), <- (of_to n'), EQ. + Qed. + + Lemma to_uint_surj d : exists n, Nat.to_uint n = unorm d. + Proof. + exists (Nat.of_uint d). apply to_of. + Qed. + + Lemma of_uint_norm d : Nat.of_uint (unorm d) = Nat.of_uint d. + Proof. + unfold Nat.of_uint. now induction d. + Qed. + + Lemma of_inj d d' : + Nat.of_uint d = Nat.of_uint d' -> unorm d = unorm d'. + Proof. + intros. rewrite <- !to_of. now f_equal. + Qed. + + Lemma of_iff d d' : Nat.of_uint d = Nat.of_uint d' <-> unorm d = unorm d'. + Proof. + split. + - apply of_inj. + - intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. + Qed. End Unsigned. @@ -260,45 +260,45 @@ End Unsigned. Module Signed. -Lemma of_to (n:nat) : Nat.of_int (Nat.to_int n) = Some n. -Proof. - unfold Nat.to_int, Nat.of_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:nat) : Nat.of_int d = Some n -> Nat.to_int n = norm d. -Proof. - unfold Nat.of_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : Nat.to_int n = Nat.to_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, Nat.to_int n = norm (Pos d). -Proof. - exists (Nat.of_uint d). unfold Nat.to_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. -Proof. - unfold Nat.of_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - Nat.of_int (Pos d) = Nat.of_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Nat.of_int. simpl. intros [= H]. apply Unsigned.of_inj. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. + Lemma of_to (n:nat) : Nat.of_int (Nat.to_int n) = Some n. + Proof. + unfold Nat.to_int, Nat.of_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. + Qed. + + Lemma to_of (d:int)(n:nat) : Nat.of_int d = Some n -> Nat.to_int n = norm d. + Proof. + unfold Nat.of_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_involutive. + - destruct (nzhead d); now intros [= <-]. + Qed. + + Lemma to_int_inj n n' : Nat.to_int n = Nat.to_int n' -> n = n'. + Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. + Qed. + + Lemma to_int_pos_surj d : exists n, Nat.to_int n = norm (Pos d). + Proof. + exists (Nat.of_uint d). unfold Nat.to_int. now rewrite Unsigned.to_of. + Qed. + + Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. + Proof. + unfold Nat.of_int. now rewrite norm_involutive. + Qed. + + Lemma of_inj_pos d d' : + Nat.of_int (Pos d) = Nat.of_int (Pos d') -> unorm d = unorm d'. + Proof. + unfold Nat.of_int. simpl. intros [= H]. apply Unsigned.of_inj. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. + Qed. End Signed. diff --git a/theories/Numbers/DecimalPos.v b/theories/Numbers/DecimalPos.v index 7959799e48..2eaee3d5b2 100644 --- a/theories/Numbers/DecimalPos.v +++ b/theories/Numbers/DecimalPos.v @@ -17,331 +17,331 @@ From Stdlib Require Import Decimal DecimalFacts BinPos BinNat Nnat. Module Unsigned. -#[local] Open Scope N. - -(** A direct version of [of_little_uint] *) -Fixpoint of_lu (d:uint) : N := - match d with - | Nil => 0 - | D0 d => 10 * of_lu d - | D1 d => 1 + 10 * of_lu d - | D2 d => 2 + 10 * of_lu d - | D3 d => 3 + 10 * of_lu d - | D4 d => 4 + 10 * of_lu d - | D5 d => 5 + 10 * of_lu d - | D6 d => 6 + 10 * of_lu d - | D7 d => 7 + 10 * of_lu d - | D8 d => 8 + 10 * of_lu d - | D9 d => 9 + 10 * of_lu d - end. - -Definition hd d := - match d with - | Nil => 0 - | D0 _ => 0 - | D1 _ => 1 - | D2 _ => 2 - | D3 _ => 3 - | D4 _ => 4 - | D5 _ => 5 - | D6 _ => 6 - | D7 _ => 7 - | D8 _ => 8 - | D9 _ => 9 - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d - end. - -Lemma of_lu_eqn d : - of_lu d = hd d + 10 * (of_lu (tl d)). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Fixpoint usize (d:uint) : N := - match d with - | Nil => 0 - | D0 d => N.succ (usize d) - | D1 d => N.succ (usize d) - | D2 d => N.succ (usize d) - | D3 d => N.succ (usize d) - | D4 d => N.succ (usize d) - | D5 d => N.succ (usize d) - | D6 d => N.succ (usize d) - | D7 d => N.succ (usize d) - | D8 d => N.succ (usize d) - | D9 d => N.succ (usize d) - end. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 10^usize d. -Proof. - revert d'. - induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite N.pow_succ_r', ?N.mul_assoc, ?(N.mul_comm 10), ?Nmult_plus_distr_r; trivial. -Qed. - -Definition Nadd n p := - match n with - | N0 => p - | Npos p0 => (p0+p)%positive - end. - -Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. -Proof. - now destruct n. -Qed. - -Lemma of_uint_acc_eqn d acc : d<>Nil -> - Pos.of_uint_acc d acc = Pos.of_uint_acc (tl d) (Nadd (hd d) (10*acc)). -Proof. - destruct d; simpl; trivial. now destruct 1. -Qed. - -Lemma of_uint_acc_rev d acc : - Npos (Pos.of_uint_acc d acc) = - of_lu (rev d) + (Npos acc) * 10^usize d. -Proof. - revert acc. - induction d; intros; simpl usize; - [ simpl; now rewrite Pos.mul_1_r | .. ]; - rewrite N.pow_succ_r'; - unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; - rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; - rewrite IHd, Nadd_simpl, ?N.mul_assoc, <-?N.add_assoc, ?(N.mul_comm 10), ?Nmult_plus_distr_r; trivial. -Qed. - -Lemma of_uint_alt d : Pos.of_uint d = of_lu (rev d). -Proof. - induction d; simpl; trivial; unfold rev; simpl revapp; - rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. - rewrite IHd, N.add_0_r; trivial. -Qed. - -Lemma of_lu_rev d : Pos.of_uint (rev d) = of_lu d. -Proof. - rewrite of_uint_alt. now rewrite rev_rev. -Qed. - -Lemma of_lu_double_gen d : - of_lu (Little.double d) = N.double (of_lu d) /\ - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - rewrite N.double_spec, N.succ_double_spec. - induction d; try destruct IHd as (IH1,IH2); - simpl Little.double; simpl Little.succ_double; - repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; - rewrite ?(N.add_comm _ 1), ?Nmult_plus_distr_l, ?N.add_assoc, ?N.mul_assoc; trivial. -Qed. - -Lemma of_lu_double d : - of_lu (Little.double d) = N.double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -Lemma of_lu_succ_double d : - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -(** First bijection result *) - -Lemma of_to (p:positive) : Pos.of_uint (Pos.to_uint p) = Npos p. -Proof. - unfold Pos.to_uint. - rewrite of_lu_rev. - induction p; simpl; trivial. - - now rewrite of_lu_succ_double, IHp. - - now rewrite of_lu_double, IHp. -Qed. - -(** The other direction *) - -Definition to_lu n := - match n with - | N0 => Decimal.zero - | Npos p => Pos.to_little_uint p - end. - -Lemma succ_double_alt d : - Little.succ_double d = Little.succ (Little.double d). -Proof. - now induction d. -Qed. - -Lemma double_succ d : - Little.double (Little.succ d) = - Little.succ (Little.succ_double d). -Proof. - induction d; simpl; f_equal; auto using succ_double_alt. -Qed. - -Lemma to_lu_succ n : - to_lu (N.succ n) = Little.succ (to_lu n). -Proof. - destruct n; simpl; trivial. - induction p; simpl; rewrite ?IHp; - auto using succ_double_alt, double_succ. -Qed. - -Lemma nat_iter_S n {A} (f:A->A) i : - Nat.iter (S n) f i = f (Nat.iter n f i). -Proof. - reflexivity. -Qed. - -Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. -Proof. - reflexivity. -Qed. - -Lemma to_ldec_tenfold p : - to_lu (10 * Npos p) = D0 (to_lu (Npos p)). -Proof. - induction p using Pos.peano_rect. - - trivial. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - rewrite N.mul_succ_r. - change 10 with (Nat.iter 10%nat N.succ 0) at 2. - rewrite ?nat_iter_S, nat_iter_0. - rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. - destruct (to_lu (N.pos p)); simpl; auto. -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; split; trivial; try discriminate; - try (intros H; now apply N.eq_add_0 in H). - - rewrite N.add_0_l. intros H. - apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. - simpl. now rewrite H. - - simpl. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. - Qed. - -Lemma to_of_lu_tenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (N.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - destruct (of_lu d) eqn:Eq; [easy| ]. - rewrite to_ldec_tenfold; auto. rewrite IH. - rewrite <- Eq in H. rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. -Proof. - destruct n. 1:trivial. - induction p using Pos.peano_rect. - - now rewrite N.add_1_l. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. -Qed. - -Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [reflexivity|..]; - simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; - rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; - unfold lnorm; simpl; destruct nztail; auto. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : N.to_uint (Pos.of_uint d) = unorm d. -Proof. - rewrite of_uint_alt. - unfold N.to_uint, Pos.to_uint. - destruct (of_lu (rev d)) eqn:H. - - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. - unfold lnorm. now rewrite H. - - change (Pos.to_little_uint p) with (to_lu (N.pos p)). - rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_nonzero p : Pos.to_uint p <> zero. -Proof. - intro E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_nonnil p : Pos.to_uint p <> Nil. -Proof. - intros E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_inj p p' : Pos.to_uint p = Pos.to_uint p' -> p = p'. -Proof. - intro E. - assert (E' : N.pos p = N.pos p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_uint_pos_surj d : - unorm d<>zero -> exists p, Pos.to_uint p = unorm d. -Proof. - intros. - destruct (Pos.of_uint d) eqn:E. - - destruct H. generalize (to_of d). now rewrite E. - - exists p. generalize (to_of d). now rewrite E. -Qed. - -Lemma of_uint_norm d : Pos.of_uint (unorm d) = Pos.of_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - Pos.of_uint d = Pos.of_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Pos.of_uint d = Pos.of_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -Lemma nztail_to_uint p : - let (h, n) := Decimal.nztail (Pos.to_uint p) in - Npos p = Pos.of_uint h * 10^(N.of_nat n). -Proof. - rewrite <-(of_to p), <-(rev_rev (Pos.to_uint p)), of_lu_rev. - unfold Decimal.nztail. - rewrite rev_rev. - induction (rev (Pos.to_uint p)); [reflexivity| | - now simpl N.of_nat; simpl N.pow; rewrite N.mul_1_r, of_lu_rev..]. - revert IHu. - set (t := _ u); case t; clear t; intros u0 n H. - rewrite of_lu_eqn; unfold hd, tl. - rewrite N.add_0_l, H, Nat2N.inj_succ, N.pow_succ_r', ?(N.mul_comm 10), N.mul_assoc; trivial. -Qed. + #[local] Open Scope N. + + (** A direct version of [of_little_uint] *) + Fixpoint of_lu (d:uint) : N := + match d with + | Nil => 0 + | D0 d => 10 * of_lu d + | D1 d => 1 + 10 * of_lu d + | D2 d => 2 + 10 * of_lu d + | D3 d => 3 + 10 * of_lu d + | D4 d => 4 + 10 * of_lu d + | D5 d => 5 + 10 * of_lu d + | D6 d => 6 + 10 * of_lu d + | D7 d => 7 + 10 * of_lu d + | D8 d => 8 + 10 * of_lu d + | D9 d => 9 + 10 * of_lu d + end. + + Definition hd d := + match d with + | Nil => 0 + | D0 _ => 0 + | D1 _ => 1 + | D2 _ => 2 + | D3 _ => 3 + | D4 _ => 4 + | D5 _ => 5 + | D6 _ => 6 + | D7 _ => 7 + | D8 _ => 8 + | D9 _ => 9 + end. + + Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d + end. + + Lemma of_lu_eqn d : + of_lu d = hd d + 10 * (of_lu (tl d)). + Proof. + induction d; simpl; trivial. + Qed. + + Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + + Fixpoint usize (d:uint) : N := + match d with + | Nil => 0 + | D0 d => N.succ (usize d) + | D1 d => N.succ (usize d) + | D2 d => N.succ (usize d) + | D3 d => N.succ (usize d) + | D4 d => N.succ (usize d) + | D5 d => N.succ (usize d) + | D6 d => N.succ (usize d) + | D7 d => N.succ (usize d) + | D8 d => N.succ (usize d) + | D9 d => N.succ (usize d) + end. + + Lemma of_lu_revapp d d' : + of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 10^usize d. + Proof. + revert d'. + induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite N.pow_succ_r', ?N.mul_assoc, ?(N.mul_comm 10), ?Nmult_plus_distr_r; trivial. + Qed. + + Definition Nadd n p := + match n with + | N0 => p + | Npos p0 => (p0+p)%positive + end. + + Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. + Proof. + now destruct n. + Qed. + + Lemma of_uint_acc_eqn d acc : d<>Nil -> + Pos.of_uint_acc d acc = Pos.of_uint_acc (tl d) (Nadd (hd d) (10*acc)). + Proof. + destruct d; simpl; trivial. now destruct 1. + Qed. + + Lemma of_uint_acc_rev d acc : + Npos (Pos.of_uint_acc d acc) = + of_lu (rev d) + (Npos acc) * 10^usize d. + Proof. + revert acc. + induction d; intros; simpl usize; + [ simpl; now rewrite Pos.mul_1_r | .. ]; + rewrite N.pow_succ_r'; + unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; + rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; + rewrite IHd, Nadd_simpl, ?N.mul_assoc, <-?N.add_assoc, ?(N.mul_comm 10), ?Nmult_plus_distr_r; trivial. + Qed. + + Lemma of_uint_alt d : Pos.of_uint d = of_lu (rev d). + Proof. + induction d; simpl; trivial; unfold rev; simpl revapp; + rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. + rewrite IHd, N.add_0_r; trivial. + Qed. + + Lemma of_lu_rev d : Pos.of_uint (rev d) = of_lu d. + Proof. + rewrite of_uint_alt. now rewrite rev_rev. + Qed. + + Lemma of_lu_double_gen d : + of_lu (Little.double d) = N.double (of_lu d) /\ + of_lu (Little.succ_double d) = N.succ_double (of_lu d). + Proof. + rewrite N.double_spec, N.succ_double_spec. + induction d; try destruct IHd as (IH1,IH2); + simpl Little.double; simpl Little.succ_double; + repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; + rewrite ?(N.add_comm _ 1), ?Nmult_plus_distr_l, ?N.add_assoc, ?N.mul_assoc; trivial. + Qed. + + Lemma of_lu_double d : + of_lu (Little.double d) = N.double (of_lu d). + Proof. + apply of_lu_double_gen. + Qed. + + Lemma of_lu_succ_double d : + of_lu (Little.succ_double d) = N.succ_double (of_lu d). + Proof. + apply of_lu_double_gen. + Qed. + + (** First bijection result *) + + Lemma of_to (p:positive) : Pos.of_uint (Pos.to_uint p) = Npos p. + Proof. + unfold Pos.to_uint. + rewrite of_lu_rev. + induction p; simpl; trivial. + - now rewrite of_lu_succ_double, IHp. + - now rewrite of_lu_double, IHp. + Qed. + + (** The other direction *) + + Definition to_lu n := + match n with + | N0 => Decimal.zero + | Npos p => Pos.to_little_uint p + end. + + Lemma succ_double_alt d : + Little.succ_double d = Little.succ (Little.double d). + Proof. + now induction d. + Qed. + + Lemma double_succ d : + Little.double (Little.succ d) = + Little.succ (Little.succ_double d). + Proof. + induction d; simpl; f_equal; auto using succ_double_alt. + Qed. + + Lemma to_lu_succ n : + to_lu (N.succ n) = Little.succ (to_lu n). + Proof. + destruct n; simpl; trivial. + induction p; simpl; rewrite ?IHp; + auto using succ_double_alt, double_succ. + Qed. + + Lemma nat_iter_S n {A} (f:A->A) i : + Nat.iter (S n) f i = f (Nat.iter n f i). + Proof. + reflexivity. + Qed. + + Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. + Proof. + reflexivity. + Qed. + + Lemma to_ldec_tenfold p : + to_lu (10 * Npos p) = D0 (to_lu (Npos p)). + Proof. + induction p using Pos.peano_rect. + - trivial. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + rewrite N.mul_succ_r. + change 10 with (Nat.iter 10%nat N.succ 0) at 2. + rewrite ?nat_iter_S, nat_iter_0. + rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. + destruct (to_lu (N.pos p)); simpl; auto. + Qed. + + Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. + Proof. + induction d; try simpl_of_lu; split; trivial; try discriminate; + try (intros H; now apply N.eq_add_0 in H). + - rewrite N.add_0_l. intros H. + apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. + simpl. now rewrite H. + - simpl. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. + Qed. + + Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (10 * of_lu d) = lnorm (D0 d). + Proof. + intro IH. + destruct (N.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - destruct (of_lu d) eqn:Eq; [easy| ]. + rewrite to_ldec_tenfold; auto. rewrite IH. + rewrite <- Eq in H. rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). + Qed. + + Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. + Proof. + destruct n. 1:trivial. + induction p using Pos.peano_rect. + - now rewrite N.add_1_l. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. + Qed. + + Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. + + Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. + Proof. + induction d; [reflexivity|..]; + simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; + rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; + unfold lnorm; simpl; destruct nztail; auto. + Qed. + + (** Second bijection result *) + + Lemma to_of (d:uint) : N.to_uint (Pos.of_uint d) = unorm d. + Proof. + rewrite of_uint_alt. + unfold N.to_uint, Pos.to_uint. + destruct (of_lu (rev d)) eqn:H. + - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. + unfold lnorm. now rewrite H. + - change (Pos.to_little_uint p) with (to_lu (N.pos p)). + rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. + Qed. + + (** Some consequences *) + + Lemma to_uint_nonzero p : Pos.to_uint p <> zero. + Proof. + intro E. generalize (of_to p). now rewrite E. + Qed. + + Lemma to_uint_nonnil p : Pos.to_uint p <> Nil. + Proof. + intros E. generalize (of_to p). now rewrite E. + Qed. + + Lemma to_uint_inj p p' : Pos.to_uint p = Pos.to_uint p' -> p = p'. + Proof. + intro E. + assert (E' : N.pos p = N.pos p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. + Qed. + + Lemma to_uint_pos_surj d : + unorm d<>zero -> exists p, Pos.to_uint p = unorm d. + Proof. + intros. + destruct (Pos.of_uint d) eqn:E. + - destruct H. generalize (to_of d). now rewrite E. + - exists p. generalize (to_of d). now rewrite E. + Qed. + + Lemma of_uint_norm d : Pos.of_uint (unorm d) = Pos.of_uint d. + Proof. + now induction d. + Qed. + + Lemma of_inj d d' : + Pos.of_uint d = Pos.of_uint d' -> unorm d = unorm d'. + Proof. + intros. rewrite <- !to_of. now f_equal. + Qed. + + Lemma of_iff d d' : Pos.of_uint d = Pos.of_uint d' <-> unorm d = unorm d'. + Proof. + split. + - apply of_inj. + - intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. + Qed. + + Lemma nztail_to_uint p : + let (h, n) := Decimal.nztail (Pos.to_uint p) in + Npos p = Pos.of_uint h * 10^(N.of_nat n). + Proof. + rewrite <-(of_to p), <-(rev_rev (Pos.to_uint p)), of_lu_rev. + unfold Decimal.nztail. + rewrite rev_rev. + induction (rev (Pos.to_uint p)); [reflexivity| | + now simpl N.of_nat; simpl N.pow; rewrite N.mul_1_r, of_lu_rev..]. + revert IHu. + set (t := _ u); case t; clear t; intros u0 n H. + rewrite of_lu_eqn; unfold hd, tl. + rewrite N.add_0_l, H, Nat2N.inj_succ, N.pow_succ_r', ?(N.mul_comm 10), N.mul_assoc; trivial. + Qed. End Unsigned. @@ -349,53 +349,53 @@ End Unsigned. Module Signed. -Lemma of_to (p:positive) : Pos.of_int (Pos.to_int p) = Some p. -Proof. - unfold Pos.to_int, Pos.of_int, norm. - now rewrite Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(p:positive) : - Pos.of_int d = Some p -> Pos.to_int p = norm d. -Proof. - unfold Pos.of_int. - destruct d; [ | intros [=]]. - simpl norm. rewrite <- Unsigned.to_of. - destruct (Pos.of_uint d); now intros [= <-]. -Qed. - -Lemma to_int_inj p p' : Pos.to_int p = Pos.to_int p' -> p = p'. -Proof. - intro E. - assert (E' : Some p = Some p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : - unorm d <> zero -> exists p, Pos.to_int p = norm (Pos d). -Proof. - simpl. unfold Pos.to_int. intros H. - destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). - exists p. now f_equal. -Qed. - -Lemma of_int_norm d : Pos.of_int (norm d) = Pos.of_int d. -Proof. - unfold Pos.of_int. - destruct d. - - simpl. now rewrite Unsigned.of_uint_norm. - - simpl. now destruct (nzhead d) eqn:H. -Qed. - -Lemma of_inj_pos d d' : - Pos.of_int (Pos d) = Pos.of_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Pos.of_int. - destruct (Pos.of_uint d) eqn:Hd, (Pos.of_uint d') eqn:Hd'; - intros [=]. - - apply Unsigned.of_inj; now rewrite Hd, Hd'. - - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. -Qed. + Lemma of_to (p:positive) : Pos.of_int (Pos.to_int p) = Some p. + Proof. + unfold Pos.to_int, Pos.of_int, norm. + now rewrite Unsigned.of_to. + Qed. + + Lemma to_of (d:int)(p:positive) : + Pos.of_int d = Some p -> Pos.to_int p = norm d. + Proof. + unfold Pos.of_int. + destruct d; [ | intros [=]]. + simpl norm. rewrite <- Unsigned.to_of. + destruct (Pos.of_uint d); now intros [= <-]. + Qed. + + Lemma to_int_inj p p' : Pos.to_int p = Pos.to_int p' -> p = p'. + Proof. + intro E. + assert (E' : Some p = Some p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. + Qed. + + Lemma to_int_pos_surj d : + unorm d <> zero -> exists p, Pos.to_int p = norm (Pos d). + Proof. + simpl. unfold Pos.to_int. intros H. + destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). + exists p. now f_equal. + Qed. + + Lemma of_int_norm d : Pos.of_int (norm d) = Pos.of_int d. + Proof. + unfold Pos.of_int. + destruct d. + - simpl. now rewrite Unsigned.of_uint_norm. + - simpl. now destruct (nzhead d) eqn:H. + Qed. + + Lemma of_inj_pos d d' : + Pos.of_int (Pos d) = Pos.of_int (Pos d') -> unorm d = unorm d'. + Proof. + unfold Pos.of_int. + destruct (Pos.of_uint d) eqn:Hd, (Pos.of_uint d') eqn:Hd'; + intros [=]. + - apply Unsigned.of_inj; now rewrite Hd, Hd'. + - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. + Qed. End Signed. diff --git a/theories/Numbers/DecimalString.v b/theories/Numbers/DecimalString.v index 28038aa16d..c703d7636b 100644 --- a/theories/Numbers/DecimalString.v +++ b/theories/Numbers/DecimalString.v @@ -63,92 +63,92 @@ Qed. Module NilEmpty. -Fixpoint string_of_uint (d:uint) := - match d with - | Nil => EmptyString - | D0 d => String "0" (string_of_uint d) - | D1 d => String "1" (string_of_uint d) - | D2 d => String "2" (string_of_uint d) - | D3 d => String "3" (string_of_uint d) - | D4 d => String "4" (string_of_uint d) - | D5 d => String "5" (string_of_uint d) - | D6 d => String "6" (string_of_uint d) - | D7 d => String "7" (string_of_uint d) - | D8 d => String "8" (string_of_uint d) - | D9 d => String "9" (string_of_uint d) - end. - -Fixpoint uint_of_string s := - match s with - | EmptyString => Some Nil - | String a s => uint_of_char a (uint_of_string s) - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => Some (Pos Nil) - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(* NB: For the moment whitespace between - and digits are not accepted. + Fixpoint string_of_uint (d:uint) := + match d with + | Nil => EmptyString + | D0 d => String "0" (string_of_uint d) + | D1 d => String "1" (string_of_uint d) + | D2 d => String "2" (string_of_uint d) + | D3 d => String "3" (string_of_uint d) + | D4 d => String "4" (string_of_uint d) + | D5 d => String "5" (string_of_uint d) + | D6 d => String "6" (string_of_uint d) + | D7 d => String "7" (string_of_uint d) + | D8 d => String "8" (string_of_uint d) + | D9 d => String "9" (string_of_uint d) + end. + + Fixpoint uint_of_string s := + match s with + | EmptyString => Some Nil + | String a s => uint_of_char a (uint_of_string s) + end. + + Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + + Definition int_of_string s := + match s with + | EmptyString => Some (Pos Nil) + | String a s' => + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + + (* NB: For the moment whitespace between - and digits are not accepted. And in this variant [int_of_string "-" = Some (Neg Nil)]. Compute int_of_string "-123456890123456890123456890123456890". Compute string_of_int (-123456890123456890123456890123456890). *) -(** Corresponding proofs *) - -Lemma usu d : - uint_of_string (string_of_uint d) = Some d. -Proof. - induction d; simpl; rewrite ?IHd; simpl; auto. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - revert d. - induction s; simpl. - - now intros d [= <-]. - - intros d. - destruct (uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - intuition subst; simpl; f_equal; auto. -Qed. - -Lemma isi d : int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. - - rewrite usu; auto. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [= <-]| ]; simpl; trivial. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. + (** Corresponding proofs *) + + Lemma usu d : + uint_of_string (string_of_uint d) = Some d. + Proof. + induction d; simpl; rewrite ?IHd; simpl; auto. + Qed. + + Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. + Proof. + revert d. + induction s; simpl. + - now intros d [= <-]. + - intros d. + destruct (uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + intuition subst; simpl; f_equal; auto. + Qed. + + Lemma isi d : int_of_string (string_of_int d) = Some d. + Proof. + destruct d; simpl. + - unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. + * rewrite <- Hd, usu; auto. + - rewrite usu; auto. + Qed. + + Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. + Proof. + destruct s; [intros [= <-]| ]; simpl; trivial. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. + Qed. End NilEmpty. @@ -156,110 +156,110 @@ End NilEmpty. Module NilZero. -Definition string_of_uint (d:uint) := - match d with - | Nil => "0" - | _ => NilEmpty.string_of_uint d - end. - -Definition uint_of_string s := - match s with - | EmptyString => None - | _ => NilEmpty.uint_of_string s - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => None - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(** Corresponding proofs *) - -Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. -Proof. - destruct s; simpl. - - easy. - - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - now intuition subst. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - destruct s; [intros [=] | intros H]. - apply NilEmpty.sus in H. now destruct d. -Qed. - -Lemma usu d : - d<>Nil -> uint_of_string (string_of_uint d) = Some d. -Proof. - destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). -Qed. - -Lemma usu_nil : - uint_of_string (string_of_uint Nil) = Some Decimal.zero. -Proof. - reflexivity. -Qed. - -Lemma usu_gen d : - uint_of_string (string_of_uint d) = Some d \/ - uint_of_string (string_of_uint d) = Some Decimal.zero. -Proof. - destruct d; (now right) || (left; now apply usu). -Qed. - -Lemma isi d : - d<>Pos Nil -> d<>Neg Nil -> - int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - intros H _. - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. now intros ->. - - intros _ H. - rewrite usu; auto. now intros ->. -Qed. - -Lemma isi_posnil : - int_of_string (string_of_int (Pos Nil)) = Some (Pos Decimal.zero). -Proof. - reflexivity. -Qed. - -(** Warning! (-0) won't parse (compatibility with the behavior of Z). *) - -Lemma isi_negnil : - int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). -Proof. - reflexivity. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [=]| ]; simpl. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. + Definition string_of_uint (d:uint) := + match d with + | Nil => "0" + | _ => NilEmpty.string_of_uint d + end. + + Definition uint_of_string s := + match s with + | EmptyString => None + | _ => NilEmpty.uint_of_string s + end. + + Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + + Definition int_of_string s := + match s with + | EmptyString => None + | String a s' => + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + + (** Corresponding proofs *) + + Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. + Proof. + destruct s; simpl. + - easy. + - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + now intuition subst. + Qed. + + Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. + Proof. + destruct s; [intros [=] | intros H]. + apply NilEmpty.sus in H. now destruct d. + Qed. + + Lemma usu d : + d<>Nil -> uint_of_string (string_of_uint d) = Some d. + Proof. + destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). + Qed. + + Lemma usu_nil : + uint_of_string (string_of_uint Nil) = Some Decimal.zero. + Proof. + reflexivity. + Qed. + + Lemma usu_gen d : + uint_of_string (string_of_uint d) = Some d \/ + uint_of_string (string_of_uint d) = Some Decimal.zero. + Proof. + destruct d; (now right) || (left; now apply usu). + Qed. + + Lemma isi d : + d<>Pos Nil -> d<>Neg Nil -> + int_of_string (string_of_int d) = Some d. + Proof. + destruct d; simpl. + - intros H _. + unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. + * rewrite <- Hd, usu; auto. now intros ->. + - intros _ H. + rewrite usu; auto. now intros ->. + Qed. + + Lemma isi_posnil : + int_of_string (string_of_int (Pos Nil)) = Some (Pos Decimal.zero). + Proof. + reflexivity. + Qed. + + (** Warning! (-0) won't parse (compatibility with the behavior of Z). *) + + Lemma isi_negnil : + int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). + Proof. + reflexivity. + Qed. + + Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. + Proof. + destruct s; [intros [=]| ]; simpl. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. + Qed. End NilZero. diff --git a/theories/Numbers/HexadecimalFacts.v b/theories/Numbers/HexadecimalFacts.v index d7e9c5a70b..dbb07a4629 100644 --- a/theories/Numbers/HexadecimalFacts.v +++ b/theories/Numbers/HexadecimalFacts.v @@ -265,7 +265,7 @@ Qed. Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. Proof. -now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. + now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. Qed. Lemma nzhead_app_nil d d' : diff --git a/theories/Numbers/HexadecimalN.v b/theories/Numbers/HexadecimalN.v index 87590fa94f..a93b38af16 100644 --- a/theories/Numbers/HexadecimalN.v +++ b/theories/Numbers/HexadecimalN.v @@ -17,46 +17,46 @@ From Stdlib Require Import Hexadecimal HexadecimalFacts HexadecimalPos BinPos Bi Module Unsigned. -Lemma of_to (n:N) : N.of_hex_uint (N.to_hex_uint n) = n. -Proof. - destruct n. - - reflexivity. - - apply HexadecimalPos.Unsigned.of_to. -Qed. - -Lemma to_of (d:uint) : N.to_hex_uint (N.of_hex_uint d) = unorm d. -Proof. - exact (HexadecimalPos.Unsigned.to_of d). -Qed. - -Lemma to_uint_inj n n' : N.to_hex_uint n = N.to_hex_uint n' -> n = n'. -Proof. - intros E. now rewrite <- (of_to n), <- (of_to n'), E. -Qed. - -Lemma to_uint_surj d : exists p, N.to_hex_uint p = unorm d. -Proof. - exists (N.of_hex_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : N.of_hex_uint (unorm d) = N.of_hex_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - N.of_hex_uint d = N.of_hex_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : N.of_hex_uint d = N.of_hex_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. + Lemma of_to (n:N) : N.of_hex_uint (N.to_hex_uint n) = n. + Proof. + destruct n. + - reflexivity. + - apply HexadecimalPos.Unsigned.of_to. + Qed. + + Lemma to_of (d:uint) : N.to_hex_uint (N.of_hex_uint d) = unorm d. + Proof. + exact (HexadecimalPos.Unsigned.to_of d). + Qed. + + Lemma to_uint_inj n n' : N.to_hex_uint n = N.to_hex_uint n' -> n = n'. + Proof. + intros E. now rewrite <- (of_to n), <- (of_to n'), E. + Qed. + + Lemma to_uint_surj d : exists p, N.to_hex_uint p = unorm d. + Proof. + exists (N.of_hex_uint d). apply to_of. + Qed. + + Lemma of_uint_norm d : N.of_hex_uint (unorm d) = N.of_hex_uint d. + Proof. + now induction d. + Qed. + + Lemma of_inj d d' : + N.of_hex_uint d = N.of_hex_uint d' -> unorm d = unorm d'. + Proof. + intros. rewrite <- !to_of. now f_equal. + Qed. + + Lemma of_iff d d' : N.of_hex_uint d = N.of_hex_uint d' <-> unorm d = unorm d'. + Proof. + split. + - apply of_inj. + - intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. + Qed. End Unsigned. @@ -64,46 +64,46 @@ End Unsigned. Module Signed. -Lemma of_to (n:N) : N.of_hex_int (N.to_hex_int n) = Some n. -Proof. - unfold N.to_hex_int, N.of_hex_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:N) : N.of_hex_int d = Some n -> N.to_hex_int n = norm d. -Proof. - unfold N.of_hex_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold N.to_hex_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : N.to_hex_int n = N.to_hex_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, N.to_hex_int n = norm (Pos d). -Proof. - exists (N.of_hex_uint d). unfold N.to_hex_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : N.of_hex_int (norm d) = N.of_hex_int d. -Proof. - unfold N.of_hex_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - N.of_hex_int (Pos d) = N.of_hex_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold N.of_hex_int. simpl. intros [= H]. apply Unsigned.of_inj. - change Pos.of_hex_uint with N.of_hex_uint in H. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. + Lemma of_to (n:N) : N.of_hex_int (N.to_hex_int n) = Some n. + Proof. + unfold N.to_hex_int, N.of_hex_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. + Qed. + + Lemma to_of (d:int)(n:N) : N.of_hex_int d = Some n -> N.to_hex_int n = norm d. + Proof. + unfold N.of_hex_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold N.to_hex_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_involutive. + - destruct (nzhead d); now intros [= <-]. + Qed. + + Lemma to_int_inj n n' : N.to_hex_int n = N.to_hex_int n' -> n = n'. + Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. + Qed. + + Lemma to_int_pos_surj d : exists n, N.to_hex_int n = norm (Pos d). + Proof. + exists (N.of_hex_uint d). unfold N.to_hex_int. now rewrite Unsigned.to_of. + Qed. + + Lemma of_int_norm d : N.of_hex_int (norm d) = N.of_hex_int d. + Proof. + unfold N.of_hex_int. now rewrite norm_involutive. + Qed. + + Lemma of_inj_pos d d' : + N.of_hex_int (Pos d) = N.of_hex_int (Pos d') -> unorm d = unorm d'. + Proof. + unfold N.of_hex_int. simpl. intros [= H]. apply Unsigned.of_inj. + change Pos.of_hex_uint with N.of_hex_uint in H. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. + Qed. End Signed. diff --git a/theories/Numbers/HexadecimalNat.v b/theories/Numbers/HexadecimalNat.v index 0ec2cee0bf..e2d9e28fe5 100644 --- a/theories/Numbers/HexadecimalNat.v +++ b/theories/Numbers/HexadecimalNat.v @@ -17,261 +17,261 @@ From Stdlib Require Import Hexadecimal HexadecimalFacts PeanoNat. Module Unsigned. -(** A few helper functions used during proofs *) - -Definition hd d := - match d with - | Nil => 0x0 - | D0 _ => 0x0 - | D1 _ => 0x1 - | D2 _ => 0x2 - | D3 _ => 0x3 - | D4 _ => 0x4 - | D5 _ => 0x5 - | D6 _ => 0x6 - | D7 _ => 0x7 - | D8 _ => 0x8 - | D9 _ => 0x9 - | Da _ => 0xa - | Db _ => 0xb - | Dc _ => 0xc - | Dd _ => 0xd - | De _ => 0xe - | Df _ => 0xf - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d - | Da d | Db d | Dc d | Dd d | De d | Df d => d - end. - -Fixpoint usize (d:uint) : nat := - match d with - | Nil => 0 - | D0 d => S (usize d) - | D1 d => S (usize d) - | D2 d => S (usize d) - | D3 d => S (usize d) - | D4 d => S (usize d) - | D5 d => S (usize d) - | D6 d => S (usize d) - | D7 d => S (usize d) - | D8 d => S (usize d) - | D9 d => S (usize d) - | Da d => S (usize d) - | Db d => S (usize d) - | Dc d => S (usize d) - | Dd d => S (usize d) - | De d => S (usize d) - | Df d => S (usize d) - end. - -(** A direct version of [to_little_uint], not tail-recursive *) -Fixpoint to_lu n := - match n with - | 0 => Hexadecimal.zero - | S n => Little.succ (to_lu n) - end. - -(** A direct version of [of_little_uint] *) -Fixpoint of_lu (d:uint) : nat := - match d with - | Nil => 0x0 - | D0 d => 0x10 * of_lu d - | D1 d => 0x1 + 0x10 * of_lu d - | D2 d => 0x2 + 0x10 * of_lu d - | D3 d => 0x3 + 0x10 * of_lu d - | D4 d => 0x4 + 0x10 * of_lu d - | D5 d => 0x5 + 0x10 * of_lu d - | D6 d => 0x6 + 0x10 * of_lu d - | D7 d => 0x7 + 0x10 * of_lu d - | D8 d => 0x8 + 0x10 * of_lu d - | D9 d => 0x9 + 0x10 * of_lu d - | Da d => 0xa + 0x10 * of_lu d - | Db d => 0xb + 0x10 * of_lu d - | Dc d => 0xc + 0x10 * of_lu d - | Dd d => 0xd + 0x10 * of_lu d - | De d => 0xe + 0x10 * of_lu d - | Df d => 0xf + 0x10 * of_lu d - end. - -(** Properties of [to_lu] *) - -Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). -Proof. - reflexivity. -Qed. - -Lemma to_little_uint_succ n d : - Nat.to_little_hex_uint n (Little.succ d) = - Little.succ (Nat.to_little_hex_uint n d). -Proof. - revert d; induction n; simpl; trivial. -Qed. - -Lemma to_lu_equiv n : - to_lu n = Nat.to_little_hex_uint n zero. -Proof. - induction n; simpl; trivial. - now rewrite IHn, <- to_little_uint_succ. -Qed. - -Lemma to_uint_alt n : - Nat.to_hex_uint n = rev (to_lu n). -Proof. - unfold Nat.to_hex_uint. f_equal. symmetry. apply to_lu_equiv. -Qed. - -(** Properties of [of_lu] *) - -Lemma of_lu_eqn d : - of_lu d = hd d + 0x10 * of_lu (tl d). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Lemma of_lu_succ d : - of_lu (Little.succ d) = S (of_lu d). -Proof. - induction d; trivial. - simpl_of_lu. rewrite IHd. simpl_of_lu. - now rewrite Nat.mul_succ_r, <- (Nat.add_comm 0x10). -Qed. - -Lemma of_to_lu n : - of_lu (to_lu n) = n. -Proof. - induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. -Qed. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 0x10^usize d. -Proof. - revert d'. - induction d; intro d'; simpl usize; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite ?Nat.pow_succ_r', ?Nat.mul_assoc, ?Nat.mul_add_distr_r, ?(Nat.mul_comm 16); trivial. -Qed. - -Lemma of_uint_acc_spec n d : - Nat.of_hex_uint_acc d n = of_lu (rev d) + n * 0x10^usize d. -Proof. - revert n. induction d; intros; - simpl Nat.of_hex_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; - simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev at 2; simpl revapp; rewrite of_lu_revapp; simpl of_lu; - rewrite ?Nat.mul_assoc, <-?Nat.add_assoc, <-?Nat.mul_add_distr_r, ?(Nat.mul_comm _ 16); trivial. -Qed. - -Lemma of_uint_alt d : Nat.of_hex_uint d = of_lu (rev d). -Proof. - unfold Nat.of_hex_uint. now rewrite of_uint_acc_spec. -Qed. - -(** First main bijection result *) - -Lemma of_to (n:nat) : Nat.of_hex_uint (Nat.to_hex_uint n) = n. -Proof. - rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. -Qed. - -(** The other direction *) - -Lemma to_lu_sixteenfold n : n<>0 -> - to_lu (0x10 * n) = D0 (to_lu n). -Proof. - induction n. - - simpl. now destruct 1. - - intros _. - destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. - rewrite !Nat.add_succ_r. - simpl in *. rewrite (IHn H). now destruct (to_lu n). -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; try easy. - rewrite Nat.add_0_l. - split; intros H. - - apply Nat.eq_mul_0_r in H; auto. - rewrite IHd in H. simpl. now rewrite H. - - simpl in H. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. -Qed. - -Lemma to_of_lu_sixteenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (0x10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - rewrite (to_lu_sixteenfold _ H), IH. - rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [ reflexivity | .. ]; - simpl_of_lu; - rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_sixteenfold - by assumption; - unfold lnorm; cbn; now destruct nztail. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : Nat.to_hex_uint (Nat.of_hex_uint d) = unorm d. -Proof. - rewrite to_uint_alt, of_uint_alt, to_of_lu. - apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_inj n n' : Nat.to_hex_uint n = Nat.to_hex_uint n' -> n = n'. -Proof. - intro EQ. - now rewrite <- (of_to n), <- (of_to n'), EQ. -Qed. - -Lemma to_uint_surj d : exists n, Nat.to_hex_uint n = unorm d. -Proof. - exists (Nat.of_hex_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : Nat.of_hex_uint (unorm d) = Nat.of_hex_uint d. -Proof. - unfold Nat.of_hex_uint. now induction d. -Qed. - -Lemma of_inj d d' : - Nat.of_hex_uint d = Nat.of_hex_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Nat.of_hex_uint d = Nat.of_hex_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. + (** A few helper functions used during proofs *) + + Definition hd d := + match d with + | Nil => 0x0 + | D0 _ => 0x0 + | D1 _ => 0x1 + | D2 _ => 0x2 + | D3 _ => 0x3 + | D4 _ => 0x4 + | D5 _ => 0x5 + | D6 _ => 0x6 + | D7 _ => 0x7 + | D8 _ => 0x8 + | D9 _ => 0x9 + | Da _ => 0xa + | Db _ => 0xb + | Dc _ => 0xc + | Dd _ => 0xd + | De _ => 0xe + | Df _ => 0xf + end. + + Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d + | Da d | Db d | Dc d | Dd d | De d | Df d => d + end. + + Fixpoint usize (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => S (usize d) + | D1 d => S (usize d) + | D2 d => S (usize d) + | D3 d => S (usize d) + | D4 d => S (usize d) + | D5 d => S (usize d) + | D6 d => S (usize d) + | D7 d => S (usize d) + | D8 d => S (usize d) + | D9 d => S (usize d) + | Da d => S (usize d) + | Db d => S (usize d) + | Dc d => S (usize d) + | Dd d => S (usize d) + | De d => S (usize d) + | Df d => S (usize d) + end. + + (** A direct version of [to_little_uint], not tail-recursive *) + Fixpoint to_lu n := + match n with + | 0 => Hexadecimal.zero + | S n => Little.succ (to_lu n) + end. + + (** A direct version of [of_little_uint] *) + Fixpoint of_lu (d:uint) : nat := + match d with + | Nil => 0x0 + | D0 d => 0x10 * of_lu d + | D1 d => 0x1 + 0x10 * of_lu d + | D2 d => 0x2 + 0x10 * of_lu d + | D3 d => 0x3 + 0x10 * of_lu d + | D4 d => 0x4 + 0x10 * of_lu d + | D5 d => 0x5 + 0x10 * of_lu d + | D6 d => 0x6 + 0x10 * of_lu d + | D7 d => 0x7 + 0x10 * of_lu d + | D8 d => 0x8 + 0x10 * of_lu d + | D9 d => 0x9 + 0x10 * of_lu d + | Da d => 0xa + 0x10 * of_lu d + | Db d => 0xb + 0x10 * of_lu d + | Dc d => 0xc + 0x10 * of_lu d + | Dd d => 0xd + 0x10 * of_lu d + | De d => 0xe + 0x10 * of_lu d + | Df d => 0xf + 0x10 * of_lu d + end. + + (** Properties of [to_lu] *) + + Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). + Proof. + reflexivity. + Qed. + + Lemma to_little_uint_succ n d : + Nat.to_little_hex_uint n (Little.succ d) = + Little.succ (Nat.to_little_hex_uint n d). + Proof. + revert d; induction n; simpl; trivial. + Qed. + + Lemma to_lu_equiv n : + to_lu n = Nat.to_little_hex_uint n zero. + Proof. + induction n; simpl; trivial. + now rewrite IHn, <- to_little_uint_succ. + Qed. + + Lemma to_uint_alt n : + Nat.to_hex_uint n = rev (to_lu n). + Proof. + unfold Nat.to_hex_uint. f_equal. symmetry. apply to_lu_equiv. + Qed. + + (** Properties of [of_lu] *) + + Lemma of_lu_eqn d : + of_lu d = hd d + 0x10 * of_lu (tl d). + Proof. + induction d; simpl; trivial. + Qed. + + Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + + Lemma of_lu_succ d : + of_lu (Little.succ d) = S (of_lu d). + Proof. + induction d; trivial. + simpl_of_lu. rewrite IHd. simpl_of_lu. + now rewrite Nat.mul_succ_r, <- (Nat.add_comm 0x10). + Qed. + + Lemma of_to_lu n : + of_lu (to_lu n) = n. + Proof. + induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. + Qed. + + Lemma of_lu_revapp d d' : + of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 0x10^usize d. + Proof. + revert d'. + induction d; intro d'; simpl usize; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite ?Nat.pow_succ_r', ?Nat.mul_assoc, ?Nat.mul_add_distr_r, ?(Nat.mul_comm 16); trivial. + Qed. + + Lemma of_uint_acc_spec n d : + Nat.of_hex_uint_acc d n = of_lu (rev d) + n * 0x10^usize d. + Proof. + revert n. induction d; intros; + simpl Nat.of_hex_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; + simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev at 2; simpl revapp; rewrite of_lu_revapp; simpl of_lu; + rewrite ?Nat.mul_assoc, <-?Nat.add_assoc, <-?Nat.mul_add_distr_r, ?(Nat.mul_comm _ 16); trivial. + Qed. + + Lemma of_uint_alt d : Nat.of_hex_uint d = of_lu (rev d). + Proof. + unfold Nat.of_hex_uint. now rewrite of_uint_acc_spec. + Qed. + + (** First main bijection result *) + + Lemma of_to (n:nat) : Nat.of_hex_uint (Nat.to_hex_uint n) = n. + Proof. + rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. + Qed. + + (** The other direction *) + + Lemma to_lu_sixteenfold n : n<>0 -> + to_lu (0x10 * n) = D0 (to_lu n). + Proof. + induction n. + - simpl. now destruct 1. + - intros _. + destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. + rewrite !Nat.add_succ_r. + simpl in *. rewrite (IHn H). now destruct (to_lu n). + Qed. + + Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. + Proof. + induction d; try simpl_of_lu; try easy. + rewrite Nat.add_0_l. + split; intros H. + - apply Nat.eq_mul_0_r in H; auto. + rewrite IHd in H. simpl. now rewrite H. + - simpl in H. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. + Qed. + + Lemma to_of_lu_sixteenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (0x10 * of_lu d) = lnorm (D0 d). + Proof. + intro IH. + destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - rewrite (to_lu_sixteenfold _ H), IH. + rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). + Qed. + + Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. + Proof. + induction d; [ reflexivity | .. ]; + simpl_of_lu; + rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_sixteenfold + by assumption; + unfold lnorm; cbn; now destruct nztail. + Qed. + + (** Second bijection result *) + + Lemma to_of (d:uint) : Nat.to_hex_uint (Nat.of_hex_uint d) = unorm d. + Proof. + rewrite to_uint_alt, of_uint_alt, to_of_lu. + apply rev_lnorm_rev. + Qed. + + (** Some consequences *) + + Lemma to_uint_inj n n' : Nat.to_hex_uint n = Nat.to_hex_uint n' -> n = n'. + Proof. + intro EQ. + now rewrite <- (of_to n), <- (of_to n'), EQ. + Qed. + + Lemma to_uint_surj d : exists n, Nat.to_hex_uint n = unorm d. + Proof. + exists (Nat.of_hex_uint d). apply to_of. + Qed. + + Lemma of_uint_norm d : Nat.of_hex_uint (unorm d) = Nat.of_hex_uint d. + Proof. + unfold Nat.of_hex_uint. now induction d. + Qed. + + Lemma of_inj d d' : + Nat.of_hex_uint d = Nat.of_hex_uint d' -> unorm d = unorm d'. + Proof. + intros. rewrite <- !to_of. now f_equal. + Qed. + + Lemma of_iff d d' : Nat.of_hex_uint d = Nat.of_hex_uint d' <-> unorm d = unorm d'. + Proof. + split. + - apply of_inj. + - intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. + Qed. End Unsigned. @@ -279,45 +279,45 @@ End Unsigned. Module Signed. -Lemma of_to (n:nat) : Nat.of_hex_int (Nat.to_hex_int n) = Some n. -Proof. - unfold Nat.to_hex_int, Nat.of_hex_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:nat) : Nat.of_hex_int d = Some n -> Nat.to_hex_int n = norm d. -Proof. - unfold Nat.of_hex_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold Nat.to_hex_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : Nat.to_hex_int n = Nat.to_hex_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, Nat.to_hex_int n = norm (Pos d). -Proof. - exists (Nat.of_hex_uint d). unfold Nat.to_hex_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : Nat.of_hex_int (norm d) = Nat.of_hex_int d. -Proof. - unfold Nat.of_hex_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - Nat.of_hex_int (Pos d) = Nat.of_hex_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Nat.of_hex_int. simpl. intros [= H]. apply Unsigned.of_inj. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. + Lemma of_to (n:nat) : Nat.of_hex_int (Nat.to_hex_int n) = Some n. + Proof. + unfold Nat.to_hex_int, Nat.of_hex_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. + Qed. + + Lemma to_of (d:int)(n:nat) : Nat.of_hex_int d = Some n -> Nat.to_hex_int n = norm d. + Proof. + unfold Nat.of_hex_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold Nat.to_hex_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_involutive. + - destruct (nzhead d); now intros [= <-]. + Qed. + + Lemma to_int_inj n n' : Nat.to_hex_int n = Nat.to_hex_int n' -> n = n'. + Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. + Qed. + + Lemma to_int_pos_surj d : exists n, Nat.to_hex_int n = norm (Pos d). + Proof. + exists (Nat.of_hex_uint d). unfold Nat.to_hex_int. now rewrite Unsigned.to_of. + Qed. + + Lemma of_int_norm d : Nat.of_hex_int (norm d) = Nat.of_hex_int d. + Proof. + unfold Nat.of_hex_int. now rewrite norm_involutive. + Qed. + + Lemma of_inj_pos d d' : + Nat.of_hex_int (Pos d) = Nat.of_hex_int (Pos d') -> unorm d = unorm d'. + Proof. + unfold Nat.of_hex_int. simpl. intros [= H]. apply Unsigned.of_inj. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. + Qed. End Signed. diff --git a/theories/Numbers/HexadecimalPos.v b/theories/Numbers/HexadecimalPos.v index 6ba618de90..a83ac0933b 100644 --- a/theories/Numbers/HexadecimalPos.v +++ b/theories/Numbers/HexadecimalPos.v @@ -17,379 +17,379 @@ From Stdlib Require Import Hexadecimal HexadecimalFacts BinPos BinNat Nnat. Module Unsigned. -#[local] Open Scope N. - -(** A direct version of [of_little_uint] *) -Fixpoint of_lu (d:uint) : N := - match d with - | Nil => 0 - | D0 d => 0x10 * of_lu d - | D1 d => 0x1 + 0x10 * of_lu d - | D2 d => 0x2 + 0x10 * of_lu d - | D3 d => 0x3 + 0x10 * of_lu d - | D4 d => 0x4 + 0x10 * of_lu d - | D5 d => 0x5 + 0x10 * of_lu d - | D6 d => 0x6 + 0x10 * of_lu d - | D7 d => 0x7 + 0x10 * of_lu d - | D8 d => 0x8 + 0x10 * of_lu d - | D9 d => 0x9 + 0x10 * of_lu d - | Da d => 0xa + 0x10 * of_lu d - | Db d => 0xb + 0x10 * of_lu d - | Dc d => 0xc + 0x10 * of_lu d - | Dd d => 0xd + 0x10 * of_lu d - | De d => 0xe + 0x10 * of_lu d - | Df d => 0xf + 0x10 * of_lu d - end. - -Definition hd d := - match d with - | Nil => 0x0 - | D0 _ => 0x0 - | D1 _ => 0x1 - | D2 _ => 0x2 - | D3 _ => 0x3 - | D4 _ => 0x4 - | D5 _ => 0x5 - | D6 _ => 0x6 - | D7 _ => 0x7 - | D8 _ => 0x8 - | D9 _ => 0x9 - | Da _ => 0xa - | Db _ => 0xb - | Dc _ => 0xc - | Dd _ => 0xd - | De _ => 0xe - | Df _ => 0xf - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d - | Da d | Db d | Dc d | Dd d | De d | Df d => d - end. - -Lemma of_lu_eqn d : - of_lu d = hd d + 0x10 * (of_lu (tl d)). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Fixpoint usize (d:uint) : N := - match d with - | Nil => 0 - | D0 d => N.succ (usize d) - | D1 d => N.succ (usize d) - | D2 d => N.succ (usize d) - | D3 d => N.succ (usize d) - | D4 d => N.succ (usize d) - | D5 d => N.succ (usize d) - | D6 d => N.succ (usize d) - | D7 d => N.succ (usize d) - | D8 d => N.succ (usize d) - | D9 d => N.succ (usize d) - | Da d => N.succ (usize d) - | Db d => N.succ (usize d) - | Dc d => N.succ (usize d) - | Dd d => N.succ (usize d) - | De d => N.succ (usize d) - | Df d => N.succ (usize d) - end. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 0x10^usize d. -Proof. - revert d'. - induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite N.pow_succ_r', ?N.mul_assoc, ?(N.mul_comm 16), ?Nmult_plus_distr_r; trivial. -Qed. - -Definition Nadd n p := - match n with - | N0 => p - | Npos p0 => (p0+p)%positive - end. - -Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. -Proof. - now destruct n. -Qed. - -Lemma of_uint_acc_eqn d acc : d<>Nil -> - Pos.of_hex_uint_acc d acc = Pos.of_hex_uint_acc (tl d) (Nadd (hd d) (0x10*acc)). -Proof. - destruct d; simpl; trivial. now destruct 1. -Qed. - -Lemma of_uint_acc_rev d acc : - Npos (Pos.of_hex_uint_acc d acc) = - of_lu (rev d) + (Npos acc) * 0x10^usize d. -Proof. - revert acc. - induction d; intros; simpl usize; - [ simpl; now rewrite Pos.mul_1_r | .. ]; - rewrite N.pow_succ_r'; - unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; - rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; - rewrite IHd, Nadd_simpl, ?N.mul_assoc, <-?N.add_assoc, ?(N.mul_comm 16), ?Nmult_plus_distr_r; trivial. -Qed. - -Lemma of_uint_alt d : Pos.of_hex_uint d = of_lu (rev d). -Proof. - induction d; simpl; trivial; unfold rev; simpl revapp; - rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. - rewrite IHd, N.add_0_r; trivial. -Qed. - -Lemma of_lu_rev d : Pos.of_hex_uint (rev d) = of_lu d. -Proof. - rewrite of_uint_alt. now rewrite rev_rev. -Qed. - -Lemma of_lu_double_gen d : - of_lu (Little.double d) = N.double (of_lu d) /\ - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - rewrite N.double_spec, N.succ_double_spec. - induction d; try destruct IHd as (IH1,IH2); - simpl Little.double; simpl Little.succ_double; - repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; - rewrite ?(N.add_comm _ 1), ?Nmult_plus_distr_l, ?N.add_assoc, ?N.mul_assoc; trivial. -Qed. - -Lemma of_lu_double d : - of_lu (Little.double d) = N.double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -Lemma of_lu_succ_double d : - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -(** First bijection result *) - -Lemma of_to (p:positive) : Pos.of_hex_uint (Pos.to_hex_uint p) = Npos p. -Proof. - unfold Pos.to_hex_uint. - rewrite of_lu_rev. - induction p; simpl; trivial. - - now rewrite of_lu_succ_double, IHp. - - now rewrite of_lu_double, IHp. -Qed. - -(** The other direction *) - -Definition to_lu n := - match n with - | N0 => Hexadecimal.zero - | Npos p => Pos.to_little_hex_uint p - end. - -Lemma succ_double_alt d : - Little.succ_double d = Little.succ (Little.double d). -Proof. - now induction d. -Qed. - -Lemma double_succ d : - Little.double (Little.succ d) = - Little.succ (Little.succ_double d). -Proof. - induction d; simpl; f_equal; auto using succ_double_alt. -Qed. - -Lemma to_lu_succ n : - to_lu (N.succ n) = Little.succ (to_lu n). -Proof. - destruct n; simpl; trivial. - induction p; simpl; rewrite ?IHp; - auto using succ_double_alt, double_succ. -Qed. - -Lemma nat_iter_S n {A} (f:A->A) i : - Nat.iter (S n) f i = f (Nat.iter n f i). -Proof. - reflexivity. -Qed. - -Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. -Proof. - reflexivity. -Qed. - -Lemma to_lhex_tenfold p : - to_lu (0x10 * Npos p) = D0 (to_lu (Npos p)). -Proof. - induction p using Pos.peano_rect. - - trivial. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - rewrite N.mul_succ_r. - change 0x10 with (Nat.iter 0x10%nat N.succ 0) at 2. - rewrite ?nat_iter_S, nat_iter_0. - rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. - destruct (to_lu (N.pos p)); simpl; auto. -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; split; trivial; try discriminate; - try (intros H; now apply N.eq_add_0 in H). - - rewrite N.add_0_l. intros H. - apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. - simpl. now rewrite H. - - simpl. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. -Qed. - -Lemma to_of_lu_tenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (0x10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (N.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - destruct (of_lu d) eqn:Eq; [easy| ]. - rewrite to_lhex_tenfold; auto. rewrite IH. - rewrite <- Eq in H. rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. -Proof. - destruct n. 1:trivial. - induction p using Pos.peano_rect. - - now rewrite N.add_1_l. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. -Qed. - -Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [reflexivity|..]; - simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; - rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; - unfold lnorm; simpl nztail; destruct nztail; reflexivity. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : N.to_hex_uint (Pos.of_hex_uint d) = unorm d. -Proof. - rewrite of_uint_alt. - unfold N.to_hex_uint, Pos.to_hex_uint. - destruct (of_lu (rev d)) eqn:H. - - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. - unfold lnorm. now rewrite H. - - change (Pos.to_little_hex_uint p) with (to_lu (N.pos p)). - rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_nonzero p : Pos.to_hex_uint p <> zero. -Proof. - intro E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_nonnil p : Pos.to_hex_uint p <> Nil. -Proof. - intros E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_inj p p' : Pos.to_hex_uint p = Pos.to_hex_uint p' -> p = p'. -Proof. - intro E. - assert (E' : N.pos p = N.pos p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_uint_pos_surj d : - unorm d<>zero -> exists p, Pos.to_hex_uint p = unorm d. -Proof. - intros. - destruct (Pos.of_hex_uint d) eqn:E. - - destruct H. generalize (to_of d). now rewrite E. - - exists p. generalize (to_of d). now rewrite E. -Qed. - -Lemma of_uint_norm d : Pos.of_hex_uint (unorm d) = Pos.of_hex_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - Pos.of_hex_uint d = Pos.of_hex_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Pos.of_hex_uint d = Pos.of_hex_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -(* various lemmas *) - -Lemma nztail_to_hex_uint p : - let (h, n) := Hexadecimal.nztail (Pos.to_hex_uint p) in - Npos p = Pos.of_hex_uint h * 0x10^(N.of_nat n). -Proof. - rewrite <-(of_to p), <-(rev_rev (Pos.to_hex_uint p)), of_lu_rev. - unfold Hexadecimal.nztail. - rewrite rev_rev. - induction (rev (Pos.to_hex_uint p)); [reflexivity| | - now simpl N.of_nat; simpl N.pow; rewrite N.mul_1_r, of_lu_rev..]. - revert IHu. - set (t := _ u); case t; clear t; intros u0 n H. - rewrite of_lu_eqn; unfold hd, tl. - rewrite N.add_0_l, H, Nat2N.inj_succ, N.pow_succ_r', ?N.mul_assoc, ?(N.mul_comm 16); trivial. -Qed. - -Definition double d := rev (Little.double (rev d)). - -Lemma double_unorm d : double (unorm d) = unorm (double d). -Proof. - unfold double. - rewrite <-!rev_lnorm_rev, !rev_rev, <-!to_of_lu, of_lu_double. - now case of_lu; [now simpl|]; intro p; induction p. -Qed. - -Lemma double_nzhead d : double (nzhead d) = nzhead (double d). -Proof. - unfold double. - rewrite <-!rev_nztail_rev, !rev_rev. - apply f_equal; generalize (rev d); clear d; intro d. - cut (Little.double (nztail d) = nztail (Little.double d) - /\ Little.succ_double (nztail d) = nztail (Little.succ_double d)). - { now simpl. } - now induction d; - [|split; simpl; rewrite <-?(proj1 IHd), <-?(proj2 IHd); case nztail..]. -Qed. - -Lemma of_hex_uint_double d : - Pos.of_hex_uint (double d) = N.double (Pos.of_hex_uint d). -Proof. - now unfold double; rewrite of_lu_rev, of_lu_double, <-of_lu_rev, rev_rev. -Qed. + #[local] Open Scope N. + + (** A direct version of [of_little_uint] *) + Fixpoint of_lu (d:uint) : N := + match d with + | Nil => 0 + | D0 d => 0x10 * of_lu d + | D1 d => 0x1 + 0x10 * of_lu d + | D2 d => 0x2 + 0x10 * of_lu d + | D3 d => 0x3 + 0x10 * of_lu d + | D4 d => 0x4 + 0x10 * of_lu d + | D5 d => 0x5 + 0x10 * of_lu d + | D6 d => 0x6 + 0x10 * of_lu d + | D7 d => 0x7 + 0x10 * of_lu d + | D8 d => 0x8 + 0x10 * of_lu d + | D9 d => 0x9 + 0x10 * of_lu d + | Da d => 0xa + 0x10 * of_lu d + | Db d => 0xb + 0x10 * of_lu d + | Dc d => 0xc + 0x10 * of_lu d + | Dd d => 0xd + 0x10 * of_lu d + | De d => 0xe + 0x10 * of_lu d + | Df d => 0xf + 0x10 * of_lu d + end. + + Definition hd d := + match d with + | Nil => 0x0 + | D0 _ => 0x0 + | D1 _ => 0x1 + | D2 _ => 0x2 + | D3 _ => 0x3 + | D4 _ => 0x4 + | D5 _ => 0x5 + | D6 _ => 0x6 + | D7 _ => 0x7 + | D8 _ => 0x8 + | D9 _ => 0x9 + | Da _ => 0xa + | Db _ => 0xb + | Dc _ => 0xc + | Dd _ => 0xd + | De _ => 0xe + | Df _ => 0xf + end. + + Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d + | Da d | Db d | Dc d | Dd d | De d | Df d => d + end. + + Lemma of_lu_eqn d : + of_lu d = hd d + 0x10 * (of_lu (tl d)). + Proof. + induction d; simpl; trivial. + Qed. + + Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + + Fixpoint usize (d:uint) : N := + match d with + | Nil => 0 + | D0 d => N.succ (usize d) + | D1 d => N.succ (usize d) + | D2 d => N.succ (usize d) + | D3 d => N.succ (usize d) + | D4 d => N.succ (usize d) + | D5 d => N.succ (usize d) + | D6 d => N.succ (usize d) + | D7 d => N.succ (usize d) + | D8 d => N.succ (usize d) + | D9 d => N.succ (usize d) + | Da d => N.succ (usize d) + | Db d => N.succ (usize d) + | Dc d => N.succ (usize d) + | Dd d => N.succ (usize d) + | De d => N.succ (usize d) + | Df d => N.succ (usize d) + end. + + Lemma of_lu_revapp d d' : + of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 0x10^usize d. + Proof. + revert d'. + induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite N.pow_succ_r', ?N.mul_assoc, ?(N.mul_comm 16), ?Nmult_plus_distr_r; trivial. + Qed. + + Definition Nadd n p := + match n with + | N0 => p + | Npos p0 => (p0+p)%positive + end. + + Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. + Proof. + now destruct n. + Qed. + + Lemma of_uint_acc_eqn d acc : d<>Nil -> + Pos.of_hex_uint_acc d acc = Pos.of_hex_uint_acc (tl d) (Nadd (hd d) (0x10*acc)). + Proof. + destruct d; simpl; trivial. now destruct 1. + Qed. + + Lemma of_uint_acc_rev d acc : + Npos (Pos.of_hex_uint_acc d acc) = + of_lu (rev d) + (Npos acc) * 0x10^usize d. + Proof. + revert acc. + induction d; intros; simpl usize; + [ simpl; now rewrite Pos.mul_1_r | .. ]; + rewrite N.pow_succ_r'; + unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; + rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; + rewrite IHd, Nadd_simpl, ?N.mul_assoc, <-?N.add_assoc, ?(N.mul_comm 16), ?Nmult_plus_distr_r; trivial. + Qed. + + Lemma of_uint_alt d : Pos.of_hex_uint d = of_lu (rev d). + Proof. + induction d; simpl; trivial; unfold rev; simpl revapp; + rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. + rewrite IHd, N.add_0_r; trivial. + Qed. + + Lemma of_lu_rev d : Pos.of_hex_uint (rev d) = of_lu d. + Proof. + rewrite of_uint_alt. now rewrite rev_rev. + Qed. + + Lemma of_lu_double_gen d : + of_lu (Little.double d) = N.double (of_lu d) /\ + of_lu (Little.succ_double d) = N.succ_double (of_lu d). + Proof. + rewrite N.double_spec, N.succ_double_spec. + induction d; try destruct IHd as (IH1,IH2); + simpl Little.double; simpl Little.succ_double; + repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; + rewrite ?(N.add_comm _ 1), ?Nmult_plus_distr_l, ?N.add_assoc, ?N.mul_assoc; trivial. + Qed. + + Lemma of_lu_double d : + of_lu (Little.double d) = N.double (of_lu d). + Proof. + apply of_lu_double_gen. + Qed. + + Lemma of_lu_succ_double d : + of_lu (Little.succ_double d) = N.succ_double (of_lu d). + Proof. + apply of_lu_double_gen. + Qed. + + (** First bijection result *) + + Lemma of_to (p:positive) : Pos.of_hex_uint (Pos.to_hex_uint p) = Npos p. + Proof. + unfold Pos.to_hex_uint. + rewrite of_lu_rev. + induction p; simpl; trivial. + - now rewrite of_lu_succ_double, IHp. + - now rewrite of_lu_double, IHp. + Qed. + + (** The other direction *) + + Definition to_lu n := + match n with + | N0 => Hexadecimal.zero + | Npos p => Pos.to_little_hex_uint p + end. + + Lemma succ_double_alt d : + Little.succ_double d = Little.succ (Little.double d). + Proof. + now induction d. + Qed. + + Lemma double_succ d : + Little.double (Little.succ d) = + Little.succ (Little.succ_double d). + Proof. + induction d; simpl; f_equal; auto using succ_double_alt. + Qed. + + Lemma to_lu_succ n : + to_lu (N.succ n) = Little.succ (to_lu n). + Proof. + destruct n; simpl; trivial. + induction p; simpl; rewrite ?IHp; + auto using succ_double_alt, double_succ. + Qed. + + Lemma nat_iter_S n {A} (f:A->A) i : + Nat.iter (S n) f i = f (Nat.iter n f i). + Proof. + reflexivity. + Qed. + + Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. + Proof. + reflexivity. + Qed. + + Lemma to_lhex_tenfold p : + to_lu (0x10 * Npos p) = D0 (to_lu (Npos p)). + Proof. + induction p using Pos.peano_rect. + - trivial. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + rewrite N.mul_succ_r. + change 0x10 with (Nat.iter 0x10%nat N.succ 0) at 2. + rewrite ?nat_iter_S, nat_iter_0. + rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. + destruct (to_lu (N.pos p)); simpl; auto. + Qed. + + Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. + Proof. + induction d; try simpl_of_lu; split; trivial; try discriminate; + try (intros H; now apply N.eq_add_0 in H). + - rewrite N.add_0_l. intros H. + apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. + simpl. now rewrite H. + - simpl. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. + Qed. + + Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (0x10 * of_lu d) = lnorm (D0 d). + Proof. + intro IH. + destruct (N.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - destruct (of_lu d) eqn:Eq; [easy| ]. + rewrite to_lhex_tenfold; auto. rewrite IH. + rewrite <- Eq in H. rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). + Qed. + + Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. + Proof. + destruct n. 1:trivial. + induction p using Pos.peano_rect. + - now rewrite N.add_1_l. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. + Qed. + + Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. + + Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. + Proof. + induction d; [reflexivity|..]; + simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; + rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; + unfold lnorm; simpl nztail; destruct nztail; reflexivity. + Qed. + + (** Second bijection result *) + + Lemma to_of (d:uint) : N.to_hex_uint (Pos.of_hex_uint d) = unorm d. + Proof. + rewrite of_uint_alt. + unfold N.to_hex_uint, Pos.to_hex_uint. + destruct (of_lu (rev d)) eqn:H. + - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. + unfold lnorm. now rewrite H. + - change (Pos.to_little_hex_uint p) with (to_lu (N.pos p)). + rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. + Qed. + + (** Some consequences *) + + Lemma to_uint_nonzero p : Pos.to_hex_uint p <> zero. + Proof. + intro E. generalize (of_to p). now rewrite E. + Qed. + + Lemma to_uint_nonnil p : Pos.to_hex_uint p <> Nil. + Proof. + intros E. generalize (of_to p). now rewrite E. + Qed. + + Lemma to_uint_inj p p' : Pos.to_hex_uint p = Pos.to_hex_uint p' -> p = p'. + Proof. + intro E. + assert (E' : N.pos p = N.pos p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. + Qed. + + Lemma to_uint_pos_surj d : + unorm d<>zero -> exists p, Pos.to_hex_uint p = unorm d. + Proof. + intros. + destruct (Pos.of_hex_uint d) eqn:E. + - destruct H. generalize (to_of d). now rewrite E. + - exists p. generalize (to_of d). now rewrite E. + Qed. + + Lemma of_uint_norm d : Pos.of_hex_uint (unorm d) = Pos.of_hex_uint d. + Proof. + now induction d. + Qed. + + Lemma of_inj d d' : + Pos.of_hex_uint d = Pos.of_hex_uint d' -> unorm d = unorm d'. + Proof. + intros. rewrite <- !to_of. now f_equal. + Qed. + + Lemma of_iff d d' : Pos.of_hex_uint d = Pos.of_hex_uint d' <-> unorm d = unorm d'. + Proof. + split. + - apply of_inj. + - intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. + Qed. + + (* various lemmas *) + + Lemma nztail_to_hex_uint p : + let (h, n) := Hexadecimal.nztail (Pos.to_hex_uint p) in + Npos p = Pos.of_hex_uint h * 0x10^(N.of_nat n). + Proof. + rewrite <-(of_to p), <-(rev_rev (Pos.to_hex_uint p)), of_lu_rev. + unfold Hexadecimal.nztail. + rewrite rev_rev. + induction (rev (Pos.to_hex_uint p)); [reflexivity| | + now simpl N.of_nat; simpl N.pow; rewrite N.mul_1_r, of_lu_rev..]. + revert IHu. + set (t := _ u); case t; clear t; intros u0 n H. + rewrite of_lu_eqn; unfold hd, tl. + rewrite N.add_0_l, H, Nat2N.inj_succ, N.pow_succ_r', ?N.mul_assoc, ?(N.mul_comm 16); trivial. + Qed. + + Definition double d := rev (Little.double (rev d)). + + Lemma double_unorm d : double (unorm d) = unorm (double d). + Proof. + unfold double. + rewrite <-!rev_lnorm_rev, !rev_rev, <-!to_of_lu, of_lu_double. + now case of_lu; [now simpl|]; intro p; induction p. + Qed. + + Lemma double_nzhead d : double (nzhead d) = nzhead (double d). + Proof. + unfold double. + rewrite <-!rev_nztail_rev, !rev_rev. + apply f_equal; generalize (rev d); clear d; intro d. + cut (Little.double (nztail d) = nztail (Little.double d) + /\ Little.succ_double (nztail d) = nztail (Little.succ_double d)). + { now simpl. } + now induction d; + [|split; simpl; rewrite <-?(proj1 IHd), <-?(proj2 IHd); case nztail..]. + Qed. + + Lemma of_hex_uint_double d : + Pos.of_hex_uint (double d) = N.double (Pos.of_hex_uint d). + Proof. + now unfold double; rewrite of_lu_rev, of_lu_double, <-of_lu_rev, rev_rev. + Qed. End Unsigned. @@ -397,53 +397,53 @@ End Unsigned. Module Signed. -Lemma of_to (p:positive) : Pos.of_hex_int (Pos.to_hex_int p) = Some p. -Proof. - unfold Pos.to_hex_int, Pos.of_hex_int, norm. - now rewrite Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(p:positive) : - Pos.of_hex_int d = Some p -> Pos.to_hex_int p = norm d. -Proof. - unfold Pos.of_hex_int. - destruct d; [ | intros [=]]. - simpl norm. rewrite <- Unsigned.to_of. - destruct (Pos.of_hex_uint d); now intros [= <-]. -Qed. - -Lemma to_int_inj p p' : Pos.to_hex_int p = Pos.to_hex_int p' -> p = p'. -Proof. - intro E. - assert (E' : Some p = Some p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : - unorm d <> zero -> exists p, Pos.to_hex_int p = norm (Pos d). -Proof. - simpl. unfold Pos.to_hex_int. intros H. - destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). - exists p. now f_equal. -Qed. - -Lemma of_int_norm d : Pos.of_hex_int (norm d) = Pos.of_hex_int d. -Proof. - unfold Pos.of_int. - destruct d. - - simpl. now rewrite Unsigned.of_uint_norm. - - simpl. now destruct (nzhead d) eqn:H. -Qed. - -Lemma of_inj_pos d d' : - Pos.of_hex_int (Pos d) = Pos.of_hex_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Pos.of_hex_int. - destruct (Pos.of_hex_uint d) eqn:Hd, (Pos.of_hex_uint d') eqn:Hd'; - intros [=]. - - apply Unsigned.of_inj; now rewrite Hd, Hd'. - - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. -Qed. + Lemma of_to (p:positive) : Pos.of_hex_int (Pos.to_hex_int p) = Some p. + Proof. + unfold Pos.to_hex_int, Pos.of_hex_int, norm. + now rewrite Unsigned.of_to. + Qed. + + Lemma to_of (d:int)(p:positive) : + Pos.of_hex_int d = Some p -> Pos.to_hex_int p = norm d. + Proof. + unfold Pos.of_hex_int. + destruct d; [ | intros [=]]. + simpl norm. rewrite <- Unsigned.to_of. + destruct (Pos.of_hex_uint d); now intros [= <-]. + Qed. + + Lemma to_int_inj p p' : Pos.to_hex_int p = Pos.to_hex_int p' -> p = p'. + Proof. + intro E. + assert (E' : Some p = Some p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. + Qed. + + Lemma to_int_pos_surj d : + unorm d <> zero -> exists p, Pos.to_hex_int p = norm (Pos d). + Proof. + simpl. unfold Pos.to_hex_int. intros H. + destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). + exists p. now f_equal. + Qed. + + Lemma of_int_norm d : Pos.of_hex_int (norm d) = Pos.of_hex_int d. + Proof. + unfold Pos.of_int. + destruct d. + - simpl. now rewrite Unsigned.of_uint_norm. + - simpl. now destruct (nzhead d) eqn:H. + Qed. + + Lemma of_inj_pos d d' : + Pos.of_hex_int (Pos d) = Pos.of_hex_int (Pos d') -> unorm d = unorm d'. + Proof. + unfold Pos.of_hex_int. + destruct (Pos.of_hex_uint d) eqn:Hd, (Pos.of_hex_uint d') eqn:Hd'; + intros [=]. + - apply Unsigned.of_inj; now rewrite Hd, Hd'. + - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. + Qed. End Signed. diff --git a/theories/Numbers/HexadecimalString.v b/theories/Numbers/HexadecimalString.v index 59d8dfb440..3f7db4ab1c 100644 --- a/theories/Numbers/HexadecimalString.v +++ b/theories/Numbers/HexadecimalString.v @@ -78,98 +78,98 @@ Qed. Module NilEmpty. -Fixpoint string_of_uint (d:uint) := - match d with - | Nil => EmptyString - | D0 d => String "0" (string_of_uint d) - | D1 d => String "1" (string_of_uint d) - | D2 d => String "2" (string_of_uint d) - | D3 d => String "3" (string_of_uint d) - | D4 d => String "4" (string_of_uint d) - | D5 d => String "5" (string_of_uint d) - | D6 d => String "6" (string_of_uint d) - | D7 d => String "7" (string_of_uint d) - | D8 d => String "8" (string_of_uint d) - | D9 d => String "9" (string_of_uint d) - | Da d => String "a" (string_of_uint d) - | Db d => String "b" (string_of_uint d) - | Dc d => String "c" (string_of_uint d) - | Dd d => String "d" (string_of_uint d) - | De d => String "e" (string_of_uint d) - | Df d => String "f" (string_of_uint d) - end. - -Fixpoint uint_of_string s := - match s with - | EmptyString => Some Nil - | String a s => uint_of_char a (uint_of_string s) - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => Some (Pos Nil) - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(* NB: For the moment whitespace between - and digits are not accepted. + Fixpoint string_of_uint (d:uint) := + match d with + | Nil => EmptyString + | D0 d => String "0" (string_of_uint d) + | D1 d => String "1" (string_of_uint d) + | D2 d => String "2" (string_of_uint d) + | D3 d => String "3" (string_of_uint d) + | D4 d => String "4" (string_of_uint d) + | D5 d => String "5" (string_of_uint d) + | D6 d => String "6" (string_of_uint d) + | D7 d => String "7" (string_of_uint d) + | D8 d => String "8" (string_of_uint d) + | D9 d => String "9" (string_of_uint d) + | Da d => String "a" (string_of_uint d) + | Db d => String "b" (string_of_uint d) + | Dc d => String "c" (string_of_uint d) + | Dd d => String "d" (string_of_uint d) + | De d => String "e" (string_of_uint d) + | Df d => String "f" (string_of_uint d) + end. + + Fixpoint uint_of_string s := + match s with + | EmptyString => Some Nil + | String a s => uint_of_char a (uint_of_string s) + end. + + Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + + Definition int_of_string s := + match s with + | EmptyString => Some (Pos Nil) + | String a s' => + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + + (* NB: For the moment whitespace between - and digits are not accepted. And in this variant [int_of_string "-" = Some (Neg Nil)]. Compute int_of_string "-123456890123456890123456890123456890". Compute string_of_int (-123456890123456890123456890123456890). *) -(** Corresponding proofs *) - -Lemma usu d : - uint_of_string (string_of_uint d) = Some d. -Proof. - induction d; simpl; rewrite ?IHd; simpl; auto. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - revert d. - induction s; simpl. - - now intros d [= <-]. - - intros d. - destruct (uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - intuition subst; simpl; f_equal; auto. -Qed. - -Lemma isi d : int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. - - rewrite usu; auto. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [= <-]| ]; simpl; trivial. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. + (** Corresponding proofs *) + + Lemma usu d : + uint_of_string (string_of_uint d) = Some d. + Proof. + induction d; simpl; rewrite ?IHd; simpl; auto. + Qed. + + Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. + Proof. + revert d. + induction s; simpl. + - now intros d [= <-]. + - intros d. + destruct (uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + intuition subst; simpl; f_equal; auto. + Qed. + + Lemma isi d : int_of_string (string_of_int d) = Some d. + Proof. + destruct d; simpl. + - unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. + * rewrite <- Hd, usu; auto. + - rewrite usu; auto. + Qed. + + Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. + Proof. + destruct s; [intros [= <-]| ]; simpl; trivial. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. + Qed. End NilEmpty. @@ -177,110 +177,110 @@ End NilEmpty. Module NilZero. -Definition string_of_uint (d:uint) := - match d with - | Nil => "0" - | _ => NilEmpty.string_of_uint d - end. - -Definition uint_of_string s := - match s with - | EmptyString => None - | _ => NilEmpty.uint_of_string s - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => None - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(** Corresponding proofs *) - -Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. -Proof. - destruct s; simpl. - - easy. - - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - now intuition subst. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - destruct s; [intros [=] | intros H]. - apply NilEmpty.sus in H. now destruct d. -Qed. - -Lemma usu d : - d<>Nil -> uint_of_string (string_of_uint d) = Some d. -Proof. - destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). -Qed. - -Lemma usu_nil : - uint_of_string (string_of_uint Nil) = Some Hexadecimal.zero. -Proof. - reflexivity. -Qed. - -Lemma usu_gen d : - uint_of_string (string_of_uint d) = Some d \/ - uint_of_string (string_of_uint d) = Some Hexadecimal.zero. -Proof. - destruct d; (now right) || (left; now apply usu). -Qed. - -Lemma isi d : - d<>Pos Nil -> d<>Neg Nil -> - int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - intros H _. - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. now intros ->. - - intros _ H. - rewrite usu; auto. now intros ->. -Qed. - -Lemma isi_posnil : - int_of_string (string_of_int (Pos Nil)) = Some (Pos Hexadecimal.zero). -Proof. - reflexivity. -Qed. - -(** Warning! (-0) won't parse (compatibility with the behavior of Z). *) - -Lemma isi_negnil : - int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). -Proof. - reflexivity. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [=]| ]; simpl. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. + Definition string_of_uint (d:uint) := + match d with + | Nil => "0" + | _ => NilEmpty.string_of_uint d + end. + + Definition uint_of_string s := + match s with + | EmptyString => None + | _ => NilEmpty.uint_of_string s + end. + + Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + + Definition int_of_string s := + match s with + | EmptyString => None + | String a s' => + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + + (** Corresponding proofs *) + + Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. + Proof. + destruct s; simpl. + - easy. + - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + now intuition subst. + Qed. + + Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. + Proof. + destruct s; [intros [=] | intros H]. + apply NilEmpty.sus in H. now destruct d. + Qed. + + Lemma usu d : + d<>Nil -> uint_of_string (string_of_uint d) = Some d. + Proof. + destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). + Qed. + + Lemma usu_nil : + uint_of_string (string_of_uint Nil) = Some Hexadecimal.zero. + Proof. + reflexivity. + Qed. + + Lemma usu_gen d : + uint_of_string (string_of_uint d) = Some d \/ + uint_of_string (string_of_uint d) = Some Hexadecimal.zero. + Proof. + destruct d; (now right) || (left; now apply usu). + Qed. + + Lemma isi d : + d<>Pos Nil -> d<>Neg Nil -> + int_of_string (string_of_int d) = Some d. + Proof. + destruct d; simpl. + - intros H _. + unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. + * rewrite <- Hd, usu; auto. now intros ->. + - intros _ H. + rewrite usu; auto. now intros ->. + Qed. + + Lemma isi_posnil : + int_of_string (string_of_int (Pos Nil)) = Some (Pos Hexadecimal.zero). + Proof. + reflexivity. + Qed. + + (** Warning! (-0) won't parse (compatibility with the behavior of Z). *) + + Lemma isi_negnil : + int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). + Proof. + reflexivity. + Qed. + + Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. + Proof. + destruct s; [intros [=]| ]; simpl. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. + Qed. End NilZero. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index c8a8998d2b..49e7906267 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -13,283 +13,283 @@ From Stdlib Require Export ZBase. Module ZAddProp (Import Z : ZAxiomsMiniSig'). -Include ZBaseProp Z. + Include ZBaseProp Z. -(** Theorems that are either not valid on N or have different proofs + (** Theorems that are either not valid on N or have different proofs on N and Z *) -#[global] Hint Rewrite opp_0 : nz. - -Theorem add_pred_l n m : P n + m == P (n + m). -Proof. -rewrite <- (succ_pred n) at 2. -now rewrite add_succ_l, pred_succ. -Qed. - -Theorem add_pred_r n m : n + P m == P (n + m). -Proof. -rewrite 2 (add_comm n); apply add_pred_l. -Qed. - -Theorem add_opp_r n m : n + (- m) == n - m. -Proof. -nzinduct m. -- now nzsimpl. -- intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd. -Qed. - -Theorem sub_0_l n : 0 - n == - n. -Proof. -rewrite <- add_opp_r; now rewrite add_0_l. -Qed. - -Theorem sub_succ_l n m : S n - m == S (n - m). -Proof. -rewrite <- 2 add_opp_r; now rewrite add_succ_l. -Qed. - -Theorem sub_pred_l n m : P n - m == P (n - m). -Proof. -rewrite <- (succ_pred n) at 2. -rewrite sub_succ_l; now rewrite pred_succ. -Qed. - -Theorem sub_pred_r n m : n - (P m) == S (n - m). -Proof. -rewrite <- (succ_pred m) at 2. -rewrite sub_succ_r; now rewrite succ_pred. -Qed. - -Theorem opp_pred n : - (P n) == S (- n). -Proof. -rewrite <- (succ_pred n) at 2. -rewrite opp_succ. now rewrite succ_pred. -Qed. - -Theorem sub_diag n : n - n == 0. -Proof. -nzinduct n. -- now nzsimpl. -- intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ. -Qed. - -Theorem add_opp_diag_l n : - n + n == 0. -Proof. -now rewrite add_comm, add_opp_r, sub_diag. -Qed. - -Theorem add_opp_diag_r n : n + (- n) == 0. -Proof. -rewrite add_comm; apply add_opp_diag_l. -Qed. - -Theorem add_opp_l n m : - m + n == n - m. -Proof. -rewrite <- add_opp_r; now rewrite add_comm. -Qed. - -Theorem add_sub_assoc n m p : n + (m - p) == (n + m) - p. -Proof. -rewrite <- 2 add_opp_r; now rewrite add_assoc. -Qed. - -Theorem opp_involutive n : - (- n) == n. -Proof. -nzinduct n. -- now nzsimpl. -- intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd. -Qed. - -Theorem opp_add_distr n m : - (n + m) == - n + (- m). -Proof. -nzinduct n. -- now nzsimpl. -- intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l. - now rewrite pred_inj_wd. -Qed. - -Theorem opp_sub_distr n m : - (n - m) == - n + m. -Proof. -rewrite <- add_opp_r, opp_add_distr. -now rewrite opp_involutive. -Qed. - -Theorem opp_inj n m : - n == - m -> n == m. -Proof. -intros H. apply opp_wd in H. now rewrite 2 opp_involutive in H. -Qed. - -Theorem opp_inj_wd n m : - n == - m <-> n == m. -Proof. -split; [apply opp_inj | intros; now f_equiv]. -Qed. - -Theorem eq_opp_l n m : - n == m <-> n == - m. -Proof. -now rewrite <- (opp_inj_wd (- n) m), opp_involutive. -Qed. - -Theorem eq_opp_r n m : n == - m <-> - n == m. -Proof. -symmetry; apply eq_opp_l. -Qed. - -Theorem sub_add_distr n m p : n - (m + p) == (n - m) - p. -Proof. -rewrite <- add_opp_r, opp_add_distr, add_assoc. -now rewrite 2 add_opp_r. -Qed. - -Theorem sub_sub_distr n m p : n - (m - p) == (n - m) + p. -Proof. -rewrite <- add_opp_r, opp_sub_distr, add_assoc. -now rewrite add_opp_r. -Qed. - -Theorem sub_opp_l n m : - n - m == - m - n. -Proof. -rewrite <- 2 add_opp_r. now rewrite add_comm. -Qed. - -Theorem sub_opp_r n m : n - (- m) == n + m. -Proof. -rewrite <- add_opp_r; now rewrite opp_involutive. -Qed. - -Theorem add_sub_swap n m p : n + m - p == n - p + m. -Proof. -rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. -now rewrite add_opp_l. -Qed. - -Theorem sub_cancel_l n m p : n - m == n - p <-> m == p. -Proof. -rewrite <- (add_cancel_l (n - m) (n - p) (- n)). -rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l. -apply opp_inj_wd. -Qed. - -Theorem sub_cancel_r n m p : n - p == m - p <-> n == m. -Proof. -stepl (n - p + p == m - p + p) by apply add_cancel_r. -now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r. -Qed. - -(** The next several theorems are devoted to moving terms from one + #[global] Hint Rewrite opp_0 : nz. + + Theorem add_pred_l n m : P n + m == P (n + m). + Proof. + rewrite <- (succ_pred n) at 2. + now rewrite add_succ_l, pred_succ. + Qed. + + Theorem add_pred_r n m : n + P m == P (n + m). + Proof. + rewrite 2 (add_comm n); apply add_pred_l. + Qed. + + Theorem add_opp_r n m : n + (- m) == n - m. + Proof. + nzinduct m. + - now nzsimpl. + - intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd. + Qed. + + Theorem sub_0_l n : 0 - n == - n. + Proof. + rewrite <- add_opp_r; now rewrite add_0_l. + Qed. + + Theorem sub_succ_l n m : S n - m == S (n - m). + Proof. + rewrite <- 2 add_opp_r; now rewrite add_succ_l. + Qed. + + Theorem sub_pred_l n m : P n - m == P (n - m). + Proof. + rewrite <- (succ_pred n) at 2. + rewrite sub_succ_l; now rewrite pred_succ. + Qed. + + Theorem sub_pred_r n m : n - (P m) == S (n - m). + Proof. + rewrite <- (succ_pred m) at 2. + rewrite sub_succ_r; now rewrite succ_pred. + Qed. + + Theorem opp_pred n : - (P n) == S (- n). + Proof. + rewrite <- (succ_pred n) at 2. + rewrite opp_succ. now rewrite succ_pred. + Qed. + + Theorem sub_diag n : n - n == 0. + Proof. + nzinduct n. + - now nzsimpl. + - intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ. + Qed. + + Theorem add_opp_diag_l n : - n + n == 0. + Proof. + now rewrite add_comm, add_opp_r, sub_diag. + Qed. + + Theorem add_opp_diag_r n : n + (- n) == 0. + Proof. + rewrite add_comm; apply add_opp_diag_l. + Qed. + + Theorem add_opp_l n m : - m + n == n - m. + Proof. + rewrite <- add_opp_r; now rewrite add_comm. + Qed. + + Theorem add_sub_assoc n m p : n + (m - p) == (n + m) - p. + Proof. + rewrite <- 2 add_opp_r; now rewrite add_assoc. + Qed. + + Theorem opp_involutive n : - (- n) == n. + Proof. + nzinduct n. + - now nzsimpl. + - intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd. + Qed. + + Theorem opp_add_distr n m : - (n + m) == - n + (- m). + Proof. + nzinduct n. + - now nzsimpl. + - intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l. + now rewrite pred_inj_wd. + Qed. + + Theorem opp_sub_distr n m : - (n - m) == - n + m. + Proof. + rewrite <- add_opp_r, opp_add_distr. + now rewrite opp_involutive. + Qed. + + Theorem opp_inj n m : - n == - m -> n == m. + Proof. + intros H. apply opp_wd in H. now rewrite 2 opp_involutive in H. + Qed. + + Theorem opp_inj_wd n m : - n == - m <-> n == m. + Proof. + split; [apply opp_inj | intros; now f_equiv]. + Qed. + + Theorem eq_opp_l n m : - n == m <-> n == - m. + Proof. + now rewrite <- (opp_inj_wd (- n) m), opp_involutive. + Qed. + + Theorem eq_opp_r n m : n == - m <-> - n == m. + Proof. + symmetry; apply eq_opp_l. + Qed. + + Theorem sub_add_distr n m p : n - (m + p) == (n - m) - p. + Proof. + rewrite <- add_opp_r, opp_add_distr, add_assoc. + now rewrite 2 add_opp_r. + Qed. + + Theorem sub_sub_distr n m p : n - (m - p) == (n - m) + p. + Proof. + rewrite <- add_opp_r, opp_sub_distr, add_assoc. + now rewrite add_opp_r. + Qed. + + Theorem sub_opp_l n m : - n - m == - m - n. + Proof. + rewrite <- 2 add_opp_r. now rewrite add_comm. + Qed. + + Theorem sub_opp_r n m : n - (- m) == n + m. + Proof. + rewrite <- add_opp_r; now rewrite opp_involutive. + Qed. + + Theorem add_sub_swap n m p : n + m - p == n - p + m. + Proof. + rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. + now rewrite add_opp_l. + Qed. + + Theorem sub_cancel_l n m p : n - m == n - p <-> m == p. + Proof. + rewrite <- (add_cancel_l (n - m) (n - p) (- n)). + rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l. + apply opp_inj_wd. + Qed. + + Theorem sub_cancel_r n m p : n - p == m - p <-> n == m. + Proof. + stepl (n - p + p == m - p + p) by apply add_cancel_r. + now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r. + Qed. + + (** The next several theorems are devoted to moving terms from one side of an equation to the other. The name contains the operation in the original equation ([add] or [sub]) and the indication whether the left or right term is moved. *) -Theorem add_move_l n m p : n + m == p <-> m == p - n. -Proof. -stepl (n + m - n == p - n) by apply sub_cancel_r. -now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r. -Qed. + Theorem add_move_l n m p : n + m == p <-> m == p - n. + Proof. + stepl (n + m - n == p - n) by apply sub_cancel_r. + now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r. + Qed. -Theorem add_move_r n m p : n + m == p <-> n == p - m. -Proof. -rewrite add_comm; now apply add_move_l. -Qed. + Theorem add_move_r n m p : n + m == p <-> n == p - m. + Proof. + rewrite add_comm; now apply add_move_l. + Qed. -(** The two theorems above do not allow rewriting subformulas of the + (** The two theorems above do not allow rewriting subformulas of the form [n - m == p] to [n == p + m] since subtraction is in the right-hand side of the equation. Hence the following two theorems. *) -Theorem sub_move_l n m p : n - m == p <-> - m == p - n. -Proof. -rewrite <- (add_opp_r n m); apply add_move_l. -Qed. - -Theorem sub_move_r n m p : n - m == p <-> n == p + m. -Proof. -rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. -Qed. - -Theorem add_move_0_l n m : n + m == 0 <-> m == - n. -Proof. -now rewrite add_move_l, sub_0_l. -Qed. - -Theorem add_move_0_r n m : n + m == 0 <-> n == - m. -Proof. -now rewrite add_move_r, sub_0_l. -Qed. - -Theorem sub_move_0_l n m : n - m == 0 <-> - m == - n. -Proof. -now rewrite sub_move_l, sub_0_l. -Qed. - -Theorem sub_move_0_r n m : n - m == 0 <-> n == m. -Proof. -now rewrite sub_move_r, add_0_l. -Qed. - -(** The following section is devoted to cancellation of like + Theorem sub_move_l n m p : n - m == p <-> - m == p - n. + Proof. + rewrite <- (add_opp_r n m); apply add_move_l. + Qed. + + Theorem sub_move_r n m p : n - m == p <-> n == p + m. + Proof. + rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. + Qed. + + Theorem add_move_0_l n m : n + m == 0 <-> m == - n. + Proof. + now rewrite add_move_l, sub_0_l. + Qed. + + Theorem add_move_0_r n m : n + m == 0 <-> n == - m. + Proof. + now rewrite add_move_r, sub_0_l. + Qed. + + Theorem sub_move_0_l n m : n - m == 0 <-> - m == - n. + Proof. + now rewrite sub_move_l, sub_0_l. + Qed. + + Theorem sub_move_0_r n m : n - m == 0 <-> n == m. + Proof. + now rewrite sub_move_r, add_0_l. + Qed. + + (** The following section is devoted to cancellation of like terms. The name includes the first operator and the position of the term being canceled. *) -Theorem add_simpl_l n m : n + m - n == m. -Proof. -now rewrite add_sub_swap, sub_diag, add_0_l. -Qed. + Theorem add_simpl_l n m : n + m - n == m. + Proof. + now rewrite add_sub_swap, sub_diag, add_0_l. + Qed. -Theorem add_simpl_r n m : n + m - m == n. -Proof. -now rewrite <- add_sub_assoc, sub_diag, add_0_r. -Qed. + Theorem add_simpl_r n m : n + m - m == n. + Proof. + now rewrite <- add_sub_assoc, sub_diag, add_0_r. + Qed. -Theorem sub_simpl_l n m : - n - m + n == - m. -Proof. -now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. -Qed. + Theorem sub_simpl_l n m : - n - m + n == - m. + Proof. + now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. + Qed. -Theorem sub_simpl_r n m : n - m + m == n. -Proof. -now rewrite <- sub_sub_distr, sub_diag, sub_0_r. -Qed. + Theorem sub_simpl_r n m : n - m + m == n. + Proof. + now rewrite <- sub_sub_distr, sub_diag, sub_0_r. + Qed. -Theorem sub_add n m : m - n + n == m. -Proof. -now rewrite <- add_sub_swap, add_simpl_r. -Qed. + Theorem sub_add n m : m - n + n == m. + Proof. + now rewrite <- add_sub_swap, add_simpl_r. + Qed. -(** Now we have two sums or differences; the name includes the two + (** Now we have two sums or differences; the name includes the two operators and the position of the terms being canceled *) -Theorem add_add_simpl_l_l n m p : (n + m) - (n + p) == m - p. -Proof. -now rewrite (add_comm n m), <- add_sub_assoc, -sub_add_distr, sub_diag, sub_0_l, add_opp_r. -Qed. - -Theorem add_add_simpl_l_r n m p : (n + m) - (p + n) == m - p. -Proof. -rewrite (add_comm p n); apply add_add_simpl_l_l. -Qed. - -Theorem add_add_simpl_r_l n m p : (n + m) - (m + p) == n - p. -Proof. -rewrite (add_comm n m); apply add_add_simpl_l_l. -Qed. - -Theorem add_add_simpl_r_r n m p : (n + m) - (p + m) == n - p. -Proof. -rewrite (add_comm p m); apply add_add_simpl_r_l. -Qed. - -Theorem sub_add_simpl_r_l n m p : (n - m) + (m + p) == n + p. -Proof. -now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, -sub_0_l, sub_opp_r. -Qed. - -Theorem sub_add_simpl_r_r n m p : (n - m) + (p + m) == n + p. -Proof. -rewrite (add_comm p m); apply sub_add_simpl_r_l. -Qed. - -(** Of course, there are many other variants *) + Theorem add_add_simpl_l_l n m p : (n + m) - (n + p) == m - p. + Proof. + now rewrite (add_comm n m), <- add_sub_assoc, + sub_add_distr, sub_diag, sub_0_l, add_opp_r. + Qed. + + Theorem add_add_simpl_l_r n m p : (n + m) - (p + n) == m - p. + Proof. + rewrite (add_comm p n); apply add_add_simpl_l_l. + Qed. + + Theorem add_add_simpl_r_l n m p : (n + m) - (m + p) == n - p. + Proof. + rewrite (add_comm n m); apply add_add_simpl_l_l. + Qed. + + Theorem add_add_simpl_r_r n m p : (n + m) - (p + m) == n - p. + Proof. + rewrite (add_comm p m); apply add_add_simpl_r_l. + Qed. + + Theorem sub_add_simpl_r_l n m p : (n - m) + (m + p) == n + p. + Proof. + now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, + sub_0_l, sub_opp_r. + Qed. + + Theorem sub_add_simpl_r_r n m p : (n - m) + (p + m) == n + p. + Proof. + rewrite (add_comm p m); apply sub_add_simpl_r_l. + Qed. + + (** Of course, there are many other variants *) End ZAddProp. diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v index 1263305ced..976983a03e 100644 --- a/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -13,273 +13,273 @@ From Stdlib Require Export ZLt. Module ZAddOrderProp (Import Z : ZAxiomsMiniSig'). -Include ZOrderProp Z. + Include ZOrderProp Z. -(** Theorems that are either not valid on N or have different proofs + (** Theorems that are either not valid on N or have different proofs on N and Z *) -Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_lt_mono. -Qed. - -Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono. -Qed. - -Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono. -Qed. - -Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_le_mono. -Qed. - -(** Sub and order *) - -Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m. -Proof. -intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r. -Qed. - -Notation sub_pos := lt_0_sub (only parsing). - -Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m. -Proof. -intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r. -Qed. - -Notation sub_nonneg := le_0_sub (only parsing). - -Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m. -Proof. -intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r. -Qed. - -Notation sub_neg := lt_sub_0 (only parsing). - -Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m. -Proof. -intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r. -Qed. - -Notation sub_nonpos := le_sub_0 (only parsing). - -Theorem opp_lt_mono : forall n m, n < m <-> - m < - n. -Proof. -intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub. -Qed. - -Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n. -Proof. -intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub. -Qed. - -Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0. -Proof. -intro n; now rewrite (opp_lt_mono n 0), opp_0. -Qed. - -Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n. -Proof. -intro n. now rewrite (opp_lt_mono 0 n), opp_0. -Qed. - -Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0. -Proof. -intro n; now rewrite (opp_le_mono n 0), opp_0. -Qed. - -Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n. -Proof. -intro n. now rewrite (opp_le_mono 0 n), opp_0. -Qed. - -Theorem lt_m1_0 : -1 < 0. -Proof. -apply opp_neg_pos, lt_0_1. -Qed. - -Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n. -Proof. -intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono. -Qed. - -Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p. -Proof. -intros. now rewrite <- 2 add_opp_r, add_lt_mono_r. -Qed. - -Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q. -Proof. -intros n m p q H1 H2. -apply lt_trans with (m - p); -[now apply sub_lt_mono_r | now apply sub_lt_mono_l]. -Qed. - -Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n. -Proof. -intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono. -Qed. - -Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p. -Proof. -intros. now rewrite <- 2 add_opp_r, add_le_mono_r. -Qed. - -Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q. -Proof. -intros n m p q H1 H2. -apply le_trans with (m - p); -[now apply sub_le_mono_r | now apply sub_le_mono_l]. -Qed. - -Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q. -Proof. -intros n m p q H1 H2. -apply lt_le_trans with (m - p); -[now apply sub_lt_mono_r | now apply sub_le_mono_l]. -Qed. - -Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q. -Proof. -intros n m p q H1 H2. -apply le_lt_trans with (m - p); -[now apply sub_le_mono_r | now apply sub_lt_mono_l]. -Qed. - -Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q. -Proof. -intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n)); -[now apply -> opp_le_mono | now rewrite 2 add_opp_r]. -Qed. - -Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q. -Proof. -intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n)); -[now apply -> opp_lt_mono | now rewrite 2 add_opp_r]. -Qed. - -Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q. -Proof. -intros n m p q H1 H2. apply (le_le_add_le (- m) (- n)); -[now apply -> opp_le_mono | now rewrite 2 add_opp_r]. -Qed. - -Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. -Proof. -intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r. -Qed. - -Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p. -Proof. -intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r. -Qed. - -Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. -Proof. -intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. -Qed. - -Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n. -Proof. -intros n m p. rewrite add_comm; apply le_add_le_sub_r. -Qed. - -Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p. -Proof. -intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r. -Qed. - -Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p. -Proof. -intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r. -Qed. - -Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p. -Proof. -intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. -Qed. - -Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. -Proof. -intros n m p. rewrite add_comm; apply le_sub_le_add_r. -Qed. - -Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p. -Proof. -intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r. -Qed. - -Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p. -Proof. -intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r. -Qed. - -Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n. -Proof. -intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r. -Qed. - -Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n. -Proof. -intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r. -Qed. - -Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p. -Proof. -intros. now apply add_lt_cases, lt_sub_lt_add. -Qed. - -Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p. -Proof. -intros. now apply add_le_cases, le_sub_le_add. -Qed. - -Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m. -Proof. -intros n m ?. -rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r. -Qed. - -Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0. -Proof. -intros n m ?. -rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r. -Qed. - -Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m. -Proof. -intros n m ?. -rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r. -Qed. - -Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0. -Proof. -intros n m ?. -rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r. -Qed. - -Section PosNeg. - -Variable P : Z.t -> Prop. -Hypothesis P_wd : Proper (eq ==> iff) P. - -Theorem zero_pos_neg : - P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n. -Proof. -intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]]. -- apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3]. - now rewrite opp_involutive in H3. -- now rewrite H3. -- apply H2 in H3; now destruct H3. -Qed. - -End PosNeg. - -Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg). + Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0. + Proof. + intros. rewrite <- (add_0_l 0). now apply add_lt_mono. + Qed. + + Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0. + Proof. + intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono. + Qed. + + Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0. + Proof. + intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono. + Qed. + + Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0. + Proof. + intros. rewrite <- (add_0_l 0). now apply add_le_mono. + Qed. + + (** Sub and order *) + + Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m. + Proof. + intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r. + Qed. + + Notation sub_pos := lt_0_sub (only parsing). + + Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m. + Proof. + intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r. + Qed. + + Notation sub_nonneg := le_0_sub (only parsing). + + Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m. + Proof. + intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r. + Qed. + + Notation sub_neg := lt_sub_0 (only parsing). + + Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m. + Proof. + intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r. + Qed. + + Notation sub_nonpos := le_sub_0 (only parsing). + + Theorem opp_lt_mono : forall n m, n < m <-> - m < - n. + Proof. + intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub. + Qed. + + Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n. + Proof. + intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub. + Qed. + + Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0. + Proof. + intro n; now rewrite (opp_lt_mono n 0), opp_0. + Qed. + + Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n. + Proof. + intro n. now rewrite (opp_lt_mono 0 n), opp_0. + Qed. + + Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0. + Proof. + intro n; now rewrite (opp_le_mono n 0), opp_0. + Qed. + + Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n. + Proof. + intro n. now rewrite (opp_le_mono 0 n), opp_0. + Qed. + + Theorem lt_m1_0 : -1 < 0. + Proof. + apply opp_neg_pos, lt_0_1. + Qed. + + Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n. + Proof. + intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono. + Qed. + + Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p. + Proof. + intros. now rewrite <- 2 add_opp_r, add_lt_mono_r. + Qed. + + Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q. + Proof. + intros n m p q H1 H2. + apply lt_trans with (m - p); + [now apply sub_lt_mono_r | now apply sub_lt_mono_l]. + Qed. + + Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n. + Proof. + intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono. + Qed. + + Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p. + Proof. + intros. now rewrite <- 2 add_opp_r, add_le_mono_r. + Qed. + + Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q. + Proof. + intros n m p q H1 H2. + apply le_trans with (m - p); + [now apply sub_le_mono_r | now apply sub_le_mono_l]. + Qed. + + Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q. + Proof. + intros n m p q H1 H2. + apply lt_le_trans with (m - p); + [now apply sub_lt_mono_r | now apply sub_le_mono_l]. + Qed. + + Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q. + Proof. + intros n m p q H1 H2. + apply le_lt_trans with (m - p); + [now apply sub_le_mono_r | now apply sub_lt_mono_l]. + Qed. + + Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q. + Proof. + intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n)); + [now apply -> opp_le_mono | now rewrite 2 add_opp_r]. + Qed. + + Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q. + Proof. + intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n)); + [now apply -> opp_lt_mono | now rewrite 2 add_opp_r]. + Qed. + + Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q. + Proof. + intros n m p q H1 H2. apply (le_le_add_le (- m) (- n)); + [now apply -> opp_le_mono | now rewrite 2 add_opp_r]. + Qed. + + Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. + Proof. + intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r. + Qed. + + Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p. + Proof. + intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r. + Qed. + + Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. + Proof. + intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. + Qed. + + Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n. + Proof. + intros n m p. rewrite add_comm; apply le_add_le_sub_r. + Qed. + + Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p. + Proof. + intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r. + Qed. + + Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p. + Proof. + intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r. + Qed. + + Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p. + Proof. + intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. + Qed. + + Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. + Proof. + intros n m p. rewrite add_comm; apply le_sub_le_add_r. + Qed. + + Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p. + Proof. + intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r. + Qed. + + Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p. + Proof. + intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r. + Qed. + + Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n. + Proof. + intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r. + Qed. + + Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n. + Proof. + intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r. + Qed. + + Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p. + Proof. + intros. now apply add_lt_cases, lt_sub_lt_add. + Qed. + + Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p. + Proof. + intros. now apply add_le_cases, le_sub_le_add. + Qed. + + Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m. + Proof. + intros n m ?. + rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r. + Qed. + + Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0. + Proof. + intros n m ?. + rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r. + Qed. + + Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m. + Proof. + intros n m ?. + rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r. + Qed. + + Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0. + Proof. + intros n m ?. + rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r. + Qed. + + Section PosNeg. + + Variable P : Z.t -> Prop. + Hypothesis P_wd : Proper (eq ==> iff) P. + + Theorem zero_pos_neg : + P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n. + Proof. + intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]]. + - apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3]. + now rewrite opp_involutive in H3. + - now rewrite H3. + - apply H2 in H3; now destruct H3. + Qed. + + End PosNeg. + + Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg). End ZAddOrderProp. diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v index 732d0ed455..06f0f1bc03 100644 --- a/theories/Numbers/Integer/Abstract/ZAxioms.v +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -17,7 +17,7 @@ From Stdlib Require Import Bool NZParity NZPow NZSqrt NZLog NZGcd NZDiv NZBits. is identity. *) Module Type ZAxiom (Import Z : NZAxiomsSig'). - Axiom succ_pred : forall n, S (P n) == n. + Axiom succ_pred : forall n, S (P n) == n. End ZAxiom. (** For historical reasons, ZAxiomsMiniSig isn't just NZ + ZAxiom, @@ -25,25 +25,25 @@ End ZAxiom. for [sub 0]. *) Module Type Opp (Import T:Typ). - Parameter Inline opp : t -> t. + Parameter Inline opp : t -> t. End Opp. Module Type OppNotation (T:Typ)(Import O : Opp T). - Notation "- x" := (opp x) (at level 35, right associativity). + Notation "- x" := (opp x) (at level 35, right associativity). End OppNotation. Module Type Opp' (T:Typ) := Opp T <+ OppNotation T. Module Type IsOpp (Import Z : NZAxiomsSig')(Import O : Opp' Z). -#[global] - Declare Instance opp_wd : Proper (eq==>eq) opp. - Axiom opp_0 : - 0 == 0. - Axiom opp_succ : forall n, - (S n) == P (- n). + #[global] + Declare Instance opp_wd : Proper (eq==>eq) opp. + Axiom opp_0 : - 0 == 0. + Axiom opp_succ : forall n, - (S n) == P (- n). End IsOpp. Module Type OppCstNotation (Import A : NZAxiomsSig)(Import B : Opp A). - Notation "- 1" := (opp one). - Notation "- 2" := (opp two). + Notation "- 1" := (opp one). + Notation "- 2" := (opp two). End OppCstNotation. Module Type ZAxiomsMiniSig := NZOrdAxiomsSig <+ ZAxiom <+ Opp <+ IsOpp. @@ -56,18 +56,18 @@ Module Type ZAxiomsMiniSig' := NZOrdAxiomsSig' <+ ZAxiom <+ Opp' <+ IsOpp (** Absolute value *) Module Type HasAbs(Import Z : ZAxiomsMiniSig'). - Parameter Inline abs : t -> t. - Axiom abs_eq : forall n, 0<=n -> abs n == n. - Axiom abs_neq : forall n, n<=0 -> abs n == -n. + Parameter Inline abs : t -> t. + Axiom abs_eq : forall n, 0<=n -> abs n == n. + Axiom abs_neq : forall n, n<=0 -> abs n == -n. End HasAbs. (** A sign function *) Module Type HasSgn (Import Z : ZAxiomsMiniSig'). - Parameter Inline sgn : t -> t. - Axiom sgn_null : forall n, n==0 -> sgn n == 0. - Axiom sgn_pos : forall n, 0 sgn n == 1. - Axiom sgn_neg : forall n, n<0 -> sgn n == -1. + Parameter Inline sgn : t -> t. + Axiom sgn_null : forall n, n==0 -> sgn n == 0. + Axiom sgn_pos : forall n, 0 sgn n == 1. + Axiom sgn_neg : forall n, n<0 -> sgn n == -1. End HasSgn. (** Divisions *) @@ -76,8 +76,8 @@ End HasSgn. (a.k.a Floor). We simply extend the NZ signature. *) Module Type ZDivSpecific (Import A:ZAxiomsMiniSig')(Import B : DivMod' A). - Axiom mod_pos_bound : forall a b, 0 < b -> 0 <= a mod b < b. - Axiom mod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0. + Axiom mod_pos_bound : forall a b, 0 < b -> 0 <= a mod b < b. + Axiom mod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0. End ZDivSpecific. Module Type ZDiv (Z:ZAxiomsMiniSig) := NZDiv.NZDiv Z <+ ZDivSpecific Z. @@ -88,25 +88,25 @@ Module Type ZDiv' (Z:ZAxiomsMiniSig) := NZDiv.NZDiv' Z <+ ZDivSpecific Z. *) Module Type QuotRem (Import A : Typ). - Parameters Inline quot rem : t -> t -> t. + Parameters Inline quot rem : t -> t -> t. End QuotRem. Module Type QuotRemNotation (A : Typ)(Import B : QuotRem A). - Infix "÷" := quot (at level 40, left associativity). - Infix "rem" := rem (at level 40, no associativity). + Infix "÷" := quot (at level 40, left associativity). + Infix "rem" := rem (at level 40, no associativity). End QuotRemNotation. Module Type QuotRem' (A : Typ) := QuotRem A <+ QuotRemNotation A. Module Type QuotRemSpec (Import A : ZAxiomsMiniSig')(Import B : QuotRem' A). -#[global] - Declare Instance quot_wd : Proper (eq==>eq==>eq) quot. -#[global] - Declare Instance rem_wd : Proper (eq==>eq==>eq) B.rem. - Axiom quot_rem : forall a b, b ~= 0 -> a == b*(a÷b) + (a rem b). - Axiom rem_bound_pos : forall a b, 0<=a -> 0 0 <= a rem b < b. - Axiom rem_opp_l : forall a b, b ~= 0 -> (-a) rem b == - (a rem b). - Axiom rem_opp_r : forall a b, b ~= 0 -> a rem (-b) == a rem b. + #[global] + Declare Instance quot_wd : Proper (eq==>eq==>eq) quot. + #[global] + Declare Instance rem_wd : Proper (eq==>eq==>eq) B.rem. + Axiom quot_rem : forall a b, b ~= 0 -> a == b*(a÷b) + (a rem b). + Axiom rem_bound_pos : forall a b, 0<=a -> 0 0 <= a rem b < b. + Axiom rem_opp_l : forall a b, b ~= 0 -> (-a) rem b == - (a rem b). + Axiom rem_opp_r : forall a b, b ~= 0 -> a rem (-b) == a rem b. End QuotRemSpec. Module Type ZQuot (Z:ZAxiomsMiniSig) := QuotRem Z <+ QuotRemSpec Z. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index 581f278315..cf88f517a2 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -15,23 +15,23 @@ From Stdlib Require Export ZAxioms. From Stdlib Require Import NZMulOrder. Module ZBaseProp (Import Z : ZAxiomsMiniSig'). -Include NZMulOrderProp Z. + Include NZMulOrderProp Z. -(* Theorems that are true for integers but not for natural numbers *) + (* Theorems that are true for integers but not for natural numbers *) -Theorem pred_inj : forall n m, P n == P m -> n == m. -Proof. -intros n m H. apply succ_wd in H. now rewrite 2 succ_pred in H. -Qed. + Theorem pred_inj : forall n m, P n == P m -> n == m. + Proof. + intros n m H. apply succ_wd in H. now rewrite 2 succ_pred in H. + Qed. -Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2. -Proof. -intros n1 n2; split; [apply pred_inj | intros; now f_equiv]. -Qed. + Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2. + Proof. + intros n1 n2; split; [apply pred_inj | intros; now f_equiv]. + Qed. -Lemma succ_m1 : S (-1) == 0. -Proof. - now rewrite one_succ, opp_succ, opp_0, succ_pred. -Qed. + Lemma succ_m1 : S (-1) == 0. + Proof. + now rewrite one_succ, opp_succ, opp_0, succ_pred. + Qed. End ZBaseProp. diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v index bcbd3d8629..f3bd13b1f1 100644 --- a/theories/Numbers/Integer/Abstract/ZBits.v +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -14,2011 +14,2011 @@ From Stdlib Require Import (** Derived properties of bitwise operations *) Module Type ZBitsProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZParityProp A B) - (Import D : ZSgnAbsProp A B) - (Import E : ZPowProp A B C D) - (Import F : ZDivProp A B D) - (Import G : NZLog2Prop A A A B E). - -Include BoolEqualityFacts A. - -Ltac order_nz := try apply pow_nonzero; order'. -Ltac order_pos' := try apply abs_nonneg; order_pos. -#[global] Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. - -(** Some properties of power and division *) - -Lemma pow_sub_r : forall a b c, a~=0 -> 0<=c<=b -> a^(b-c) == a^b / a^c. -Proof. - intros a b c Ha (H,H'). rewrite <- (sub_simpl_r b c) at 2. - rewrite pow_add_r; trivial. - - rewrite div_mul. { reflexivity. } - now apply pow_nonzero. - - now apply le_0_sub. -Qed. - -Lemma pow_div_l : forall a b c, b~=0 -> 0<=c -> a mod b == 0 -> - (a/b)^c == a^c / b^c. -Proof. - intros a b c Hb Hc H. rewrite (div_mod a b Hb) at 2. - rewrite H, add_0_r, pow_mul_l, mul_comm, div_mul. { reflexivity. } - now apply pow_nonzero. -Qed. - -(** An injection from bits [true] and [false] to numbers 1 and 0. + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZParityProp A B) + (Import D : ZSgnAbsProp A B) + (Import E : ZPowProp A B C D) + (Import F : ZDivProp A B D) + (Import G : NZLog2Prop A A A B E). + + Include BoolEqualityFacts A. + + Ltac order_nz := try apply pow_nonzero; order'. + Ltac order_pos' := try apply abs_nonneg; order_pos. + #[global] Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. + + (** Some properties of power and division *) + + Lemma pow_sub_r : forall a b c, a~=0 -> 0<=c<=b -> a^(b-c) == a^b / a^c. + Proof. + intros a b c Ha (H,H'). rewrite <- (sub_simpl_r b c) at 2. + rewrite pow_add_r; trivial. + - rewrite div_mul. { reflexivity. } + now apply pow_nonzero. + - now apply le_0_sub. + Qed. + + Lemma pow_div_l : forall a b c, b~=0 -> 0<=c -> a mod b == 0 -> + (a/b)^c == a^c / b^c. + Proof. + intros a b c Hb Hc H. rewrite (div_mod a b Hb) at 2. + rewrite H, add_0_r, pow_mul_l, mul_comm, div_mul. { reflexivity. } + now apply pow_nonzero. + Qed. + + (** An injection from bits [true] and [false] to numbers 1 and 0. We declare it as a (local) coercion for shorter statements. *) -Definition b2z (b:bool) := if b then 1 else 0. -#[local] Coercion b2z : bool >-> t. + Definition b2z (b:bool) := if b then 1 else 0. + #[local] Coercion b2z : bool >-> t. -#[global] -Instance b2z_wd : Proper (Logic.eq ==> eq) b2z := _. + #[global] + Instance b2z_wd : Proper (Logic.eq ==> eq) b2z := _. -Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. -Proof. - elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. - - exists a'. exists false. now nzsimpl. - - exists a'. exists true. now simpl. -Qed. + Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. + Proof. + elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. + - exists a'. exists false. now nzsimpl. + - exists a'. exists true. now simpl. + Qed. -(** We can compact [testbit_odd_0] [testbit_even_0] + (** We can compact [testbit_odd_0] [testbit_even_0] [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *) -Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - apply testbit_odd_0. - - apply testbit_even_0. -Qed. + Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. + Proof. + destruct b; simpl; rewrite ?add_0_r. + - apply testbit_odd_0. + - apply testbit_even_0. + Qed. -Lemma testbit_succ_r a (b:bool) n : 0<=n -> - testbit (2*a+b) (succ n) = testbit a n. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - now apply testbit_odd_succ. - - now apply testbit_even_succ. -Qed. + Lemma testbit_succ_r a (b:bool) n : 0<=n -> + testbit (2*a+b) (succ n) = testbit a n. + Proof. + destruct b; simpl; rewrite ?add_0_r. + - now apply testbit_odd_succ. + - now apply testbit_even_succ. + Qed. -(** Alternative characterisations of [testbit] *) + (** Alternative characterisations of [testbit] *) -(** This concise equation could have been taken as specification + (** This concise equation could have been taken as specification for testbit in the interface, but it would have been hard to implement with little initial knowledge about div and mod *) -Lemma testbit_spec' a n : 0<=n -> a.[n] == (a / 2^n) mod 2. -Proof. - intro Hn. revert a. apply le_ind with (4:=Hn). - - solve_proper. - - intros a. nzsimpl. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_0_r. apply mod_unique with a'; trivial. - left. destruct b; split; simpl; order'. - - clear n Hn. intros n Hn IH a. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_succ_r, IH by trivial. f_equiv. - rewrite pow_succ_r, <- div_div by order_pos. f_equiv. - apply div_unique with b; trivial. - left. destruct b; split; simpl; order'. -Qed. - -(** This characterisation that uses only basic operations and + Lemma testbit_spec' a n : 0<=n -> a.[n] == (a / 2^n) mod 2. + Proof. + intro Hn. revert a. apply le_ind with (4:=Hn). + - solve_proper. + - intros a. nzsimpl. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_0_r. apply mod_unique with a'; trivial. + left. destruct b; split; simpl; order'. + - clear n Hn. intros n Hn IH a. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_succ_r, IH by trivial. f_equiv. + rewrite pow_succ_r, <- div_div by order_pos. f_equiv. + apply div_unique with b; trivial. + left. destruct b; split; simpl; order'. + Qed. + + (** This characterisation that uses only basic operations and power was initially taken as specification for testbit. We describe [a] as having a low part and a high part, with the corresponding bit in the middle. This characterisation is moderatly complex to implement, but also moderately usable... *) -Lemma testbit_spec a n : 0<=n -> - exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. -Proof. - intro Hn. exists (a mod 2^n). exists (a / 2^n / 2). split. - - apply mod_pos_bound; order_pos. - - rewrite add_comm, mul_comm, (add_comm a.[n]). - rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. - rewrite testbit_spec' by trivial. apply div_mod. order'. -Qed. - -Lemma testbit_true : forall a n, 0<=n -> - (a.[n] = true <-> (a / 2^n) mod 2 == 1). -Proof. - intros a n Hn. - rewrite <- testbit_spec' by trivial. - destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_false : forall a n, 0<=n -> - (a.[n] = false <-> (a / 2^n) mod 2 == 0). -Proof. - intros a n Hn. - rewrite <- testbit_spec' by trivial. - destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_eqb : forall a n, 0<=n -> - a.[n] = eqb ((a / 2^n) mod 2) 1. -Proof. - intros a n Hn. - apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. -Qed. - -(** Results about the injection [b2z] *) - -Lemma b2z_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. -Proof. - intros [|] [|]; simpl; trivial; order'. -Qed. - -Lemma add_b2z_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. -Proof. - intros a0 a. rewrite mul_comm, div_add by order'. - now rewrite div_small, add_0_l by (destruct a0; split; simpl; order'). -Qed. - -Lemma add_b2z_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. -Proof. - intros a0 a. apply b2z_inj. - rewrite testbit_spec' by order. - nzsimpl. rewrite mul_comm, mod_add by order'. - now rewrite mod_small by (destruct a0; split; simpl; order'). -Qed. - -Lemma b2z_div2 : forall (a0:bool), a0/2 == 0. -Proof. - intros a0. rewrite <- (add_b2z_double_div2 a0 0). now nzsimpl. -Qed. - -Lemma b2z_bit0 : forall (a0:bool), a0.[0] = a0. -Proof. - intros a0. rewrite <- (add_b2z_double_bit0 a0 0) at 2. now nzsimpl. -Qed. - -(** The specification of testbit by low and high parts is complete *) - -Lemma testbit_unique : forall a n (a0:bool) l h, - 0<=l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. -Proof. - intros a n a0 l h Hl EQ. - assert (0<=n). { - destruct (le_gt_cases 0 n) as [Hn|Hn]; trivial. - rewrite pow_neg_r in Hl by trivial. destruct Hl; order. - } - apply b2z_inj. rewrite testbit_spec' by trivial. - symmetry. apply mod_unique with h. - - left; destruct a0; simpl; split; order'. - - symmetry. apply div_unique with l. - + now left. - + now rewrite add_comm, (add_comm _ a0), mul_comm. -Qed. - -(** All bits of number 0 are 0 *) - -Lemma bits_0 : forall n, 0.[n] = false. -Proof. - intros n. - destruct (le_gt_cases 0 n). - - apply testbit_false; trivial. nzsimpl; order_nz. - - now apply testbit_neg_r. -Qed. - -(** For negative numbers, we are actually doing two's complement *) - -Lemma bits_opp : forall a n, 0<=n -> (-a).[n] = negb (P a).[n]. -Proof. - intros a n Hn. - destruct (testbit_spec (-a) n Hn) as (l & h & Hl & EQ). - fold (b2z (-a).[n]) in EQ. - apply negb_sym. - apply testbit_unique with (2^n-l-1) (-h-1). - - split. - + apply lt_succ_r. rewrite sub_1_r, succ_pred. now apply lt_0_sub. - + apply le_succ_l. rewrite sub_1_r, succ_pred. apply le_sub_le_add_r. - rewrite <- (add_0_r (2^n)) at 1. now apply add_le_mono_l. - - rewrite <- add_sub_swap, sub_1_r. f_equiv. - apply opp_inj. rewrite opp_add_distr, opp_sub_distr. - rewrite (add_comm _ l), <- add_assoc. - rewrite EQ at 1. apply add_cancel_l. - rewrite <- opp_add_distr. - rewrite <- (mul_1_l (2^n)) at 2. rewrite <- mul_add_distr_r. - rewrite <- mul_opp_l. - f_equiv. - rewrite !opp_add_distr. - rewrite <- mul_opp_r. - rewrite opp_sub_distr, opp_involutive. - rewrite (add_comm h). - rewrite mul_add_distr_l. - rewrite !add_assoc. - apply add_cancel_r. - rewrite mul_1_r. - rewrite add_comm, add_assoc, !add_opp_r, sub_1_r, two_succ, pred_succ. - destruct (-a).[n]; simpl. - + now rewrite sub_0_r. - + now nzsimpl'. -Qed. - -(** All bits of number (-1) are 1 *) - -Lemma bits_m1 : forall n, 0<=n -> (-1).[n] = true. -Proof. - intros. now rewrite bits_opp, one_succ, pred_succ, bits_0. -Qed. - -(** Various ways to refer to the lowest bit of a number *) - -Lemma bit0_odd : forall a, a.[0] = odd a. -Proof. - intros a. symmetry. - destruct (exists_div2 a) as (a' & b & EQ). - rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. - destruct b; simpl; apply odd_1 || apply odd_0. -Qed. - -Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. -Proof. - intros a. rewrite testbit_eqb by order. now nzsimpl. -Qed. - -Lemma bit0_mod : forall a, a.[0] == a mod 2. -Proof. - intros a. rewrite testbit_spec' by order. now nzsimpl. -Qed. - -(** Hence testing a bit is equivalent to shifting and testing parity *) - -Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). -Proof. - intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. -Qed. - -(** [log2] gives the highest nonzero bit of positive numbers *) - -Lemma bit_log2 : forall a, 0 a.[log2 a] = true. -Proof. - intros a Ha. - assert (Ha' := log2_nonneg a). - destruct (log2_spec_alt a Ha) as (r & EQ & Hr). - rewrite EQ at 1. - rewrite testbit_true, add_comm by trivial. - rewrite <- (mul_1_l (2^log2 a)) at 1. - rewrite div_add by order_nz. - rewrite div_small; trivial. - rewrite add_0_l. apply mod_small. split; order'. -Qed. - -Lemma bits_above_log2 : forall a n, 0<=a -> log2 a < n -> - a.[n] = false. -Proof. - intros a n Ha H. - assert (Hn : 0<=n). - { transitivity (log2 a). - apply log2_nonneg. - order'. } - rewrite testbit_false by trivial. - rewrite div_small. { nzsimpl; order'. } - split. - - order. - - apply log2_lt_cancel. now rewrite log2_pow2. -Qed. - -(** Hence the number of bits of [a] is [1+log2 a] + Lemma testbit_spec a n : 0<=n -> + exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. + Proof. + intro Hn. exists (a mod 2^n). exists (a / 2^n / 2). split. + - apply mod_pos_bound; order_pos. + - rewrite add_comm, mul_comm, (add_comm a.[n]). + rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. + rewrite testbit_spec' by trivial. apply div_mod. order'. + Qed. + + Lemma testbit_true : forall a n, 0<=n -> + (a.[n] = true <-> (a / 2^n) mod 2 == 1). + Proof. + intros a n Hn. + rewrite <- testbit_spec' by trivial. + destruct a.[n]; split; simpl; now try order'. + Qed. + + Lemma testbit_false : forall a n, 0<=n -> + (a.[n] = false <-> (a / 2^n) mod 2 == 0). + Proof. + intros a n Hn. + rewrite <- testbit_spec' by trivial. + destruct a.[n]; split; simpl; now try order'. + Qed. + + Lemma testbit_eqb : forall a n, 0<=n -> + a.[n] = eqb ((a / 2^n) mod 2) 1. + Proof. + intros a n Hn. + apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. + Qed. + + (** Results about the injection [b2z] *) + + Lemma b2z_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. + Proof. + intros [|] [|]; simpl; trivial; order'. + Qed. + + Lemma add_b2z_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. + Proof. + intros a0 a. rewrite mul_comm, div_add by order'. + now rewrite div_small, add_0_l by (destruct a0; split; simpl; order'). + Qed. + + Lemma add_b2z_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. + Proof. + intros a0 a. apply b2z_inj. + rewrite testbit_spec' by order. + nzsimpl. rewrite mul_comm, mod_add by order'. + now rewrite mod_small by (destruct a0; split; simpl; order'). + Qed. + + Lemma b2z_div2 : forall (a0:bool), a0/2 == 0. + Proof. + intros a0. rewrite <- (add_b2z_double_div2 a0 0). now nzsimpl. + Qed. + + Lemma b2z_bit0 : forall (a0:bool), a0.[0] = a0. + Proof. + intros a0. rewrite <- (add_b2z_double_bit0 a0 0) at 2. now nzsimpl. + Qed. + + (** The specification of testbit by low and high parts is complete *) + + Lemma testbit_unique : forall a n (a0:bool) l h, + 0<=l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. + Proof. + intros a n a0 l h Hl EQ. + assert (0<=n). { + destruct (le_gt_cases 0 n) as [Hn|Hn]; trivial. + rewrite pow_neg_r in Hl by trivial. destruct Hl; order. + } + apply b2z_inj. rewrite testbit_spec' by trivial. + symmetry. apply mod_unique with h. + - left; destruct a0; simpl; split; order'. + - symmetry. apply div_unique with l. + + now left. + + now rewrite add_comm, (add_comm _ a0), mul_comm. + Qed. + + (** All bits of number 0 are 0 *) + + Lemma bits_0 : forall n, 0.[n] = false. + Proof. + intros n. + destruct (le_gt_cases 0 n). + - apply testbit_false; trivial. nzsimpl; order_nz. + - now apply testbit_neg_r. + Qed. + + (** For negative numbers, we are actually doing two's complement *) + + Lemma bits_opp : forall a n, 0<=n -> (-a).[n] = negb (P a).[n]. + Proof. + intros a n Hn. + destruct (testbit_spec (-a) n Hn) as (l & h & Hl & EQ). + fold (b2z (-a).[n]) in EQ. + apply negb_sym. + apply testbit_unique with (2^n-l-1) (-h-1). + - split. + + apply lt_succ_r. rewrite sub_1_r, succ_pred. now apply lt_0_sub. + + apply le_succ_l. rewrite sub_1_r, succ_pred. apply le_sub_le_add_r. + rewrite <- (add_0_r (2^n)) at 1. now apply add_le_mono_l. + - rewrite <- add_sub_swap, sub_1_r. f_equiv. + apply opp_inj. rewrite opp_add_distr, opp_sub_distr. + rewrite (add_comm _ l), <- add_assoc. + rewrite EQ at 1. apply add_cancel_l. + rewrite <- opp_add_distr. + rewrite <- (mul_1_l (2^n)) at 2. rewrite <- mul_add_distr_r. + rewrite <- mul_opp_l. + f_equiv. + rewrite !opp_add_distr. + rewrite <- mul_opp_r. + rewrite opp_sub_distr, opp_involutive. + rewrite (add_comm h). + rewrite mul_add_distr_l. + rewrite !add_assoc. + apply add_cancel_r. + rewrite mul_1_r. + rewrite add_comm, add_assoc, !add_opp_r, sub_1_r, two_succ, pred_succ. + destruct (-a).[n]; simpl. + + now rewrite sub_0_r. + + now nzsimpl'. + Qed. + + (** All bits of number (-1) are 1 *) + + Lemma bits_m1 : forall n, 0<=n -> (-1).[n] = true. + Proof. + intros. now rewrite bits_opp, one_succ, pred_succ, bits_0. + Qed. + + (** Various ways to refer to the lowest bit of a number *) + + Lemma bit0_odd : forall a, a.[0] = odd a. + Proof. + intros a. symmetry. + destruct (exists_div2 a) as (a' & b & EQ). + rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. + destruct b; simpl; apply odd_1 || apply odd_0. + Qed. + + Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. + Proof. + intros a. rewrite testbit_eqb by order. now nzsimpl. + Qed. + + Lemma bit0_mod : forall a, a.[0] == a mod 2. + Proof. + intros a. rewrite testbit_spec' by order. now nzsimpl. + Qed. + + (** Hence testing a bit is equivalent to shifting and testing parity *) + + Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). + Proof. + intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. + Qed. + + (** [log2] gives the highest nonzero bit of positive numbers *) + + Lemma bit_log2 : forall a, 0 a.[log2 a] = true. + Proof. + intros a Ha. + assert (Ha' := log2_nonneg a). + destruct (log2_spec_alt a Ha) as (r & EQ & Hr). + rewrite EQ at 1. + rewrite testbit_true, add_comm by trivial. + rewrite <- (mul_1_l (2^log2 a)) at 1. + rewrite div_add by order_nz. + rewrite div_small; trivial. + rewrite add_0_l. apply mod_small. split; order'. + Qed. + + Lemma bits_above_log2 : forall a n, 0<=a -> log2 a < n -> + a.[n] = false. + Proof. + intros a n Ha H. + assert (Hn : 0<=n). + { transitivity (log2 a). - apply log2_nonneg. - order'. } + rewrite testbit_false by trivial. + rewrite div_small. { nzsimpl; order'. } + split. + - order. + - apply log2_lt_cancel. now rewrite log2_pow2. + Qed. + + (** Hence the number of bits of [a] is [1+log2 a] (see [Pos.size_nat] and [Pos.size]). *) -(** For negative numbers, things are the other ways around: + (** For negative numbers, things are the other ways around: log2 gives the highest zero bit (for numbers below -1). *) -Lemma bit_log2_neg : forall a, a < -1 -> a.[log2 (P (-a))] = false. -Proof. - intros a Ha. - rewrite <- (opp_involutive a) at 1. - rewrite bits_opp. - - apply negb_false_iff. - apply bit_log2. - apply opp_lt_mono in Ha. rewrite opp_involutive in Ha. - apply lt_succ_lt_pred. now rewrite <- one_succ. - - apply log2_nonneg. -Qed. - -Lemma bits_above_log2_neg : forall a n, a < 0 -> log2 (P (-a)) < n -> - a.[n] = true. -Proof. - intros a n Ha H. - assert (Hn : 0<=n). - { transitivity (log2 (P (-a))). - apply log2_nonneg. - order'. } - rewrite <- (opp_involutive a), bits_opp, negb_true_iff by trivial. - apply bits_above_log2; trivial. - now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. -Qed. - -(** Accessing a high enough bit of a number gives its sign *) - -Lemma bits_iff_nonneg : forall a n, log2 (abs a) < n -> - (0<=a <-> a.[n] = false). -Proof. - intros a n Hn. split; intros H. - - rewrite abs_eq in Hn; trivial. now apply bits_above_log2. - - destruct (le_gt_cases 0 a); trivial. - rewrite abs_neq in Hn by order. - rewrite bits_above_log2_neg in H; try easy. - apply le_lt_trans with (log2 (-a)); trivial. - apply log2_le_mono. apply le_pred_l. -Qed. - -Lemma bits_iff_nonneg' : forall a, - 0<=a <-> a.[S (log2 (abs a))] = false. -Proof. - intros. apply bits_iff_nonneg. apply lt_succ_diag_r. -Qed. - -Lemma bits_iff_nonneg_ex : forall a, - 0<=a <-> (exists k, forall m, k a.[m] = false). -Proof. - intros a. split. - - intros Ha. exists (log2 a). intros m Hm. now apply bits_above_log2. - - intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). - + now apply bits_iff_nonneg', Hk, lt_succ_r. - + apply (bits_iff_nonneg a (S k)). - * now apply lt_succ_r, lt_le_incl. - * apply Hk. apply lt_succ_diag_r. -Qed. - -Lemma bits_iff_neg : forall a n, log2 (abs a) < n -> - (a<0 <-> a.[n] = true). -Proof. - intros a n Hn. - now rewrite lt_nge, <- not_false_iff_true, (bits_iff_nonneg a n). -Qed. - -Lemma bits_iff_neg' : forall a, a<0 <-> a.[S (log2 (abs a))] = true. -Proof. - intros. apply bits_iff_neg. apply lt_succ_diag_r. -Qed. - -Lemma bits_iff_neg_ex : forall a, - a<0 <-> (exists k, forall m, k a.[m] = true). -Proof. - intros a. split. - - intros Ha. exists (log2 (P (-a))). intros m Hm. now apply bits_above_log2_neg. - - intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). - + now apply bits_iff_neg', Hk, lt_succ_r. - + apply (bits_iff_neg a (S k)). - * now apply lt_succ_r, lt_le_incl. - * apply Hk. apply lt_succ_diag_r. -Qed. - -(** Testing bits after division or multiplication by a power of two *) - -Lemma div2_bits : forall a n, 0<=n -> (a/2).[n] = a.[S n]. -Proof. - intros a n Hn. - apply eq_true_iff_eq. rewrite 2 testbit_true by order_pos. - rewrite pow_succ_r by trivial. - now rewrite div_div by order_pos. -Qed. - -Lemma div_pow2_bits : forall a n m, 0<=n -> 0<=m -> (a/2^n).[m] = a.[m+n]. -Proof. - intros a n m Hn. revert a m. apply le_ind with (4:=Hn). - - solve_proper. - - intros a m Hm. now nzsimpl. - - clear n Hn. intros n Hn IH a m Hm. nzsimpl; trivial. - rewrite <- div_div by order_pos. - now rewrite IH, div2_bits by order_pos. -Qed. - -Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. -Proof. - intros a n. - destruct (le_gt_cases 0 n) as [Hn|Hn]. - - now rewrite <- div2_bits, mul_comm, div_mul by order'. - - rewrite (testbit_neg_r a n Hn). - apply le_succ_l in Hn. le_elim Hn. - + now rewrite testbit_neg_r. - + now rewrite Hn, bit0_odd, odd_mul, odd_2. -Qed. - -Lemma double_bits : forall a n, (2*a).[n] = a.[P n]. -Proof. - intros a n. rewrite <- (succ_pred n) at 1. apply double_bits_succ. -Qed. - -Lemma mul_pow2_bits_add : forall a n m, 0<=n -> (a*2^n).[n+m] = a.[m]. -Proof. - intros a n m Hn. revert a m. apply le_ind with (4:=Hn). - - solve_proper. - - intros a m. now nzsimpl. - - clear n Hn. intros n Hn IH a m. nzsimpl; trivial. - rewrite mul_assoc, (mul_comm _ 2), <- mul_assoc. - now rewrite double_bits_succ. -Qed. - -Lemma mul_pow2_bits : forall a n m, 0<=n -> (a*2^n).[m] = a.[m-n]. -Proof. - intros a n m ?. - rewrite <- (add_simpl_r m n) at 1. rewrite add_sub_swap, add_comm. - now apply mul_pow2_bits_add. -Qed. - -Lemma mul_pow2_bits_low : forall a n m, m (a*2^n).[m] = false. -Proof. - intros a n m ?. - destruct (le_gt_cases 0 n). - - rewrite mul_pow2_bits by trivial. - apply testbit_neg_r. now apply lt_sub_0. - - now rewrite pow_neg_r, mul_0_r, bits_0. -Qed. - -(** Selecting the low part of a number can be done by a modulo *) - -Lemma mod_pow2_bits_high : forall a n m, 0<=n<=m -> - (a mod 2^n).[m] = false. -Proof. - intros a n m (Hn,H). - destruct (mod_pos_bound a (2^n)) as [LE LT]. { order_pos. } - le_elim LE. - - apply bits_above_log2; try order. - apply lt_le_trans with n; trivial. - apply log2_lt_pow2; trivial. - - now rewrite <- LE, bits_0. -Qed. - -Lemma mod_pow2_bits_low : forall a n m, m - (a mod 2^n).[m] = a.[m]. -Proof. - intros a n m H. - destruct (le_gt_cases 0 m) as [Hm|Hm]; [|now rewrite !testbit_neg_r]. - rewrite testbit_eqb; trivial. - rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. - rewrite <- div_add by order_nz. - rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r, succ_pred. - - rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add; trivial. - + rewrite add_comm, <- div_mod by order_nz. - symmetry. apply testbit_eqb; trivial. - + apply le_0_sub; order. - - now apply lt_le_pred, lt_0_sub. -Qed. - -(** We now prove that having the same bits implies equality. + Lemma bit_log2_neg : forall a, a < -1 -> a.[log2 (P (-a))] = false. + Proof. + intros a Ha. + rewrite <- (opp_involutive a) at 1. + rewrite bits_opp. + - apply negb_false_iff. + apply bit_log2. + apply opp_lt_mono in Ha. rewrite opp_involutive in Ha. + apply lt_succ_lt_pred. now rewrite <- one_succ. + - apply log2_nonneg. + Qed. + + Lemma bits_above_log2_neg : forall a n, a < 0 -> log2 (P (-a)) < n -> + a.[n] = true. + Proof. + intros a n Ha H. + assert (Hn : 0<=n). + { transitivity (log2 (P (-a))). - apply log2_nonneg. - order'. } + rewrite <- (opp_involutive a), bits_opp, negb_true_iff by trivial. + apply bits_above_log2; trivial. + now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. + Qed. + + (** Accessing a high enough bit of a number gives its sign *) + + Lemma bits_iff_nonneg : forall a n, log2 (abs a) < n -> + (0<=a <-> a.[n] = false). + Proof. + intros a n Hn. split; intros H. + - rewrite abs_eq in Hn; trivial. now apply bits_above_log2. + - destruct (le_gt_cases 0 a); trivial. + rewrite abs_neq in Hn by order. + rewrite bits_above_log2_neg in H; try easy. + apply le_lt_trans with (log2 (-a)); trivial. + apply log2_le_mono. apply le_pred_l. + Qed. + + Lemma bits_iff_nonneg' : forall a, + 0<=a <-> a.[S (log2 (abs a))] = false. + Proof. + intros. apply bits_iff_nonneg. apply lt_succ_diag_r. + Qed. + + Lemma bits_iff_nonneg_ex : forall a, + 0<=a <-> (exists k, forall m, k a.[m] = false). + Proof. + intros a. split. + - intros Ha. exists (log2 a). intros m Hm. now apply bits_above_log2. + - intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). + + now apply bits_iff_nonneg', Hk, lt_succ_r. + + apply (bits_iff_nonneg a (S k)). + * now apply lt_succ_r, lt_le_incl. + * apply Hk. apply lt_succ_diag_r. + Qed. + + Lemma bits_iff_neg : forall a n, log2 (abs a) < n -> + (a<0 <-> a.[n] = true). + Proof. + intros a n Hn. + now rewrite lt_nge, <- not_false_iff_true, (bits_iff_nonneg a n). + Qed. + + Lemma bits_iff_neg' : forall a, a<0 <-> a.[S (log2 (abs a))] = true. + Proof. + intros. apply bits_iff_neg. apply lt_succ_diag_r. + Qed. + + Lemma bits_iff_neg_ex : forall a, + a<0 <-> (exists k, forall m, k a.[m] = true). + Proof. + intros a. split. + - intros Ha. exists (log2 (P (-a))). intros m Hm. now apply bits_above_log2_neg. + - intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). + + now apply bits_iff_neg', Hk, lt_succ_r. + + apply (bits_iff_neg a (S k)). + * now apply lt_succ_r, lt_le_incl. + * apply Hk. apply lt_succ_diag_r. + Qed. + + (** Testing bits after division or multiplication by a power of two *) + + Lemma div2_bits : forall a n, 0<=n -> (a/2).[n] = a.[S n]. + Proof. + intros a n Hn. + apply eq_true_iff_eq. rewrite 2 testbit_true by order_pos. + rewrite pow_succ_r by trivial. + now rewrite div_div by order_pos. + Qed. + + Lemma div_pow2_bits : forall a n m, 0<=n -> 0<=m -> (a/2^n).[m] = a.[m+n]. + Proof. + intros a n m Hn. revert a m. apply le_ind with (4:=Hn). + - solve_proper. + - intros a m Hm. now nzsimpl. + - clear n Hn. intros n Hn IH a m Hm. nzsimpl; trivial. + rewrite <- div_div by order_pos. + now rewrite IH, div2_bits by order_pos. + Qed. + + Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. + Proof. + intros a n. + destruct (le_gt_cases 0 n) as [Hn|Hn]. + - now rewrite <- div2_bits, mul_comm, div_mul by order'. + - rewrite (testbit_neg_r a n Hn). + apply le_succ_l in Hn. le_elim Hn. + + now rewrite testbit_neg_r. + + now rewrite Hn, bit0_odd, odd_mul, odd_2. + Qed. + + Lemma double_bits : forall a n, (2*a).[n] = a.[P n]. + Proof. + intros a n. rewrite <- (succ_pred n) at 1. apply double_bits_succ. + Qed. + + Lemma mul_pow2_bits_add : forall a n m, 0<=n -> (a*2^n).[n+m] = a.[m]. + Proof. + intros a n m Hn. revert a m. apply le_ind with (4:=Hn). + - solve_proper. + - intros a m. now nzsimpl. + - clear n Hn. intros n Hn IH a m. nzsimpl; trivial. + rewrite mul_assoc, (mul_comm _ 2), <- mul_assoc. + now rewrite double_bits_succ. + Qed. + + Lemma mul_pow2_bits : forall a n m, 0<=n -> (a*2^n).[m] = a.[m-n]. + Proof. + intros a n m ?. + rewrite <- (add_simpl_r m n) at 1. rewrite add_sub_swap, add_comm. + now apply mul_pow2_bits_add. + Qed. + + Lemma mul_pow2_bits_low : forall a n m, m (a*2^n).[m] = false. + Proof. + intros a n m ?. + destruct (le_gt_cases 0 n). + - rewrite mul_pow2_bits by trivial. + apply testbit_neg_r. now apply lt_sub_0. + - now rewrite pow_neg_r, mul_0_r, bits_0. + Qed. + + (** Selecting the low part of a number can be done by a modulo *) + + Lemma mod_pow2_bits_high : forall a n m, 0<=n<=m -> + (a mod 2^n).[m] = false. + Proof. + intros a n m (Hn,H). + destruct (mod_pos_bound a (2^n)) as [LE LT]. { order_pos. } + le_elim LE. + - apply bits_above_log2; try order. + apply lt_le_trans with n; trivial. + apply log2_lt_pow2; trivial. + - now rewrite <- LE, bits_0. + Qed. + + Lemma mod_pow2_bits_low : forall a n m, m + (a mod 2^n).[m] = a.[m]. + Proof. + intros a n m H. + destruct (le_gt_cases 0 m) as [Hm|Hm]; [|now rewrite !testbit_neg_r]. + rewrite testbit_eqb; trivial. + rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. + rewrite <- div_add by order_nz. + rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r, succ_pred. + - rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add; trivial. + + rewrite add_comm, <- div_mod by order_nz. + symmetry. apply testbit_eqb; trivial. + + apply le_0_sub; order. + - now apply lt_le_pred, lt_0_sub. + Qed. + + (** We now prove that having the same bits implies equality. For that we use a notion of equality over functional streams of bits. *) -Definition eqf (f g:t -> bool) := forall n:t, f n = g n. - -#[global] -Instance eqf_equiv : Equivalence eqf. -Proof. - split; congruence. -Qed. - -#[local] Infix "===" := eqf (at level 70, no associativity). - -#[global] -Instance testbit_eqf : Proper (eq==>eqf) testbit. -Proof. - intros a a' Ha n. now rewrite Ha. -Qed. - -(** Only zero corresponds to the always-false stream. *) - -Lemma bits_inj_0 : - forall a, (forall n, a.[n] = false) -> a == 0. -Proof. - intros a H. destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]; trivial. - - apply (bits_above_log2_neg a (S (log2 (P (-a))))) in Ha. - + now rewrite H in Ha. - + apply lt_succ_diag_r. - - apply bit_log2 in Ha. now rewrite H in Ha. -Qed. - -(** If two numbers produce the same stream of bits, they are equal. *) - -Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. -Proof. - assert (AUX : forall n, 0<=n -> forall a b, - 0<=a<2^n -> testbit a === testbit b -> a == b). { - intros n Hn. apply le_ind with (4:=Hn). - - solve_proper. - - intros a b Ha H. rewrite pow_0_r, one_succ, lt_succ_r in Ha. - assert (Ha' : a == 0) by (destruct Ha; order). - rewrite Ha' in *. - symmetry. apply bits_inj_0. - intros m. now rewrite <- H, bits_0. - - clear n Hn. intros n Hn IH a b (Ha,Ha') H. - rewrite (div_mod a 2), (div_mod b 2) by order'. - f_equiv; [ | now rewrite <- 2 bit0_mod, H]. - f_equiv. - apply IH. - + split. - * apply div_pos; order'. - * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. - + intros m. - destruct (le_gt_cases 0 m). - * rewrite 2 div2_bits by trivial. apply H. - * now rewrite 2 testbit_neg_r. - } - intros a b H. - destruct (le_gt_cases 0 a) as [Ha|Ha]. - - apply (AUX a); trivial. split; trivial. - apply pow_gt_lin_r; order'. - - apply succ_inj, opp_inj. - assert (0 <= - S a). { - apply opp_le_mono. now rewrite opp_involutive, opp_0, le_succ_l. - } - apply (AUX (-(S a))); trivial. - + split; trivial. - apply pow_gt_lin_r; order'. - + intros m. destruct (le_gt_cases 0 m). - * now rewrite 2 bits_opp, 2 pred_succ, H. - * now rewrite 2 testbit_neg_r. -Qed. - -Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. -Proof. - split. - - apply bits_inj. - - intros EQ; now rewrite EQ. -Qed. - -(** In fact, checking the bits at positive indexes is enough. *) - -Lemma bits_inj' : forall a b, - (forall n, 0<=n -> a.[n] = b.[n]) -> a == b. -Proof. - intros a b H. apply bits_inj. - intros n. destruct (le_gt_cases 0 n). - - now apply H. - - now rewrite 2 testbit_neg_r. -Qed. - -Lemma bits_inj_iff' : forall a b, (forall n, 0<=n -> a.[n] = b.[n]) <-> a == b. -Proof. - split. - - apply bits_inj'. - - intros EQ n Hn; now rewrite EQ. -Qed. - -Tactic Notation "bitwise" "as" simple_intropattern(m) simple_intropattern(Hm) - := apply bits_inj'; intros m Hm; autorewrite with bitwise. - -Ltac bitwise := bitwise as ?m ?Hm. - -#[global] Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. - -(** The streams of bits that correspond to a numbers are + Definition eqf (f g:t -> bool) := forall n:t, f n = g n. + + #[global] + Instance eqf_equiv : Equivalence eqf. + Proof. + split; congruence. + Qed. + + #[local] Infix "===" := eqf (at level 70, no associativity). + + #[global] + Instance testbit_eqf : Proper (eq==>eqf) testbit. + Proof. + intros a a' Ha n. now rewrite Ha. + Qed. + + (** Only zero corresponds to the always-false stream. *) + + Lemma bits_inj_0 : + forall a, (forall n, a.[n] = false) -> a == 0. + Proof. + intros a H. destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]; trivial. + - apply (bits_above_log2_neg a (S (log2 (P (-a))))) in Ha. + + now rewrite H in Ha. + + apply lt_succ_diag_r. + - apply bit_log2 in Ha. now rewrite H in Ha. + Qed. + + (** If two numbers produce the same stream of bits, they are equal. *) + + Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. + Proof. + assert (AUX : forall n, 0<=n -> forall a b, + 0<=a<2^n -> testbit a === testbit b -> a == b). { + intros n Hn. apply le_ind with (4:=Hn). + - solve_proper. + - intros a b Ha H. rewrite pow_0_r, one_succ, lt_succ_r in Ha. + assert (Ha' : a == 0) by (destruct Ha; order). + rewrite Ha' in *. + symmetry. apply bits_inj_0. + intros m. now rewrite <- H, bits_0. + - clear n Hn. intros n Hn IH a b (Ha,Ha') H. + rewrite (div_mod a 2), (div_mod b 2) by order'. + f_equiv; [ | now rewrite <- 2 bit0_mod, H]. + f_equiv. + apply IH. + + split. + * apply div_pos; order'. + * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. + + intros m. + destruct (le_gt_cases 0 m). + * rewrite 2 div2_bits by trivial. apply H. + * now rewrite 2 testbit_neg_r. + } + intros a b H. + destruct (le_gt_cases 0 a) as [Ha|Ha]. + - apply (AUX a); trivial. split; trivial. + apply pow_gt_lin_r; order'. + - apply succ_inj, opp_inj. + assert (0 <= - S a). { + apply opp_le_mono. now rewrite opp_involutive, opp_0, le_succ_l. + } + apply (AUX (-(S a))); trivial. + + split; trivial. + apply pow_gt_lin_r; order'. + + intros m. destruct (le_gt_cases 0 m). + * now rewrite 2 bits_opp, 2 pred_succ, H. + * now rewrite 2 testbit_neg_r. + Qed. + + Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. + Proof. + split. + - apply bits_inj. + - intros EQ; now rewrite EQ. + Qed. + + (** In fact, checking the bits at positive indexes is enough. *) + + Lemma bits_inj' : forall a b, + (forall n, 0<=n -> a.[n] = b.[n]) -> a == b. + Proof. + intros a b H. apply bits_inj. + intros n. destruct (le_gt_cases 0 n). + - now apply H. + - now rewrite 2 testbit_neg_r. + Qed. + + Lemma bits_inj_iff' : forall a b, (forall n, 0<=n -> a.[n] = b.[n]) <-> a == b. + Proof. + split. + - apply bits_inj'. + - intros EQ n Hn; now rewrite EQ. + Qed. + + Tactic Notation "bitwise" "as" simple_intropattern(m) simple_intropattern(Hm) + := apply bits_inj'; intros m Hm; autorewrite with bitwise. + + Ltac bitwise := bitwise as ?m ?Hm. + + #[global] Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. + + (** The streams of bits that correspond to a numbers are exactly the ones which are stationary after some point. *) -Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> - ((exists n, forall m, 0<=m -> f m = n.[m]) <-> - (exists k, forall m, k<=m -> f m = f k)). -Proof. - intros f Hf. split. - - intros (a,H). - destruct (le_gt_cases 0 a). - + exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. - rewrite 2 H, 2 bits_above_log2; trivial using lt_succ_diag_r. - { order_pos. } apply le_trans with (log2 a); order_pos. - + exists (S (log2 (P (-a)))). intros m Hm. apply le_succ_l in Hm. - rewrite 2 H, 2 bits_above_log2_neg; trivial using lt_succ_diag_r. - { order_pos. } apply le_trans with (log2 (P (-a))); order_pos. - - intros (k,Hk). - destruct (lt_ge_cases k 0) as [LT|LE]. - + case_eq (f 0); intros H0. - * exists (-1). intros m Hm. rewrite bits_m1, Hk by order. - symmetry; rewrite <- H0. apply Hk; order. - * exists 0. intros m Hm. rewrite bits_0, Hk by order. - symmetry; rewrite <- H0. apply Hk; order. - + revert f Hf Hk. apply le_ind with (4:=LE). - * (* compat : solve_proper fails here *) - apply proper_sym_impl_iff. { exact eq_sym. } - clear k LE. intros k k' Hk IH f Hf H. apply IH; trivial. - now setoid_rewrite Hk. - * (* /compat *) { - intros f Hf H0. destruct (f 0). - - exists (-1). intros m Hm. now rewrite bits_m1, H0. - - exists 0. intros m Hm. now rewrite bits_0, H0. - } - * { clear k LE. intros k LE IH f Hf Hk. - destruct (IH (fun m => f (S m))) as (n, Hn). - - solve_proper. - - intros m Hm. apply Hk. now rewrite <- succ_le_mono. - - exists (f 0 + 2*n). intros m Hm. - le_elim Hm. - + rewrite <- (succ_pred m), Hn, <- div2_bits. - * rewrite mul_comm, div_add, b2z_div2, add_0_l; trivial. order'. - * now rewrite <- lt_succ_r, succ_pred. - * now rewrite <- lt_succ_r, succ_pred. - + rewrite <- Hm. - symmetry. apply add_b2z_double_bit0. - } -Qed. - -(** * Properties of shifts *) - -(** First, a unified specification for [shiftl] : the [shiftl_spec] + Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> + ((exists n, forall m, 0<=m -> f m = n.[m]) <-> + (exists k, forall m, k<=m -> f m = f k)). + Proof. + intros f Hf. split. + - intros (a,H). + destruct (le_gt_cases 0 a). + + exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. + rewrite 2 H, 2 bits_above_log2; trivial using lt_succ_diag_r. + { order_pos. } apply le_trans with (log2 a); order_pos. + + exists (S (log2 (P (-a)))). intros m Hm. apply le_succ_l in Hm. + rewrite 2 H, 2 bits_above_log2_neg; trivial using lt_succ_diag_r. + { order_pos. } apply le_trans with (log2 (P (-a))); order_pos. + - intros (k,Hk). + destruct (lt_ge_cases k 0) as [LT|LE]. + + case_eq (f 0); intros H0. + * exists (-1). intros m Hm. rewrite bits_m1, Hk by order. + symmetry; rewrite <- H0. apply Hk; order. + * exists 0. intros m Hm. rewrite bits_0, Hk by order. + symmetry; rewrite <- H0. apply Hk; order. + + revert f Hf Hk. apply le_ind with (4:=LE). + * (* compat : solve_proper fails here *) + apply proper_sym_impl_iff. { exact eq_sym. } + clear k LE. intros k k' Hk IH f Hf H. apply IH; trivial. + now setoid_rewrite Hk. + * (* /compat *) { + intros f Hf H0. destruct (f 0). + - exists (-1). intros m Hm. now rewrite bits_m1, H0. + - exists 0. intros m Hm. now rewrite bits_0, H0. + } + * { clear k LE. intros k LE IH f Hf Hk. + destruct (IH (fun m => f (S m))) as (n, Hn). + - solve_proper. + - intros m Hm. apply Hk. now rewrite <- succ_le_mono. + - exists (f 0 + 2*n). intros m Hm. + le_elim Hm. + + rewrite <- (succ_pred m), Hn, <- div2_bits. + * rewrite mul_comm, div_add, b2z_div2, add_0_l; trivial. order'. + * now rewrite <- lt_succ_r, succ_pred. + * now rewrite <- lt_succ_r, succ_pred. + + rewrite <- Hm. + symmetry. apply add_b2z_double_bit0. + } + Qed. + + (** * Properties of shifts *) + + (** First, a unified specification for [shiftl] : the [shiftl_spec] below (combined with [testbit_neg_r]) is equivalent to [shiftl_spec_low] and [shiftl_spec_high]. *) -Lemma shiftl_spec : forall a n m, 0<=m -> (a << n).[m] = a.[m-n]. -Proof. - intros a n m ?. - destruct (le_gt_cases n m). - - now apply shiftl_spec_high. - - rewrite shiftl_spec_low, testbit_neg_r; trivial. now apply lt_sub_0. -Qed. - -(** A shiftl by a negative number is a shiftr, and vice-versa *) - -Lemma shiftr_opp_r : forall a n, a >> (-n) == a << n. -Proof. - intros. bitwise. now rewrite shiftr_spec, shiftl_spec, add_opp_r. -Qed. - -Lemma shiftl_opp_r : forall a n, a << (-n) == a >> n. -Proof. - intros. bitwise. now rewrite shiftr_spec, shiftl_spec, sub_opp_r. -Qed. - -(** Shifts correspond to multiplication or division by a power of two *) - -Lemma shiftr_div_pow2 : forall a n, 0<=n -> a >> n == a / 2^n. -Proof. - intros. bitwise. now rewrite shiftr_spec, div_pow2_bits. -Qed. - -Lemma shiftr_mul_pow2 : forall a n, n<=0 -> a >> n == a * 2^(-n). -Proof. - intros. bitwise. rewrite shiftr_spec, mul_pow2_bits; trivial. - - now rewrite sub_opp_r. - - now apply opp_nonneg_nonpos. -Qed. - -Lemma shiftl_mul_pow2 : forall a n, 0<=n -> a << n == a * 2^n. -Proof. - intros. bitwise. now rewrite shiftl_spec, mul_pow2_bits. -Qed. - -Lemma shiftl_div_pow2 : forall a n, n<=0 -> a << n == a / 2^(-n). -Proof. - intros. bitwise. rewrite shiftl_spec, div_pow2_bits; trivial. - - now rewrite add_opp_r. - - now apply opp_nonneg_nonpos. -Qed. - -(** Shifts are morphisms *) - -#[global] -Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. -Proof. - intros a a' Ha n n' Hn. - destruct (le_ge_cases n 0) as [H|H]; assert (H':=H); rewrite Hn in H'. - - now rewrite 2 shiftr_mul_pow2, Ha, Hn. - - now rewrite 2 shiftr_div_pow2, Ha, Hn. -Qed. - -#[global] -Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. -Proof. - intros a a' Ha n n' Hn. now rewrite <- 2 shiftr_opp_r, Ha, Hn. -Qed. - -(** We could also have specified shiftl with an addition on the left. *) - -Lemma shiftl_spec_alt : forall a n m, 0<=n -> (a << n).[m+n] = a.[m]. -Proof. - intros. now rewrite shiftl_mul_pow2, mul_pow2_bits, add_simpl_r. -Qed. - -(** Chaining several shifts. The only case for which + Lemma shiftl_spec : forall a n m, 0<=m -> (a << n).[m] = a.[m-n]. + Proof. + intros a n m ?. + destruct (le_gt_cases n m). + - now apply shiftl_spec_high. + - rewrite shiftl_spec_low, testbit_neg_r; trivial. now apply lt_sub_0. + Qed. + + (** A shiftl by a negative number is a shiftr, and vice-versa *) + + Lemma shiftr_opp_r : forall a n, a >> (-n) == a << n. + Proof. + intros. bitwise. now rewrite shiftr_spec, shiftl_spec, add_opp_r. + Qed. + + Lemma shiftl_opp_r : forall a n, a << (-n) == a >> n. + Proof. + intros. bitwise. now rewrite shiftr_spec, shiftl_spec, sub_opp_r. + Qed. + + (** Shifts correspond to multiplication or division by a power of two *) + + Lemma shiftr_div_pow2 : forall a n, 0<=n -> a >> n == a / 2^n. + Proof. + intros. bitwise. now rewrite shiftr_spec, div_pow2_bits. + Qed. + + Lemma shiftr_mul_pow2 : forall a n, n<=0 -> a >> n == a * 2^(-n). + Proof. + intros. bitwise. rewrite shiftr_spec, mul_pow2_bits; trivial. + - now rewrite sub_opp_r. + - now apply opp_nonneg_nonpos. + Qed. + + Lemma shiftl_mul_pow2 : forall a n, 0<=n -> a << n == a * 2^n. + Proof. + intros. bitwise. now rewrite shiftl_spec, mul_pow2_bits. + Qed. + + Lemma shiftl_div_pow2 : forall a n, n<=0 -> a << n == a / 2^(-n). + Proof. + intros. bitwise. rewrite shiftl_spec, div_pow2_bits; trivial. + - now rewrite add_opp_r. + - now apply opp_nonneg_nonpos. + Qed. + + (** Shifts are morphisms *) + + #[global] + Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. + Proof. + intros a a' Ha n n' Hn. + destruct (le_ge_cases n 0) as [H|H]; assert (H':=H); rewrite Hn in H'. + - now rewrite 2 shiftr_mul_pow2, Ha, Hn. + - now rewrite 2 shiftr_div_pow2, Ha, Hn. + Qed. + + #[global] + Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. + Proof. + intros a a' Ha n n' Hn. now rewrite <- 2 shiftr_opp_r, Ha, Hn. + Qed. + + (** We could also have specified shiftl with an addition on the left. *) + + Lemma shiftl_spec_alt : forall a n m, 0<=n -> (a << n).[m+n] = a.[m]. + Proof. + intros. now rewrite shiftl_mul_pow2, mul_pow2_bits, add_simpl_r. + Qed. + + (** Chaining several shifts. The only case for which there isn't any simple expression is a true shiftr followed by a true shiftl. *) -Lemma shiftl_shiftl : forall a n m, 0<=n -> - (a << n) << m == a << (n+m). -Proof. - intros a n p Hn. bitwise as m Hm. - rewrite 2 (shiftl_spec _ _ m) by trivial. - rewrite add_comm, sub_add_distr. - destruct (le_gt_cases 0 (m-p)) as [H|H]. - - now rewrite shiftl_spec. - - rewrite 2 testbit_neg_r; trivial. - apply lt_sub_0. now apply lt_le_trans with 0. -Qed. - -Lemma shiftr_shiftl_l : forall a n m, 0<=n -> - (a << n) >> m == a << (n-m). -Proof. - intros. now rewrite <- shiftl_opp_r, shiftl_shiftl, add_opp_r. -Qed. - -Lemma shiftr_shiftl_r : forall a n m, 0<=n -> - (a << n) >> m == a >> (m-n). -Proof. - intros. now rewrite <- 2 shiftl_opp_r, shiftl_shiftl, opp_sub_distr, add_comm. -Qed. - -Lemma shiftr_shiftr : forall a n m, 0<=m -> - (a >> n) >> m == a >> (n+m). -Proof. - intros a n p Hn. bitwise. - rewrite 3 shiftr_spec; trivial. - - now rewrite (add_comm n p), add_assoc. - - now apply add_nonneg_nonneg. -Qed. - -(** shifts and constants *) - -Lemma shiftl_1_l : forall n, 1 << n == 2^n. -Proof. - intros n. destruct (le_gt_cases 0 n). - - now rewrite shiftl_mul_pow2, mul_1_l. - - rewrite shiftl_div_pow2, div_1_l, pow_neg_r; try order. - apply pow_gt_1. - + order'. - + now apply opp_pos_neg. -Qed. - -Lemma shiftl_0_r : forall a, a << 0 == a. -Proof. - intros. rewrite shiftl_mul_pow2 by order. now nzsimpl. -Qed. - -Lemma shiftr_0_r : forall a, a >> 0 == a. -Proof. - intros. now rewrite <- shiftl_opp_r, opp_0, shiftl_0_r. -Qed. - -Lemma shiftl_0_l : forall n, 0 << n == 0. -Proof. - intros n. - destruct (le_ge_cases 0 n) as [H|H]. - - rewrite shiftl_mul_pow2 by trivial. now nzsimpl. - - rewrite shiftl_div_pow2 by trivial. - rewrite <- opp_nonneg_nonpos in H. nzsimpl; order_nz. -Qed. - -Lemma shiftr_0_l : forall n, 0 >> n == 0. -Proof. - intros. now rewrite <- shiftl_opp_r, shiftl_0_l. -Qed. - -Lemma shiftl_eq_0_iff : forall a n, 0<=n -> (a << n == 0 <-> a == 0). -Proof. - intros a n Hn. - rewrite shiftl_mul_pow2 by trivial. rewrite eq_mul_0. split. - - intros [H | H]; trivial. contradict H; order_nz. - - intros H. now left. -Qed. - -Lemma shiftr_eq_0_iff : forall a n, - a >> n == 0 <-> a==0 \/ (0 log2 a < n -> a >> n == 0. -Proof. - intros a n Ha H. apply shiftr_eq_0_iff. - le_elim Ha. - - right. now split. - - now left. -Qed. - -(** Properties of [div2]. *) - -Lemma div2_div : forall a, div2 a == a/2. -Proof. - intros. rewrite div2_spec, shiftr_div_pow2. - - now nzsimpl. - - order'. -Qed. - -#[global] -Instance div2_wd : Proper (eq==>eq) div2. -Proof. - intros a a' Ha. now rewrite 2 div2_div, Ha. -Qed. - -Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. -Proof. - intros a. rewrite div2_div, <- bit0_odd, bit0_mod. - apply div_mod. order'. -Qed. - -(** Properties of [lxor] and others, directly deduced + Lemma shiftl_shiftl : forall a n m, 0<=n -> + (a << n) << m == a << (n+m). + Proof. + intros a n p Hn. bitwise as m Hm. + rewrite 2 (shiftl_spec _ _ m) by trivial. + rewrite add_comm, sub_add_distr. + destruct (le_gt_cases 0 (m-p)) as [H|H]. + - now rewrite shiftl_spec. + - rewrite 2 testbit_neg_r; trivial. + apply lt_sub_0. now apply lt_le_trans with 0. + Qed. + + Lemma shiftr_shiftl_l : forall a n m, 0<=n -> + (a << n) >> m == a << (n-m). + Proof. + intros. now rewrite <- shiftl_opp_r, shiftl_shiftl, add_opp_r. + Qed. + + Lemma shiftr_shiftl_r : forall a n m, 0<=n -> + (a << n) >> m == a >> (m-n). + Proof. + intros. now rewrite <- 2 shiftl_opp_r, shiftl_shiftl, opp_sub_distr, add_comm. + Qed. + + Lemma shiftr_shiftr : forall a n m, 0<=m -> + (a >> n) >> m == a >> (n+m). + Proof. + intros a n p Hn. bitwise. + rewrite 3 shiftr_spec; trivial. + - now rewrite (add_comm n p), add_assoc. + - now apply add_nonneg_nonneg. + Qed. + + (** shifts and constants *) + + Lemma shiftl_1_l : forall n, 1 << n == 2^n. + Proof. + intros n. destruct (le_gt_cases 0 n). + - now rewrite shiftl_mul_pow2, mul_1_l. + - rewrite shiftl_div_pow2, div_1_l, pow_neg_r; try order. + apply pow_gt_1. + + order'. + + now apply opp_pos_neg. + Qed. + + Lemma shiftl_0_r : forall a, a << 0 == a. + Proof. + intros. rewrite shiftl_mul_pow2 by order. now nzsimpl. + Qed. + + Lemma shiftr_0_r : forall a, a >> 0 == a. + Proof. + intros. now rewrite <- shiftl_opp_r, opp_0, shiftl_0_r. + Qed. + + Lemma shiftl_0_l : forall n, 0 << n == 0. + Proof. + intros n. + destruct (le_ge_cases 0 n) as [H|H]. + - rewrite shiftl_mul_pow2 by trivial. now nzsimpl. + - rewrite shiftl_div_pow2 by trivial. + rewrite <- opp_nonneg_nonpos in H. nzsimpl; order_nz. + Qed. + + Lemma shiftr_0_l : forall n, 0 >> n == 0. + Proof. + intros. now rewrite <- shiftl_opp_r, shiftl_0_l. + Qed. + + Lemma shiftl_eq_0_iff : forall a n, 0<=n -> (a << n == 0 <-> a == 0). + Proof. + intros a n Hn. + rewrite shiftl_mul_pow2 by trivial. rewrite eq_mul_0. split. + - intros [H | H]; trivial. contradict H; order_nz. + - intros H. now left. + Qed. + + Lemma shiftr_eq_0_iff : forall a n, + a >> n == 0 <-> a==0 \/ (0 log2 a < n -> a >> n == 0. + Proof. + intros a n Ha H. apply shiftr_eq_0_iff. + le_elim Ha. + - right. now split. + - now left. + Qed. + + (** Properties of [div2]. *) + + Lemma div2_div : forall a, div2 a == a/2. + Proof. + intros. rewrite div2_spec, shiftr_div_pow2. + - now nzsimpl. + - order'. + Qed. + + #[global] + Instance div2_wd : Proper (eq==>eq) div2. + Proof. + intros a a' Ha. now rewrite 2 div2_div, Ha. + Qed. + + Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. + Proof. + intros a. rewrite div2_div, <- bit0_odd, bit0_mod. + apply div_mod. order'. + Qed. + + (** Properties of [lxor] and others, directly deduced from properties of [xorb] and others. *) -#[global] -Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance land_wd : Proper (eq ==> eq ==> eq) land. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance lor_wd : Proper (eq ==> eq ==> eq) lor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. -Proof. - intros a a' H. bitwise. apply xorb_eq. - now rewrite <- lxor_spec, H, bits_0. -Qed. - -Lemma lxor_nilpotent : forall a, lxor a a == 0. -Proof. - intros. bitwise. apply xorb_nilpotent. -Qed. - -Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. -Proof. - split. - - apply lxor_eq. - - intros EQ; rewrite EQ; apply lxor_nilpotent. -Qed. - -Lemma lxor_0_l : forall a, lxor 0 a == a. -Proof. - intros. bitwise. apply xorb_false_l. -Qed. - -Lemma lxor_0_r : forall a, lxor a 0 == a. -Proof. - intros. bitwise. apply xorb_false_r. -Qed. - -Lemma lxor_comm : forall a b, lxor a b == lxor b a. -Proof. - intros. bitwise. apply xorb_comm. -Qed. - -Lemma lxor_assoc : - forall a b c, lxor (lxor a b) c == lxor a (lxor b c). -Proof. - intros. bitwise. apply xorb_assoc. -Qed. - -Lemma lor_0_l : forall a, lor 0 a == a. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma lor_0_r : forall a, lor a 0 == a. -Proof. - intros. bitwise. apply orb_false_r. -Qed. - -Lemma lor_comm : forall a b, lor a b == lor b a. -Proof. - intros. bitwise. apply orb_comm. -Qed. - -Lemma lor_assoc : - forall a b c, lor a (lor b c) == lor (lor a b) c. -Proof. - intros. bitwise. apply orb_assoc. -Qed. - -Lemma lor_diag : forall a, lor a a == a. -Proof. - intros. bitwise. apply orb_diag. -Qed. - -Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. -Proof. - intros a b H. bitwise as m ?. - apply (orb_false_iff a.[m] b.[m]). - now rewrite <- lor_spec, H, bits_0. -Qed. - -Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. -Proof. - intros a b. split. - - intro H; split. - + now apply lor_eq_0_l in H. - + rewrite lor_comm in H. now apply lor_eq_0_l in H. - - intros (EQ,EQ'). now rewrite EQ, lor_0_l. -Qed. - -Lemma land_0_l : forall a, land 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma land_0_r : forall a, land a 0 == 0. -Proof. - intros. bitwise. apply andb_false_r. -Qed. - -Lemma land_comm : forall a b, land a b == land b a. -Proof. - intros. bitwise. apply andb_comm. -Qed. - -Lemma land_assoc : - forall a b c, land a (land b c) == land (land a b) c. -Proof. - intros. bitwise. apply andb_assoc. -Qed. - -Lemma land_diag : forall a, land a a == a. -Proof. - intros. bitwise. apply andb_diag. -Qed. - -Lemma ldiff_0_l : forall a, ldiff 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma ldiff_0_r : forall a, ldiff a 0 == a. -Proof. - intros. bitwise. now rewrite andb_true_r. -Qed. - -Lemma ldiff_diag : forall a, ldiff a a == 0. -Proof. - intros. bitwise. apply andb_negb_r. -Qed. - -Lemma lor_land_distr_l : forall a b c, - lor (land a b) c == land (lor a c) (lor b c). -Proof. - intros. bitwise. apply orb_andb_distrib_l. -Qed. - -Lemma lor_land_distr_r : forall a b c, - lor a (land b c) == land (lor a b) (lor a c). -Proof. - intros. bitwise. apply orb_andb_distrib_r. -Qed. - -Lemma land_lor_distr_l : forall a b c, - land (lor a b) c == lor (land a c) (land b c). -Proof. - intros. bitwise. apply andb_orb_distrib_l. -Qed. - -Lemma land_lor_distr_r : forall a b c, - land a (lor b c) == lor (land a b) (land a c). -Proof. - intros. bitwise. apply andb_orb_distrib_r. -Qed. - -Lemma ldiff_ldiff_l : forall a b c, - ldiff (ldiff a b) c == ldiff a (lor b c). -Proof. - intros. bitwise. now rewrite negb_orb, andb_assoc. -Qed. - -Lemma lor_ldiff_and : forall a b, - lor (ldiff a b) (land a b) == a. -Proof. - intros. bitwise. - now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. -Qed. - -Lemma land_ldiff : forall a b, - land (ldiff a b) b == 0. -Proof. - intros. bitwise. - now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. -Qed. - -(** Properties of [setbit] and [clearbit] *) - -Definition setbit a n := lor a (1 << n). -Definition clearbit a n := ldiff a (1 << n). - -Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n). -Proof. - intros. unfold setbit. now rewrite shiftl_1_l. -Qed. - -Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n). -Proof. - intros. unfold clearbit. now rewrite shiftl_1_l. -Qed. - -#[global] -Instance setbit_wd : Proper (eq==>eq==>eq) setbit. -Proof. unfold setbit. solve_proper. Qed. - -#[global] -Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. -Proof. unfold clearbit. solve_proper. Qed. - -Lemma pow2_bits_true : forall n, 0<=n -> (2^n).[n] = true. -Proof. - intros n ?. rewrite <- (mul_1_l (2^n)). - now rewrite mul_pow2_bits, sub_diag, bit0_odd, odd_1. -Qed. - -Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. -Proof. - intros n m ?. - destruct (le_gt_cases 0 n); [|now rewrite pow_neg_r, bits_0]. - destruct (le_gt_cases n m). - - rewrite <- (mul_1_l (2^n)), mul_pow2_bits; trivial. - rewrite <- (succ_pred (m-n)), <- div2_bits. - + now rewrite div_small, bits_0 by (split; order'). - + rewrite <- lt_succ_r, succ_pred, lt_0_sub. order. - - rewrite <- (mul_1_l (2^n)), mul_pow2_bits_low; trivial. -Qed. - -Lemma pow2_bits_eqb : forall n m, 0<=n -> (2^n).[m] = eqb n m. -Proof. - intros n m Hn. apply eq_true_iff_eq. rewrite eqb_eq. split. - - destruct (eq_decidable n m) as [H|H]. { trivial. } - now rewrite (pow2_bits_false _ _ H). - - intros EQ. rewrite EQ. apply pow2_bits_true; order. -Qed. - -Lemma setbit_eqb : forall a n m, 0<=n -> - (setbit a n).[m] = eqb n m || a.[m]. -Proof. - intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. -Qed. - -Lemma setbit_iff : forall a n m, 0<=n -> - ((setbit a n).[m] = true <-> n==m \/ a.[m] = true). -Proof. - intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. -Qed. - -Lemma setbit_eq : forall a n, 0<=n -> (setbit a n).[n] = true. -Proof. - intros. apply setbit_iff; trivial. now left. -Qed. - -Lemma setbit_neq : forall a n m, 0<=n -> n~=m -> - (setbit a n).[m] = a.[m]. -Proof. - intros a n m Hn H. rewrite setbit_eqb; trivial. - rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. -Qed. - -Lemma clearbit_eqb : forall a n m, - (clearbit a n).[m] = a.[m] && negb (eqb n m). -Proof. - intros a n m. - destruct (le_gt_cases 0 m); [| now rewrite 2 testbit_neg_r]. - rewrite clearbit_spec', ldiff_spec. f_equal. f_equal. - destruct (le_gt_cases 0 n) as [Hn|Hn]. - - now apply pow2_bits_eqb. - - symmetry. rewrite pow_neg_r, bits_0, <- not_true_iff_false, eqb_eq; order. -Qed. - -Lemma clearbit_iff : forall a n m, - (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. -Proof. - intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. - now rewrite negb_true_iff, not_true_iff_false. -Qed. - -Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. -Proof. - intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). - apply andb_false_r. -Qed. - -Lemma clearbit_neq : forall a n m, n~=m -> - (clearbit a n).[m] = a.[m]. -Proof. - intros a n m H. rewrite clearbit_eqb. - rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. - apply andb_true_r. -Qed. - -(** Shifts of bitwise operations *) - -Lemma shiftl_lxor : forall a b n, - (lxor a b) << n == lxor (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, lxor_spec. -Qed. - -Lemma shiftr_lxor : forall a b n, - (lxor a b) >> n == lxor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, lxor_spec. -Qed. - -Lemma shiftl_land : forall a b n, - (land a b) << n == land (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, land_spec. -Qed. - -Lemma shiftr_land : forall a b n, - (land a b) >> n == land (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, land_spec. -Qed. - -Lemma shiftl_lor : forall a b n, - (lor a b) << n == lor (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, lor_spec. -Qed. - -Lemma shiftr_lor : forall a b n, - (lor a b) >> n == lor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, lor_spec. -Qed. - -Lemma shiftl_ldiff : forall a b n, - (ldiff a b) << n == ldiff (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, ldiff_spec. -Qed. - -Lemma shiftr_ldiff : forall a b n, - (ldiff a b) >> n == ldiff (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, ldiff_spec. -Qed. - -(** For integers, we do have a binary complement function *) - -Definition lnot a := P (-a). - -#[global] -Instance lnot_wd : Proper (eq==>eq) lnot. -Proof. unfold lnot. solve_proper. Qed. - -Lemma lnot_spec : forall a n, 0<=n -> (lnot a).[n] = negb a.[n]. -Proof. - intros a n ?. unfold lnot. rewrite <- (opp_involutive a) at 2. - rewrite bits_opp, negb_involutive; trivial. -Qed. - -Lemma lnot_involutive : forall a, lnot (lnot a) == a. -Proof. - intros a. bitwise. now rewrite 2 lnot_spec, negb_involutive. -Qed. - -Lemma lnot_0 : lnot 0 == -1. -Proof. - unfold lnot. now rewrite opp_0, <- sub_1_r, sub_0_l. -Qed. - -Lemma lnot_m1 : lnot (-1) == 0. -Proof. - unfold lnot. now rewrite opp_involutive, one_succ, pred_succ. -Qed. - -(** Complement and other operations *) - -Lemma lor_m1_r : forall a, lor a (-1) == -1. -Proof. - intros. bitwise. now rewrite bits_m1, orb_true_r. -Qed. - -Lemma lor_m1_l : forall a, lor (-1) a == -1. -Proof. - intros. now rewrite lor_comm, lor_m1_r. -Qed. - -Lemma land_m1_r : forall a, land a (-1) == a. -Proof. - intros. bitwise. now rewrite bits_m1, andb_true_r. -Qed. - -Lemma land_m1_l : forall a, land (-1) a == a. -Proof. - intros. now rewrite land_comm, land_m1_r. -Qed. - -Lemma ldiff_m1_r : forall a, ldiff a (-1) == 0. -Proof. - intros. bitwise. now rewrite bits_m1, andb_false_r. -Qed. - -Lemma ldiff_m1_l : forall a, ldiff (-1) a == lnot a. -Proof. - intros. bitwise. now rewrite lnot_spec, bits_m1. -Qed. - -Lemma lor_lnot_diag : forall a, lor a (lnot a) == -1. -Proof. - intros a. bitwise as m ?. rewrite lnot_spec, bits_m1; trivial. - now destruct a.[m]. -Qed. - -Lemma add_lnot_diag : forall a, a + lnot a == -1. -Proof. - intros a. unfold lnot. - now rewrite add_pred_r, add_opp_r, sub_diag, one_succ, opp_succ, opp_0. -Qed. - -Lemma ldiff_land : forall a b, ldiff a b == land a (lnot b). -Proof. - intros. bitwise. now rewrite lnot_spec. -Qed. - -Lemma land_lnot_diag : forall a, land a (lnot a) == 0. -Proof. - intros. now rewrite <- ldiff_land, ldiff_diag. -Qed. - -Lemma lnot_lor : forall a b, lnot (lor a b) == land (lnot a) (lnot b). -Proof. - intros a b. bitwise. now rewrite !lnot_spec, lor_spec, negb_orb. -Qed. - -Lemma lnot_land : forall a b, lnot (land a b) == lor (lnot a) (lnot b). -Proof. - intros a b. bitwise. now rewrite !lnot_spec, land_spec, negb_andb. -Qed. - -Lemma lnot_ldiff : forall a b, lnot (ldiff a b) == lor (lnot a) b. -Proof. - intros a b. bitwise. - now rewrite !lnot_spec, ldiff_spec, negb_andb, negb_involutive. -Qed. - -Lemma lxor_lnot_lnot : forall a b, lxor (lnot a) (lnot b) == lxor a b. -Proof. - intros a b. bitwise. now rewrite !lnot_spec, xorb_negb_negb. -Qed. - -Lemma lnot_lxor_l : forall a b, lnot (lxor a b) == lxor (lnot a) b. -Proof. - intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_l. -Qed. - -Lemma lnot_lxor_r : forall a b, lnot (lxor a b) == lxor a (lnot b). -Proof. - intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_r. -Qed. - -Lemma lxor_m1_r : forall a, lxor a (-1) == lnot a. -Proof. - intros a. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot. -Qed. - -Lemma lxor_m1_l : forall a, lxor (-1) a == lnot a. -Proof. - intros. now rewrite lxor_comm, lxor_m1_r. -Qed. - -Lemma lxor_lor : forall a b, land a b == 0 -> - lxor a b == lor a b. -Proof. - intros a b H. bitwise as m ?. - assert (a.[m] && b.[m] = false) - by now rewrite <- land_spec, H, bits_0. - now destruct a.[m], b.[m]. -Qed. - -Lemma lnot_shiftr : forall a n, 0<=n -> lnot (a >> n) == (lnot a) >> n. -Proof. - intros a n Hn. bitwise. - now rewrite lnot_spec, 2 shiftr_spec, lnot_spec by order_pos. -Qed. - -(** [(ones n)] is [2^n-1], the number with [n] digits 1 *) - -Definition ones n := P (1<eq) ones. -Proof. unfold ones. solve_proper. Qed. - -Lemma ones_equiv : forall n, ones n == P (2^n). -Proof. - intros n. unfold ones. - destruct (le_gt_cases 0 n). - - now rewrite shiftl_mul_pow2, mul_1_l. - - f_equiv. rewrite pow_neg_r; trivial. - rewrite <- shiftr_opp_r. apply shiftr_eq_0_iff. right; split. - { order'. } - rewrite log2_1. now apply opp_pos_neg. -Qed. - -Lemma ones_add : forall n m, 0<=n -> 0<=m -> - ones (m+n) == 2^m * ones n + ones m. -Proof. - intros n m Hn Hm. rewrite !ones_equiv. - rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r by trivial. - rewrite add_sub_assoc, sub_add. reflexivity. -Qed. - -Lemma ones_div_pow2 : forall n m, 0<=m<=n -> ones n / 2^m == ones (n-m). -Proof. - intros n m (Hm,H). symmetry. apply div_unique with (ones m). - - left. rewrite ones_equiv. split. - + rewrite <- lt_succ_r, succ_pred. order_pos. - + now rewrite <- le_succ_l, succ_pred. - - rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). - apply ones_add; trivial. now apply le_0_sub. -Qed. - -Lemma ones_mod_pow2 : forall n m, 0<=m<=n -> (ones n) mod (2^m) == ones m. -Proof. - intros n m (Hm,H). symmetry. apply mod_unique with (ones (n-m)). - - left. rewrite ones_equiv. split. - + rewrite <- lt_succ_r, succ_pred. order_pos. - + now rewrite <- le_succ_l, succ_pred. - - rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). - apply ones_add; trivial. now apply le_0_sub. -Qed. - -Lemma ones_spec_low : forall n m, 0<=m (ones n).[m] = true. -Proof. - intros n m (Hm,H). apply testbit_true; trivial. - rewrite ones_div_pow2 by (split; order). - rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. - - rewrite ones_equiv. now nzsimpl'. - - split. { order'. } apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. -Qed. - -Lemma ones_spec_high : forall n m, 0<=n<=m -> (ones n).[m] = false. -Proof. - intros n m (Hn,H). le_elim Hn. - - apply bits_above_log2; rewrite ones_equiv. - + rewrite <-lt_succ_r, succ_pred; order_pos. - + rewrite log2_pred_pow2; trivial. now rewrite <-le_succ_l, succ_pred. - - rewrite ones_equiv. now rewrite <- Hn, pow_0_r, one_succ, pred_succ, bits_0. -Qed. - -Lemma ones_spec_iff : forall n m, 0<=n -> - ((ones n).[m] = true <-> 0<=m log2 a < n -> - lor a (ones n) == ones n. -Proof. - intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; try split; trivial. - + now apply lt_le_trans with n. - + apply le_trans with (log2 a); order_pos. - - rewrite ones_spec_low, orb_true_r; try split; trivial. -Qed. - -Lemma land_ones : forall a n, 0<=n -> land a (ones n) == a mod 2^n. -Proof. - intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r; - try split; trivial. - - rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r; - try split; trivial. -Qed. - -Lemma land_ones_low : forall a n, 0<=a -> log2 a < n -> - land a (ones n) == a. -Proof. - intros a n Ha H. - assert (Hn : 0<=n) by (generalize (log2_nonneg a); order). - rewrite land_ones; trivial. apply mod_small. - split; trivial. - apply log2_lt_cancel. now rewrite log2_pow2. -Qed. - -Lemma ldiff_ones_r : forall a n, 0<=n -> - ldiff a (ones n) == (a >> n) << n. -Proof. - intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, shiftl_spec_high, shiftr_spec; trivial. - + rewrite sub_add; trivial. apply andb_true_r. - + now apply le_0_sub. - + now split. - - rewrite ones_spec_low, shiftl_spec_low, andb_false_r; - try split; trivial. -Qed. - -Lemma ldiff_ones_r_low : forall a n, 0<=a -> log2 a < n -> - ldiff a (ones n) == 0. -Proof. - intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - + now apply lt_le_trans with n. - + split; trivial. now apply le_trans with (log2 a); order_pos. - - rewrite ones_spec_low, andb_false_r; try split; trivial. -Qed. - -Lemma ldiff_ones_l_low : forall a n, 0<=a -> log2 a < n -> - ldiff (ones n) a == lxor a (ones n). -Proof. - intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - + now apply lt_le_trans with n. - + split; trivial. now apply le_trans with (log2 a); order_pos. - - rewrite ones_spec_low, xorb_true_r; try split; trivial. -Qed. - -(** Bitwise operations and sign *) - -Lemma shiftl_nonneg : forall a n, 0 <= (a << n) <-> 0 <= a. -Proof. - intros a n. - destruct (le_ge_cases 0 n) as [Hn|Hn]. - - (* 0<=n *) - rewrite 2 bits_iff_nonneg_ex. split; intros (k,Hk). - + exists (k-n). intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite <- (add_simpl_r m n), <- (shiftl_spec a n) by order_pos. - apply Hk. now apply lt_sub_lt_add_r. - + exists (k+n). intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite shiftl_spec by trivial. apply Hk. now apply lt_add_lt_sub_r. - - (* n<=0*) - rewrite <- shiftr_opp_r, 2 bits_iff_nonneg_ex. split; intros (k,Hk). - + destruct (le_gt_cases 0 k). - * exists (k-n). intros m Hm. apply lt_sub_lt_add_r in Hm. - rewrite <- (add_simpl_r m n), <- add_opp_r, <- (shiftr_spec a (-n)) by order. - now apply Hk. - * assert (EQ : a >> (-n) == 0). { - apply bits_inj'. intros m Hm. rewrite bits_0. apply Hk; order. - } - apply shiftr_eq_0_iff in EQ. - rewrite <- bits_iff_nonneg_ex. destruct EQ as [EQ|[LT _]]; order. - + exists (k+n). intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite shiftr_spec by trivial. apply Hk. - rewrite add_opp_r. now apply lt_add_lt_sub_r. -Qed. - -Lemma shiftl_neg : forall a n, (a << n) < 0 <-> a < 0. -Proof. - intros a n. now rewrite 2 lt_nge, shiftl_nonneg. -Qed. - -Lemma shiftr_nonneg : forall a n, 0 <= (a >> n) <-> 0 <= a. -Proof. - intros. rewrite <- shiftl_opp_r. apply shiftl_nonneg. -Qed. - -Lemma shiftr_neg : forall a n, (a >> n) < 0 <-> a < 0. -Proof. - intros a n. now rewrite 2 lt_nge, shiftr_nonneg. -Qed. - -Lemma div2_nonneg : forall a, 0 <= div2 a <-> 0 <= a. -Proof. - intros. rewrite div2_spec. apply shiftr_nonneg. -Qed. - -Lemma div2_neg : forall a, div2 a < 0 <-> a < 0. -Proof. - intros a. now rewrite 2 lt_nge, div2_nonneg. -Qed. - -Lemma lor_nonneg : forall a b, 0 <= lor a b <-> 0<=a /\ 0<=b. -Proof. - intros a b. - rewrite 3 bits_iff_nonneg_ex. split. - - intros (k,Hk). - split; exists k; intros m Hm; apply (orb_false_elim a.[m] b.[m]); - rewrite <- lor_spec; now apply Hk. - - intros ((k,Hk),(k',Hk')). - destruct (le_ge_cases k k'); [ exists k' | exists k ]; - intros m Hm; rewrite lor_spec, Hk, Hk'; trivial; order. -Qed. - -Lemma lor_neg : forall a b, lor a b < 0 <-> a < 0 \/ b < 0. -Proof. - intros a b. rewrite 3 lt_nge, lor_nonneg. split. - - apply not_and. apply le_decidable. - - now intros [H|H] (H',H''). -Qed. - -Lemma lnot_nonneg : forall a, 0 <= lnot a <-> a < 0. -Proof. - intros a; unfold lnot. - now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. -Qed. - -Lemma lnot_neg : forall a, lnot a < 0 <-> 0 <= a. -Proof. - intros a. now rewrite le_ngt, lt_nge, lnot_nonneg. -Qed. - -Lemma land_nonneg : forall a b, 0 <= land a b <-> 0<=a \/ 0<=b. -Proof. - intros a b. - now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_nonneg, - lor_neg, !lnot_neg. -Qed. - -Lemma land_neg : forall a b, land a b < 0 <-> a < 0 /\ b < 0. -Proof. - intros a b. - now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_neg, - lor_nonneg, !lnot_nonneg. -Qed. - -Lemma ldiff_nonneg : forall a b, 0 <= ldiff a b <-> 0<=a \/ b<0. -Proof. - intros. now rewrite ldiff_land, land_nonneg, lnot_nonneg. -Qed. - -Lemma ldiff_neg : forall a b, ldiff a b < 0 <-> a<0 /\ 0<=b. -Proof. - intros. now rewrite ldiff_land, land_neg, lnot_neg. -Qed. - -Lemma lxor_nonneg : forall a b, 0 <= lxor a b <-> (0<=a <-> 0<=b). -Proof. - assert (H : forall a b, 0<=a -> 0<=b -> 0<=lxor a b). { - intros a b. rewrite 3 bits_iff_nonneg_ex. intros (k,Hk) (k', Hk'). - destruct (le_ge_cases k k'); [ exists k' | exists k]; - intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. - } - assert (H' : forall a b, 0<=a -> b<0 -> lxor a b<0). { - intros a b. rewrite bits_iff_nonneg_ex, 2 bits_iff_neg_ex. - intros (k,Hk) (k', Hk'). - destruct (le_ge_cases k k'); [ exists k' | exists k]; - intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. - } - intros a b. - split. - - intros Hab. split. - + intros Ha. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. - generalize (H' _ _ Ha Hb). order. - + intros Hb. destruct (le_gt_cases 0 a) as [Ha|Ha]; trivial. - generalize (H' _ _ Hb Ha). rewrite lxor_comm. order. - - intros E. - destruct (le_gt_cases 0 a) as [Ha|Ha]. - + apply H; trivial. apply E; trivial. - + destruct (le_gt_cases 0 b) as [Hb|Hb]. - * apply H; trivial. apply E; trivial. - * rewrite <- lxor_lnot_lnot. apply H; now apply lnot_nonneg. -Qed. - -(** Bitwise operations and log2 *) - -Lemma log2_bits_unique : forall a n, - a.[n] = true -> - (forall m, n a.[m] = false) -> - log2 a == n. -Proof. - intros a n H H'. - destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]. - - (* a < 0 *) - destruct (proj1 (bits_iff_neg_ex a) Ha) as (k,Hk). - destruct (le_gt_cases n k). - + specialize (Hk (S k) (lt_succ_diag_r _)). - rewrite H' in Hk. - * discriminate. - * apply lt_succ_r; order. - + specialize (H' (S n) (lt_succ_diag_r _)). - rewrite Hk in H'. - * discriminate. - * apply lt_succ_r; order. - - (* a = 0 *) - now rewrite Ha, bits_0 in H. - - (* 0 < a *) - apply le_antisymm; apply le_ngt; intros LT. - + specialize (H' _ LT). now rewrite bit_log2 in H'. - + now rewrite bits_above_log2 in H by order. -Qed. - -Lemma log2_shiftr : forall a n, 0 log2 (a >> n) == max 0 (log2 a - n). -Proof. - intros a n Ha. - destruct (le_gt_cases 0 (log2 a - n)) as [H|H]; - [rewrite max_r | rewrite max_l]; try order. - - apply log2_bits_unique. - + now rewrite shiftr_spec, sub_add, bit_log2. - + intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite shiftr_spec; trivial. apply bits_above_log2; try order. - now apply lt_sub_lt_add_r. - - rewrite lt_sub_lt_add_r, add_0_l in H. - apply log2_nonpos. apply le_lteq; right. - apply shiftr_eq_0_iff. right. now split. -Qed. - -Lemma log2_shiftl : forall a n, 0 0<=n -> log2 (a << n) == log2 a + n. -Proof. - intros a n Ha Hn. - rewrite shiftl_mul_pow2, add_comm by trivial. - now apply log2_mul_pow2. -Qed. - -Lemma log2_shiftl' : forall a n, 0 log2 (a << n) == max 0 (log2 a + n). -Proof. - intros a n Ha. - rewrite <- shiftr_opp_r, log2_shiftr by trivial. - destruct (le_gt_cases 0 (log2 a + n)); - [rewrite 2 max_r | rewrite 2 max_l]; rewrite ?sub_opp_r; try order. -Qed. - -Lemma log2_lor : forall a b, 0<=a -> 0<=b -> - log2 (lor a b) == max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lor a b) == log2 b). { - intros a b Ha H. - le_elim Ha; [|now rewrite <- Ha, lor_0_l]. - apply log2_bits_unique. - - now rewrite lor_spec, bit_log2, orb_true_r by order. - - intros m Hm. assert (H' := log2_le_mono _ _ H). - now rewrite lor_spec, 2 bits_above_log2 by order. - } - (* main *) - intros a b Ha Hb. destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. - now apply AUX. - - rewrite max_l by now apply log2_le_mono. - rewrite lor_comm. now apply AUX. -Qed. - -Lemma log2_land : forall a b, 0<=a -> 0<=b -> - log2 (land a b) <= min (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, 0<=a -> a<=b -> log2 (land a b) <= log2 a). { - intros a b Ha Hb. - apply le_ngt. intros LT. - assert (H : 0 <= land a b) by (apply land_nonneg; now left). - le_elim H. - - generalize (bit_log2 (land a b) H). - now rewrite land_spec, bits_above_log2. - - rewrite <- H in LT. apply log2_lt_cancel in LT; order. - } - (* main *) - intros a b Ha Hb. - destruct (le_ge_cases a b) as [H|H]. - - rewrite min_l by now apply log2_le_mono. now apply AUX. - - rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. -Qed. - -Lemma log2_lxor : forall a b, 0<=a -> 0<=b -> - log2 (lxor a b) <= max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lxor a b) <= log2 b). { - intros a b Ha Hb. - apply le_ngt. intros LT. - assert (H : 0 <= lxor a b) by (apply lxor_nonneg; split; order). - le_elim H. - - generalize (bit_log2 (lxor a b) H). - rewrite lxor_spec, 2 bits_above_log2; try order. - + discriminate. - + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. - - rewrite <- H in LT. apply log2_lt_cancel in LT; order. - } - (* main *) - intros a b Ha Hb. - destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. now apply AUX. - - rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. -Qed. - -(** Bitwise operations and arithmetical operations *) - -#[local] Notation xor3 a b c := (xorb (xorb a b) c). -#[local] Notation lxor3 a b c := (lxor (lxor a b) c). -#[local] Notation nextcarry a b c := ((a&&b) || (c && (a||b))). -#[local] Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). - -Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. -Proof. - intros. now rewrite !bit0_odd, odd_add. -Qed. - -Lemma add3_bit0 : forall a b c, - (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. -Proof. - intros. now rewrite !add_bit0. -Qed. - -Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), - (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. -Proof. - assert (H : 1+1 == 2) by now nzsimpl'. - intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; - (apply div_same; order') || (apply div_small; split; order') || idtac. - symmetry. apply div_unique with 1. - - left; split; order'. - - now nzsimpl'. -Qed. - -Lemma add_carry_div2 : forall a b (c0:bool), - (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. -Proof. - intros a b c0. - rewrite <- add3_bits_div2. - rewrite (add_comm ((a/2)+_)). - rewrite <- div_add by order'. - f_equiv. - rewrite <- !div2_div, mul_comm, mul_add_distr_l. - rewrite (div2_odd a), <- bit0_odd at 1. - rewrite (div2_odd b), <- bit0_odd at 1. - rewrite add_shuffle1. - rewrite <-(add_assoc _ _ c0). apply add_comm. -Qed. - -(** The main result concerning addition: we express the bits of the sum + #[global] + Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + #[global] + Instance land_wd : Proper (eq ==> eq ==> eq) land. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + #[global] + Instance lor_wd : Proper (eq ==> eq ==> eq) lor. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + #[global] + Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. + Proof. + intros a a' H. bitwise. apply xorb_eq. + now rewrite <- lxor_spec, H, bits_0. + Qed. + + Lemma lxor_nilpotent : forall a, lxor a a == 0. + Proof. + intros. bitwise. apply xorb_nilpotent. + Qed. + + Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. + Proof. + split. + - apply lxor_eq. + - intros EQ; rewrite EQ; apply lxor_nilpotent. + Qed. + + Lemma lxor_0_l : forall a, lxor 0 a == a. + Proof. + intros. bitwise. apply xorb_false_l. + Qed. + + Lemma lxor_0_r : forall a, lxor a 0 == a. + Proof. + intros. bitwise. apply xorb_false_r. + Qed. + + Lemma lxor_comm : forall a b, lxor a b == lxor b a. + Proof. + intros. bitwise. apply xorb_comm. + Qed. + + Lemma lxor_assoc : + forall a b c, lxor (lxor a b) c == lxor a (lxor b c). + Proof. + intros. bitwise. apply xorb_assoc. + Qed. + + Lemma lor_0_l : forall a, lor 0 a == a. + Proof. + intros. bitwise. trivial. + Qed. + + Lemma lor_0_r : forall a, lor a 0 == a. + Proof. + intros. bitwise. apply orb_false_r. + Qed. + + Lemma lor_comm : forall a b, lor a b == lor b a. + Proof. + intros. bitwise. apply orb_comm. + Qed. + + Lemma lor_assoc : + forall a b c, lor a (lor b c) == lor (lor a b) c. + Proof. + intros. bitwise. apply orb_assoc. + Qed. + + Lemma lor_diag : forall a, lor a a == a. + Proof. + intros. bitwise. apply orb_diag. + Qed. + + Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. + Proof. + intros a b H. bitwise as m ?. + apply (orb_false_iff a.[m] b.[m]). + now rewrite <- lor_spec, H, bits_0. + Qed. + + Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. + Proof. + intros a b. split. + - intro H; split. + + now apply lor_eq_0_l in H. + + rewrite lor_comm in H. now apply lor_eq_0_l in H. + - intros (EQ,EQ'). now rewrite EQ, lor_0_l. + Qed. + + Lemma land_0_l : forall a, land 0 a == 0. + Proof. + intros. bitwise. trivial. + Qed. + + Lemma land_0_r : forall a, land a 0 == 0. + Proof. + intros. bitwise. apply andb_false_r. + Qed. + + Lemma land_comm : forall a b, land a b == land b a. + Proof. + intros. bitwise. apply andb_comm. + Qed. + + Lemma land_assoc : + forall a b c, land a (land b c) == land (land a b) c. + Proof. + intros. bitwise. apply andb_assoc. + Qed. + + Lemma land_diag : forall a, land a a == a. + Proof. + intros. bitwise. apply andb_diag. + Qed. + + Lemma ldiff_0_l : forall a, ldiff 0 a == 0. + Proof. + intros. bitwise. trivial. + Qed. + + Lemma ldiff_0_r : forall a, ldiff a 0 == a. + Proof. + intros. bitwise. now rewrite andb_true_r. + Qed. + + Lemma ldiff_diag : forall a, ldiff a a == 0. + Proof. + intros. bitwise. apply andb_negb_r. + Qed. + + Lemma lor_land_distr_l : forall a b c, + lor (land a b) c == land (lor a c) (lor b c). + Proof. + intros. bitwise. apply orb_andb_distrib_l. + Qed. + + Lemma lor_land_distr_r : forall a b c, + lor a (land b c) == land (lor a b) (lor a c). + Proof. + intros. bitwise. apply orb_andb_distrib_r. + Qed. + + Lemma land_lor_distr_l : forall a b c, + land (lor a b) c == lor (land a c) (land b c). + Proof. + intros. bitwise. apply andb_orb_distrib_l. + Qed. + + Lemma land_lor_distr_r : forall a b c, + land a (lor b c) == lor (land a b) (land a c). + Proof. + intros. bitwise. apply andb_orb_distrib_r. + Qed. + + Lemma ldiff_ldiff_l : forall a b c, + ldiff (ldiff a b) c == ldiff a (lor b c). + Proof. + intros. bitwise. now rewrite negb_orb, andb_assoc. + Qed. + + Lemma lor_ldiff_and : forall a b, + lor (ldiff a b) (land a b) == a. + Proof. + intros. bitwise. + now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. + Qed. + + Lemma land_ldiff : forall a b, + land (ldiff a b) b == 0. + Proof. + intros. bitwise. + now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. + Qed. + + (** Properties of [setbit] and [clearbit] *) + + Definition setbit a n := lor a (1 << n). + Definition clearbit a n := ldiff a (1 << n). + + Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n). + Proof. + intros. unfold setbit. now rewrite shiftl_1_l. + Qed. + + Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n). + Proof. + intros. unfold clearbit. now rewrite shiftl_1_l. + Qed. + + #[global] + Instance setbit_wd : Proper (eq==>eq==>eq) setbit. + Proof. unfold setbit. solve_proper. Qed. + + #[global] + Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. + Proof. unfold clearbit. solve_proper. Qed. + + Lemma pow2_bits_true : forall n, 0<=n -> (2^n).[n] = true. + Proof. + intros n ?. rewrite <- (mul_1_l (2^n)). + now rewrite mul_pow2_bits, sub_diag, bit0_odd, odd_1. + Qed. + + Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. + Proof. + intros n m ?. + destruct (le_gt_cases 0 n); [|now rewrite pow_neg_r, bits_0]. + destruct (le_gt_cases n m). + - rewrite <- (mul_1_l (2^n)), mul_pow2_bits; trivial. + rewrite <- (succ_pred (m-n)), <- div2_bits. + + now rewrite div_small, bits_0 by (split; order'). + + rewrite <- lt_succ_r, succ_pred, lt_0_sub. order. + - rewrite <- (mul_1_l (2^n)), mul_pow2_bits_low; trivial. + Qed. + + Lemma pow2_bits_eqb : forall n m, 0<=n -> (2^n).[m] = eqb n m. + Proof. + intros n m Hn. apply eq_true_iff_eq. rewrite eqb_eq. split. + - destruct (eq_decidable n m) as [H|H]. { trivial. } + now rewrite (pow2_bits_false _ _ H). + - intros EQ. rewrite EQ. apply pow2_bits_true; order. + Qed. + + Lemma setbit_eqb : forall a n m, 0<=n -> + (setbit a n).[m] = eqb n m || a.[m]. + Proof. + intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. + Qed. + + Lemma setbit_iff : forall a n m, 0<=n -> + ((setbit a n).[m] = true <-> n==m \/ a.[m] = true). + Proof. + intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. + Qed. + + Lemma setbit_eq : forall a n, 0<=n -> (setbit a n).[n] = true. + Proof. + intros. apply setbit_iff; trivial. now left. + Qed. + + Lemma setbit_neq : forall a n m, 0<=n -> n~=m -> + (setbit a n).[m] = a.[m]. + Proof. + intros a n m Hn H. rewrite setbit_eqb; trivial. + rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. + Qed. + + Lemma clearbit_eqb : forall a n m, + (clearbit a n).[m] = a.[m] && negb (eqb n m). + Proof. + intros a n m. + destruct (le_gt_cases 0 m); [| now rewrite 2 testbit_neg_r]. + rewrite clearbit_spec', ldiff_spec. f_equal. f_equal. + destruct (le_gt_cases 0 n) as [Hn|Hn]. + - now apply pow2_bits_eqb. + - symmetry. rewrite pow_neg_r, bits_0, <- not_true_iff_false, eqb_eq; order. + Qed. + + Lemma clearbit_iff : forall a n m, + (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. + Proof. + intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. + now rewrite negb_true_iff, not_true_iff_false. + Qed. + + Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. + Proof. + intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + apply andb_false_r. + Qed. + + Lemma clearbit_neq : forall a n m, n~=m -> + (clearbit a n).[m] = a.[m]. + Proof. + intros a n m H. rewrite clearbit_eqb. + rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. + apply andb_true_r. + Qed. + + (** Shifts of bitwise operations *) + + Lemma shiftl_lxor : forall a b n, + (lxor a b) << n == lxor (a << n) (b << n). + Proof. + intros. bitwise. now rewrite !shiftl_spec, lxor_spec. + Qed. + + Lemma shiftr_lxor : forall a b n, + (lxor a b) >> n == lxor (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec, lxor_spec. + Qed. + + Lemma shiftl_land : forall a b n, + (land a b) << n == land (a << n) (b << n). + Proof. + intros. bitwise. now rewrite !shiftl_spec, land_spec. + Qed. + + Lemma shiftr_land : forall a b n, + (land a b) >> n == land (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec, land_spec. + Qed. + + Lemma shiftl_lor : forall a b n, + (lor a b) << n == lor (a << n) (b << n). + Proof. + intros. bitwise. now rewrite !shiftl_spec, lor_spec. + Qed. + + Lemma shiftr_lor : forall a b n, + (lor a b) >> n == lor (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec, lor_spec. + Qed. + + Lemma shiftl_ldiff : forall a b n, + (ldiff a b) << n == ldiff (a << n) (b << n). + Proof. + intros. bitwise. now rewrite !shiftl_spec, ldiff_spec. + Qed. + + Lemma shiftr_ldiff : forall a b n, + (ldiff a b) >> n == ldiff (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec, ldiff_spec. + Qed. + + (** For integers, we do have a binary complement function *) + + Definition lnot a := P (-a). + + #[global] + Instance lnot_wd : Proper (eq==>eq) lnot. + Proof. unfold lnot. solve_proper. Qed. + + Lemma lnot_spec : forall a n, 0<=n -> (lnot a).[n] = negb a.[n]. + Proof. + intros a n ?. unfold lnot. rewrite <- (opp_involutive a) at 2. + rewrite bits_opp, negb_involutive; trivial. + Qed. + + Lemma lnot_involutive : forall a, lnot (lnot a) == a. + Proof. + intros a. bitwise. now rewrite 2 lnot_spec, negb_involutive. + Qed. + + Lemma lnot_0 : lnot 0 == -1. + Proof. + unfold lnot. now rewrite opp_0, <- sub_1_r, sub_0_l. + Qed. + + Lemma lnot_m1 : lnot (-1) == 0. + Proof. + unfold lnot. now rewrite opp_involutive, one_succ, pred_succ. + Qed. + + (** Complement and other operations *) + + Lemma lor_m1_r : forall a, lor a (-1) == -1. + Proof. + intros. bitwise. now rewrite bits_m1, orb_true_r. + Qed. + + Lemma lor_m1_l : forall a, lor (-1) a == -1. + Proof. + intros. now rewrite lor_comm, lor_m1_r. + Qed. + + Lemma land_m1_r : forall a, land a (-1) == a. + Proof. + intros. bitwise. now rewrite bits_m1, andb_true_r. + Qed. + + Lemma land_m1_l : forall a, land (-1) a == a. + Proof. + intros. now rewrite land_comm, land_m1_r. + Qed. + + Lemma ldiff_m1_r : forall a, ldiff a (-1) == 0. + Proof. + intros. bitwise. now rewrite bits_m1, andb_false_r. + Qed. + + Lemma ldiff_m1_l : forall a, ldiff (-1) a == lnot a. + Proof. + intros. bitwise. now rewrite lnot_spec, bits_m1. + Qed. + + Lemma lor_lnot_diag : forall a, lor a (lnot a) == -1. + Proof. + intros a. bitwise as m ?. rewrite lnot_spec, bits_m1; trivial. + now destruct a.[m]. + Qed. + + Lemma add_lnot_diag : forall a, a + lnot a == -1. + Proof. + intros a. unfold lnot. + now rewrite add_pred_r, add_opp_r, sub_diag, one_succ, opp_succ, opp_0. + Qed. + + Lemma ldiff_land : forall a b, ldiff a b == land a (lnot b). + Proof. + intros. bitwise. now rewrite lnot_spec. + Qed. + + Lemma land_lnot_diag : forall a, land a (lnot a) == 0. + Proof. + intros. now rewrite <- ldiff_land, ldiff_diag. + Qed. + + Lemma lnot_lor : forall a b, lnot (lor a b) == land (lnot a) (lnot b). + Proof. + intros a b. bitwise. now rewrite !lnot_spec, lor_spec, negb_orb. + Qed. + + Lemma lnot_land : forall a b, lnot (land a b) == lor (lnot a) (lnot b). + Proof. + intros a b. bitwise. now rewrite !lnot_spec, land_spec, negb_andb. + Qed. + + Lemma lnot_ldiff : forall a b, lnot (ldiff a b) == lor (lnot a) b. + Proof. + intros a b. bitwise. + now rewrite !lnot_spec, ldiff_spec, negb_andb, negb_involutive. + Qed. + + Lemma lxor_lnot_lnot : forall a b, lxor (lnot a) (lnot b) == lxor a b. + Proof. + intros a b. bitwise. now rewrite !lnot_spec, xorb_negb_negb. + Qed. + + Lemma lnot_lxor_l : forall a b, lnot (lxor a b) == lxor (lnot a) b. + Proof. + intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_l. + Qed. + + Lemma lnot_lxor_r : forall a b, lnot (lxor a b) == lxor a (lnot b). + Proof. + intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_r. + Qed. + + Lemma lxor_m1_r : forall a, lxor a (-1) == lnot a. + Proof. + intros a. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot. + Qed. + + Lemma lxor_m1_l : forall a, lxor (-1) a == lnot a. + Proof. + intros. now rewrite lxor_comm, lxor_m1_r. + Qed. + + Lemma lxor_lor : forall a b, land a b == 0 -> + lxor a b == lor a b. + Proof. + intros a b H. bitwise as m ?. + assert (a.[m] && b.[m] = false) + by now rewrite <- land_spec, H, bits_0. + now destruct a.[m], b.[m]. + Qed. + + Lemma lnot_shiftr : forall a n, 0<=n -> lnot (a >> n) == (lnot a) >> n. + Proof. + intros a n Hn. bitwise. + now rewrite lnot_spec, 2 shiftr_spec, lnot_spec by order_pos. + Qed. + + (** [(ones n)] is [2^n-1], the number with [n] digits 1 *) + + Definition ones n := P (1<eq) ones. + Proof. unfold ones. solve_proper. Qed. + + Lemma ones_equiv : forall n, ones n == P (2^n). + Proof. + intros n. unfold ones. + destruct (le_gt_cases 0 n). + - now rewrite shiftl_mul_pow2, mul_1_l. + - f_equiv. rewrite pow_neg_r; trivial. + rewrite <- shiftr_opp_r. apply shiftr_eq_0_iff. right; split. + { order'. } + rewrite log2_1. now apply opp_pos_neg. + Qed. + + Lemma ones_add : forall n m, 0<=n -> 0<=m -> + ones (m+n) == 2^m * ones n + ones m. + Proof. + intros n m Hn Hm. rewrite !ones_equiv. + rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r by trivial. + rewrite add_sub_assoc, sub_add. reflexivity. + Qed. + + Lemma ones_div_pow2 : forall n m, 0<=m<=n -> ones n / 2^m == ones (n-m). + Proof. + intros n m (Hm,H). symmetry. apply div_unique with (ones m). + - left. rewrite ones_equiv. split. + + rewrite <- lt_succ_r, succ_pred. order_pos. + + now rewrite <- le_succ_l, succ_pred. + - rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). + apply ones_add; trivial. now apply le_0_sub. + Qed. + + Lemma ones_mod_pow2 : forall n m, 0<=m<=n -> (ones n) mod (2^m) == ones m. + Proof. + intros n m (Hm,H). symmetry. apply mod_unique with (ones (n-m)). + - left. rewrite ones_equiv. split. + + rewrite <- lt_succ_r, succ_pred. order_pos. + + now rewrite <- le_succ_l, succ_pred. + - rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). + apply ones_add; trivial. now apply le_0_sub. + Qed. + + Lemma ones_spec_low : forall n m, 0<=m (ones n).[m] = true. + Proof. + intros n m (Hm,H). apply testbit_true; trivial. + rewrite ones_div_pow2 by (split; order). + rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. + - rewrite ones_equiv. now nzsimpl'. + - split. { order'. } apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. + Qed. + + Lemma ones_spec_high : forall n m, 0<=n<=m -> (ones n).[m] = false. + Proof. + intros n m (Hn,H). le_elim Hn. + - apply bits_above_log2; rewrite ones_equiv. + + rewrite <-lt_succ_r, succ_pred; order_pos. + + rewrite log2_pred_pow2; trivial. now rewrite <-le_succ_l, succ_pred. + - rewrite ones_equiv. now rewrite <- Hn, pow_0_r, one_succ, pred_succ, bits_0. + Qed. + + Lemma ones_spec_iff : forall n m, 0<=n -> + ((ones n).[m] = true <-> 0<=m log2 a < n -> + lor a (ones n) == ones n. + Proof. + intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). + - rewrite ones_spec_high, bits_above_log2; try split; trivial. + + now apply lt_le_trans with n. + + apply le_trans with (log2 a); order_pos. + - rewrite ones_spec_low, orb_true_r; try split; trivial. + Qed. + + Lemma land_ones : forall a n, 0<=n -> land a (ones n) == a mod 2^n. + Proof. + intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). + - rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r; + try split; trivial. + - rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r; + try split; trivial. + Qed. + + Lemma land_ones_low : forall a n, 0<=a -> log2 a < n -> + land a (ones n) == a. + Proof. + intros a n Ha H. + assert (Hn : 0<=n) by (generalize (log2_nonneg a); order). + rewrite land_ones; trivial. apply mod_small. + split; trivial. + apply log2_lt_cancel. now rewrite log2_pow2. + Qed. + + Lemma ldiff_ones_r : forall a n, 0<=n -> + ldiff a (ones n) == (a >> n) << n. + Proof. + intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). + - rewrite ones_spec_high, shiftl_spec_high, shiftr_spec; trivial. + + rewrite sub_add; trivial. apply andb_true_r. + + now apply le_0_sub. + + now split. + - rewrite ones_spec_low, shiftl_spec_low, andb_false_r; + try split; trivial. + Qed. + + Lemma ldiff_ones_r_low : forall a n, 0<=a -> log2 a < n -> + ldiff a (ones n) == 0. + Proof. + intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). + - rewrite ones_spec_high, bits_above_log2; trivial. + + now apply lt_le_trans with n. + + split; trivial. now apply le_trans with (log2 a); order_pos. + - rewrite ones_spec_low, andb_false_r; try split; trivial. + Qed. + + Lemma ldiff_ones_l_low : forall a n, 0<=a -> log2 a < n -> + ldiff (ones n) a == lxor a (ones n). + Proof. + intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). + - rewrite ones_spec_high, bits_above_log2; trivial. + + now apply lt_le_trans with n. + + split; trivial. now apply le_trans with (log2 a); order_pos. + - rewrite ones_spec_low, xorb_true_r; try split; trivial. + Qed. + + (** Bitwise operations and sign *) + + Lemma shiftl_nonneg : forall a n, 0 <= (a << n) <-> 0 <= a. + Proof. + intros a n. + destruct (le_ge_cases 0 n) as [Hn|Hn]. + - (* 0<=n *) + rewrite 2 bits_iff_nonneg_ex. split; intros (k,Hk). + + exists (k-n). intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite <- (add_simpl_r m n), <- (shiftl_spec a n) by order_pos. + apply Hk. now apply lt_sub_lt_add_r. + + exists (k+n). intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite shiftl_spec by trivial. apply Hk. now apply lt_add_lt_sub_r. + - (* n<=0*) + rewrite <- shiftr_opp_r, 2 bits_iff_nonneg_ex. split; intros (k,Hk). + + destruct (le_gt_cases 0 k). + * exists (k-n). intros m Hm. apply lt_sub_lt_add_r in Hm. + rewrite <- (add_simpl_r m n), <- add_opp_r, <- (shiftr_spec a (-n)) by order. + now apply Hk. + * assert (EQ : a >> (-n) == 0). { + apply bits_inj'. intros m Hm. rewrite bits_0. apply Hk; order. + } + apply shiftr_eq_0_iff in EQ. + rewrite <- bits_iff_nonneg_ex. destruct EQ as [EQ|[LT _]]; order. + + exists (k+n). intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite shiftr_spec by trivial. apply Hk. + rewrite add_opp_r. now apply lt_add_lt_sub_r. + Qed. + + Lemma shiftl_neg : forall a n, (a << n) < 0 <-> a < 0. + Proof. + intros a n. now rewrite 2 lt_nge, shiftl_nonneg. + Qed. + + Lemma shiftr_nonneg : forall a n, 0 <= (a >> n) <-> 0 <= a. + Proof. + intros. rewrite <- shiftl_opp_r. apply shiftl_nonneg. + Qed. + + Lemma shiftr_neg : forall a n, (a >> n) < 0 <-> a < 0. + Proof. + intros a n. now rewrite 2 lt_nge, shiftr_nonneg. + Qed. + + Lemma div2_nonneg : forall a, 0 <= div2 a <-> 0 <= a. + Proof. + intros. rewrite div2_spec. apply shiftr_nonneg. + Qed. + + Lemma div2_neg : forall a, div2 a < 0 <-> a < 0. + Proof. + intros a. now rewrite 2 lt_nge, div2_nonneg. + Qed. + + Lemma lor_nonneg : forall a b, 0 <= lor a b <-> 0<=a /\ 0<=b. + Proof. + intros a b. + rewrite 3 bits_iff_nonneg_ex. split. + - intros (k,Hk). + split; exists k; intros m Hm; apply (orb_false_elim a.[m] b.[m]); + rewrite <- lor_spec; now apply Hk. + - intros ((k,Hk),(k',Hk')). + destruct (le_ge_cases k k'); [ exists k' | exists k ]; + intros m Hm; rewrite lor_spec, Hk, Hk'; trivial; order. + Qed. + + Lemma lor_neg : forall a b, lor a b < 0 <-> a < 0 \/ b < 0. + Proof. + intros a b. rewrite 3 lt_nge, lor_nonneg. split. + - apply not_and. apply le_decidable. + - now intros [H|H] (H',H''). + Qed. + + Lemma lnot_nonneg : forall a, 0 <= lnot a <-> a < 0. + Proof. + intros a; unfold lnot. + now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. + Qed. + + Lemma lnot_neg : forall a, lnot a < 0 <-> 0 <= a. + Proof. + intros a. now rewrite le_ngt, lt_nge, lnot_nonneg. + Qed. + + Lemma land_nonneg : forall a b, 0 <= land a b <-> 0<=a \/ 0<=b. + Proof. + intros a b. + now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_nonneg, + lor_neg, !lnot_neg. + Qed. + + Lemma land_neg : forall a b, land a b < 0 <-> a < 0 /\ b < 0. + Proof. + intros a b. + now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_neg, + lor_nonneg, !lnot_nonneg. + Qed. + + Lemma ldiff_nonneg : forall a b, 0 <= ldiff a b <-> 0<=a \/ b<0. + Proof. + intros. now rewrite ldiff_land, land_nonneg, lnot_nonneg. + Qed. + + Lemma ldiff_neg : forall a b, ldiff a b < 0 <-> a<0 /\ 0<=b. + Proof. + intros. now rewrite ldiff_land, land_neg, lnot_neg. + Qed. + + Lemma lxor_nonneg : forall a b, 0 <= lxor a b <-> (0<=a <-> 0<=b). + Proof. + assert (H : forall a b, 0<=a -> 0<=b -> 0<=lxor a b). { + intros a b. rewrite 3 bits_iff_nonneg_ex. intros (k,Hk) (k', Hk'). + destruct (le_ge_cases k k'); [ exists k' | exists k]; + intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. + } + assert (H' : forall a b, 0<=a -> b<0 -> lxor a b<0). { + intros a b. rewrite bits_iff_nonneg_ex, 2 bits_iff_neg_ex. + intros (k,Hk) (k', Hk'). + destruct (le_ge_cases k k'); [ exists k' | exists k]; + intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. + } + intros a b. + split. + - intros Hab. split. + + intros Ha. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. + generalize (H' _ _ Ha Hb). order. + + intros Hb. destruct (le_gt_cases 0 a) as [Ha|Ha]; trivial. + generalize (H' _ _ Hb Ha). rewrite lxor_comm. order. + - intros E. + destruct (le_gt_cases 0 a) as [Ha|Ha]. + + apply H; trivial. apply E; trivial. + + destruct (le_gt_cases 0 b) as [Hb|Hb]. + * apply H; trivial. apply E; trivial. + * rewrite <- lxor_lnot_lnot. apply H; now apply lnot_nonneg. + Qed. + + (** Bitwise operations and log2 *) + + Lemma log2_bits_unique : forall a n, + a.[n] = true -> + (forall m, n a.[m] = false) -> + log2 a == n. + Proof. + intros a n H H'. + destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]. + - (* a < 0 *) + destruct (proj1 (bits_iff_neg_ex a) Ha) as (k,Hk). + destruct (le_gt_cases n k). + + specialize (Hk (S k) (lt_succ_diag_r _)). + rewrite H' in Hk. + * discriminate. + * apply lt_succ_r; order. + + specialize (H' (S n) (lt_succ_diag_r _)). + rewrite Hk in H'. + * discriminate. + * apply lt_succ_r; order. + - (* a = 0 *) + now rewrite Ha, bits_0 in H. + - (* 0 < a *) + apply le_antisymm; apply le_ngt; intros LT. + + specialize (H' _ LT). now rewrite bit_log2 in H'. + + now rewrite bits_above_log2 in H by order. + Qed. + + Lemma log2_shiftr : forall a n, 0 log2 (a >> n) == max 0 (log2 a - n). + Proof. + intros a n Ha. + destruct (le_gt_cases 0 (log2 a - n)) as [H|H]; + [rewrite max_r | rewrite max_l]; try order. + - apply log2_bits_unique. + + now rewrite shiftr_spec, sub_add, bit_log2. + + intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite shiftr_spec; trivial. apply bits_above_log2; try order. + now apply lt_sub_lt_add_r. + - rewrite lt_sub_lt_add_r, add_0_l in H. + apply log2_nonpos. apply le_lteq; right. + apply shiftr_eq_0_iff. right. now split. + Qed. + + Lemma log2_shiftl : forall a n, 0 0<=n -> log2 (a << n) == log2 a + n. + Proof. + intros a n Ha Hn. + rewrite shiftl_mul_pow2, add_comm by trivial. + now apply log2_mul_pow2. + Qed. + + Lemma log2_shiftl' : forall a n, 0 log2 (a << n) == max 0 (log2 a + n). + Proof. + intros a n Ha. + rewrite <- shiftr_opp_r, log2_shiftr by trivial. + destruct (le_gt_cases 0 (log2 a + n)); + [rewrite 2 max_r | rewrite 2 max_l]; rewrite ?sub_opp_r; try order. + Qed. + + Lemma log2_lor : forall a b, 0<=a -> 0<=b -> + log2 (lor a b) == max (log2 a) (log2 b). + Proof. + assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lor a b) == log2 b). { + intros a b Ha H. + le_elim Ha; [|now rewrite <- Ha, lor_0_l]. + apply log2_bits_unique. + - now rewrite lor_spec, bit_log2, orb_true_r by order. + - intros m Hm. assert (H' := log2_le_mono _ _ H). + now rewrite lor_spec, 2 bits_above_log2 by order. + } + (* main *) + intros a b Ha Hb. destruct (le_ge_cases a b) as [H|H]. + - rewrite max_r by now apply log2_le_mono. + now apply AUX. + - rewrite max_l by now apply log2_le_mono. + rewrite lor_comm. now apply AUX. + Qed. + + Lemma log2_land : forall a b, 0<=a -> 0<=b -> + log2 (land a b) <= min (log2 a) (log2 b). + Proof. + assert (AUX : forall a b, 0<=a -> a<=b -> log2 (land a b) <= log2 a). { + intros a b Ha Hb. + apply le_ngt. intros LT. + assert (H : 0 <= land a b) by (apply land_nonneg; now left). + le_elim H. + - generalize (bit_log2 (land a b) H). + now rewrite land_spec, bits_above_log2. + - rewrite <- H in LT. apply log2_lt_cancel in LT; order. + } + (* main *) + intros a b Ha Hb. + destruct (le_ge_cases a b) as [H|H]. + - rewrite min_l by now apply log2_le_mono. now apply AUX. + - rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. + Qed. + + Lemma log2_lxor : forall a b, 0<=a -> 0<=b -> + log2 (lxor a b) <= max (log2 a) (log2 b). + Proof. + assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lxor a b) <= log2 b). { + intros a b Ha Hb. + apply le_ngt. intros LT. + assert (H : 0 <= lxor a b) by (apply lxor_nonneg; split; order). + le_elim H. + - generalize (bit_log2 (lxor a b) H). + rewrite lxor_spec, 2 bits_above_log2; try order. + + discriminate. + + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. + - rewrite <- H in LT. apply log2_lt_cancel in LT; order. + } + (* main *) + intros a b Ha Hb. + destruct (le_ge_cases a b) as [H|H]. + - rewrite max_r by now apply log2_le_mono. now apply AUX. + - rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. + Qed. + + (** Bitwise operations and arithmetical operations *) + + #[local] Notation xor3 a b c := (xorb (xorb a b) c). + #[local] Notation lxor3 a b c := (lxor (lxor a b) c). + #[local] Notation nextcarry a b c := ((a&&b) || (c && (a||b))). + #[local] Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). + + Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. + Proof. + intros. now rewrite !bit0_odd, odd_add. + Qed. + + Lemma add3_bit0 : forall a b c, + (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. + Proof. + intros. now rewrite !add_bit0. + Qed. + + Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), + (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. + Proof. + assert (H : 1+1 == 2) by now nzsimpl'. + intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; + (apply div_same; order') || (apply div_small; split; order') || idtac. + symmetry. apply div_unique with 1. + - left; split; order'. + - now nzsimpl'. + Qed. + + Lemma add_carry_div2 : forall a b (c0:bool), + (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. + Proof. + intros a b c0. + rewrite <- add3_bits_div2. + rewrite (add_comm ((a/2)+_)). + rewrite <- div_add by order'. + f_equiv. + rewrite <- !div2_div, mul_comm, mul_add_distr_l. + rewrite (div2_odd a), <- bit0_odd at 1. + rewrite (div2_odd b), <- bit0_odd at 1. + rewrite add_shuffle1. + rewrite <-(add_assoc _ _ c0). apply add_comm. + Qed. + + (** The main result concerning addition: we express the bits of the sum in term of bits of [a] and [b] and of some carry stream which is also recursively determined by another equation. *) -Lemma add_carry_bits_aux : forall n, 0<=n -> - forall a b (c0:bool), -(2^n) <= a < 2^n -> -(2^n) <= b < 2^n -> - exists c, + Lemma add_carry_bits_aux : forall n, 0<=n -> + forall a b (c0:bool), -(2^n) <= a < 2^n -> -(2^n) <= b < 2^n -> + exists c, + a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. + Proof. + intros n Hn. apply le_ind with (4:=Hn). + - solve_proper. + - (* base *) + intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r, <- !one_succ. + intros (Ha1,Ha2) (Hb1,Hb2). + le_elim Ha1; rewrite <- ?le_succ_l, ?succ_m1 in Ha1; + le_elim Hb1; rewrite <- ?le_succ_l, ?succ_m1 in Hb1. + + (* base, a = 0, b = 0 *) + exists c0. + rewrite (le_antisymm _ _ Ha2 Ha1), (le_antisymm _ _ Hb2 Hb1). + rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. + rewrite b2z_div2, b2z_bit0; now repeat split. + + (* base, a = 0, b = -1 *) + exists (-c0). rewrite <- Hb1, (le_antisymm _ _ Ha2 Ha1). repeat split. + * rewrite add_0_l, lxor_0_l, lxor_m1_l. + unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. + * rewrite land_0_l, !lor_0_l, land_m1_r. + symmetry. apply div_unique with c0. { left; destruct c0; simpl; split; order'. } + now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. + * rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. + + (* base, a = -1, b = 0 *) + exists (-c0). rewrite <- Ha1, (le_antisymm _ _ Hb2 Hb1). repeat split. + * rewrite add_0_r, lxor_0_r, lxor_m1_l. + unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. + * rewrite land_0_r, lor_0_r, lor_0_l, land_m1_r. + symmetry. apply div_unique with c0. { left; destruct c0; simpl; split; order'. } + now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. + * rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. + + (* base, a = -1, b = -1 *) + exists (c0 + 2*(-1)). rewrite <- Ha1, <- Hb1. repeat split. + * rewrite lxor_m1_l, lnot_m1, lxor_0_l. + now rewrite two_succ, mul_succ_l, mul_1_l, add_comm, add_assoc. + * rewrite land_m1_l, lor_m1_l. + apply add_b2z_double_div2. + * apply add_b2z_double_bit0. + - (* step *) + clear n Hn. intros n Hn IH a b c0 Ha Hb. + set (c1:=nextcarry a.[0] b.[0] c0). + destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. + + split. + * apply div_le_lower_bound. { order'. } now rewrite mul_opp_r, <- pow_succ_r. + * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. + + split. + * apply div_le_lower_bound. { order'. } now rewrite mul_opp_r, <- pow_succ_r. + * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. + + exists (c0 + 2*c). repeat split. + * { (* step, add *) + bitwise as m Hm. + le_elim Hm. + - rewrite <- (succ_pred m), lt_succ_r in Hm. + rewrite <- (succ_pred m), <- !div2_bits, <- 2 lxor_spec by trivial. + f_equiv. + rewrite add_b2z_double_div2, <- IH1. apply add_carry_div2. + - rewrite <- Hm. + now rewrite add_b2z_double_bit0, add3_bit0, b2z_bit0. + } + * { (* step, carry *) + rewrite add_b2z_double_div2. + bitwise as m Hm. + le_elim Hm. + - rewrite <- (succ_pred m), lt_succ_r in Hm. + rewrite <- (succ_pred m), <- !div2_bits, IH2 by trivial. + autorewrite with bitwise. now rewrite add_b2z_double_div2. + - rewrite <- Hm. + now rewrite add_b2z_double_bit0. + } + * (* step, carry0 *) + apply add_b2z_double_bit0. + Qed. + + Lemma add_carry_bits : forall a b (c0:bool), exists c, a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. -Proof. - intros n Hn. apply le_ind with (4:=Hn). - - solve_proper. - - (* base *) - intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r, <- !one_succ. - intros (Ha1,Ha2) (Hb1,Hb2). - le_elim Ha1; rewrite <- ?le_succ_l, ?succ_m1 in Ha1; - le_elim Hb1; rewrite <- ?le_succ_l, ?succ_m1 in Hb1. - + (* base, a = 0, b = 0 *) - exists c0. - rewrite (le_antisymm _ _ Ha2 Ha1), (le_antisymm _ _ Hb2 Hb1). - rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. - rewrite b2z_div2, b2z_bit0; now repeat split. - + (* base, a = 0, b = -1 *) - exists (-c0). rewrite <- Hb1, (le_antisymm _ _ Ha2 Ha1). repeat split. - * rewrite add_0_l, lxor_0_l, lxor_m1_l. - unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. - * rewrite land_0_l, !lor_0_l, land_m1_r. - symmetry. apply div_unique with c0. { left; destruct c0; simpl; split; order'. } - now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. - * rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. - + (* base, a = -1, b = 0 *) - exists (-c0). rewrite <- Ha1, (le_antisymm _ _ Hb2 Hb1). repeat split. - * rewrite add_0_r, lxor_0_r, lxor_m1_l. - unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. - * rewrite land_0_r, lor_0_r, lor_0_l, land_m1_r. - symmetry. apply div_unique with c0. { left; destruct c0; simpl; split; order'. } - now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. - * rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. - + (* base, a = -1, b = -1 *) - exists (c0 + 2*(-1)). rewrite <- Ha1, <- Hb1. repeat split. - * rewrite lxor_m1_l, lnot_m1, lxor_0_l. - now rewrite two_succ, mul_succ_l, mul_1_l, add_comm, add_assoc. - * rewrite land_m1_l, lor_m1_l. - apply add_b2z_double_div2. - * apply add_b2z_double_bit0. - - (* step *) - clear n Hn. intros n Hn IH a b c0 Ha Hb. - set (c1:=nextcarry a.[0] b.[0] c0). - destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. - + split. - * apply div_le_lower_bound. { order'. } now rewrite mul_opp_r, <- pow_succ_r. - * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. - + split. - * apply div_le_lower_bound. { order'. } now rewrite mul_opp_r, <- pow_succ_r. - * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. - + exists (c0 + 2*c). repeat split. - * { (* step, add *) - bitwise as m Hm. - le_elim Hm. - - rewrite <- (succ_pred m), lt_succ_r in Hm. - rewrite <- (succ_pred m), <- !div2_bits, <- 2 lxor_spec by trivial. - f_equiv. - rewrite add_b2z_double_div2, <- IH1. apply add_carry_div2. - - rewrite <- Hm. - now rewrite add_b2z_double_bit0, add3_bit0, b2z_bit0. - } - * { (* step, carry *) - rewrite add_b2z_double_div2. - bitwise as m Hm. - le_elim Hm. - - rewrite <- (succ_pred m), lt_succ_r in Hm. - rewrite <- (succ_pred m), <- !div2_bits, IH2 by trivial. - autorewrite with bitwise. now rewrite add_b2z_double_div2. - - rewrite <- Hm. - now rewrite add_b2z_double_bit0. - } - * (* step, carry0 *) - apply add_b2z_double_bit0. -Qed. - -Lemma add_carry_bits : forall a b (c0:bool), exists c, - a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. -Proof. - intros a b c0. - set (n := max (abs a) (abs b)). - apply (add_carry_bits_aux n). - - (* positivity *) - unfold n. - destruct (le_ge_cases (abs a) (abs b)); - [rewrite max_r|rewrite max_l]; order_pos'. - - (* bound for a *) - assert (Ha : abs a < 2^n). - + apply lt_le_trans with (2^(abs a)). - * apply pow_gt_lin_r; order_pos'. - * apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases (abs a) (abs b)); - [rewrite max_r|rewrite max_l]; try order. - + apply abs_lt in Ha. destruct Ha; split; order. - - (* bound for b *) - assert (Hb : abs b < 2^n). { - apply lt_le_trans with (2^(abs b)). - - apply pow_gt_lin_r; order_pos'. - - apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases (abs a) (abs b)); - [rewrite max_r|rewrite max_l]; try order. - } - apply abs_lt in Hb. destruct Hb; split; order. -Qed. - -(** Particular case : the second bit of an addition *) - -Lemma add_bit1 : forall a b, - (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). -Proof. - intros a b. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - autorewrite with bitwise. f_equal. - rewrite one_succ, <- div2_bits, EQ2 by order. - autorewrite with bitwise. - rewrite Hc. simpl. apply orb_false_r. -Qed. - -(** In an addition, there will be no carries iff there is + Proof. + intros a b c0. + set (n := max (abs a) (abs b)). + apply (add_carry_bits_aux n). + - (* positivity *) + unfold n. + destruct (le_ge_cases (abs a) (abs b)); + [rewrite max_r|rewrite max_l]; order_pos'. + - (* bound for a *) + assert (Ha : abs a < 2^n). + + apply lt_le_trans with (2^(abs a)). + * apply pow_gt_lin_r; order_pos'. + * apply pow_le_mono_r. { order'. } unfold n. + destruct (le_ge_cases (abs a) (abs b)); + [rewrite max_r|rewrite max_l]; try order. + + apply abs_lt in Ha. destruct Ha; split; order. + - (* bound for b *) + assert (Hb : abs b < 2^n). { + apply lt_le_trans with (2^(abs b)). + - apply pow_gt_lin_r; order_pos'. + - apply pow_le_mono_r. { order'. } unfold n. + destruct (le_ge_cases (abs a) (abs b)); + [rewrite max_r|rewrite max_l]; try order. + } + apply abs_lt in Hb. destruct Hb; split; order. + Qed. + + (** Particular case : the second bit of an addition *) + + Lemma add_bit1 : forall a b, + (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). + Proof. + intros a b. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + autorewrite with bitwise. f_equal. + rewrite one_succ, <- div2_bits, EQ2 by order. + autorewrite with bitwise. + rewrite Hc. simpl. apply orb_false_r. + Qed. + + (** In an addition, there will be no carries iff there is no common bits in the numbers to add *) -Lemma nocarry_equiv : forall a b c, - c/2 == lnextcarry a b c -> c.[0] = false -> - (c == 0 <-> land a b == 0). -Proof. - intros a b c H H'. - split. - - intros EQ; rewrite EQ in *. - rewrite div_0_l in H by order'. - symmetry in H. now apply lor_eq_0_l in H. - - intros EQ. rewrite EQ, lor_0_l in H. - apply bits_inj'. intros n Hn. rewrite bits_0. - apply le_ind with (4:=Hn). - + solve_proper. - + trivial. - + clear n Hn. intros n Hn IH. - rewrite <- div2_bits, H; trivial. - autorewrite with bitwise. - now rewrite IH. -Qed. - -(** When there is no common bits, the addition is just a xor *) - -Lemma add_nocarry_lxor : forall a b, land a b == 0 -> - a+b == lxor a b. -Proof. - intros a b H. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - apply (nocarry_equiv a b c) in H; trivial. - rewrite H. now rewrite lxor_0_r. -Qed. - -(** A null [ldiff] implies being smaller *) - -Lemma ldiff_le : forall a b, 0<=b -> ldiff a b == 0 -> 0 <= a <= b. -Proof. - assert (AUX : forall n, 0<=n -> - forall a b, 0 <= a < 2^n -> 0<=b -> ldiff a b == 0 -> a <= b). { - intros n Hn. apply le_ind with (4:=Hn); clear n Hn. - - solve_proper. - - intros a b Ha Hb _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. - setoid_replace a with 0 by (destruct Ha; order'); trivial. - - intros n Hn IH a b (Ha,Ha') Hb H. - assert (NEQ : 2 ~= 0) by order'. - rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). - apply add_le_mono. - + apply mul_le_mono_pos_l; try order'. - apply IH. - * split. { apply div_pos; order'. } - apply div_lt_upper_bound; try order'. now rewrite <- pow_succ_r. - * apply div_pos; order'. - * rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2 by order'. - rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l; order'. - + rewrite <- 2 bit0_mod. - apply bits_inj_iff in H. specialize (H 0). - rewrite ldiff_spec, bits_0 in H. - destruct a.[0], b.[0]; try discriminate; simpl; order'. - } - (* main *) - intros a b Hb Hd. - assert (Ha : 0<=a). - { apply le_ngt; intros Ha'. apply (lt_irrefl 0). rewrite <- Hd at 1. - apply ldiff_neg. now split. } - split; trivial. apply (AUX a); try split; trivial. apply pow_gt_lin_r; order'. -Qed. - -(** Subtraction can be a ldiff when the opposite ldiff is null. *) - -Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> - a-b == ldiff a b. -Proof. - intros a b H. - apply add_cancel_r with b. - rewrite sub_add. - symmetry. - rewrite add_nocarry_lxor; trivial. - - bitwise as m ?. - apply bits_inj_iff in H. specialize (H m). - rewrite ldiff_spec, bits_0 in H. - now destruct a.[m], b.[m]. - - apply land_ldiff. -Qed. - -(** Adding numbers with no common bits cannot lead to a much bigger number *) - -Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> - a < 2^n -> b < 2^n -> a+b < 2^n. -Proof. - intros a b n H Ha Hb. - destruct (le_gt_cases a 0) as [Ha'|Ha']. - - apply le_lt_trans with (0+b). - + now apply add_le_mono_r. - + now nzsimpl. - - destruct (le_gt_cases b 0) as [Hb'|Hb']. - + apply le_lt_trans with (a+0). - * now apply add_le_mono_l. - * now nzsimpl. - + rewrite add_nocarry_lxor by order. - destruct (lt_ge_cases 0 (lxor a b)); [|apply le_lt_trans with 0; order_pos]. - apply log2_lt_pow2; trivial. - apply log2_lt_pow2 in Ha; trivial. - apply log2_lt_pow2 in Hb; trivial. - apply le_lt_trans with (max (log2 a) (log2 b)). - * apply log2_lxor; order. - * destruct (le_ge_cases (log2 a) (log2 b)); - [rewrite max_r|rewrite max_l]; order. -Qed. - -Lemma add_nocarry_mod_lt_pow2 : forall a b n, 0<=n -> land a b == 0 -> - a mod 2^n + b mod 2^n < 2^n. -Proof. - intros a b n Hn H. - apply add_nocarry_lt_pow2. - - bitwise as m ?. - destruct (le_gt_cases n m). - + rewrite mod_pow2_bits_high; now split. - + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. - - apply mod_pos_bound; order_pos. - - apply mod_pos_bound; order_pos. -Qed. + Lemma nocarry_equiv : forall a b c, + c/2 == lnextcarry a b c -> c.[0] = false -> + (c == 0 <-> land a b == 0). + Proof. + intros a b c H H'. + split. + - intros EQ; rewrite EQ in *. + rewrite div_0_l in H by order'. + symmetry in H. now apply lor_eq_0_l in H. + - intros EQ. rewrite EQ, lor_0_l in H. + apply bits_inj'. intros n Hn. rewrite bits_0. + apply le_ind with (4:=Hn). + + solve_proper. + + trivial. + + clear n Hn. intros n Hn IH. + rewrite <- div2_bits, H; trivial. + autorewrite with bitwise. + now rewrite IH. + Qed. + + (** When there is no common bits, the addition is just a xor *) + + Lemma add_nocarry_lxor : forall a b, land a b == 0 -> + a+b == lxor a b. + Proof. + intros a b H. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + apply (nocarry_equiv a b c) in H; trivial. + rewrite H. now rewrite lxor_0_r. + Qed. + + (** A null [ldiff] implies being smaller *) + + Lemma ldiff_le : forall a b, 0<=b -> ldiff a b == 0 -> 0 <= a <= b. + Proof. + assert (AUX : forall n, 0<=n -> + forall a b, 0 <= a < 2^n -> 0<=b -> ldiff a b == 0 -> a <= b). { + intros n Hn. apply le_ind with (4:=Hn); clear n Hn. + - solve_proper. + - intros a b Ha Hb _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. + setoid_replace a with 0 by (destruct Ha; order'); trivial. + - intros n Hn IH a b (Ha,Ha') Hb H. + assert (NEQ : 2 ~= 0) by order'. + rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). + apply add_le_mono. + + apply mul_le_mono_pos_l; try order'. + apply IH. + * split. { apply div_pos; order'. } + apply div_lt_upper_bound; try order'. now rewrite <- pow_succ_r. + * apply div_pos; order'. + * rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2 by order'. + rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l; order'. + + rewrite <- 2 bit0_mod. + apply bits_inj_iff in H. specialize (H 0). + rewrite ldiff_spec, bits_0 in H. + destruct a.[0], b.[0]; try discriminate; simpl; order'. + } + (* main *) + intros a b Hb Hd. + assert (Ha : 0<=a). + { apply le_ngt; intros Ha'. apply (lt_irrefl 0). rewrite <- Hd at 1. + apply ldiff_neg. now split. } + split; trivial. apply (AUX a); try split; trivial. apply pow_gt_lin_r; order'. + Qed. + + (** Subtraction can be a ldiff when the opposite ldiff is null. *) + + Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> + a-b == ldiff a b. + Proof. + intros a b H. + apply add_cancel_r with b. + rewrite sub_add. + symmetry. + rewrite add_nocarry_lxor; trivial. + - bitwise as m ?. + apply bits_inj_iff in H. specialize (H m). + rewrite ldiff_spec, bits_0 in H. + now destruct a.[m], b.[m]. + - apply land_ldiff. + Qed. + + (** Adding numbers with no common bits cannot lead to a much bigger number *) + + Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> + a < 2^n -> b < 2^n -> a+b < 2^n. + Proof. + intros a b n H Ha Hb. + destruct (le_gt_cases a 0) as [Ha'|Ha']. + - apply le_lt_trans with (0+b). + + now apply add_le_mono_r. + + now nzsimpl. + - destruct (le_gt_cases b 0) as [Hb'|Hb']. + + apply le_lt_trans with (a+0). + * now apply add_le_mono_l. + * now nzsimpl. + + rewrite add_nocarry_lxor by order. + destruct (lt_ge_cases 0 (lxor a b)); [|apply le_lt_trans with 0; order_pos]. + apply log2_lt_pow2; trivial. + apply log2_lt_pow2 in Ha; trivial. + apply log2_lt_pow2 in Hb; trivial. + apply le_lt_trans with (max (log2 a) (log2 b)). + * apply log2_lxor; order. + * destruct (le_ge_cases (log2 a) (log2 b)); + [rewrite max_r|rewrite max_l]; order. + Qed. + + Lemma add_nocarry_mod_lt_pow2 : forall a b n, 0<=n -> land a b == 0 -> + a mod 2^n + b mod 2^n < 2^n. + Proof. + intros a b n Hn H. + apply add_nocarry_lt_pow2. + - bitwise as m ?. + destruct (le_gt_cases n m). + + rewrite mod_pow2_bits_high; now split. + + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. + - apply mod_pos_bound; order_pos. + - apply mod_pos_bound; order_pos. + Qed. End ZBitsProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v index 1d4962c2d3..0a3cf33871 100644 --- a/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -36,325 +36,325 @@ From Stdlib.Numbers.NatInt Require Import NZDiv. *) Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A). - Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b. + Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b. End EuclidSpec. Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z. Module ZEuclidProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZSgnAbsProp A B) - (Import D : ZEuclid A). + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B) + (Import D : ZEuclid A). - (** We put notations in a scope, to avoid warnings about + (** We put notations in a scope, to avoid warnings about redefinitions of notations *) - Declare Scope euclid. - Infix "/" := D.div : euclid. - Infix "mod" := D.modulo : euclid. - #[local] Open Scope euclid. - - Module Import Private_NZDiv := Nop <+ NZDivProp A D B. - -(** Another formulation of the main equation *) - -Lemma mod_eq : - forall a b, b~=0 -> a mod b == a - b*(a/b). -Proof. -intros. -rewrite <- add_move_l. -symmetry. now apply div_mod. -Qed. - -Ltac pos_or_neg a := - let LT := fresh "LT" in - let LE := fresh "LE" in - destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. - -(** Uniqueness theorems *) - -Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, - 0<=r1 0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 EQ. -pos_or_neg b. -- rewrite abs_eq in * by trivial. - apply div_mod_unique with b; trivial. -- rewrite abs_neq' in * by auto using lt_le_incl. - rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial. - rewrite 2 mul_opp_l. - rewrite add_move_l, sub_opp_r. - rewrite <-add_assoc. - symmetry. rewrite add_move_l, sub_opp_r. - now rewrite (add_comm r2), (add_comm r1). -Qed. - -Theorem div_unique: - forall a b q r, 0<=r a == b*q + r -> q == a/b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0). { - pos_or_neg b. - - rewrite abs_eq in Hr; intuition; order. - - rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. -} -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- now apply mod_always_pos. -- now rewrite <- div_mod. -Qed. - -Theorem mod_unique: - forall a b q r, 0<=r a == b*q + r -> r == a mod b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0). { - pos_or_neg b. - - rewrite abs_eq in Hr; intuition; order. - - rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. -} -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- now apply mod_always_pos. -- now rewrite <- div_mod. -Qed. - -(** Sign rules *) - -Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b). -Proof. -intros. symmetry. -apply div_unique with (a mod b). -- rewrite abs_opp; now apply mod_always_pos. -- rewrite mul_opp_opp; now apply div_mod. -Qed. - -Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b. -Proof. -intros. symmetry. -apply mod_unique with (-(a/b)). -- rewrite abs_opp; now apply mod_always_pos. -- rewrite mul_opp_opp; now apply div_mod. -Qed. - -Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> - (-a)/b == -(a/b). -Proof. -intros a b Hb Hab. symmetry. -apply div_unique with (-(a mod b)). -- rewrite Hab, opp_0. split; [order|]. - pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order. -- now rewrite mul_opp_r, <-opp_add_distr, <-div_mod. -Qed. - -Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a)/b == -(a/b)-sgn b. -Proof. -intros a b Hb Hab. symmetry. -apply div_unique with (abs b -(a mod b)). -- rewrite lt_sub_lt_add_l. - rewrite <- le_add_le_sub_l. nzsimpl. - rewrite <- (add_0_l (abs b)) at 2. - rewrite <- add_lt_mono_r. - destruct (mod_always_pos a b); intuition order. -- rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. - rewrite sgn_abs. - rewrite add_shuffle2, add_opp_diag_l; nzsimpl. - rewrite <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> - (-a) mod b == 0. -Proof. -intros a b Hb Hab. symmetry. -apply mod_unique with (-(a/b)). -- split; [order|now rewrite abs_pos]. -- now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod. -Qed. - -Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a) mod b == abs b - (a mod b). -Proof. -intros a b Hb Hab. symmetry. -apply mod_unique with (-(a/b)-sgn b). -- rewrite lt_sub_lt_add_l. - rewrite <- le_add_le_sub_l. nzsimpl. - rewrite <- (add_0_l (abs b)) at 2. - rewrite <- add_lt_mono_r. - destruct (mod_always_pos a b); intuition order. -- rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. - rewrite sgn_abs. - rewrite add_shuffle2, add_opp_diag_l; nzsimpl. - rewrite <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> - (-a)/(-b) == a/b. -Proof. -intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive. -Qed. - -Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a)/(-b) == a/b + sgn(b). -Proof. -intros. rewrite div_opp_r, div_opp_l_nz by trivial. -now rewrite opp_sub_distr, opp_involutive. -Qed. - -Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> - (-a) mod (-b) == 0. -Proof. -intros. now rewrite mod_opp_r, mod_opp_l_z. -Qed. - -Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a) mod (-b) == abs b - a mod b. -Proof. -intros. now rewrite mod_opp_r, mod_opp_l_nz. -Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, a~=0 -> a/a == 1. -Proof. -intros. symmetry. apply div_unique with 0. -- split; [order|now rewrite abs_pos]. -- now nzsimpl. -Qed. - -Lemma mod_same : forall a, a~=0 -> a mod a == 0. -Proof. -intros. -rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, 0<=a a/b == 0. -Proof. exact div_small. Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, 0<=a a mod b == a. -Proof. exact mod_small. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. -Proof. - intros. pos_or_neg a. - - apply div_0_l; order. - - apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l. -Qed. - -Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. -Proof. -intros; rewrite mod_eq, div_0_l; now nzsimpl. -Qed. - -Lemma div_1_r: forall a, a/1 == a. -Proof. -intros. symmetry. apply div_unique with 0. -- assert (H:=lt_0_1); rewrite abs_pos; intuition auto; order. -- now nzsimpl. -Qed. - -Lemma mod_1_r: forall a, a mod 1 == 0. -Proof. -intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. -apply neq_sym, lt_neq; apply lt_0_1. -Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. exact div_1_l. Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. exact mod_1_l. Qed. - -Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. -Proof. -intros. symmetry. apply div_unique with 0. -- split; [order|now rewrite abs_pos]. -- nzsimpl; apply mul_comm. -Qed. - -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. -Proof. -intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. -Qed. - -Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. -Proof. - intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. -Qed. - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a. -Proof. - intros. pos_or_neg b. - - apply mod_le; order. - - rewrite <- mod_opp_r by trivial. apply mod_le; order. -Qed. - -Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. -Proof. exact div_pos. Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. exact div_str_pos. Qed. - -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a a mod b == a - b*(a/b). + Proof. + intros. + rewrite <- add_move_l. + symmetry. now apply div_mod. + Qed. + + Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + + (** Uniqueness theorems *) + + Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + 0<=r1 0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. + Proof. + intros b q1 q2 r1 r2 Hr1 Hr2 EQ. + pos_or_neg b. + - rewrite abs_eq in * by trivial. + apply div_mod_unique with b; trivial. + - rewrite abs_neq' in * by auto using lt_le_incl. + rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial. + rewrite 2 mul_opp_l. + rewrite add_move_l, sub_opp_r. + rewrite <-add_assoc. + symmetry. rewrite add_move_l, sub_opp_r. + now rewrite (add_comm r2), (add_comm r1). + Qed. + + Theorem div_unique: + forall a b q r, 0<=r a == b*q + r -> q == a/b. + Proof. + intros a b q r Hr EQ. + assert (Hb : b~=0). { + pos_or_neg b. + - rewrite abs_eq in Hr; intuition; order. + - rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. + } + destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. + - now apply mod_always_pos. + - now rewrite <- div_mod. + Qed. + + Theorem mod_unique: + forall a b q r, 0<=r a == b*q + r -> r == a mod b. + Proof. + intros a b q r Hr EQ. + assert (Hb : b~=0). { + pos_or_neg b. + - rewrite abs_eq in Hr; intuition; order. + - rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. + } + destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. + - now apply mod_always_pos. + - now rewrite <- div_mod. + Qed. + + (** Sign rules *) + + Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b). + Proof. + intros. symmetry. + apply div_unique with (a mod b). + - rewrite abs_opp; now apply mod_always_pos. + - rewrite mul_opp_opp; now apply div_mod. + Qed. + + Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b. + Proof. + intros. symmetry. + apply mod_unique with (-(a/b)). + - rewrite abs_opp; now apply mod_always_pos. + - rewrite mul_opp_opp; now apply div_mod. + Qed. + + Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> + (-a)/b == -(a/b). + Proof. + intros a b Hb Hab. symmetry. + apply div_unique with (-(a mod b)). + - rewrite Hab, opp_0. split; [order|]. + pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order. + - now rewrite mul_opp_r, <-opp_add_distr, <-div_mod. + Qed. + + Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a)/b == -(a/b)-sgn b. + Proof. + intros a b Hb Hab. symmetry. + apply div_unique with (abs b -(a mod b)). + - rewrite lt_sub_lt_add_l. + rewrite <- le_add_le_sub_l. nzsimpl. + rewrite <- (add_0_l (abs b)) at 2. + rewrite <- add_lt_mono_r. + destruct (mod_always_pos a b); intuition order. + - rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. + rewrite sgn_abs. + rewrite add_shuffle2, add_opp_diag_l; nzsimpl. + rewrite <-opp_add_distr, <-div_mod; order. + Qed. + + Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> + (-a) mod b == 0. + Proof. + intros a b Hb Hab. symmetry. + apply mod_unique with (-(a/b)). + - split; [order|now rewrite abs_pos]. + - now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod. + Qed. + + Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a) mod b == abs b - (a mod b). + Proof. + intros a b Hb Hab. symmetry. + apply mod_unique with (-(a/b)-sgn b). + - rewrite lt_sub_lt_add_l. + rewrite <- le_add_le_sub_l. nzsimpl. + rewrite <- (add_0_l (abs b)) at 2. + rewrite <- add_lt_mono_r. + destruct (mod_always_pos a b); intuition order. + - rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. + rewrite sgn_abs. + rewrite add_shuffle2, add_opp_diag_l; nzsimpl. + rewrite <-opp_add_distr, <-div_mod; order. + Qed. + + Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> + (-a)/(-b) == a/b. + Proof. + intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive. + Qed. + + Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a)/(-b) == a/b + sgn(b). + Proof. + intros. rewrite div_opp_r, div_opp_l_nz by trivial. + now rewrite opp_sub_distr, opp_involutive. + Qed. + + Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> + (-a) mod (-b) == 0. + Proof. + intros. now rewrite mod_opp_r, mod_opp_l_z. + Qed. + + Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a) mod (-b) == abs b - a mod b. + Proof. + intros. now rewrite mod_opp_r, mod_opp_l_nz. + Qed. + + (** A division by itself returns 1 *) + + Lemma div_same : forall a, a~=0 -> a/a == 1. + Proof. + intros. symmetry. apply div_unique with 0. + - split; [order|now rewrite abs_pos]. + - now nzsimpl. + Qed. + + Lemma mod_same : forall a, a~=0 -> a mod a == 0. + Proof. + intros. + rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. + Qed. + + (** A division of a small number by a bigger one yields zero. *) + + Theorem div_small: forall a b, 0<=a a/b == 0. + Proof. exact div_small. Qed. + + (** Same situation, in term of modulo: *) + + Theorem mod_small: forall a b, 0<=a a mod b == a. + Proof. exact mod_small. Qed. + + (** * Basic values of divisions and modulo. *) + + Lemma div_0_l: forall a, a~=0 -> 0/a == 0. + Proof. + intros. pos_or_neg a. + - apply div_0_l; order. + - apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l. + Qed. + + Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. + Proof. + intros; rewrite mod_eq, div_0_l; now nzsimpl. + Qed. + + Lemma div_1_r: forall a, a/1 == a. + Proof. + intros. symmetry. apply div_unique with 0. + - assert (H:=lt_0_1); rewrite abs_pos; intuition auto; order. + - now nzsimpl. + Qed. + + Lemma mod_1_r: forall a, a mod 1 == 0. + Proof. + intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. + apply neq_sym, lt_neq; apply lt_0_1. + Qed. + + Lemma div_1_l: forall a, 1 1/a == 0. + Proof. exact div_1_l. Qed. + + Lemma mod_1_l: forall a, 1 1 mod a == 1. + Proof. exact mod_1_l. Qed. + + Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. + Proof. + intros. symmetry. apply div_unique with 0. + - split; [order|now rewrite abs_pos]. + - nzsimpl; apply mul_comm. + Qed. + + Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. + Proof. + intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. + Qed. + + Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. + Proof. + intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. + Qed. + + (** * Order results about mod and div *) + + (** A modulo cannot grow beyond its starting point. *) + + Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a. + Proof. + intros. pos_or_neg b. + - apply mod_le; order. + - rewrite <- mod_opp_r by trivial. apply mod_le; order. + Qed. + + Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. + Proof. exact div_pos. Qed. + + Lemma div_str_pos : forall a b, 0 0 < a/b. + Proof. exact div_str_pos. Qed. + + Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a 1 a/b < a. -Proof. exact div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. -Proof. -intros a b c Hc Hab. -rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; - [|rewrite EQ; order]. -rewrite <- lt_succ_r. -rewrite (mul_lt_mono_pos_l c) by order. -nzsimpl. -rewrite (add_lt_mono_r _ _ (a mod c)). -rewrite <- div_mod by order. -apply lt_le_trans with b; trivial. -rewrite (div_mod b c) at 1 by order. -rewrite <- add_assoc, <- add_le_mono_l. -apply le_trans with (c+0). -- nzsimpl; destruct (mod_always_pos b c); try order. - rewrite abs_eq in *; order. -- rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order. -Qed. - -(** In this convention, [div] performs Rounding-Toward-Bottom + Lemma div_lt : forall a b, 0 1 a/b < a. + Proof. exact div_lt. Qed. + + (** [le] is compatible with a positive division. *) + + Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. + Proof. + intros a b c Hc Hab. + rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. + rewrite <- lt_succ_r. + rewrite (mul_lt_mono_pos_l c) by order. + nzsimpl. + rewrite (add_lt_mono_r _ _ (a mod c)). + rewrite <- div_mod by order. + apply lt_le_trans with b; trivial. + rewrite (div_mod b c) at 1 by order. + rewrite <- add_assoc, <- add_le_mono_l. + apply le_trans with (c+0). + - nzsimpl; destruct (mod_always_pos b c); try order. + rewrite abs_eq in *; order. + - rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order. + Qed. + + (** In this convention, [div] performs Rounding-Toward-Bottom when divisor is positive, and Rounding-Toward-Top otherwise. Since we cannot speak of rational values here, we express this @@ -362,279 +362,279 @@ Qed. unique statement. *) -Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. -Proof. -intros. -rewrite (div_mod a b) at 2; trivial. -rewrite <- (add_0_r (b*(a/b))) at 1. -rewrite <- add_le_mono_l. -now destruct (mod_always_pos a b). -Qed. - -(** Giving a reversed bound is slightly more complex *) - -Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). -Proof. -intros. -nzsimpl. -rewrite (div_mod a b) at 1; try order. -rewrite <- add_lt_mono_l. -destruct (mod_always_pos a b). { order. } -rewrite abs_eq in *; order. -Qed. - -Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)). -Proof. -intros a b Hb. -rewrite mul_pred_r, <- add_opp_r. -rewrite (div_mod a b) at 1; try order. -rewrite <- add_lt_mono_l. -destruct (mod_always_pos a b). { order. } -rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order. -Qed. - -(** NB: The three previous properties could be used as + Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. + Proof. + intros. + rewrite (div_mod a b) at 2; trivial. + rewrite <- (add_0_r (b*(a/b))) at 1. + rewrite <- add_le_mono_l. + now destruct (mod_always_pos a b). + Qed. + + (** Giving a reversed bound is slightly more complex *) + + Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). + Proof. + intros. + nzsimpl. + rewrite (div_mod a b) at 1; try order. + rewrite <- add_lt_mono_l. + destruct (mod_always_pos a b). { order. } + rewrite abs_eq in *; order. + Qed. + + Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)). + Proof. + intros a b Hb. + rewrite mul_pred_r, <- add_opp_r. + rewrite (div_mod a b) at 1; try order. + rewrite <- add_lt_mono_l. + destruct (mod_always_pos a b). { order. } + rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order. + Qed. + + (** NB: The three previous properties could be used as specifications for [div]. *) -(** Inequality [mul_div_le] is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). -Proof. -intros. -rewrite (div_mod a b) at 1; try order. -rewrite <- (add_0_r (b*(a/b))) at 2. -apply add_cancel_l. -Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, 0 a < b*q -> a/b < q. -Proof. -intros. -rewrite (mul_lt_mono_pos_l b) by trivial. -apply le_lt_trans with a; trivial. -apply mul_div_le; order. -Qed. - -Theorem div_le_upper_bound: - forall a b q, 0 a <= b*q -> a/b <= q. -Proof. -intros. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -Theorem div_le_lower_bound: - forall a b q, 0 b*q <= a -> q <= a/b. -Proof. -intros. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. -Proof. exact div_le_compat_l. Qed. - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, c~=0 -> - (a + b * c) mod c == a mod c. -Proof. -intros. -symmetry. -apply mod_unique with (a/c+b); trivial. -- now apply mod_always_pos. -- rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add : forall a b c, c~=0 -> - (a + b * c) / c == a / c + b. -Proof. -intros. -apply (mul_cancel_l _ _ c); try order. -apply (add_cancel_r _ _ ((a+b*c) mod c)). -rewrite <- div_mod, mod_add by order. -rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. -now rewrite mul_comm. -Qed. - -Lemma div_add_l: forall a b c, b~=0 -> - (a * b + c) / b == a + c / b. -Proof. - intros a b c. rewrite (add_comm _ c), (add_comm a). - now apply div_add. -Qed. - -(** Cancellations. *) - -(** With the current convention, the following isn't always true + (** Inequality [mul_div_le] is exact iff the modulo is zero. *) + + Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). + Proof. + intros. + rewrite (div_mod a b) at 1; try order. + rewrite <- (add_0_r (b*(a/b))) at 2. + apply add_cancel_l. + Qed. + + (** Some additional inequalities about div. *) + + Theorem div_lt_upper_bound: + forall a b q, 0 a < b*q -> a/b < q. + Proof. + intros. + rewrite (mul_lt_mono_pos_l b) by trivial. + apply le_lt_trans with a; trivial. + apply mul_div_le; order. + Qed. + + Theorem div_le_upper_bound: + forall a b q, 0 a <= b*q -> a/b <= q. + Proof. + intros. + rewrite <- (div_mul q b) by order. + apply div_le_mono; trivial. now rewrite mul_comm. + Qed. + + Theorem div_le_lower_bound: + forall a b q, 0 b*q <= a -> q <= a/b. + Proof. + intros. + rewrite <- (div_mul q b) by order. + apply div_le_mono; trivial. now rewrite mul_comm. + Qed. + + (** A division respects opposite monotonicity for the divisor *) + + Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. + Proof. exact div_le_compat_l. Qed. + + (** * Relations between usual operations and mod and div *) + + Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. + Proof. + intros. + symmetry. + apply mod_unique with (a/c+b); trivial. + - now apply mod_always_pos. + - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. + Qed. + + Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. + Proof. + intros. + apply (mul_cancel_l _ _ c); try order. + apply (add_cancel_r _ _ ((a+b*c) mod c)). + rewrite <- div_mod, mod_add by order. + rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. + Qed. + + Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. + Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + now apply div_add. + Qed. + + (** Cancellations. *) + + (** With the current convention, the following isn't always true when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *) -Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0 - (a*c)/(b*c) == a/b. -Proof. -intros. -symmetry. -apply div_unique with ((a mod b)*c). -- (* ineqs *) - rewrite abs_mul, (abs_eq c) by order. - rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial. - now apply mod_always_pos. -- (* equation *) - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). -Qed. - -Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0 - (c*a)/(c*b) == a/b. -Proof. -intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. -Qed. - -Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0 - (c*a) mod (c*b) == c * (a mod b). -Proof. -intros. -rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). -rewrite <- div_mod. -- rewrite div_mul_cancel_l by trivial. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. -- rewrite <- neq_mul_0; intuition; order. -Qed. - -Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0 - (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. -Qed. - - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. -Proof. -intros. rewrite mod_small_iff by trivial. -now apply mod_always_pos. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite add_comm, (mul_comm n), (mul_comm _ b). - rewrite mul_add_distr_l, mul_assoc. - rewrite mod_add by trivial. - now rewrite mul_comm. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. -Qed. - -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. -Qed. - -Lemma add_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite <- add_assoc, add_comm, mul_comm. - now rewrite mod_add. -Qed. - -Lemma add_mod_idemp_r : forall a b n, n~=0 -> - (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros. rewrite !(add_comm a). now apply add_mod_idemp_l. -Qed. - -Theorem add_mod: forall a b n, n~=0 -> - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. -Qed. - -(** With the current convention, the following result isn't always + Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0 + (a*c)/(b*c) == a/b. + Proof. + intros. + symmetry. + apply div_unique with ((a mod b)*c). + - (* ineqs *) + rewrite abs_mul, (abs_eq c) by order. + rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial. + now apply mod_always_pos. + - (* equation *) + rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). + Qed. + + Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0 + (c*a)/(c*b) == a/b. + Proof. + intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. + Qed. + + Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0 + (c*a) mod (c*b) == c * (a mod b). + Proof. + intros. + rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). + rewrite <- div_mod. + - rewrite div_mul_cancel_l by trivial. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. + - rewrite <- neq_mul_0; intuition; order. + Qed. + + Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0 + (a*c) mod (b*c) == (a mod b) * c. + Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. + Qed. + + + (** Operations modulo. *) + + Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. + Proof. + intros. rewrite mod_small_iff by trivial. + now apply mod_always_pos. + Qed. + + Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. + Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + rewrite mod_add by trivial. + now rewrite mul_comm. + Qed. + + Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. + Proof. + intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. + Qed. + + Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. + Proof. + intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. + Qed. + + Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. + Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite <- add_assoc, add_comm, mul_comm. + now rewrite mod_add. + Qed. + + Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. + Proof. + intros. rewrite !(add_comm a). now apply add_mod_idemp_l. + Qed. + + Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. + Proof. + intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. + Qed. + + (** With the current convention, the following result isn't always true with a negative intermediate divisor. For instance [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *) -Lemma div_div : forall a b c, 0 c~=0 -> - (a/b)/c == a/(b*c). -Proof. - intros a b c Hb Hc. - apply div_unique with (b*((a/b) mod c) + a mod b). - - (* begin 0<= ... c~=0 -> + (a/b)/c == a/(b*c). + Proof. + intros a b c Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b). + - (* begin 0<= ... c~=0 -> - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c Hb Hc. - apply add_cancel_l with (b*c*(a/(b*c))). - rewrite <- div_mod by (apply neq_mul_0; split; order). - rewrite <- div_div by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- div_mod by order. - apply div_mod; order. -Qed. - -Lemma mod_div: forall a b, b~=0 -> - a mod b / b == 0. -Proof. - intros a b Hb. - rewrite div_small_iff by assumption. - auto using mod_always_pos. -Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. -Proof. exact div_mul_le. Qed. - -(** mod is related to divisibility *) - -Lemma mod_divides : forall a b, b~=0 -> - (a mod b == 0 <-> (b|a)). -Proof. -intros a b Hb. split. -- intros Hab. exists (a/b). rewrite mul_comm. - rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. -- intros (c,Hc). rewrite Hc. now apply mod_mul. -Qed. + Lemma mod_mul_r : forall a b c, 0 c~=0 -> + a mod (b*c) == a mod b + b*((a/b) mod c). + Proof. + intros a b c Hb Hc. + apply add_cancel_l with (b*c*(a/(b*c))). + rewrite <- div_mod by (apply neq_mul_0; split; order). + rewrite <- div_div by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- div_mod by order. + apply div_mod; order. + Qed. + + Lemma mod_div: forall a b, b~=0 -> + a mod b / b == 0. + Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_always_pos. + Qed. + + (** A last inequality: *) + + Theorem div_mul_le: + forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. + Proof. exact div_mul_le. Qed. + + (** mod is related to divisibility *) + + Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> (b|a)). + Proof. + intros a b Hb. split. + - intros Hab. exists (a/b). rewrite mul_comm. + rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. + - intros (c,Hc). rewrite Hc. now apply mod_mul. + Qed. End ZEuclidProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index 4879c4c2e9..77041a5b38 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -29,369 +29,369 @@ From Stdlib Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. *) Module Type ZDivProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZSgnAbsProp A B). - -(** We benefit from what already exists for NZ *) -Module Import Private_NZDiv := Nop <+ NZDivProp A A B. - -(** Another formulation of the main equation *) - -Lemma mod_eq : - forall a b, b~=0 -> a mod b == a - b*(a/b). -Proof. -intros. -rewrite <- add_move_l. -symmetry. now apply div_mod. -Qed. - -(** We have a general bound for absolute values *) - -Lemma mod_bound_abs : - forall a b, b~=0 -> abs (a mod b) < abs b. -Proof. -intros a b **. -destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ. -- destruct (mod_pos_bound a b). - + order. - + now rewrite abs_eq. -- destruct (mod_neg_bound a b). - + order. - + rewrite abs_neq; trivial. - now rewrite <- opp_lt_mono. -Qed. - -(** Uniqueness theorems *) - -Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, - (0<=r1 (0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 EQ. -destruct Hr1; destruct Hr2; try (intuition; order). -- apply div_mod_unique with b; trivial. -- rewrite <- (opp_inj_wd r1 r2). - apply div_mod_unique with (-b); trivial. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. -Qed. - -Theorem div_unique: - forall a b q r, (0<=r a == b*q + r -> q == a/b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0) by (destruct Hr; intuition; order). -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; - intuition order. -- now rewrite <- div_mod. -Qed. - -Theorem div_unique_pos: - forall a b q r, 0<=r a == b*q + r -> q == a/b. -Proof. intros a b q r **; apply div_unique with r; auto. Qed. - -Theorem div_unique_neg: - forall a b q r, b a == b*q + r -> q == a/b. -Proof. intros a b q r **; apply div_unique with r; auto. Qed. - -Theorem mod_unique: - forall a b q r, (0<=r a == b*q + r -> r == a mod b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0) by (destruct Hr; intuition; order). -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; - intuition order. -- now rewrite <- div_mod. -Qed. - -Theorem mod_unique_pos: - forall a b q r, 0<=r a == b*q + r -> r == a mod b. -Proof. intros a b q r **; apply mod_unique with q; auto. Qed. - -Theorem mod_unique_neg: - forall a b q r, b a == b*q + r -> r == a mod b. -Proof. intros a b q r **; apply mod_unique with q; auto. Qed. - -(** Sign rules *) - -Ltac pos_or_neg a := - let LT := fresh "LT" in - let LE := fresh "LE" in - destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. - -Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b - 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0. -Proof. -intros a b **. -destruct (lt_ge_cases 0 b); [right|left]. -- rewrite <- opp_lt_mono, opp_nonpos_nonneg. - destruct (mod_pos_bound a b); intuition; order. -- rewrite <- opp_lt_mono, opp_nonneg_nonpos. - destruct (mod_neg_bound a b); intuition; order. -Qed. - -Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b. -Proof. -intros a b **. symmetry. apply div_unique with (- (a mod b)). -- now apply opp_mod_bound_or. -- rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. -Qed. - -Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b). -Proof. -intros a b **. symmetry. apply mod_unique with (a/b). -- now apply opp_mod_bound_or. -- rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. -Qed. - -(** With the current conventions, the other sign rules are rather complex. *) - -Lemma div_opp_l_z : - forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b). -Proof. -intros a b Hb H. symmetry. apply div_unique with 0. -- destruct (lt_ge_cases 0 b); [left|right]; intuition auto; order. -- rewrite <- opp_0, <- H. - rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. -Qed. - -Lemma div_opp_l_nz : - forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1. -Proof. -intros a b Hb H. symmetry. apply div_unique with (b - a mod b). -- destruct (lt_ge_cases 0 b); [left|right]. - + rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. - destruct (mod_pos_bound a b); intuition; order. - + rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. - destruct (mod_neg_bound a b); intuition; order. -- rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. - rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma mod_opp_l_z : - forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0. -Proof. -intros a b Hb H. symmetry. apply mod_unique with (-(a/b)). -- destruct (lt_ge_cases 0 b); [left|right]; intuition auto; order. -- rewrite <- opp_0, <- H. - rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. -Qed. - -Lemma mod_opp_l_nz : - forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b. -Proof. -intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1). -- destruct (lt_ge_cases 0 b); [left|right]. - + rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. - destruct (mod_pos_bound a b); intuition; order. - + rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. - destruct (mod_neg_bound a b); intuition; order. -- rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. - rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma div_opp_r_z : - forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b). -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -rewrite div_opp_opp; auto using div_opp_l_z. -Qed. - -Lemma div_opp_r_nz : - forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1. -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -rewrite div_opp_opp; auto using div_opp_l_nz. -Qed. - -Lemma mod_opp_r_z : - forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0. -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -now rewrite mod_opp_opp, mod_opp_l_z, opp_0. -Qed. - -Lemma mod_opp_r_nz : - forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b. -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -rewrite mod_opp_opp, mod_opp_l_nz by trivial. -now rewrite opp_sub_distr, add_comm, add_opp_r. -Qed. - -(** The sign of [a mod b] is the one of [b] (when it isn't null) *) - -Lemma mod_sign_nz : forall a b, b~=0 -> a mod b ~= 0 -> - sgn (a mod b) == sgn b. -Proof. -intros a b Hb H. destruct (lt_ge_cases 0 b) as [Hb'|Hb']. -- destruct (mod_pos_bound a b Hb'). rewrite 2 sgn_pos; order. -- destruct (mod_neg_bound a b). + order. + rewrite 2 sgn_neg; order. -Qed. - -Lemma mod_sign : forall a b, b~=0 -> sgn (a mod b) ~= -sgn b. -Proof. -intros a b Hb H. -destruct (eq_decidable (a mod b) 0) as [EQ|NEQ]. -- apply Hb, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. -- apply Hb, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. - apply add_move_0_l. rewrite <- H. symmetry. now apply mod_sign_nz. -Qed. - -Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b. -Proof. -intros a b **. destruct (lt_ge_cases 0 b). -- apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. -- apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order. -Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, a~=0 -> a/a == 1. -Proof. - intros a ?. pos_or_neg a. - - apply div_same; order. - - rewrite <- div_opp_opp by trivial. now apply div_same. -Qed. - -Lemma mod_same : forall a, a~=0 -> a mod a == 0. -Proof. -intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, 0<=a a/b == 0. -Proof. exact div_small. Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, 0<=a a mod b == a. -Proof. exact mod_small. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. -Proof. - intros a ?. pos_or_neg a. - - apply div_0_l; order. - - rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. -Qed. - -Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. -Proof. -intros; rewrite mod_eq, div_0_l; now nzsimpl. -Qed. - -Lemma div_1_r: forall a, a/1 == a. -Proof. - intros. symmetry. apply div_unique with 0. - - left. split; order || apply lt_0_1. - - now nzsimpl. -Qed. - -Lemma mod_1_r: forall a, a mod 1 == 0. -Proof. -intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. -intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. -Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. exact div_1_l. Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. exact mod_1_l. Qed. - -Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. -Proof. -intros a b ?. symmetry. apply div_unique with 0. -- destruct (lt_ge_cases 0 b); [left|right]; split; order. -- nzsimpl; apply mul_comm. -Qed. - -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. -Proof. -intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. -Qed. - -Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. -Proof. - intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. -Qed. - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. -Proof. exact mod_le. Qed. - -Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. -Proof. exact div_pos. Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. exact div_str_pos. Qed. - -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a a mod b == a - b*(a/b). + Proof. + intros. + rewrite <- add_move_l. + symmetry. now apply div_mod. + Qed. + + (** We have a general bound for absolute values *) + + Lemma mod_bound_abs : + forall a b, b~=0 -> abs (a mod b) < abs b. + Proof. + intros a b **. + destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ. + - destruct (mod_pos_bound a b). + + order. + + now rewrite abs_eq. + - destruct (mod_neg_bound a b). + + order. + + rewrite abs_neq; trivial. + now rewrite <- opp_lt_mono. + Qed. + + (** Uniqueness theorems *) + + Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + (0<=r1 (0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. + Proof. + intros b q1 q2 r1 r2 Hr1 Hr2 EQ. + destruct Hr1; destruct Hr2; try (intuition; order). + - apply div_mod_unique with b; trivial. + - rewrite <- (opp_inj_wd r1 r2). + apply div_mod_unique with (-b); trivial. + + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. + + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. + + now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. + Qed. + + Theorem div_unique: + forall a b q r, (0<=r a == b*q + r -> q == a/b. + Proof. + intros a b q r Hr EQ. + assert (Hb : b~=0) by (destruct Hr; intuition; order). + destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. + - destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; + intuition order. + - now rewrite <- div_mod. + Qed. + + Theorem div_unique_pos: + forall a b q r, 0<=r a == b*q + r -> q == a/b. + Proof. intros a b q r **; apply div_unique with r; auto. Qed. + + Theorem div_unique_neg: + forall a b q r, b a == b*q + r -> q == a/b. + Proof. intros a b q r **; apply div_unique with r; auto. Qed. + + Theorem mod_unique: + forall a b q r, (0<=r a == b*q + r -> r == a mod b. + Proof. + intros a b q r Hr EQ. + assert (Hb : b~=0) by (destruct Hr; intuition; order). + destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. + - destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; + intuition order. + - now rewrite <- div_mod. + Qed. + + Theorem mod_unique_pos: + forall a b q r, 0<=r a == b*q + r -> r == a mod b. + Proof. intros a b q r **; apply mod_unique with q; auto. Qed. + + Theorem mod_unique_neg: + forall a b q r, b a == b*q + r -> r == a mod b. + Proof. intros a b q r **; apply mod_unique with q; auto. Qed. + + (** Sign rules *) + + Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + + Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b + 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0. + Proof. + intros a b **. + destruct (lt_ge_cases 0 b); [right|left]. + - rewrite <- opp_lt_mono, opp_nonpos_nonneg. + destruct (mod_pos_bound a b); intuition; order. + - rewrite <- opp_lt_mono, opp_nonneg_nonpos. + destruct (mod_neg_bound a b); intuition; order. + Qed. + + Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b. + Proof. + intros a b **. symmetry. apply div_unique with (- (a mod b)). + - now apply opp_mod_bound_or. + - rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. + Qed. + + Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b). + Proof. + intros a b **. symmetry. apply mod_unique with (a/b). + - now apply opp_mod_bound_or. + - rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. + Qed. + + (** With the current conventions, the other sign rules are rather complex. *) + + Lemma div_opp_l_z : + forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b). + Proof. + intros a b Hb H. symmetry. apply div_unique with 0. + - destruct (lt_ge_cases 0 b); [left|right]; intuition auto; order. + - rewrite <- opp_0, <- H. + rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. + Qed. + + Lemma div_opp_l_nz : + forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1. + Proof. + intros a b Hb H. symmetry. apply div_unique with (b - a mod b). + - destruct (lt_ge_cases 0 b); [left|right]. + + rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. + destruct (mod_pos_bound a b); intuition; order. + + rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. + destruct (mod_neg_bound a b); intuition; order. + - rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. + rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. + Qed. + + Lemma mod_opp_l_z : + forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0. + Proof. + intros a b Hb H. symmetry. apply mod_unique with (-(a/b)). + - destruct (lt_ge_cases 0 b); [left|right]; intuition auto; order. + - rewrite <- opp_0, <- H. + rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. + Qed. + + Lemma mod_opp_l_nz : + forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b. + Proof. + intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1). + - destruct (lt_ge_cases 0 b); [left|right]. + + rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. + destruct (mod_pos_bound a b); intuition; order. + + rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. + destruct (mod_neg_bound a b); intuition; order. + - rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. + rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. + Qed. + + Lemma div_opp_r_z : + forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b). + Proof. + intros a b **. rewrite <- (opp_involutive a) at 1. + rewrite div_opp_opp; auto using div_opp_l_z. + Qed. + + Lemma div_opp_r_nz : + forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1. + Proof. + intros a b **. rewrite <- (opp_involutive a) at 1. + rewrite div_opp_opp; auto using div_opp_l_nz. + Qed. + + Lemma mod_opp_r_z : + forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0. + Proof. + intros a b **. rewrite <- (opp_involutive a) at 1. + now rewrite mod_opp_opp, mod_opp_l_z, opp_0. + Qed. + + Lemma mod_opp_r_nz : + forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b. + Proof. + intros a b **. rewrite <- (opp_involutive a) at 1. + rewrite mod_opp_opp, mod_opp_l_nz by trivial. + now rewrite opp_sub_distr, add_comm, add_opp_r. + Qed. + + (** The sign of [a mod b] is the one of [b] (when it isn't null) *) + + Lemma mod_sign_nz : forall a b, b~=0 -> a mod b ~= 0 -> + sgn (a mod b) == sgn b. + Proof. + intros a b Hb H. destruct (lt_ge_cases 0 b) as [Hb'|Hb']. + - destruct (mod_pos_bound a b Hb'). rewrite 2 sgn_pos; order. + - destruct (mod_neg_bound a b). + order. + rewrite 2 sgn_neg; order. + Qed. + + Lemma mod_sign : forall a b, b~=0 -> sgn (a mod b) ~= -sgn b. + Proof. + intros a b Hb H. + destruct (eq_decidable (a mod b) 0) as [EQ|NEQ]. + - apply Hb, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. + - apply Hb, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. + apply add_move_0_l. rewrite <- H. symmetry. now apply mod_sign_nz. + Qed. + + Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b. + Proof. + intros a b **. destruct (lt_ge_cases 0 b). + - apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. + - apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order. + Qed. + + (** A division by itself returns 1 *) + + Lemma div_same : forall a, a~=0 -> a/a == 1. + Proof. + intros a ?. pos_or_neg a. + - apply div_same; order. + - rewrite <- div_opp_opp by trivial. now apply div_same. + Qed. + + Lemma mod_same : forall a, a~=0 -> a mod a == 0. + Proof. + intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. + Qed. + + (** A division of a small number by a bigger one yields zero. *) + + Theorem div_small: forall a b, 0<=a a/b == 0. + Proof. exact div_small. Qed. + + (** Same situation, in term of modulo: *) + + Theorem mod_small: forall a b, 0<=a a mod b == a. + Proof. exact mod_small. Qed. + + (** * Basic values of divisions and modulo. *) + + Lemma div_0_l: forall a, a~=0 -> 0/a == 0. + Proof. + intros a ?. pos_or_neg a. + - apply div_0_l; order. + - rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. + Qed. + + Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. + Proof. + intros; rewrite mod_eq, div_0_l; now nzsimpl. + Qed. + + Lemma div_1_r: forall a, a/1 == a. + Proof. + intros. symmetry. apply div_unique with 0. + - left. split; order || apply lt_0_1. + - now nzsimpl. + Qed. + + Lemma mod_1_r: forall a, a mod 1 == 0. + Proof. + intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. + intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. + Qed. + + Lemma div_1_l: forall a, 1 1/a == 0. + Proof. exact div_1_l. Qed. + + Lemma mod_1_l: forall a, 1 1 mod a == 1. + Proof. exact mod_1_l. Qed. + + Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. + Proof. + intros a b ?. symmetry. apply div_unique with 0. + - destruct (lt_ge_cases 0 b); [left|right]; split; order. + - nzsimpl; apply mul_comm. + Qed. + + Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. + Proof. + intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. + Qed. + + Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. + Proof. + intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. + Qed. + + (** * Order results about mod and div *) + + (** A modulo cannot grow beyond its starting point. *) + + Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. + Proof. exact mod_le. Qed. + + Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. + Proof. exact div_pos. Qed. + + Lemma div_str_pos : forall a b, 0 0 < a/b. + Proof. exact div_str_pos. Qed. + + Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a 1 a/b < a. -Proof. exact div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. -Proof. -intros a b c Hc Hab. -rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; - [|rewrite EQ; order]. -rewrite <- lt_succ_r. -rewrite (mul_lt_mono_pos_l c) by order. -nzsimpl. -rewrite (add_lt_mono_r _ _ (a mod c)). -rewrite <- div_mod by order. -apply lt_le_trans with b; trivial. -rewrite (div_mod b c) at 1 by order. -rewrite <- add_assoc, <- add_le_mono_l. -apply le_trans with (c+0). -- nzsimpl; destruct (mod_pos_bound b c); order. -- rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order. -Qed. - -(** In this convention, [div] performs Rounding-Toward-Bottom. + Lemma div_lt : forall a b, 0 1 a/b < a. + Proof. exact div_lt. Qed. + + (** [le] is compatible with a positive division. *) + + Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. + Proof. + intros a b c Hc Hab. + rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. + rewrite <- lt_succ_r. + rewrite (mul_lt_mono_pos_l c) by order. + nzsimpl. + rewrite (add_lt_mono_r _ _ (a mod c)). + rewrite <- div_mod by order. + apply lt_le_trans with b; trivial. + rewrite (div_mod b c) at 1 by order. + rewrite <- add_assoc, <- add_le_mono_l. + apply le_trans with (c+0). + - nzsimpl; destruct (mod_pos_bound b c); order. + - rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order. + Qed. + + (** In this convention, [div] performs Rounding-Toward-Bottom. Since we cannot speak of rational values here, we express this fact by multiplying back by [b], and this leads to separates @@ -400,287 +400,287 @@ Qed. First, [a/b] is below the exact fraction ... *) -Lemma mul_div_le : forall a b, 0 b*(a/b) <= a. -Proof. -intros a b **. -rewrite (div_mod a b) at 2; try order. -rewrite <- (add_0_r (b*(a/b))) at 1. -rewrite <- add_le_mono_l. -now destruct (mod_pos_bound a b). -Qed. - -Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b). -Proof. -intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order. -apply mul_div_le. now rewrite opp_pos_neg. -Qed. - -(** ... and moreover it is the larger such integer, since [S(a/b)] + Lemma mul_div_le : forall a b, 0 b*(a/b) <= a. + Proof. + intros a b **. + rewrite (div_mod a b) at 2; try order. + rewrite <- (add_0_r (b*(a/b))) at 1. + rewrite <- add_le_mono_l. + now destruct (mod_pos_bound a b). + Qed. + + Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b). + Proof. + intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order. + apply mul_div_le. now rewrite opp_pos_neg. + Qed. + + (** ... and moreover it is the larger such integer, since [S(a/b)] is strictly above the exact fraction. *) -Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). -Proof. -intros a b ?. -nzsimpl. -rewrite (div_mod a b) at 1; try order. -rewrite <- add_lt_mono_l. -destruct (mod_pos_bound a b); order. -Qed. - -Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a. -Proof. -intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order. -apply mul_succ_div_gt. now rewrite opp_pos_neg. -Qed. - -(** NB: The four previous properties could be used as + Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). + Proof. + intros a b ?. + nzsimpl. + rewrite (div_mod a b) at 1; try order. + rewrite <- add_lt_mono_l. + destruct (mod_pos_bound a b); order. + Qed. + + Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a. + Proof. + intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order. + apply mul_succ_div_gt. now rewrite opp_pos_neg. + Qed. + + (** NB: The four previous properties could be used as specifications for [div]. *) -(** Inequality [mul_div_le] is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). -Proof. -intros a b **. -rewrite (div_mod a b) at 1; try order. -rewrite <- (add_0_r (b*(a/b))) at 2. -apply add_cancel_l. -Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, 0 a < b*q -> a/b < q. -Proof. -intros a b q **. -rewrite (mul_lt_mono_pos_l b) by trivial. -apply le_lt_trans with a; trivial. -now apply mul_div_le. -Qed. - -Theorem div_le_upper_bound: - forall a b q, 0 a <= b*q -> a/b <= q. -Proof. -intros a b q **. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -Theorem div_le_lower_bound: - forall a b q, 0 b*q <= a -> q <= a/b. -Proof. -intros a b q **. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. -Proof. exact div_le_compat_l. Qed. - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, c~=0 -> - (a + b * c) mod c == a mod c. -Proof. -intros a b c **. -symmetry. -apply mod_unique with (a/c+b); trivial. -- now apply mod_bound_or. -- rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add : forall a b c, c~=0 -> - (a + b * c) / c == a / c + b. -Proof. -intros a b c **. -apply (mul_cancel_l _ _ c); try order. -apply (add_cancel_r _ _ ((a+b*c) mod c)). -rewrite <- div_mod, mod_add by order. -rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. -now rewrite mul_comm. -Qed. - -Lemma div_add_l: forall a b c, b~=0 -> - (a * b + c) / b == a + c / b. -Proof. - intros a b c. rewrite (add_comm _ c), (add_comm a). - now apply div_add. -Qed. - -(** Cancellations. *) - -Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)/(b*c) == a/b. -Proof. -intros a b c **. -symmetry. -apply div_unique with ((a mod b)*c). -- (* ineqs *) - destruct (lt_ge_cases 0 c). - + rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial. + (** Inequality [mul_div_le] is exact iff the modulo is zero. *) + + Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). + Proof. + intros a b **. + rewrite (div_mod a b) at 1; try order. + rewrite <- (add_0_r (b*(a/b))) at 2. + apply add_cancel_l. + Qed. + + (** Some additional inequalities about div. *) + + Theorem div_lt_upper_bound: + forall a b q, 0 a < b*q -> a/b < q. + Proof. + intros a b q **. + rewrite (mul_lt_mono_pos_l b) by trivial. + apply le_lt_trans with a; trivial. + now apply mul_div_le. + Qed. + + Theorem div_le_upper_bound: + forall a b q, 0 a <= b*q -> a/b <= q. + Proof. + intros a b q **. + rewrite <- (div_mul q b) by order. + apply div_le_mono; trivial. now rewrite mul_comm. + Qed. + + Theorem div_le_lower_bound: + forall a b q, 0 b*q <= a -> q <= a/b. + Proof. + intros a b q **. + rewrite <- (div_mul q b) by order. + apply div_le_mono; trivial. now rewrite mul_comm. + Qed. + + (** A division respects opposite monotonicity for the divisor *) + + Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. + Proof. exact div_le_compat_l. Qed. + + (** * Relations between usual operations and mod and div *) + + Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. + Proof. + intros a b c **. + symmetry. + apply mod_unique with (a/c+b); trivial. + - now apply mod_bound_or. + - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. + Qed. + + Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. + Proof. + intros a b c **. + apply (mul_cancel_l _ _ c); try order. + apply (add_cancel_r _ _ ((a+b*c) mod c)). + rewrite <- div_mod, mod_add by order. + rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. + Qed. + + Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. + Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + now apply div_add. + Qed. + + (** Cancellations. *) + + Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. + Proof. + intros a b c **. + symmetry. + apply div_unique with ((a mod b)*c). + - (* ineqs *) + destruct (lt_ge_cases 0 c). + + rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial. + now apply mod_bound_or. + + rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order. + destruct (mod_bound_or a b); tauto. + - (* equation *) + rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). + Qed. + + Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. + Proof. + intros a b c **. rewrite !(mul_comm c); now apply div_mul_cancel_r. + Qed. + + Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). + Proof. + intros a b c **. + rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). + rewrite <- div_mod. + - rewrite div_mul_cancel_l by trivial. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. + - rewrite <- neq_mul_0; auto. + Qed. + + Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. + Proof. + intros a b c **. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. + Qed. + + + (** Operations modulo. *) + + Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. + Proof. + intros. rewrite mod_small_iff by trivial. now apply mod_bound_or. - + rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order. - destruct (mod_bound_or a b); tauto. -- (* equation *) - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). -Qed. - -Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)/(c*b) == a/b. -Proof. -intros a b c **. rewrite !(mul_comm c); now apply div_mul_cancel_r. -Qed. - -Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) mod (c*b) == c * (a mod b). -Proof. -intros a b c **. -rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). -rewrite <- div_mod. -- rewrite div_mul_cancel_l by trivial. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. -- rewrite <- neq_mul_0; auto. -Qed. - -Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros a b c **. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. -Qed. - - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. -Proof. -intros. rewrite mod_small_iff by trivial. -now apply mod_bound_or. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite add_comm, (mul_comm n), (mul_comm _ b). - rewrite mul_add_distr_l, mul_assoc. - intros. rewrite mod_add by trivial. - now rewrite mul_comm. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros a b n **. rewrite !(mul_comm a). now apply mul_mod_idemp_l. -Qed. - -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. -Qed. - -Lemma add_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite <- add_assoc, add_comm, mul_comm. - intros. now rewrite mod_add. -Qed. - -Lemma add_mod_idemp_r : forall a b n, n~=0 -> - (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros a b n **. rewrite !(add_comm a). now apply add_mod_idemp_l. -Qed. - -Theorem add_mod: forall a b n, n~=0 -> - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. -Qed. - -(** With the current convention, the following result isn't always + Qed. + + Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. + Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + intros. rewrite mod_add by trivial. + now rewrite mul_comm. + Qed. + + Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. + Proof. + intros a b n **. rewrite !(mul_comm a). now apply mul_mod_idemp_l. + Qed. + + Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. + Proof. + intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. + Qed. + + Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. + Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite <- add_assoc, add_comm, mul_comm. + intros. now rewrite mod_add. + Qed. + + Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. + Proof. + intros a b n **. rewrite !(add_comm a). now apply add_mod_idemp_l. + Qed. + + Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. + Proof. + intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. + Qed. + + (** With the current convention, the following result isn't always true with a negative last divisor. For instance [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ], or [ 5/2/(-2) = -1 <> -2 = 5 / (2*-2) ]. *) -Lemma div_div : forall a b c, b~=0 -> 0 - (a/b)/c == a/(b*c). -Proof. - intros a b c Hb Hc. - apply div_unique with (b*((a/b) mod c) + a mod b). - - (* begin 0<= ... 0 + (a/b)/c == a/(b*c). + Proof. + intros a b c Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b). + - (* begin 0<= ... 0 - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c Hb Hc. - apply add_cancel_l with (b*c*(a/(b*c))). - rewrite <- div_mod by (apply neq_mul_0; split; order). - rewrite <- div_div by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- div_mod by order. - apply div_mod; order. -Qed. - -Lemma mod_div: forall a b, b~=0 -> - a mod b / b == 0. -Proof. - intros a b Hb. - rewrite div_small_iff by assumption. - auto using mod_bound_or. -Qed. - -Lemma add_mul_mod_distr_l : forall a b c d, 0<=a -> 0 0<=d - (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. intros. apply add_mul_mod_distr_l; assumption. Qed. - -Lemma add_mul_mod_distr_r: forall a b c d, 0<=a -> 0 0<=d - (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. intros. apply add_mul_mod_distr_r; assumption. Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. -Proof. exact div_mul_le. Qed. + Lemma rem_mul_r : forall a b c, b~=0 -> 0 + a mod (b*c) == a mod b + b*((a/b) mod c). + Proof. + intros a b c Hb Hc. + apply add_cancel_l with (b*c*(a/(b*c))). + rewrite <- div_mod by (apply neq_mul_0; split; order). + rewrite <- div_div by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- div_mod by order. + apply div_mod; order. + Qed. + + Lemma mod_div: forall a b, b~=0 -> + a mod b / b == 0. + Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_bound_or. + Qed. + + Lemma add_mul_mod_distr_l : forall a b c d, 0<=a -> 0 0<=d + (c*a+d) mod (c*b) == c*(a mod b)+d. + Proof. intros. apply add_mul_mod_distr_l; assumption. Qed. + + Lemma add_mul_mod_distr_r: forall a b c d, 0<=a -> 0 0<=d + (a*c+d) mod (b*c) == (a mod b)*c+d. + Proof. intros. apply add_mul_mod_distr_r; assumption. Qed. + + (** A last inequality: *) + + Theorem div_mul_le: + forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. + Proof. exact div_mul_le. Qed. End ZDivProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index c327ac252e..57f26ce0f1 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -29,552 +29,552 @@ From Stdlib Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. *) Module Type ZQuotProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZSgnAbsProp A B). - -(** We benefit from what already exists for NZ *) - - Module Import Private_Div. - Module Quot2Div <: NZDiv A. - Definition div := quot. - Definition modulo := A.rem. - Definition div_wd := quot_wd. - Definition mod_wd := rem_wd. - Definition div_mod := quot_rem. - Definition mod_bound_pos := rem_bound_pos. - End Quot2Div. - Module NZQuot := Nop <+ NZDivProp A Quot2Div B. - End Private_Div. - -Ltac pos_or_neg a := - let LT := fresh "LT" in - let LE := fresh "LE" in - destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. - -(** Another formulation of the main equation *) - -Lemma rem_eq : - forall a b, b~=0 -> a rem b == a - b*(a÷b). -Proof. -intros. -rewrite <- add_move_l. -symmetry. now apply quot_rem. -Qed. - -(** A few sign rules (simple ones) *) - -Lemma rem_opp_opp : forall a b, b ~= 0 -> (-a) rem (-b) == - (a rem b). -Proof. intros. now rewrite rem_opp_r, rem_opp_l. Qed. - -Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)÷b == -(a÷b). -Proof. -intros a b ?. -rewrite <- (mul_cancel_l _ _ b) by trivial. -rewrite <- (add_cancel_r _ _ ((-a) rem b)). -now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem. -Qed. - -Lemma quot_opp_r : forall a b, b ~= 0 -> a÷(-b) == -(a÷b). -Proof. -intros a b ?. -assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). -rewrite <- (mul_cancel_l _ _ (-b)) by trivial. -rewrite <- (add_cancel_r _ _ (a rem (-b))). -now rewrite <- quot_rem, rem_opp_r, mul_opp_opp, <- quot_rem. -Qed. - -Lemma quot_opp_opp : forall a b, b ~= 0 -> (-a)÷(-b) == a÷b. -Proof. intros. now rewrite quot_opp_r, quot_opp_l, opp_involutive. Qed. - -(** Uniqueness theorems *) - -Theorem quot_rem_unique : forall b q1 q2 r1 r2 : t, - (0<=r1 (0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 EQ. -destruct Hr1; destruct Hr2; try (intuition; order). -- apply NZQuot.div_mod_unique with b; trivial. -- rewrite <- (opp_inj_wd r1 r2). - apply NZQuot.div_mod_unique with (-b); trivial. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. -Qed. - -Theorem quot_unique: - forall a b q r, 0<=a -> 0<=r a == b*q + r -> q == a÷b. -Proof. intros a b q r **; now apply NZQuot.div_unique with r. Qed. - -Theorem rem_unique: - forall a b q r, 0<=a -> 0<=r a == b*q + r -> r == a rem b. -Proof. intros a b q r **; now apply NZQuot.mod_unique with q. Qed. - -(** A division by itself returns 1 *) - -Lemma quot_same : forall a, a~=0 -> a÷a == 1. -Proof. - intros a ?. pos_or_neg a. - - apply NZQuot.div_same; order. - - rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same. -Qed. - -Lemma rem_same : forall a, a~=0 -> a rem a == 0. -Proof. -intros. rewrite rem_eq, quot_same by trivial. nzsimpl. apply sub_diag. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem quot_small: forall a b, 0<=a a÷b == 0. -Proof. exact NZQuot.div_small. Qed. - -(** Same situation, in term of remulo: *) - -Theorem rem_small: forall a b, 0<=a a rem b == a. -Proof. exact NZQuot.mod_small. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma quot_0_l: forall a, a~=0 -> 0÷a == 0. -Proof. - intros a ?. pos_or_neg a. - - apply NZQuot.div_0_l; order. - - rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l. -Qed. - -Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0. -Proof. -intros; rewrite rem_eq, quot_0_l; now nzsimpl. -Qed. - -Lemma quot_1_r: forall a, a÷1 == a. -Proof. - intros a. pos_or_neg a. - - now apply NZQuot.div_1_r. - - apply opp_inj. rewrite <- quot_opp_l. - + apply NZQuot.div_1_r; order. - + intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1. -Qed. - -Lemma rem_1_r: forall a, a rem 1 == 0. -Proof. -intros. rewrite rem_eq, quot_1_r; nzsimpl; auto using sub_diag. -intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. -Qed. - -Lemma quot_1_l: forall a, 1 1÷a == 0. -Proof. exact NZQuot.div_1_l. Qed. - -Lemma rem_1_l: forall a, 1 1 rem a == 1. -Proof. exact NZQuot.mod_1_l. Qed. - -Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a. -Proof. - intros a b ?. pos_or_neg a; pos_or_neg b. - - apply NZQuot.div_mul; order. - - rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order. - - rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order. - apply NZQuot.div_mul; order. - - rewrite <- opp_inj_wd, <- quot_opp_r, <- mul_opp_opp by order. - apply NZQuot.div_mul; order. -Qed. - -Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0. -Proof. -intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag. -Qed. - -Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == a÷b. -Proof. - intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul. -Qed. - -(** The sign of [a rem b] is the one of [a] (when it's not null) *) - -Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b. -Proof. - intros a b **. pos_or_neg b. - - destruct (rem_bound_pos a b); order. - - rewrite <- rem_opp_r; trivial. - destruct (rem_bound_pos a (-b)); trivial. -Qed. - -Lemma rem_nonpos : forall a b, b~=0 -> a <= 0 -> a rem b <= 0. -Proof. - intros a b Hb Ha. - apply opp_nonneg_nonpos. apply opp_nonneg_nonpos in Ha. - rewrite <- rem_opp_l by trivial. now apply rem_nonneg. -Qed. - -Lemma rem_sign_mul : forall a b, b~=0 -> 0 <= (a rem b) * a. -Proof. -intros a b Hb. destruct (le_ge_cases 0 a). - - apply mul_nonneg_nonneg; trivial. now apply rem_nonneg. - - apply mul_nonpos_nonpos; trivial. now apply rem_nonpos. -Qed. - -Lemma rem_sign_nz : forall a b, b~=0 -> a rem b ~= 0 -> - sgn (a rem b) == sgn a. -Proof. -intros a b Hb H. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. -- rewrite 2 sgn_pos; try easy. - generalize (rem_nonneg a b Hb (lt_le_incl _ _ LT)). order. -- now rewrite <- EQ, rem_0_l, sgn_0. -- rewrite 2 sgn_neg; try easy. - generalize (rem_nonpos a b Hb (lt_le_incl _ _ LT)). order. -Qed. - -Lemma rem_sign : forall a b, a~=0 -> b~=0 -> sgn (a rem b) ~= -sgn a. -Proof. -intros a b Ha Hb H. -destruct (eq_decidable (a rem b) 0) as [EQ|NEQ]. -- apply Ha, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. -- apply Ha, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. - apply add_move_0_l. rewrite <- H. symmetry. now apply rem_sign_nz. -Qed. - -(** Operations and absolute value *) - -Lemma rem_abs_l : forall a b, b ~= 0 -> (abs a) rem b == abs (a rem b). -Proof. -intros a b Hb. destruct (le_ge_cases 0 a) as [LE|LE]. -- rewrite 2 abs_eq; try easy. now apply rem_nonneg. -- rewrite 2 abs_neq, rem_opp_l; try easy. now apply rem_nonpos. -Qed. - -Lemma rem_abs_r : forall a b, b ~= 0 -> a rem (abs b) == a rem b. -Proof. -intros a b Hb. destruct (le_ge_cases 0 b). -- now rewrite abs_eq. -- now rewrite abs_neq, ?rem_opp_r. -Qed. - -Lemma rem_abs : forall a b, b ~= 0 -> (abs a) rem (abs b) == abs (a rem b). -Proof. -intros. now rewrite rem_abs_r, rem_abs_l. -Qed. - -Lemma quot_abs_l : forall a b, b ~= 0 -> (abs a)÷b == (sgn a)*(a÷b). -Proof. -intros a b Hb. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. -- rewrite abs_eq, sgn_pos by order. now nzsimpl. -- rewrite <- EQ, abs_0, quot_0_l; trivial. now nzsimpl. -- rewrite abs_neq, quot_opp_l, sgn_neg by order. - rewrite mul_opp_l. now nzsimpl. -Qed. - -Lemma quot_abs_r : forall a b, b ~= 0 -> a÷(abs b) == (sgn b)*(a÷b). -Proof. -intros a b Hb. destruct (lt_trichotomy 0 b) as [LT|[EQ|LT]]. -- rewrite abs_eq, sgn_pos by order. now nzsimpl. -- order. -- rewrite abs_neq, quot_opp_r, sgn_neg by order. - rewrite mul_opp_l. now nzsimpl. -Qed. - -Lemma quot_abs : forall a b, b ~= 0 -> (abs a)÷(abs b) == abs (a÷b). -Proof. -intros a b Hb. -pos_or_neg a; [rewrite (abs_eq a)|rewrite (abs_neq a)]; - try apply opp_nonneg_nonpos; try order. -- pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; - try apply opp_nonneg_nonpos; try order. - + rewrite abs_eq; try easy. apply NZQuot.div_pos; order. - + rewrite <- abs_opp, <- quot_opp_r, abs_eq; try easy. - apply NZQuot.div_pos; order. -- pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; - try apply opp_nonneg_nonpos; try order. - + rewrite <- (abs_opp (_÷_)), <- quot_opp_l, abs_eq; try easy. - apply NZQuot.div_pos; order. - + rewrite <- (quot_opp_opp a b), abs_eq; try easy. - apply NZQuot.div_pos; order. -Qed. - -(** We have a general bound for absolute values *) - -Lemma rem_bound_abs : - forall a b, b~=0 -> abs (a rem b) < abs b. -Proof. -intros. rewrite <- rem_abs; trivial. -apply rem_bound_pos. -- apply abs_nonneg. -- now apply abs_pos. -Qed. - -(** * Order results about rem and quot *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem rem_le: forall a b, 0<=a -> 0 a rem b <= a. -Proof. exact NZQuot.mod_le. Qed. - -Theorem quot_pos : forall a b, 0<=a -> 0 0<= a÷b. -Proof. exact NZQuot.div_pos. Qed. - -Lemma quot_str_pos : forall a b, 0 0 < a÷b. -Proof. exact NZQuot.div_str_pos. Qed. - -Lemma quot_small_iff : forall a b, b~=0 -> (a÷b==0 <-> abs a < abs b). -Proof. -intros a b ?. pos_or_neg a; pos_or_neg b. -- rewrite NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order. -- rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.div_small_iff by order. - rewrite (abs_eq a), (abs_neq' b); intuition; order. -- rewrite <- opp_inj_wd, opp_0, <- quot_opp_l, NZQuot.div_small_iff by order. - rewrite (abs_neq' a), (abs_eq b); intuition; order. -- rewrite <- quot_opp_opp, NZQuot.div_small_iff by order. - rewrite (abs_neq' a), (abs_neq' b); intuition; order. -Qed. - -Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b). -Proof. -intros a b ?. rewrite rem_eq, <- quot_small_iff by order. -rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. -rewrite eq_sym_iff, eq_mul_0. tauto. -Qed. - -(** As soon as the divisor is strictly greater than 1, + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B). + + (** We benefit from what already exists for NZ *) + + Module Import Private_Div. + Module Quot2Div <: NZDiv A. + Definition div := quot. + Definition modulo := A.rem. + Definition div_wd := quot_wd. + Definition mod_wd := rem_wd. + Definition div_mod := quot_rem. + Definition mod_bound_pos := rem_bound_pos. + End Quot2Div. + Module NZQuot := Nop <+ NZDivProp A Quot2Div B. + End Private_Div. + + Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + + (** Another formulation of the main equation *) + + Lemma rem_eq : + forall a b, b~=0 -> a rem b == a - b*(a÷b). + Proof. + intros. + rewrite <- add_move_l. + symmetry. now apply quot_rem. + Qed. + + (** A few sign rules (simple ones) *) + + Lemma rem_opp_opp : forall a b, b ~= 0 -> (-a) rem (-b) == - (a rem b). + Proof. intros. now rewrite rem_opp_r, rem_opp_l. Qed. + + Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)÷b == -(a÷b). + Proof. + intros a b ?. + rewrite <- (mul_cancel_l _ _ b) by trivial. + rewrite <- (add_cancel_r _ _ ((-a) rem b)). + now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem. + Qed. + + Lemma quot_opp_r : forall a b, b ~= 0 -> a÷(-b) == -(a÷b). + Proof. + intros a b ?. + assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). + rewrite <- (mul_cancel_l _ _ (-b)) by trivial. + rewrite <- (add_cancel_r _ _ (a rem (-b))). + now rewrite <- quot_rem, rem_opp_r, mul_opp_opp, <- quot_rem. + Qed. + + Lemma quot_opp_opp : forall a b, b ~= 0 -> (-a)÷(-b) == a÷b. + Proof. intros. now rewrite quot_opp_r, quot_opp_l, opp_involutive. Qed. + + (** Uniqueness theorems *) + + Theorem quot_rem_unique : forall b q1 q2 r1 r2 : t, + (0<=r1 (0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. + Proof. + intros b q1 q2 r1 r2 Hr1 Hr2 EQ. + destruct Hr1; destruct Hr2; try (intuition; order). + - apply NZQuot.div_mod_unique with b; trivial. + - rewrite <- (opp_inj_wd r1 r2). + apply NZQuot.div_mod_unique with (-b); trivial. + + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. + + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. + + now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. + Qed. + + Theorem quot_unique: + forall a b q r, 0<=a -> 0<=r a == b*q + r -> q == a÷b. + Proof. intros a b q r **; now apply NZQuot.div_unique with r. Qed. + + Theorem rem_unique: + forall a b q r, 0<=a -> 0<=r a == b*q + r -> r == a rem b. + Proof. intros a b q r **; now apply NZQuot.mod_unique with q. Qed. + + (** A division by itself returns 1 *) + + Lemma quot_same : forall a, a~=0 -> a÷a == 1. + Proof. + intros a ?. pos_or_neg a. + - apply NZQuot.div_same; order. + - rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same. + Qed. + + Lemma rem_same : forall a, a~=0 -> a rem a == 0. + Proof. + intros. rewrite rem_eq, quot_same by trivial. nzsimpl. apply sub_diag. + Qed. + + (** A division of a small number by a bigger one yields zero. *) + + Theorem quot_small: forall a b, 0<=a a÷b == 0. + Proof. exact NZQuot.div_small. Qed. + + (** Same situation, in term of remulo: *) + + Theorem rem_small: forall a b, 0<=a a rem b == a. + Proof. exact NZQuot.mod_small. Qed. + + (** * Basic values of divisions and modulo. *) + + Lemma quot_0_l: forall a, a~=0 -> 0÷a == 0. + Proof. + intros a ?. pos_or_neg a. + - apply NZQuot.div_0_l; order. + - rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l. + Qed. + + Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0. + Proof. + intros; rewrite rem_eq, quot_0_l; now nzsimpl. + Qed. + + Lemma quot_1_r: forall a, a÷1 == a. + Proof. + intros a. pos_or_neg a. + - now apply NZQuot.div_1_r. + - apply opp_inj. rewrite <- quot_opp_l. + + apply NZQuot.div_1_r; order. + + intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1. + Qed. + + Lemma rem_1_r: forall a, a rem 1 == 0. + Proof. + intros. rewrite rem_eq, quot_1_r; nzsimpl; auto using sub_diag. + intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. + Qed. + + Lemma quot_1_l: forall a, 1 1÷a == 0. + Proof. exact NZQuot.div_1_l. Qed. + + Lemma rem_1_l: forall a, 1 1 rem a == 1. + Proof. exact NZQuot.mod_1_l. Qed. + + Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a. + Proof. + intros a b ?. pos_or_neg a; pos_or_neg b. + - apply NZQuot.div_mul; order. + - rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order. + - rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order. + apply NZQuot.div_mul; order. + - rewrite <- opp_inj_wd, <- quot_opp_r, <- mul_opp_opp by order. + apply NZQuot.div_mul; order. + Qed. + + Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0. + Proof. + intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag. + Qed. + + Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == a÷b. + Proof. + intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul. + Qed. + + (** The sign of [a rem b] is the one of [a] (when it's not null) *) + + Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b. + Proof. + intros a b **. pos_or_neg b. + - destruct (rem_bound_pos a b); order. + - rewrite <- rem_opp_r; trivial. + destruct (rem_bound_pos a (-b)); trivial. + Qed. + + Lemma rem_nonpos : forall a b, b~=0 -> a <= 0 -> a rem b <= 0. + Proof. + intros a b Hb Ha. + apply opp_nonneg_nonpos. apply opp_nonneg_nonpos in Ha. + rewrite <- rem_opp_l by trivial. now apply rem_nonneg. + Qed. + + Lemma rem_sign_mul : forall a b, b~=0 -> 0 <= (a rem b) * a. + Proof. + intros a b Hb. destruct (le_ge_cases 0 a). + - apply mul_nonneg_nonneg; trivial. now apply rem_nonneg. + - apply mul_nonpos_nonpos; trivial. now apply rem_nonpos. + Qed. + + Lemma rem_sign_nz : forall a b, b~=0 -> a rem b ~= 0 -> + sgn (a rem b) == sgn a. + Proof. + intros a b Hb H. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. + - rewrite 2 sgn_pos; try easy. + generalize (rem_nonneg a b Hb (lt_le_incl _ _ LT)). order. + - now rewrite <- EQ, rem_0_l, sgn_0. + - rewrite 2 sgn_neg; try easy. + generalize (rem_nonpos a b Hb (lt_le_incl _ _ LT)). order. + Qed. + + Lemma rem_sign : forall a b, a~=0 -> b~=0 -> sgn (a rem b) ~= -sgn a. + Proof. + intros a b Ha Hb H. + destruct (eq_decidable (a rem b) 0) as [EQ|NEQ]. + - apply Ha, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. + - apply Ha, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. + apply add_move_0_l. rewrite <- H. symmetry. now apply rem_sign_nz. + Qed. + + (** Operations and absolute value *) + + Lemma rem_abs_l : forall a b, b ~= 0 -> (abs a) rem b == abs (a rem b). + Proof. + intros a b Hb. destruct (le_ge_cases 0 a) as [LE|LE]. + - rewrite 2 abs_eq; try easy. now apply rem_nonneg. + - rewrite 2 abs_neq, rem_opp_l; try easy. now apply rem_nonpos. + Qed. + + Lemma rem_abs_r : forall a b, b ~= 0 -> a rem (abs b) == a rem b. + Proof. + intros a b Hb. destruct (le_ge_cases 0 b). + - now rewrite abs_eq. + - now rewrite abs_neq, ?rem_opp_r. + Qed. + + Lemma rem_abs : forall a b, b ~= 0 -> (abs a) rem (abs b) == abs (a rem b). + Proof. + intros. now rewrite rem_abs_r, rem_abs_l. + Qed. + + Lemma quot_abs_l : forall a b, b ~= 0 -> (abs a)÷b == (sgn a)*(a÷b). + Proof. + intros a b Hb. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. + - rewrite abs_eq, sgn_pos by order. now nzsimpl. + - rewrite <- EQ, abs_0, quot_0_l; trivial. now nzsimpl. + - rewrite abs_neq, quot_opp_l, sgn_neg by order. + rewrite mul_opp_l. now nzsimpl. + Qed. + + Lemma quot_abs_r : forall a b, b ~= 0 -> a÷(abs b) == (sgn b)*(a÷b). + Proof. + intros a b Hb. destruct (lt_trichotomy 0 b) as [LT|[EQ|LT]]. + - rewrite abs_eq, sgn_pos by order. now nzsimpl. + - order. + - rewrite abs_neq, quot_opp_r, sgn_neg by order. + rewrite mul_opp_l. now nzsimpl. + Qed. + + Lemma quot_abs : forall a b, b ~= 0 -> (abs a)÷(abs b) == abs (a÷b). + Proof. + intros a b Hb. + pos_or_neg a; [rewrite (abs_eq a)|rewrite (abs_neq a)]; + try apply opp_nonneg_nonpos; try order. + - pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; + try apply opp_nonneg_nonpos; try order. + + rewrite abs_eq; try easy. apply NZQuot.div_pos; order. + + rewrite <- abs_opp, <- quot_opp_r, abs_eq; try easy. + apply NZQuot.div_pos; order. + - pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; + try apply opp_nonneg_nonpos; try order. + + rewrite <- (abs_opp (_÷_)), <- quot_opp_l, abs_eq; try easy. + apply NZQuot.div_pos; order. + + rewrite <- (quot_opp_opp a b), abs_eq; try easy. + apply NZQuot.div_pos; order. + Qed. + + (** We have a general bound for absolute values *) + + Lemma rem_bound_abs : + forall a b, b~=0 -> abs (a rem b) < abs b. + Proof. + intros. rewrite <- rem_abs; trivial. + apply rem_bound_pos. + - apply abs_nonneg. + - now apply abs_pos. + Qed. + + (** * Order results about rem and quot *) + + (** A modulo cannot grow beyond its starting point. *) + + Theorem rem_le: forall a b, 0<=a -> 0 a rem b <= a. + Proof. exact NZQuot.mod_le. Qed. + + Theorem quot_pos : forall a b, 0<=a -> 0 0<= a÷b. + Proof. exact NZQuot.div_pos. Qed. + + Lemma quot_str_pos : forall a b, 0 0 < a÷b. + Proof. exact NZQuot.div_str_pos. Qed. + + Lemma quot_small_iff : forall a b, b~=0 -> (a÷b==0 <-> abs a < abs b). + Proof. + intros a b ?. pos_or_neg a; pos_or_neg b. + - rewrite NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order. + - rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.div_small_iff by order. + rewrite (abs_eq a), (abs_neq' b); intuition; order. + - rewrite <- opp_inj_wd, opp_0, <- quot_opp_l, NZQuot.div_small_iff by order. + rewrite (abs_neq' a), (abs_eq b); intuition; order. + - rewrite <- quot_opp_opp, NZQuot.div_small_iff by order. + rewrite (abs_neq' a), (abs_neq' b); intuition; order. + Qed. + + Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b). + Proof. + intros a b ?. rewrite rem_eq, <- quot_small_iff by order. + rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. + rewrite eq_sym_iff, eq_mul_0. tauto. + Qed. + + (** As soon as the divisor is strictly greater than 1, the division is strictly decreasing. *) -Lemma quot_lt : forall a b, 0 1 a÷b < a. -Proof. exact NZQuot.div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma quot_le_mono : forall a b c, 0 a<=b -> a÷c <= b÷c. -Proof. - intros a b c **. pos_or_neg a. - - apply NZQuot.div_le_mono; auto. - - pos_or_neg b. - + apply le_trans with 0. - * rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order. - apply quot_pos; order. - * apply quot_pos; order. - + rewrite opp_le_mono in *. rewrite <- 2 quot_opp_l by order. - apply NZQuot.div_le_mono; intuition; order. -Qed. - -(** With this choice of division, + Lemma quot_lt : forall a b, 0 1 a÷b < a. + Proof. exact NZQuot.div_lt. Qed. + + (** [le] is compatible with a positive division. *) + + Lemma quot_le_mono : forall a b c, 0 a<=b -> a÷c <= b÷c. + Proof. + intros a b c **. pos_or_neg a. + - apply NZQuot.div_le_mono; auto. + - pos_or_neg b. + + apply le_trans with 0. + * rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order. + apply quot_pos; order. + * apply quot_pos; order. + + rewrite opp_le_mono in *. rewrite <- 2 quot_opp_l by order. + apply NZQuot.div_le_mono; intuition; order. + Qed. + + (** With this choice of division, rounding of quot is always done toward zero: *) -Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a÷b) <= a. -Proof. -intros a b **. pos_or_neg b. -- split. - + apply mul_nonneg_nonneg; [|apply quot_pos]; order. - + apply NZQuot.mul_div_le; order. -- rewrite <- mul_opp_opp, <- quot_opp_r by order. - split. - + apply mul_nonneg_nonneg; [|apply quot_pos]; order. - + apply NZQuot.mul_div_le; order. -Qed. - -Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a÷b) <= 0. -Proof. -intros a b **. -rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order. -rewrite <- opp_nonneg_nonpos in *. -destruct (mul_quot_le (-a) b); tauto. -Qed. - -(** For positive numbers, considering [S (a÷b)] leads to an upper bound for [a] *) - -Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0 a < b*(S (a÷b)). -Proof. exact NZQuot.mul_succ_div_gt. Qed. - -(** Similar results with negative numbers *) - -Lemma mul_pred_quot_lt: forall a b, a<=0 -> 0 b*(P (a÷b)) < a. -Proof. -intros. -rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order. -rewrite <- opp_nonneg_nonpos in *. -now apply mul_succ_quot_gt. -Qed. - -Lemma mul_pred_quot_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a÷b)). -Proof. -intros. -rewrite <- mul_opp_opp, opp_pred, <- quot_opp_r by order. -rewrite <- opp_pos_neg in *. -now apply mul_succ_quot_gt. -Qed. - -Lemma mul_succ_quot_lt: forall a b, a<=0 -> b<0 -> b*(S (a÷b)) < a. -Proof. -intros. -rewrite opp_lt_mono, <- mul_opp_l, <- quot_opp_opp by order. -rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *. -now apply mul_succ_quot_gt. -Qed. - -(** Inequality [mul_quot_le] is exact iff the modulo is zero. *) - -Lemma quot_exact : forall a b, b~=0 -> (a == b*(a÷b) <-> a rem b == 0). -Proof. -intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. -Qed. - -(** Some additional inequalities about quot. *) - -Theorem quot_lt_upper_bound: - forall a b q, 0<=a -> 0 a < b*q -> a÷b < q. -Proof. exact NZQuot.div_lt_upper_bound. Qed. - -Theorem quot_le_upper_bound: - forall a b q, 0 a <= b*q -> a÷b <= q. -Proof. -intros a b q **. -rewrite <- (quot_mul q b) by order. -apply quot_le_mono; trivial. now rewrite mul_comm. -Qed. - -Theorem quot_le_lower_bound: - forall a b q, 0 b*q <= a -> q <= a÷b. -Proof. -intros a b q **. -rewrite <- (quot_mul q b) by order. -apply quot_le_mono; trivial. now rewrite mul_comm. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma quot_le_compat_l: forall p q r, 0<=p -> 0 p÷r <= p÷q. -Proof. exact NZQuot.div_le_compat_l. Qed. - -(** * Relations between usual operations and rem and quot *) - -(** Unlike with other division conventions, some results here aren't + Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a÷b) <= a. + Proof. + intros a b **. pos_or_neg b. + - split. + + apply mul_nonneg_nonneg; [|apply quot_pos]; order. + + apply NZQuot.mul_div_le; order. + - rewrite <- mul_opp_opp, <- quot_opp_r by order. + split. + + apply mul_nonneg_nonneg; [|apply quot_pos]; order. + + apply NZQuot.mul_div_le; order. + Qed. + + Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a÷b) <= 0. + Proof. + intros a b **. + rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order. + rewrite <- opp_nonneg_nonpos in *. + destruct (mul_quot_le (-a) b); tauto. + Qed. + + (** For positive numbers, considering [S (a÷b)] leads to an upper bound for [a] *) + + Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0 a < b*(S (a÷b)). + Proof. exact NZQuot.mul_succ_div_gt. Qed. + + (** Similar results with negative numbers *) + + Lemma mul_pred_quot_lt: forall a b, a<=0 -> 0 b*(P (a÷b)) < a. + Proof. + intros. + rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order. + rewrite <- opp_nonneg_nonpos in *. + now apply mul_succ_quot_gt. + Qed. + + Lemma mul_pred_quot_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a÷b)). + Proof. + intros. + rewrite <- mul_opp_opp, opp_pred, <- quot_opp_r by order. + rewrite <- opp_pos_neg in *. + now apply mul_succ_quot_gt. + Qed. + + Lemma mul_succ_quot_lt: forall a b, a<=0 -> b<0 -> b*(S (a÷b)) < a. + Proof. + intros. + rewrite opp_lt_mono, <- mul_opp_l, <- quot_opp_opp by order. + rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *. + now apply mul_succ_quot_gt. + Qed. + + (** Inequality [mul_quot_le] is exact iff the modulo is zero. *) + + Lemma quot_exact : forall a b, b~=0 -> (a == b*(a÷b) <-> a rem b == 0). + Proof. + intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. + Qed. + + (** Some additional inequalities about quot. *) + + Theorem quot_lt_upper_bound: + forall a b q, 0<=a -> 0 a < b*q -> a÷b < q. + Proof. exact NZQuot.div_lt_upper_bound. Qed. + + Theorem quot_le_upper_bound: + forall a b q, 0 a <= b*q -> a÷b <= q. + Proof. + intros a b q **. + rewrite <- (quot_mul q b) by order. + apply quot_le_mono; trivial. now rewrite mul_comm. + Qed. + + Theorem quot_le_lower_bound: + forall a b q, 0 b*q <= a -> q <= a÷b. + Proof. + intros a b q **. + rewrite <- (quot_mul q b) by order. + apply quot_le_mono; trivial. now rewrite mul_comm. + Qed. + + (** A division respects opposite monotonicity for the divisor *) + + Lemma quot_le_compat_l: forall p q r, 0<=p -> 0 p÷r <= p÷q. + Proof. exact NZQuot.div_le_compat_l. Qed. + + (** * Relations between usual operations and rem and quot *) + + (** Unlike with other division conventions, some results here aren't always valid, and need to be restricted. For instance [(a+b*c) rem c <> a rem c] for [a=9,b=-5,c=2] *) -Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> - (a + b * c) rem c == a rem c. -Proof. -assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c). { - intros a b c **. pos_or_neg c. - - apply NZQuot.mod_add; order. - - rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order. - rewrite <- mul_opp_opp in *. - apply NZQuot.mod_add; order. -} -intros a b c Hc Habc. -destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. { auto. } -apply opp_inj. revert Ha Habc'. -rewrite <- 2 opp_nonneg_nonpos. -rewrite <- 2 rem_opp_l, opp_add_distr, <- mul_opp_l by order. auto. -Qed. - -Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> - (a + b * c) ÷ c == a ÷ c + b. -Proof. -intros a b c **. -rewrite <- (mul_cancel_l _ _ c) by trivial. -rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)). -rewrite <- quot_rem, rem_add by trivial. -now rewrite mul_add_distr_l, add_shuffle0, <-quot_rem, mul_comm. -Qed. - -Lemma quot_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c -> - (a * b + c) ÷ b == a + c ÷ b. -Proof. - intros a b c. rewrite add_comm, (add_comm a). now apply quot_add. -Qed. - -(** Cancellations. *) - -Lemma quot_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)÷(b*c) == a÷b. -Proof. -assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a*c)÷(b*c) == a÷b). { - intros a b c **. pos_or_neg c. - - apply NZQuot.div_mul_cancel_r; order. - - rewrite <- quot_opp_opp, <- 2 mul_opp_r. - + apply NZQuot.div_mul_cancel_r; order. - + rewrite <- neq_mul_0; intuition order. -} -assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b). { - intros a b c **. pos_or_neg b. - - apply Aux1; order. - - apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_l; try order. - + apply Aux1; order. - + rewrite <- neq_mul_0; intuition order. -} -intros a b c **. pos_or_neg a. { apply Aux2; order. } -apply opp_inj. rewrite <- 2 quot_opp_l, <- mul_opp_l; try order. { apply Aux2; order. } -rewrite <- neq_mul_0; intuition order. -Qed. - -Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)÷(c*b) == a÷b. -Proof. -intros a b c **. rewrite !(mul_comm c); now apply quot_mul_cancel_r. -Qed. - -Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) rem (b*c) == (a rem b) * c. -Proof. -intros a b c **. -assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). -rewrite ! rem_eq by trivial. -rewrite quot_mul_cancel_r by order. -now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a÷b) c). -Qed. - -Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) rem (c*b) == c * (a rem b). -Proof. -intros a b c **; rewrite !(mul_comm c); now apply mul_rem_distr_r. -Qed. - -(** Operations modulo. *) - -Theorem rem_rem: forall a n, n~=0 -> - (a rem n) rem n == a rem n. -Proof. - intros a n **. pos_or_neg a; pos_or_neg n. - - apply NZQuot.mod_mod; order. - - rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order. - - apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order. - - apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.mod_mod; order. -Qed. - -Lemma mul_rem_idemp_l : forall a b n, n~=0 -> - ((a rem n)*b) rem n == (a*b) rem n. -Proof. -assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 -> - ((a rem n)*b) rem n == (a*b) rem n). { - intros a b n **. pos_or_neg n. - - apply NZQuot.mul_mod_idemp_l; order. - - rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.mul_mod_idemp_l; order. -} -assert (Aux2 : forall a b n, 0<=a -> n~=0 -> - ((a rem n)*b) rem n == (a*b) rem n). { - intros a b n **. pos_or_neg b. - - now apply Aux1. - - apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_r by order. - apply Aux1; order. -} -intros a b n Hn. pos_or_neg a. { now apply Aux2. } -apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_opp_l by order. -apply Aux2; order. -Qed. - -Lemma mul_rem_idemp_r : forall a b n, n~=0 -> - (a*(b rem n)) rem n == (a*b) rem n. -Proof. -intros a b n **. rewrite !(mul_comm a). now apply mul_rem_idemp_l. -Qed. - -Theorem mul_rem: forall a b n, n~=0 -> - (a * b) rem n == ((a rem n) * (b rem n)) rem n. -Proof. -intros. now rewrite mul_rem_idemp_l, mul_rem_idemp_r. -Qed. - -(** addition and modulo + Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) rem c == a rem c. + Proof. + assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c). { + intros a b c **. pos_or_neg c. + - apply NZQuot.mod_add; order. + - rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order. + rewrite <- mul_opp_opp in *. + apply NZQuot.mod_add; order. + } + intros a b c Hc Habc. + destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. { auto. } + apply opp_inj. revert Ha Habc'. + rewrite <- 2 opp_nonneg_nonpos. + rewrite <- 2 rem_opp_l, opp_add_distr, <- mul_opp_l by order. auto. + Qed. + + Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) ÷ c == a ÷ c + b. + Proof. + intros a b c **. + rewrite <- (mul_cancel_l _ _ c) by trivial. + rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)). + rewrite <- quot_rem, rem_add by trivial. + now rewrite mul_add_distr_l, add_shuffle0, <-quot_rem, mul_comm. + Qed. + + Lemma quot_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c -> + (a * b + c) ÷ b == a + c ÷ b. + Proof. + intros a b c. rewrite add_comm, (add_comm a). now apply quot_add. + Qed. + + (** Cancellations. *) + + Lemma quot_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)÷(b*c) == a÷b. + Proof. + assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a*c)÷(b*c) == a÷b). { + intros a b c **. pos_or_neg c. + - apply NZQuot.div_mul_cancel_r; order. + - rewrite <- quot_opp_opp, <- 2 mul_opp_r. + + apply NZQuot.div_mul_cancel_r; order. + + rewrite <- neq_mul_0; intuition order. + } + assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b). { + intros a b c **. pos_or_neg b. + - apply Aux1; order. + - apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_l; try order. + + apply Aux1; order. + + rewrite <- neq_mul_0; intuition order. + } + intros a b c **. pos_or_neg a. { apply Aux2; order. } + apply opp_inj. rewrite <- 2 quot_opp_l, <- mul_opp_l; try order. { apply Aux2; order. } + rewrite <- neq_mul_0; intuition order. + Qed. + + Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)÷(c*b) == a÷b. + Proof. + intros a b c **. rewrite !(mul_comm c); now apply quot_mul_cancel_r. + Qed. + + Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) rem (b*c) == (a rem b) * c. + Proof. + intros a b c **. + assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). + rewrite ! rem_eq by trivial. + rewrite quot_mul_cancel_r by order. + now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a÷b) c). + Qed. + + Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) rem (c*b) == c * (a rem b). + Proof. + intros a b c **; rewrite !(mul_comm c); now apply mul_rem_distr_r. + Qed. + + (** Operations modulo. *) + + Theorem rem_rem: forall a n, n~=0 -> + (a rem n) rem n == a rem n. + Proof. + intros a n **. pos_or_neg a; pos_or_neg n. + - apply NZQuot.mod_mod; order. + - rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order. + - apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order. + - apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.mod_mod; order. + Qed. + + Lemma mul_rem_idemp_l : forall a b n, n~=0 -> + ((a rem n)*b) rem n == (a*b) rem n. + Proof. + assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 -> + ((a rem n)*b) rem n == (a*b) rem n). { + intros a b n **. pos_or_neg n. + - apply NZQuot.mul_mod_idemp_l; order. + - rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.mul_mod_idemp_l; order. + } + assert (Aux2 : forall a b n, 0<=a -> n~=0 -> + ((a rem n)*b) rem n == (a*b) rem n). { + intros a b n **. pos_or_neg b. + - now apply Aux1. + - apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_r by order. + apply Aux1; order. + } + intros a b n Hn. pos_or_neg a. { now apply Aux2. } + apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_opp_l by order. + apply Aux2; order. + Qed. + + Lemma mul_rem_idemp_r : forall a b n, n~=0 -> + (a*(b rem n)) rem n == (a*b) rem n. + Proof. + intros a b n **. rewrite !(mul_comm a). now apply mul_rem_idemp_l. + Qed. + + Theorem mul_rem: forall a b n, n~=0 -> + (a * b) rem n == ((a rem n) * (b rem n)) rem n. + Proof. + intros. now rewrite mul_rem_idemp_l, mul_rem_idemp_r. + Qed. + + (** addition and modulo Generally speaking, unlike with other conventions, we don't have [(a+b) rem n = (a rem n + b rem n) rem n] @@ -583,86 +583,86 @@ Qed. (8 rem 3 + (-10 rem 3)) rem 3 = 1. *) -Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> - ((a rem n)+b) rem n == (a+b) rem n. -Proof. -assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 -> - ((a rem n)+b) rem n == (a+b) rem n). { - intros a b n **. pos_or_neg n. { apply NZQuot.add_mod_idemp_l; order. } - rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.add_mod_idemp_l; order. -} -intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]. -{ now apply Aux. } -apply opp_inj. rewrite <-2 rem_opp_l, 2 opp_add_distr, <-rem_opp_l by order. -rewrite <- opp_nonneg_nonpos in *. -now apply Aux. -Qed. - -Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> - (a+(b rem n)) rem n == (a+b) rem n. -Proof. -intros a b n **. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. -now rewrite mul_comm. -Qed. - -Theorem add_rem: forall a b n, n~=0 -> 0 <= a*b -> - (a+b) rem n == (a rem n + b rem n) rem n. -Proof. -intros a b n Hn Hab. rewrite add_rem_idemp_l, add_rem_idemp_r; trivial. -- reflexivity. -- destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]; - destruct (le_0_mul _ _ (rem_sign_mul b n Hn)) as [(Hb',Hm)|(Hb',Hm)]; - auto using mul_nonneg_nonneg, mul_nonpos_nonpos. - + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. - + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. -Qed. - -(** Conversely, the following results need less restrictions here. *) - -Lemma quot_quot : forall a b c, b~=0 -> c~=0 -> - (a÷b)÷c == a÷(b*c). -Proof. -assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a÷b)÷c == a÷(b*c)). { - intros a b c **. pos_or_neg c. { apply NZQuot.div_div; order. } - apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial. - { apply NZQuot.div_div; order. } - rewrite <- neq_mul_0; intuition order. -} -assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c)). { - intros a b c **. pos_or_neg b. { apply Aux1; order. } - apply opp_inj. rewrite <- quot_opp_l, <- 2 quot_opp_r, <- mul_opp_l; trivial. - { apply Aux1; trivial. } - rewrite <- neq_mul_0; intuition order. -} -intros a b c **. pos_or_neg a. { apply Aux2; order. } -apply opp_inj. rewrite <- 3 quot_opp_l; try order. { apply Aux2; order. } -rewrite <- neq_mul_0. tauto. -Qed. - -Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> - a rem (b*c) == a rem b + b*((a÷b) rem c). -Proof. - intros a b c Hb Hc. - apply add_cancel_l with (b*c*(a÷(b*c))). - rewrite <- quot_rem by (apply neq_mul_0; split; order). - rewrite <- quot_quot by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- quot_rem by order. - apply quot_rem; order. -Qed. - -Lemma rem_quot: forall a b, b~=0 -> - a rem b ÷ b == 0. -Proof. - intros a b Hb. - rewrite quot_small_iff by assumption. - auto using rem_bound_abs. -Qed. - -(** A last inequality: *) - -Theorem quot_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a÷b) <= (c*a)÷b. -Proof. exact NZQuot.div_mul_le. Qed. + Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> + ((a rem n)+b) rem n == (a+b) rem n. + Proof. + assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 -> + ((a rem n)+b) rem n == (a+b) rem n). { + intros a b n **. pos_or_neg n. { apply NZQuot.add_mod_idemp_l; order. } + rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.add_mod_idemp_l; order. + } + intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]. + { now apply Aux. } + apply opp_inj. rewrite <-2 rem_opp_l, 2 opp_add_distr, <-rem_opp_l by order. + rewrite <- opp_nonneg_nonpos in *. + now apply Aux. + Qed. + + Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> + (a+(b rem n)) rem n == (a+b) rem n. + Proof. + intros a b n **. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. + now rewrite mul_comm. + Qed. + + Theorem add_rem: forall a b n, n~=0 -> 0 <= a*b -> + (a+b) rem n == (a rem n + b rem n) rem n. + Proof. + intros a b n Hn Hab. rewrite add_rem_idemp_l, add_rem_idemp_r; trivial. + - reflexivity. + - destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]; + destruct (le_0_mul _ _ (rem_sign_mul b n Hn)) as [(Hb',Hm)|(Hb',Hm)]; + auto using mul_nonneg_nonneg, mul_nonpos_nonpos. + + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. + + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. + Qed. + + (** Conversely, the following results need less restrictions here. *) + + Lemma quot_quot : forall a b c, b~=0 -> c~=0 -> + (a÷b)÷c == a÷(b*c). + Proof. + assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a÷b)÷c == a÷(b*c)). { + intros a b c **. pos_or_neg c. { apply NZQuot.div_div; order. } + apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial. + { apply NZQuot.div_div; order. } + rewrite <- neq_mul_0; intuition order. + } + assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c)). { + intros a b c **. pos_or_neg b. { apply Aux1; order. } + apply opp_inj. rewrite <- quot_opp_l, <- 2 quot_opp_r, <- mul_opp_l; trivial. + { apply Aux1; trivial. } + rewrite <- neq_mul_0; intuition order. + } + intros a b c **. pos_or_neg a. { apply Aux2; order. } + apply opp_inj. rewrite <- 3 quot_opp_l; try order. { apply Aux2; order. } + rewrite <- neq_mul_0. tauto. + Qed. + + Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> + a rem (b*c) == a rem b + b*((a÷b) rem c). + Proof. + intros a b c Hb Hc. + apply add_cancel_l with (b*c*(a÷(b*c))). + rewrite <- quot_rem by (apply neq_mul_0; split; order). + rewrite <- quot_quot by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- quot_rem by order. + apply quot_rem; order. + Qed. + + Lemma rem_quot: forall a b, b~=0 -> + a rem b ÷ b == 0. + Proof. + intros a b Hb. + rewrite quot_small_iff by assumption. + auto using rem_bound_abs. + Qed. + + (** A last inequality: *) + + Theorem quot_mul_le: + forall a b c, 0<=a -> 0 0<=c -> c*(a÷b) <= (c*a)÷b. + Proof. exact NZQuot.div_mul_le. Qed. End ZQuotProp. diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v index ff0e4ff0c1..bb3c5fb600 100644 --- a/theories/Numbers/Integer/Abstract/ZGcd.v +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -13,275 +13,275 @@ From Stdlib Require Import ZAxioms ZMulOrder ZSgnAbs NZGcd. Module Type ZGcdProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZSgnAbsProp A B). - - Include NZGcdProp A A B. - -(** Results concerning divisibility*) - -Lemma divide_opp_l : forall n m, (-n | m) <-> (n | m). -Proof. - intros n m. split; intros (p,Hp); exists (-p); rewrite Hp. - - now rewrite mul_opp_l, mul_opp_r. - - now rewrite mul_opp_opp. -Qed. - -Lemma divide_opp_r : forall n m, (n | -m) <-> (n | m). -Proof. - intros n m. split; intros (p,Hp); exists (-p). - - now rewrite mul_opp_l, <- Hp, opp_involutive. - - now rewrite Hp, mul_opp_l. -Qed. - -Lemma divide_abs_l : forall n m, (abs n | m) <-> (n | m). -Proof. - intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. - - easy. - - apply divide_opp_l. -Qed. - -Lemma divide_abs_r : forall n m, (n | abs m) <-> (n | m). -Proof. - intros n m. destruct (abs_eq_or_opp m) as [H|H]; rewrite H. - - easy. - - apply divide_opp_r. -Qed. - -Lemma divide_1_r_abs : forall n, (n | 1) -> abs n == 1. -Proof. - intros n Hn. apply divide_1_r_nonneg. - - apply abs_nonneg. - - now apply divide_abs_l. -Qed. - -Lemma divide_1_r : forall n, (n | 1) -> n==1 \/ n==-1. -Proof. - intros n (m,H). rewrite mul_comm in H. now apply eq_mul_1 with m. -Qed. - -Lemma divide_antisym_abs : forall n m, - (n | m) -> (m | n) -> abs n == abs m. -Proof. - intros. apply divide_antisym_nonneg; try apply abs_nonneg. - - now apply divide_abs_l, divide_abs_r. - - now apply divide_abs_l, divide_abs_r. -Qed. - -Lemma divide_antisym : forall n m, - (n | m) -> (m | n) -> n == m \/ n == -m. -Proof. - intros. now apply abs_eq_cases, divide_antisym_abs. -Qed. - -Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). -Proof. - intros n m p H H'. rewrite <- add_opp_r. - apply divide_add_r; trivial. now apply divide_opp_r. -Qed. - -Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). -Proof. - intros n m p H H'. rewrite <- (add_simpl_l m p). now apply divide_sub_r. -Qed. - -(** Properties of gcd *) - -Lemma gcd_opp_l : forall n m, gcd (-n) m == gcd n m. -Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. - intros. rewrite divide_opp_r. apply gcd_divide_iff. -Qed. - -Lemma gcd_opp_r : forall n m, gcd n (-m) == gcd n m. -Proof. - intros. now rewrite gcd_comm, gcd_opp_l, gcd_comm. -Qed. - -Lemma gcd_abs_l : forall n m, gcd (abs n) m == gcd n m. -Proof. - intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. - - easy. - - apply gcd_opp_l. -Qed. - -Lemma gcd_abs_r : forall n m, gcd n (abs m) == gcd n m. -Proof. - intros. now rewrite gcd_comm, gcd_abs_l, gcd_comm. -Qed. - -Lemma gcd_0_l : forall n, gcd 0 n == abs n. -Proof. - intros. rewrite <- gcd_abs_r. apply gcd_0_l_nonneg, abs_nonneg. -Qed. - -Lemma gcd_0_r : forall n, gcd n 0 == abs n. -Proof. - intros. now rewrite gcd_comm, gcd_0_l. -Qed. - -Lemma gcd_diag : forall n, gcd n n == abs n. -Proof. - intros. rewrite <- gcd_abs_l, <- gcd_abs_r. - apply gcd_diag_nonneg, abs_nonneg. -Qed. - -Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. -Proof. - intros n m p. apply gcd_unique_alt; try apply gcd_nonneg. - intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. - - apply divide_add_r; trivial. now apply divide_mul_r. - - apply divide_add_cancel_r with (p*n); trivial. - + now apply divide_mul_r. - + now rewrite add_comm. -Qed. - -Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. -Proof. - intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. -Qed. - -Lemma gcd_sub_diag_r : forall n m, gcd n (m-n) == gcd n m. -Proof. - intros n m. rewrite <- (mul_1_l n) at 2. - rewrite <- add_opp_r, <- mul_opp_l. apply gcd_add_mult_diag_r. -Qed. - -Definition Bezout n m p := exists a b, a*n + b*m == p. - -#[global] -Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. -Proof. - unfold Bezout. intros x x' Hx y y' Hy z z' Hz. - setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. -Qed. - -Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. -Proof. - intros n m (q & r & H). - apply gcd_unique; trivial using divide_1_l, le_0_1. - intros p Hn Hm. - rewrite <- H. apply divide_add_r; now apply divide_mul_r. -Qed. - -Lemma gcd_bezout : forall n m p, gcd n m == p -> Bezout n m p. -Proof. - (* First, a version restricted to natural numbers *) - assert (aux : forall n, 0<=n -> forall m, 0<=m -> Bezout n m (gcd n m)). { - intros n Hn; pattern n. - apply (fun H => strong_right_induction H 0); trivial. - clear n Hn. intros n Hn IHn. - apply le_lteq in Hn; destruct Hn as [Hn|Hn]. - - intros m Hm; pattern m. + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B). + + Include NZGcdProp A A B. + + (** Results concerning divisibility*) + + Lemma divide_opp_l : forall n m, (-n | m) <-> (n | m). + Proof. + intros n m. split; intros (p,Hp); exists (-p); rewrite Hp. + - now rewrite mul_opp_l, mul_opp_r. + - now rewrite mul_opp_opp. + Qed. + + Lemma divide_opp_r : forall n m, (n | -m) <-> (n | m). + Proof. + intros n m. split; intros (p,Hp); exists (-p). + - now rewrite mul_opp_l, <- Hp, opp_involutive. + - now rewrite Hp, mul_opp_l. + Qed. + + Lemma divide_abs_l : forall n m, (abs n | m) <-> (n | m). + Proof. + intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + - easy. + - apply divide_opp_l. + Qed. + + Lemma divide_abs_r : forall n m, (n | abs m) <-> (n | m). + Proof. + intros n m. destruct (abs_eq_or_opp m) as [H|H]; rewrite H. + - easy. + - apply divide_opp_r. + Qed. + + Lemma divide_1_r_abs : forall n, (n | 1) -> abs n == 1. + Proof. + intros n Hn. apply divide_1_r_nonneg. + - apply abs_nonneg. + - now apply divide_abs_l. + Qed. + + Lemma divide_1_r : forall n, (n | 1) -> n==1 \/ n==-1. + Proof. + intros n (m,H). rewrite mul_comm in H. now apply eq_mul_1 with m. + Qed. + + Lemma divide_antisym_abs : forall n m, + (n | m) -> (m | n) -> abs n == abs m. + Proof. + intros. apply divide_antisym_nonneg; try apply abs_nonneg. + - now apply divide_abs_l, divide_abs_r. + - now apply divide_abs_l, divide_abs_r. + Qed. + + Lemma divide_antisym : forall n m, + (n | m) -> (m | n) -> n == m \/ n == -m. + Proof. + intros. now apply abs_eq_cases, divide_antisym_abs. + Qed. + + Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). + Proof. + intros n m p H H'. rewrite <- add_opp_r. + apply divide_add_r; trivial. now apply divide_opp_r. + Qed. + + Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). + Proof. + intros n m p H H'. rewrite <- (add_simpl_l m p). now apply divide_sub_r. + Qed. + + (** Properties of gcd *) + + Lemma gcd_opp_l : forall n m, gcd (-n) m == gcd n m. + Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. rewrite divide_opp_r. apply gcd_divide_iff. + Qed. + + Lemma gcd_opp_r : forall n m, gcd n (-m) == gcd n m. + Proof. + intros. now rewrite gcd_comm, gcd_opp_l, gcd_comm. + Qed. + + Lemma gcd_abs_l : forall n m, gcd (abs n) m == gcd n m. + Proof. + intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + - easy. + - apply gcd_opp_l. + Qed. + + Lemma gcd_abs_r : forall n m, gcd n (abs m) == gcd n m. + Proof. + intros. now rewrite gcd_comm, gcd_abs_l, gcd_comm. + Qed. + + Lemma gcd_0_l : forall n, gcd 0 n == abs n. + Proof. + intros. rewrite <- gcd_abs_r. apply gcd_0_l_nonneg, abs_nonneg. + Qed. + + Lemma gcd_0_r : forall n, gcd n 0 == abs n. + Proof. + intros. now rewrite gcd_comm, gcd_0_l. + Qed. + + Lemma gcd_diag : forall n, gcd n n == abs n. + Proof. + intros. rewrite <- gcd_abs_l, <- gcd_abs_r. + apply gcd_diag_nonneg, abs_nonneg. + Qed. + + Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. + Proof. + intros n m p. apply gcd_unique_alt; try apply gcd_nonneg. + intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. + - apply divide_add_r; trivial. now apply divide_mul_r. + - apply divide_add_cancel_r with (p*n); trivial. + + now apply divide_mul_r. + + now rewrite add_comm. + Qed. + + Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. + Proof. + intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. + Qed. + + Lemma gcd_sub_diag_r : forall n m, gcd n (m-n) == gcd n m. + Proof. + intros n m. rewrite <- (mul_1_l n) at 2. + rewrite <- add_opp_r, <- mul_opp_l. apply gcd_add_mult_diag_r. + Qed. + + Definition Bezout n m p := exists a b, a*n + b*m == p. + + #[global] + Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. + Proof. + unfold Bezout. intros x x' Hx y y' Hy z z' Hz. + setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. + Qed. + + Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. + Proof. + intros n m (q & r & H). + apply gcd_unique; trivial using divide_1_l, le_0_1. + intros p Hn Hm. + rewrite <- H. apply divide_add_r; now apply divide_mul_r. + Qed. + + Lemma gcd_bezout : forall n m p, gcd n m == p -> Bezout n m p. + Proof. + (* First, a version restricted to natural numbers *) + assert (aux : forall n, 0<=n -> forall m, 0<=m -> Bezout n m (gcd n m)). { + intros n Hn; pattern n. apply (fun H => strong_right_induction H 0); trivial. - clear m Hm. intros m Hm IHm. - destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. - + (* n < m *) - destruct (IHm (m-n)) as (a & b & EQ). - * apply sub_nonneg; order. - * now apply lt_sub_pos. - * exists (a-b). exists b. - rewrite gcd_sub_diag_r in EQ. rewrite <- EQ. - rewrite mul_sub_distr_r, mul_sub_distr_l. - now rewrite add_sub_assoc, add_sub_swap. - + (* n = m *) - rewrite EQ. rewrite gcd_diag_nonneg; trivial. - exists 1. exists 0. now nzsimpl. - + (* m < n *) - destruct (IHn m Hm LT n) as (a & b & EQ). { order. } - exists b. exists a. now rewrite gcd_comm, <- EQ, add_comm. - - (* n = 0 *) - intros m Hm. rewrite <- Hn, gcd_0_l_nonneg; trivial. - exists 0. exists 1. now nzsimpl. - } - (* Then we relax the positivity condition on n *) - assert (aux' : forall n m, 0<=m -> Bezout n m (gcd n m)). { - intros n m Hm. - destruct (le_ge_cases 0 n). - - now apply aux. - - assert (Hn' : 0 <= -n) by now apply opp_nonneg_nonpos. - destruct (aux (-n) Hn' m Hm) as (a & b & EQ). - exists (-a). exists b. now rewrite <- gcd_opp_l, <- EQ, mul_opp_r, mul_opp_l. - } - (* And finally we do the same for m *) - intros n m p Hp. rewrite <- Hp; clear Hp. - destruct (le_ge_cases 0 m). - - now apply aux'. - - assert (Hm' : 0 <= -m) by now apply opp_nonneg_nonpos. - destruct (aux' n (-m) Hm') as (a & b & EQ). - exists a. exists (-b). now rewrite <- gcd_opp_r, <- EQ, mul_opp_r, mul_opp_l. -Qed. - -Lemma gcd_mul_mono_l : - forall n m p, gcd (p * n) (p * m) == abs p * gcd n m. -Proof. - intros n m p. - apply gcd_unique. - - apply mul_nonneg_nonneg; trivial using gcd_nonneg, abs_nonneg. - - destruct (gcd_divide_l n m) as (q,Hq). - rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. - rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. - - destruct (gcd_divide_r n m) as (q,Hq). - rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. - rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. - - intros q H H'. - destruct (gcd_bezout n m (gcd n m) (eq_refl _)) as (a & b & EQ). - rewrite <- EQ, <- sgn_abs, mul_add_distr_l. apply divide_add_r. - + rewrite mul_shuffle2. now apply divide_mul_l. - + rewrite mul_shuffle2. now apply divide_mul_l. -Qed. - -Lemma gcd_mul_mono_l_nonneg : - forall n m p, 0<=p -> gcd (p*n) (p*m) == p * gcd n m. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l. -Qed. - -Lemma gcd_mul_mono_r : - forall n m p, gcd (n * p) (m * p) == gcd n m * abs p. -Proof. - intros n m p. now rewrite !(mul_comm _ p), gcd_mul_mono_l, mul_comm. -Qed. - -Lemma gcd_mul_mono_r_nonneg : - forall n m p, 0<=p -> gcd (n*p) (m*p) == gcd n m * p. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r. -Qed. - -Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). -Proof. - intros n m p H G. - destruct (gcd_bezout n m 1 G) as (a & b & EQ). - rewrite <- (mul_1_l p), <- EQ, mul_add_distr_r. - apply divide_add_r. - - rewrite mul_shuffle0. apply divide_factor_r. - - rewrite <- mul_assoc. now apply divide_mul_r. -Qed. - -Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> - exists q r, n == q*r /\ (q | m) /\ (r | p). -Proof. - intros n m p Hn H. - assert (G := gcd_nonneg n m). - apply le_lteq in G; destruct G as [G|G]. - - destruct (gcd_divide_l n m) as (q,Hq). - exists (gcd n m). exists q. - split. - + now rewrite mul_comm. - + split. - * apply gcd_divide_r. - * destruct (gcd_divide_r n m) as (r,Hr). - rewrite Hr in H. rewrite Hq in H at 1. - rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. - apply gauss with r; trivial. - apply mul_cancel_r with (gcd n m); [order|]. - rewrite mul_1_l. - rewrite <- gcd_mul_mono_r_nonneg, <- Hq, <- Hr; order. - - symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. -Qed. - -(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) + clear n Hn. intros n Hn IHn. + apply le_lteq in Hn; destruct Hn as [Hn|Hn]. + - intros m Hm; pattern m. + apply (fun H => strong_right_induction H 0); trivial. + clear m Hm. intros m Hm IHm. + destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. + + (* n < m *) + destruct (IHm (m-n)) as (a & b & EQ). + * apply sub_nonneg; order. + * now apply lt_sub_pos. + * exists (a-b). exists b. + rewrite gcd_sub_diag_r in EQ. rewrite <- EQ. + rewrite mul_sub_distr_r, mul_sub_distr_l. + now rewrite add_sub_assoc, add_sub_swap. + + (* n = m *) + rewrite EQ. rewrite gcd_diag_nonneg; trivial. + exists 1. exists 0. now nzsimpl. + + (* m < n *) + destruct (IHn m Hm LT n) as (a & b & EQ). { order. } + exists b. exists a. now rewrite gcd_comm, <- EQ, add_comm. + - (* n = 0 *) + intros m Hm. rewrite <- Hn, gcd_0_l_nonneg; trivial. + exists 0. exists 1. now nzsimpl. + } + (* Then we relax the positivity condition on n *) + assert (aux' : forall n m, 0<=m -> Bezout n m (gcd n m)). { + intros n m Hm. + destruct (le_ge_cases 0 n). + - now apply aux. + - assert (Hn' : 0 <= -n) by now apply opp_nonneg_nonpos. + destruct (aux (-n) Hn' m Hm) as (a & b & EQ). + exists (-a). exists b. now rewrite <- gcd_opp_l, <- EQ, mul_opp_r, mul_opp_l. + } + (* And finally we do the same for m *) + intros n m p Hp. rewrite <- Hp; clear Hp. + destruct (le_ge_cases 0 m). + - now apply aux'. + - assert (Hm' : 0 <= -m) by now apply opp_nonneg_nonpos. + destruct (aux' n (-m) Hm') as (a & b & EQ). + exists a. exists (-b). now rewrite <- gcd_opp_r, <- EQ, mul_opp_r, mul_opp_l. + Qed. + + Lemma gcd_mul_mono_l : + forall n m p, gcd (p * n) (p * m) == abs p * gcd n m. + Proof. + intros n m p. + apply gcd_unique. + - apply mul_nonneg_nonneg; trivial using gcd_nonneg, abs_nonneg. + - destruct (gcd_divide_l n m) as (q,Hq). + rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. + rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. + - destruct (gcd_divide_r n m) as (q,Hq). + rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. + rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. + - intros q H H'. + destruct (gcd_bezout n m (gcd n m) (eq_refl _)) as (a & b & EQ). + rewrite <- EQ, <- sgn_abs, mul_add_distr_l. apply divide_add_r. + + rewrite mul_shuffle2. now apply divide_mul_l. + + rewrite mul_shuffle2. now apply divide_mul_l. + Qed. + + Lemma gcd_mul_mono_l_nonneg : + forall n m p, 0<=p -> gcd (p*n) (p*m) == p * gcd n m. + Proof. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l. + Qed. + + Lemma gcd_mul_mono_r : + forall n m p, gcd (n * p) (m * p) == gcd n m * abs p. + Proof. + intros n m p. now rewrite !(mul_comm _ p), gcd_mul_mono_l, mul_comm. + Qed. + + Lemma gcd_mul_mono_r_nonneg : + forall n m p, 0<=p -> gcd (n*p) (m*p) == gcd n m * p. + Proof. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r. + Qed. + + Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). + Proof. + intros n m p H G. + destruct (gcd_bezout n m 1 G) as (a & b & EQ). + rewrite <- (mul_1_l p), <- EQ, mul_add_distr_r. + apply divide_add_r. + - rewrite mul_shuffle0. apply divide_factor_r. + - rewrite <- mul_assoc. now apply divide_mul_r. + Qed. + + Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> + exists q r, n == q*r /\ (q | m) /\ (r | p). + Proof. + intros n m p Hn H. + assert (G := gcd_nonneg n m). + apply le_lteq in G; destruct G as [G|G]. + - destruct (gcd_divide_l n m) as (q,Hq). + exists (gcd n m). exists q. + split. + + now rewrite mul_comm. + + split. + * apply gcd_divide_r. + * destruct (gcd_divide_r n m) as (r,Hr). + rewrite Hr in H. rewrite Hq in H at 1. + rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. + apply gauss with r; trivial. + apply mul_cancel_r with (gcd n m); [order|]. + rewrite mul_1_l. + rewrite <- gcd_mul_mono_r_nonneg, <- Hq, <- Hr; order. + - symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. + Qed. + + (** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) End ZGcdProp. diff --git a/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v index 00535e37d1..3c9cd85e6a 100644 --- a/theories/Numbers/Integer/Abstract/ZLcm.v +++ b/theories/Numbers/Integer/Abstract/ZLcm.v @@ -22,186 +22,186 @@ From Stdlib Require Import ZAxioms ZMulOrder ZSgnAbs ZGcd ZDivTrunc ZDivFloor. *) Module Type ZLcmProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZSgnAbsProp A B) - (Import D : ZDivProp A B C) - (Import E : ZQuotProp A B C) - (Import F : ZGcdProp A B C). - -(** The two notions of division are equal on non-negative numbers *) - -Lemma quot_div_nonneg : forall a b, 0<=a -> 0 a÷b == a/b. -Proof. - intros a b **. apply div_unique_pos with (a rem b). - - now apply rem_bound_pos. - - apply quot_rem. order. -Qed. - -Lemma rem_mod_nonneg : forall a b, 0<=a -> 0 a rem b == a mod b. -Proof. - intros a b **. apply mod_unique_pos with (a÷b). - - now apply rem_bound_pos. - - apply quot_rem. order. -Qed. - -(** We can use the sign rule to have an relation between divisions. *) - -Lemma quot_div : forall a b, b~=0 -> - a÷b == (sgn a)*(sgn b)*(abs a / abs b). -Proof. - assert (AUX : forall a b, 0 a÷b == (sgn a)*(sgn b)*(abs a / abs b)). { - intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order. - destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. - - rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order. - - rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order. - - rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l - by order. - apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order. - } - (* main *) - intros a b Hb. - apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX]. - rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r. - - rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive. - + reflexivity. - + now apply opp_pos_neg. - - rewrite eq_opp_l, opp_0; order. -Qed. - -Lemma rem_mod : forall a b, b~=0 -> - a rem b == (sgn a) * ((abs a) mod (abs b)). -Proof. - intros a b Hb. - rewrite <- rem_abs_r by trivial. - assert (Hb' := proj2 (abs_pos b) Hb). - destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. - - rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order. - - rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order. - - rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l - by order. - apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order. -Qed. - -(** Modulo and remainder are null at the same place, + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B) + (Import D : ZDivProp A B C) + (Import E : ZQuotProp A B C) + (Import F : ZGcdProp A B C). + + (** The two notions of division are equal on non-negative numbers *) + + Lemma quot_div_nonneg : forall a b, 0<=a -> 0 a÷b == a/b. + Proof. + intros a b **. apply div_unique_pos with (a rem b). + - now apply rem_bound_pos. + - apply quot_rem. order. + Qed. + + Lemma rem_mod_nonneg : forall a b, 0<=a -> 0 a rem b == a mod b. + Proof. + intros a b **. apply mod_unique_pos with (a÷b). + - now apply rem_bound_pos. + - apply quot_rem. order. + Qed. + + (** We can use the sign rule to have an relation between divisions. *) + + Lemma quot_div : forall a b, b~=0 -> + a÷b == (sgn a)*(sgn b)*(abs a / abs b). + Proof. + assert (AUX : forall a b, 0 a÷b == (sgn a)*(sgn b)*(abs a / abs b)). { + intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order. + destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. + - rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order. + - rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order. + - rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l + by order. + apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order. + } + (* main *) + intros a b Hb. + apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX]. + rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r. + - rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive. + + reflexivity. + + now apply opp_pos_neg. + - rewrite eq_opp_l, opp_0; order. + Qed. + + Lemma rem_mod : forall a b, b~=0 -> + a rem b == (sgn a) * ((abs a) mod (abs b)). + Proof. + intros a b Hb. + rewrite <- rem_abs_r by trivial. + assert (Hb' := proj2 (abs_pos b) Hb). + destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. + - rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order. + - rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order. + - rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l + by order. + apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order. + Qed. + + (** Modulo and remainder are null at the same place, and this correspond to the divisibility relation. *) -Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). -Proof. - intros a b Hb. split. - - intros Hab. exists (a/b). rewrite mul_comm. - rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. - - intros (c,Hc). rewrite Hc. now apply mod_mul. -Qed. - -Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)). -Proof. - intros a b Hb. split. - - intros Hab. exists (a÷b). rewrite mul_comm. - rewrite (quot_rem a b Hb) at 1. rewrite Hab; now nzsimpl. - - intros (c,Hc). rewrite Hc. now apply rem_mul. -Qed. - -Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0). -Proof. - intros a b Hb. now rewrite mod_divide, rem_divide. -Qed. - -(** When division is exact, div and quot agree *) - -Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> a÷b == a/b. -Proof. - intros a b Hb H. - apply mul_cancel_l with b; trivial. - assert (H':=H). - apply rem_divide, quot_exact in H; trivial. - apply mod_divide, div_exact in H'; trivial. - now rewrite <-H,<-H'. -Qed. - -Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> - (c*a)/b == c*(a/b). -Proof. - intros a b c Hb H. - apply mul_cancel_l with b; trivial. - rewrite mul_assoc, mul_shuffle0. - assert (H':=H). apply mod_divide, div_exact in H'; trivial. - rewrite <- H', (mul_comm a c). - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - now apply divide_mul_r. -Qed. - -Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) -> - (c*a)÷b == c*(a÷b). -Proof. - intros a b c Hb H. - rewrite 2 quot_div_exact; trivial. - - apply divide_div_mul_exact; trivial. - - now apply divide_mul_r. -Qed. - -(** Gcd of divided elements, for exact divisions *) - -Lemma gcd_div_factor : forall a b c, 0 (c|a) -> (c|b) -> - gcd (a/c) (b/c) == (gcd a b)/c. -Proof. - intros a b c Hc Ha Hb. - apply mul_cancel_l with c; try order. - assert (H:=gcd_greatest _ _ _ Ha Hb). - apply mod_divide, div_exact in H; try order. - rewrite <- H. - rewrite <- gcd_mul_mono_l_nonneg; try order. - f_equiv; symmetry; apply div_exact; try order; - apply mod_divide; trivial; try order. -Qed. - -Lemma gcd_quot_factor : forall a b c, 0 (c|a) -> (c|b) -> - gcd (a÷c) (b÷c) == (gcd a b)÷c. -Proof. - intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order. - - now apply gcd_div_factor. - - now apply gcd_greatest. -Qed. - -Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> - gcd (a/g) (b/g) == 1. -Proof. - intros a b g NZ EQ. rewrite gcd_div_factor. - - now rewrite <- EQ, div_same. - - generalize (gcd_nonneg a b); order. - - rewrite EQ; apply gcd_divide_l. - - rewrite EQ; apply gcd_divide_r. -Qed. - -Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b -> - gcd (a÷g) (b÷g) == 1. -Proof. - intros a b g NZ EQ. rewrite !quot_div_exact; trivial. - - now apply gcd_div_gcd. - - rewrite EQ; apply gcd_divide_r. - - rewrite EQ; apply gcd_divide_l. -Qed. - -(** The following equality is crucial for Euclid algorithm *) - -Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. -Proof. - intros a b Hb. rewrite mod_eq; trivial. - rewrite <- add_opp_r, mul_comm, <- mul_opp_l. - rewrite (gcd_comm _ b). - apply gcd_add_mult_diag_r. -Qed. - -Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a. -Proof. - intros a b Hb. rewrite rem_eq; trivial. - rewrite <- add_opp_r, mul_comm, <- mul_opp_l. - rewrite (gcd_comm _ b). - apply gcd_add_mult_diag_r. -Qed. - -(** We now define lcm thanks to gcd: + Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). + Proof. + intros a b Hb. split. + - intros Hab. exists (a/b). rewrite mul_comm. + rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. + - intros (c,Hc). rewrite Hc. now apply mod_mul. + Qed. + + Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)). + Proof. + intros a b Hb. split. + - intros Hab. exists (a÷b). rewrite mul_comm. + rewrite (quot_rem a b Hb) at 1. rewrite Hab; now nzsimpl. + - intros (c,Hc). rewrite Hc. now apply rem_mul. + Qed. + + Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0). + Proof. + intros a b Hb. now rewrite mod_divide, rem_divide. + Qed. + + (** When division is exact, div and quot agree *) + + Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> a÷b == a/b. + Proof. + intros a b Hb H. + apply mul_cancel_l with b; trivial. + assert (H':=H). + apply rem_divide, quot_exact in H; trivial. + apply mod_divide, div_exact in H'; trivial. + now rewrite <-H,<-H'. + Qed. + + Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> + (c*a)/b == c*(a/b). + Proof. + intros a b c Hb H. + apply mul_cancel_l with b; trivial. + rewrite mul_assoc, mul_shuffle0. + assert (H':=H). apply mod_divide, div_exact in H'; trivial. + rewrite <- H', (mul_comm a c). + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + now apply divide_mul_r. + Qed. + + Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) -> + (c*a)÷b == c*(a÷b). + Proof. + intros a b c Hb H. + rewrite 2 quot_div_exact; trivial. + - apply divide_div_mul_exact; trivial. + - now apply divide_mul_r. + Qed. + + (** Gcd of divided elements, for exact divisions *) + + Lemma gcd_div_factor : forall a b c, 0 (c|a) -> (c|b) -> + gcd (a/c) (b/c) == (gcd a b)/c. + Proof. + intros a b c Hc Ha Hb. + apply mul_cancel_l with c; try order. + assert (H:=gcd_greatest _ _ _ Ha Hb). + apply mod_divide, div_exact in H; try order. + rewrite <- H. + rewrite <- gcd_mul_mono_l_nonneg; try order. + f_equiv; symmetry; apply div_exact; try order; + apply mod_divide; trivial; try order. + Qed. + + Lemma gcd_quot_factor : forall a b c, 0 (c|a) -> (c|b) -> + gcd (a÷c) (b÷c) == (gcd a b)÷c. + Proof. + intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order. + - now apply gcd_div_factor. + - now apply gcd_greatest. + Qed. + + Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> + gcd (a/g) (b/g) == 1. + Proof. + intros a b g NZ EQ. rewrite gcd_div_factor. + - now rewrite <- EQ, div_same. + - generalize (gcd_nonneg a b); order. + - rewrite EQ; apply gcd_divide_l. + - rewrite EQ; apply gcd_divide_r. + Qed. + + Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b -> + gcd (a÷g) (b÷g) == 1. + Proof. + intros a b g NZ EQ. rewrite !quot_div_exact; trivial. + - now apply gcd_div_gcd. + - rewrite EQ; apply gcd_divide_r. + - rewrite EQ; apply gcd_divide_l. + Qed. + + (** The following equality is crucial for Euclid algorithm *) + + Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. + Proof. + intros a b Hb. rewrite mod_eq; trivial. + rewrite <- add_opp_r, mul_comm, <- mul_opp_l. + rewrite (gcd_comm _ b). + apply gcd_add_mult_diag_r. + Qed. + + Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a. + Proof. + intros a b Hb. rewrite rem_eq; trivial. + rewrite <- add_opp_r, mul_comm, <- mul_opp_l. + rewrite (gcd_comm _ b). + apply gcd_add_mult_diag_r. + Qed. + + (** We now define lcm thanks to gcd: lcm a b = a * (b / gcd a b) = (a / gcd a b) * b @@ -212,277 +212,277 @@ Qed. isn't guarantee with the third equation above. *) -Definition lcm a b := abs (a*(b/gcd a b)). - -#[global] -Instance lcm_wd : Proper (eq==>eq==>eq) lcm. -Proof. unfold lcm. solve_proper. Qed. - -Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> - a * (b / gcd a b) == (a*b)/gcd a b. -Proof. - intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. -Qed. - -Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> - (a / gcd a b) * b == (a*b)/gcd a b. -Proof. - intros a b H. rewrite 2 (mul_comm _ b). - rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. -Qed. - -Lemma gcd_div_swap : forall a b, - (a / gcd a b) * b == a * (b / gcd a b). -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. - - now rewrite lcm_equiv1, <-lcm_equiv2. -Qed. - -Lemma divide_lcm_l : forall a b, (a | lcm a b). -Proof. - unfold lcm. intros a b. apply divide_abs_r, divide_factor_l. -Qed. - -Lemma divide_lcm_r : forall a b, (b | lcm a b). -Proof. - unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap. - apply divide_factor_r. -Qed. - -Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). -Proof. - intros a b c Ha Hb (c',Hc). exists c'. - now rewrite <- divide_div_mul_exact, <- Hc. -Qed. - -Lemma lcm_least : forall a b c, - (a | c) -> (b | c) -> (lcm a b | c). -Proof. - intros a b c Ha Hb. unfold lcm. apply divide_abs_l. - destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. - - assert (Ga := gcd_divide_l a b). - assert (Gb := gcd_divide_r a b). - set (g:=gcd a b) in *. - assert (Ha' := divide_div g a c NEQ Ga Ha). - assert (Hb' := divide_div g b c NEQ Gb Hb). - destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. - apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. - destruct Hb' as (b',Hb'). - exists b'. - rewrite mul_shuffle3, <- Hb'. - rewrite (proj2 (div_exact c g NEQ)). - + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - + apply mod_divide; trivial. transitivity a; trivial. -Qed. - -Lemma lcm_nonneg : forall a b, 0 <= lcm a b. -Proof. - intros a b. unfold lcm. apply abs_nonneg. -Qed. - -Lemma lcm_comm : forall a b, lcm a b == lcm b a. -Proof. - intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). - now rewrite <- gcd_div_swap. -Qed. - -Lemma lcm_divide_iff : forall n m p, - (lcm n m | p) <-> (n | p) /\ (m | p). -Proof. - intros n m p. split;[split|]. - - transitivity (lcm n m); trivial using divide_lcm_l. - - transitivity (lcm n m); trivial using divide_lcm_r. - - intros (H,H'). now apply lcm_least. -Qed. - -Lemma lcm_unique : forall n m p, - 0<=p -> (n|p) -> (m|p) -> - (forall q, (n|q) -> (m|q) -> (p|q)) -> - lcm n m == p. -Proof. - intros n m p Hp Hn Hm H. - apply divide_antisym_nonneg; trivial. - - apply lcm_nonneg. - - now apply lcm_least. - - apply H. - + apply divide_lcm_l. - + apply divide_lcm_r. -Qed. - -Lemma lcm_unique_alt : forall n m p, 0<=p -> - (forall q, (p|q) <-> (n|q) /\ (m|q)) -> - lcm n m == p. -Proof. - intros n m p Hp H. - apply lcm_unique; trivial. - - apply H, divide_refl. - - apply H, divide_refl. - - intros. apply H. now split. -Qed. - -Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. -Proof. - intros. apply lcm_unique_alt; try apply lcm_nonneg. - intros. now rewrite !lcm_divide_iff, and_assoc. -Qed. - -Lemma lcm_0_l : forall n, lcm 0 n == 0. -Proof. - intros. apply lcm_unique; trivial. - - order. - - apply divide_refl. - - apply divide_0_r. -Qed. - -Lemma lcm_0_r : forall n, lcm n 0 == 0. -Proof. - intros. now rewrite lcm_comm, lcm_0_l. -Qed. - -Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n. -Proof. - intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl. -Qed. - -Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n. -Proof. - intros. now rewrite lcm_comm, lcm_1_l_nonneg. -Qed. - -Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n. -Proof. - intros. apply lcm_unique; trivial using divide_refl. -Qed. - -Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. -Proof. - intros. split. - - intros EQ. - apply eq_mul_0. - apply divide_0_l. rewrite <- EQ. apply lcm_least. - + apply divide_factor_l. - + apply divide_factor_r. - - destruct 1 as [EQ|EQ]; rewrite EQ. - + apply lcm_0_l. - + apply lcm_0_r. -Qed. - -Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m. -Proof. - intros n m Hm H. apply lcm_unique_alt; trivial. - intros q. split. - - split; trivial. now transitivity m. - - now destruct 1. -Qed. - -Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m). -Proof. - intros n m Hn. split. - - now apply divide_lcm_eq_r. - - intros EQ. rewrite <- EQ. apply divide_lcm_l. -Qed. - -Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m. -Proof. - intros. apply lcm_unique_alt; try apply lcm_nonneg. - intros. rewrite divide_opp_l. apply lcm_divide_iff. -Qed. - -Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m. -Proof. - intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm. -Qed. - -Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m. -Proof. - intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. - - easy. - - apply lcm_opp_l. -Qed. - -Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m. -Proof. - intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm. -Qed. - -Lemma lcm_1_l : forall n, lcm 1 n == abs n. -Proof. - intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg. -Qed. - -Lemma lcm_1_r : forall n, lcm n 1 == abs n. -Proof. - intros. now rewrite lcm_comm, lcm_1_l. -Qed. - -Lemma lcm_diag : forall n, lcm n n == abs n. -Proof. - intros. rewrite <- lcm_abs_l, <- lcm_abs_r. - apply lcm_diag_nonneg, abs_nonneg. -Qed. - -Lemma lcm_mul_mono_l : - forall n m p, lcm (p * n) (p * m) == abs p * lcm n m. -Proof. - intros n m p. - destruct (eq_decidable p 0) as [Hp|Hp];[|destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]]. - - rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl. - - apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. - nzsimpl. rewrite lcm_0_l. now nzsimpl. - - unfold lcm. - rewrite gcd_mul_mono_l. - rewrite !abs_mul, mul_assoc. f_equiv. - rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc. - rewrite div_mul_cancel_l; trivial. - + rewrite divide_div_mul_exact; trivial. - * rewrite abs_mul. - rewrite <- (sgn_abs (sgn p)), sgn_sgn. - { destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]]. - - rewrite EQ. now nzsimpl. - - order. - - rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl. - } - * apply gcd_divide_r. - + contradict Hp. now apply abs_0_iff. -Qed. - -Lemma lcm_mul_mono_l_nonneg : - forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l. -Qed. - -Lemma lcm_mul_mono_r : - forall n m p, lcm (n * p) (m * p) == lcm n m * abs p. -Proof. - intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. -Qed. - -Lemma lcm_mul_mono_r_nonneg : - forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r. -Qed. - -Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> - (gcd n m == 1 <-> lcm n m == abs (n*m)). -Proof. - intros n m Hn Hm. split; intros H. - - unfold lcm. rewrite H. now rewrite div_1_r. - - unfold lcm in *. - rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff]. - assert (H' := gcd_divide_r n m). - assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). - apply mod_divide in H'; trivial. apply div_exact in H'; trivial. - assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl). - rewrite <- (mul_1_l (abs (_/_))) in H. - rewrite H' in H at 3. rewrite abs_mul in H. - apply mul_cancel_r in H; [|now rewrite abs_0_iff]. - rewrite abs_eq in H. { order. } apply gcd_nonneg. -Qed. + Definition lcm a b := abs (a*(b/gcd a b)). + + #[global] + Instance lcm_wd : Proper (eq==>eq==>eq) lcm. + Proof. unfold lcm. solve_proper. Qed. + + Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> + a * (b / gcd a b) == (a*b)/gcd a b. + Proof. + intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. + Qed. + + Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> + (a / gcd a b) * b == (a*b)/gcd a b. + Proof. + intros a b H. rewrite 2 (mul_comm _ b). + rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. + Qed. + + Lemma gcd_div_swap : forall a b, + (a / gcd a b) * b == a * (b / gcd a b). + Proof. + intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. + - now rewrite lcm_equiv1, <-lcm_equiv2. + Qed. + + Lemma divide_lcm_l : forall a b, (a | lcm a b). + Proof. + unfold lcm. intros a b. apply divide_abs_r, divide_factor_l. + Qed. + + Lemma divide_lcm_r : forall a b, (b | lcm a b). + Proof. + unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap. + apply divide_factor_r. + Qed. + + Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). + Proof. + intros a b c Ha Hb (c',Hc). exists c'. + now rewrite <- divide_div_mul_exact, <- Hc. + Qed. + + Lemma lcm_least : forall a b c, + (a | c) -> (b | c) -> (lcm a b | c). + Proof. + intros a b c Ha Hb. unfold lcm. apply divide_abs_l. + destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. + - assert (Ga := gcd_divide_l a b). + assert (Gb := gcd_divide_r a b). + set (g:=gcd a b) in *. + assert (Ha' := divide_div g a c NEQ Ga Ha). + assert (Hb' := divide_div g b c NEQ Gb Hb). + destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. + apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. + destruct Hb' as (b',Hb'). + exists b'. + rewrite mul_shuffle3, <- Hb'. + rewrite (proj2 (div_exact c g NEQ)). + + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + + apply mod_divide; trivial. transitivity a; trivial. + Qed. + + Lemma lcm_nonneg : forall a b, 0 <= lcm a b. + Proof. + intros a b. unfold lcm. apply abs_nonneg. + Qed. + + Lemma lcm_comm : forall a b, lcm a b == lcm b a. + Proof. + intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). + now rewrite <- gcd_div_swap. + Qed. + + Lemma lcm_divide_iff : forall n m p, + (lcm n m | p) <-> (n | p) /\ (m | p). + Proof. + intros n m p. split;[split|]. + - transitivity (lcm n m); trivial using divide_lcm_l. + - transitivity (lcm n m); trivial using divide_lcm_r. + - intros (H,H'). now apply lcm_least. + Qed. + + Lemma lcm_unique : forall n m p, + 0<=p -> (n|p) -> (m|p) -> + (forall q, (n|q) -> (m|q) -> (p|q)) -> + lcm n m == p. + Proof. + intros n m p Hp Hn Hm H. + apply divide_antisym_nonneg; trivial. + - apply lcm_nonneg. + - now apply lcm_least. + - apply H. + + apply divide_lcm_l. + + apply divide_lcm_r. + Qed. + + Lemma lcm_unique_alt : forall n m p, 0<=p -> + (forall q, (p|q) <-> (n|q) /\ (m|q)) -> + lcm n m == p. + Proof. + intros n m p Hp H. + apply lcm_unique; trivial. + - apply H, divide_refl. + - apply H, divide_refl. + - intros. apply H. now split. + Qed. + + Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. + Proof. + intros. apply lcm_unique_alt; try apply lcm_nonneg. + intros. now rewrite !lcm_divide_iff, and_assoc. + Qed. + + Lemma lcm_0_l : forall n, lcm 0 n == 0. + Proof. + intros. apply lcm_unique; trivial. + - order. + - apply divide_refl. + - apply divide_0_r. + Qed. + + Lemma lcm_0_r : forall n, lcm n 0 == 0. + Proof. + intros. now rewrite lcm_comm, lcm_0_l. + Qed. + + Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n. + Proof. + intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl. + Qed. + + Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n. + Proof. + intros. now rewrite lcm_comm, lcm_1_l_nonneg. + Qed. + + Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n. + Proof. + intros. apply lcm_unique; trivial using divide_refl. + Qed. + + Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. + Proof. + intros. split. + - intros EQ. + apply eq_mul_0. + apply divide_0_l. rewrite <- EQ. apply lcm_least. + + apply divide_factor_l. + + apply divide_factor_r. + - destruct 1 as [EQ|EQ]; rewrite EQ. + + apply lcm_0_l. + + apply lcm_0_r. + Qed. + + Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m. + Proof. + intros n m Hm H. apply lcm_unique_alt; trivial. + intros q. split. + - split; trivial. now transitivity m. + - now destruct 1. + Qed. + + Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m). + Proof. + intros n m Hn. split. + - now apply divide_lcm_eq_r. + - intros EQ. rewrite <- EQ. apply divide_lcm_l. + Qed. + + Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m. + Proof. + intros. apply lcm_unique_alt; try apply lcm_nonneg. + intros. rewrite divide_opp_l. apply lcm_divide_iff. + Qed. + + Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m. + Proof. + intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm. + Qed. + + Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m. + Proof. + intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + - easy. + - apply lcm_opp_l. + Qed. + + Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m. + Proof. + intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm. + Qed. + + Lemma lcm_1_l : forall n, lcm 1 n == abs n. + Proof. + intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg. + Qed. + + Lemma lcm_1_r : forall n, lcm n 1 == abs n. + Proof. + intros. now rewrite lcm_comm, lcm_1_l. + Qed. + + Lemma lcm_diag : forall n, lcm n n == abs n. + Proof. + intros. rewrite <- lcm_abs_l, <- lcm_abs_r. + apply lcm_diag_nonneg, abs_nonneg. + Qed. + + Lemma lcm_mul_mono_l : + forall n m p, lcm (p * n) (p * m) == abs p * lcm n m. + Proof. + intros n m p. + destruct (eq_decidable p 0) as [Hp|Hp];[|destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]]. + - rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl. + - apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. + nzsimpl. rewrite lcm_0_l. now nzsimpl. + - unfold lcm. + rewrite gcd_mul_mono_l. + rewrite !abs_mul, mul_assoc. f_equiv. + rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc. + rewrite div_mul_cancel_l; trivial. + + rewrite divide_div_mul_exact; trivial. + * rewrite abs_mul. + rewrite <- (sgn_abs (sgn p)), sgn_sgn. + { destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]]. + - rewrite EQ. now nzsimpl. + - order. + - rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl. + } + * apply gcd_divide_r. + + contradict Hp. now apply abs_0_iff. + Qed. + + Lemma lcm_mul_mono_l_nonneg : + forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m. + Proof. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l. + Qed. + + Lemma lcm_mul_mono_r : + forall n m p, lcm (n * p) (m * p) == lcm n m * abs p. + Proof. + intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. + Qed. + + Lemma lcm_mul_mono_r_nonneg : + forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p. + Proof. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r. + Qed. + + Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> + (gcd n m == 1 <-> lcm n m == abs (n*m)). + Proof. + intros n m Hn Hm. split; intros H. + - unfold lcm. rewrite H. now rewrite div_1_r. + - unfold lcm in *. + rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff]. + assert (H' := gcd_divide_r n m). + assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). + apply mod_divide in H'; trivial. apply div_exact in H'; trivial. + assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl). + rewrite <- (mul_1_l (abs (_/_))) in H. + rewrite H' in H at 3. rewrite abs_mul in H. + apply mul_cancel_r in H; [|now rewrite abs_0_iff]. + rewrite abs_eq in H. { order. } apply gcd_nonneg. + Qed. End ZLcmProp. diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v index 407be64874..f6c10c9c72 100644 --- a/theories/Numbers/Integer/Abstract/ZLt.v +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -13,122 +13,122 @@ From Stdlib Require Export ZMul. Module ZOrderProp (Import Z : ZAxiomsMiniSig'). -Include ZMulProp Z. + Include ZMulProp Z. -(** Instances of earlier theorems for m == 0 *) + (** Instances of earlier theorems for m == 0 *) -Theorem neg_pos_cases : forall n, n ~= 0 <-> n < 0 \/ n > 0. -Proof. -intro; apply lt_gt_cases. -Qed. + Theorem neg_pos_cases : forall n, n ~= 0 <-> n < 0 \/ n > 0. + Proof. + intro; apply lt_gt_cases. + Qed. -Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0. -Proof. -intro; apply le_gt_cases. -Qed. + Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0. + Proof. + intro; apply le_gt_cases. + Qed. -Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0. -Proof. -intro; apply lt_ge_cases. -Qed. + Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0. + Proof. + intro; apply lt_ge_cases. + Qed. -Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0. -Proof. -intro; apply le_ge_cases. -Qed. + Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0. + Proof. + intro; apply le_ge_cases. + Qed. -Ltac zinduct n := induction_maker n ltac:(apply order_induction_0). + Ltac zinduct n := induction_maker n ltac:(apply order_induction_0). -(** Theorems that are either not valid on N or have different proofs + (** Theorems that are either not valid on N or have different proofs on N and Z *) -Theorem lt_pred_l : forall n, P n < n. -Proof. -intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r. -Qed. - -Theorem le_pred_l : forall n, P n <= n. -Proof. -intro; apply lt_le_incl; apply lt_pred_l. -Qed. - -Theorem lt_le_pred : forall n m, n < m <-> n <= P m. -Proof. -intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r. -Qed. - -Theorem nle_pred_r : forall n, ~ n <= P n. -Proof. -intro; rewrite <- lt_le_pred; apply lt_irrefl. -Qed. - -Theorem lt_pred_le : forall n m, P n < m <-> n <= m. -Proof. -intros n m; rewrite <- (succ_pred n) at 2. -symmetry; apply le_succ_l. -Qed. - -Theorem lt_lt_pred : forall n m, n < m -> P n < m. -Proof. -intros; apply lt_pred_le; now apply lt_le_incl. -Qed. - -Theorem le_le_pred : forall n m, n <= m -> P n <= m. -Proof. -intros; apply lt_le_incl; now apply lt_pred_le. -Qed. - -Theorem lt_pred_lt : forall n m, n < P m -> n < m. -Proof. -intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l]. -Qed. - -Theorem le_pred_lt : forall n m, n <= P m -> n <= m. -Proof. -intros; apply lt_le_incl; now apply lt_le_pred. -Qed. - -Theorem pred_lt_mono : forall n m, n < m <-> P n < P m. -Proof. -intros; rewrite lt_le_pred; symmetry; apply lt_pred_le. -Qed. - -Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m. -Proof. -intros; rewrite <- lt_pred_le; now rewrite lt_le_pred. -Qed. - -Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. -Proof. -intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ. -Qed. - -Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m. -Proof. -intros n m; now rewrite (pred_le_mono (S n) m), pred_succ. -Qed. - -Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m. -Proof. -intros; rewrite lt_pred_le; symmetry; apply lt_succ_r. -Qed. - -Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m. -Proof. -intros n m; now rewrite (pred_le_mono n (S m)), pred_succ. -Qed. - -Theorem neq_pred_l : forall n, P n ~= n. -Proof. -intro; apply lt_neq; apply lt_pred_l. -Qed. - -Theorem lt_m1_r : forall n m, n < m -> m < 0 -> n < -1. -Proof. -intros n m H1 H2. apply lt_le_pred in H2. -setoid_replace (P 0) with (-1) in H2. -- now apply lt_le_trans with m. -- apply eq_opp_r. now rewrite one_succ, opp_pred, opp_0. -Qed. + Theorem lt_pred_l : forall n, P n < n. + Proof. + intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r. + Qed. + + Theorem le_pred_l : forall n, P n <= n. + Proof. + intro; apply lt_le_incl; apply lt_pred_l. + Qed. + + Theorem lt_le_pred : forall n m, n < m <-> n <= P m. + Proof. + intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r. + Qed. + + Theorem nle_pred_r : forall n, ~ n <= P n. + Proof. + intro; rewrite <- lt_le_pred; apply lt_irrefl. + Qed. + + Theorem lt_pred_le : forall n m, P n < m <-> n <= m. + Proof. + intros n m; rewrite <- (succ_pred n) at 2. + symmetry; apply le_succ_l. + Qed. + + Theorem lt_lt_pred : forall n m, n < m -> P n < m. + Proof. + intros; apply lt_pred_le; now apply lt_le_incl. + Qed. + + Theorem le_le_pred : forall n m, n <= m -> P n <= m. + Proof. + intros; apply lt_le_incl; now apply lt_pred_le. + Qed. + + Theorem lt_pred_lt : forall n m, n < P m -> n < m. + Proof. + intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l]. + Qed. + + Theorem le_pred_lt : forall n m, n <= P m -> n <= m. + Proof. + intros; apply lt_le_incl; now apply lt_le_pred. + Qed. + + Theorem pred_lt_mono : forall n m, n < m <-> P n < P m. + Proof. + intros; rewrite lt_le_pred; symmetry; apply lt_pred_le. + Qed. + + Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m. + Proof. + intros; rewrite <- lt_pred_le; now rewrite lt_le_pred. + Qed. + + Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. + Proof. + intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ. + Qed. + + Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m. + Proof. + intros n m; now rewrite (pred_le_mono (S n) m), pred_succ. + Qed. + + Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m. + Proof. + intros; rewrite lt_pred_le; symmetry; apply lt_succ_r. + Qed. + + Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m. + Proof. + intros n m; now rewrite (pred_le_mono n (S m)), pred_succ. + Qed. + + Theorem neq_pred_l : forall n, P n ~= n. + Proof. + intro; apply lt_neq; apply lt_pred_l. + Qed. + + Theorem lt_m1_r : forall n m, n < m -> m < 0 -> n < -1. + Proof. + intros n m H1 H2. apply lt_le_pred in H2. + setoid_replace (P 0) with (-1) in H2. + - now apply lt_le_trans with m. + - apply eq_opp_r. now rewrite one_succ, opp_pred, opp_0. + Qed. End ZOrderProp. diff --git a/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v index c4d405ad1b..8478c4c8aa 100644 --- a/theories/Numbers/Integer/Abstract/ZMaxMin.v +++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v @@ -13,169 +13,169 @@ From Stdlib Require Import ZAxioms ZMulOrder GenericMinMax. (** * Properties of minimum and maximum specific to integer numbers *) Module Type ZMaxMinProp (Import Z : ZAxiomsMiniSig'). -Include ZMulOrderProp Z. + Include ZMulOrderProp Z. -(** The following results are concrete instances of [max_monotone] + (** The following results are concrete instances of [max_monotone] and similar lemmas. *) -(** Succ *) - -Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. -Qed. - -Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. -Qed. - -(** Pred *) - -Lemma pred_max_distr n m : P (max n m) == max (P n) (P m). -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?pred_le_mono. -Qed. - -Lemma pred_min_distr n m : P (min n m) == min (P n) (P m). -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?pred_le_mono. -Qed. - -(** Add *) - -Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. -Qed. - -Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. -Qed. - -Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. -Qed. - -Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. -Qed. - -(** Opp *) - -Lemma opp_max_distr n m : -(max n m) == min (-n) (-m). -Proof. - destruct (le_ge_cases n m). - - rewrite max_r by trivial. symmetry. apply min_r. now rewrite <- opp_le_mono. - - rewrite max_l by trivial. symmetry. apply min_l. now rewrite <- opp_le_mono. -Qed. - -Lemma opp_min_distr n m : -(min n m) == max (-n) (-m). -Proof. - destruct (le_ge_cases n m). - - rewrite min_l by trivial. symmetry. apply max_l. now rewrite <- opp_le_mono. - - rewrite min_r by trivial. symmetry. apply max_r. now rewrite <- opp_le_mono. -Qed. - -(** Sub *) - -Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. -Proof. - destruct (le_ge_cases n m). - - rewrite min_l by trivial. apply max_l. now rewrite <- sub_le_mono_l. - - rewrite min_r by trivial. apply max_r. now rewrite <- sub_le_mono_l. -Qed. - -Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. -Qed. - -Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. -Proof. - destruct (le_ge_cases n m). - - rewrite max_r by trivial. apply min_r. now rewrite <- sub_le_mono_l. - - rewrite max_l by trivial. apply min_l. now rewrite <- sub_le_mono_l. -Qed. - -Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. -Qed. - -(** Mul *) - -Lemma mul_max_distr_nonneg_l n m p : 0 <= p -> - max (p * n) (p * m) == p * max n m. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_l. -Qed. - -Lemma mul_max_distr_nonneg_r n m p : 0 <= p -> - max (n * p) (m * p) == max n m * p. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_r. -Qed. - -Lemma mul_min_distr_nonneg_l n m p : 0 <= p -> - min (p * n) (p * m) == p * min n m. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_l. -Qed. - -Lemma mul_min_distr_nonneg_r n m p : 0 <= p -> - min (n * p) (m * p) == min n m * p. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_r. -Qed. - -Lemma mul_max_distr_nonpos_l n m p : p <= 0 -> - max (p * n) (p * m) == p * min n m. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite min_l by trivial. rewrite max_l by now apply mul_le_mono_nonpos_l. reflexivity. - - rewrite min_r by trivial. rewrite max_r by now apply mul_le_mono_nonpos_l. reflexivity. -Qed. - -Lemma mul_max_distr_nonpos_r n m p : p <= 0 -> - max (n * p) (m * p) == min n m * p. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite min_l by trivial. rewrite max_l by now apply mul_le_mono_nonpos_r. reflexivity. - - rewrite min_r by trivial. rewrite max_r by now apply mul_le_mono_nonpos_r. reflexivity. -Qed. - -Lemma mul_min_distr_nonpos_l n m p : p <= 0 -> - min (p * n) (p * m) == p * max n m. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite max_r by trivial. rewrite min_r by now apply mul_le_mono_nonpos_l. reflexivity. - - rewrite max_l by trivial. rewrite min_l by now apply mul_le_mono_nonpos_l. reflexivity. -Qed. - -Lemma mul_min_distr_nonpos_r n m p : p <= 0 -> - min (n * p) (m * p) == max n m * p. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite max_r by trivial. rewrite min_r by now apply mul_le_mono_nonpos_r. reflexivity. - - rewrite max_l by trivial. rewrite min_l by now apply mul_le_mono_nonpos_r. reflexivity. -Qed. + (** Succ *) + + Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. + Qed. + + Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. + Qed. + + (** Pred *) + + Lemma pred_max_distr n m : P (max n m) == max (P n) (P m). + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?pred_le_mono. + Qed. + + Lemma pred_min_distr n m : P (min n m) == min (P n) (P m). + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?pred_le_mono. + Qed. + + (** Add *) + + Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. + Qed. + + Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. + Qed. + + Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. + Qed. + + Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. + Qed. + + (** Opp *) + + Lemma opp_max_distr n m : -(max n m) == min (-n) (-m). + Proof. + destruct (le_ge_cases n m). + - rewrite max_r by trivial. symmetry. apply min_r. now rewrite <- opp_le_mono. + - rewrite max_l by trivial. symmetry. apply min_l. now rewrite <- opp_le_mono. + Qed. + + Lemma opp_min_distr n m : -(min n m) == max (-n) (-m). + Proof. + destruct (le_ge_cases n m). + - rewrite min_l by trivial. symmetry. apply max_l. now rewrite <- opp_le_mono. + - rewrite min_r by trivial. symmetry. apply max_r. now rewrite <- opp_le_mono. + Qed. + + (** Sub *) + + Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. + Proof. + destruct (le_ge_cases n m). + - rewrite min_l by trivial. apply max_l. now rewrite <- sub_le_mono_l. + - rewrite min_r by trivial. apply max_r. now rewrite <- sub_le_mono_l. + Qed. + + Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. + Qed. + + Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. + Proof. + destruct (le_ge_cases n m). + - rewrite max_r by trivial. apply min_r. now rewrite <- sub_le_mono_l. + - rewrite max_l by trivial. apply min_l. now rewrite <- sub_le_mono_l. + Qed. + + Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. + Qed. + + (** Mul *) + + Lemma mul_max_distr_nonneg_l n m p : 0 <= p -> + max (p * n) (p * m) == p * max n m. + Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_l. + Qed. + + Lemma mul_max_distr_nonneg_r n m p : 0 <= p -> + max (n * p) (m * p) == max n m * p. + Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_r. + Qed. + + Lemma mul_min_distr_nonneg_l n m p : 0 <= p -> + min (p * n) (p * m) == p * min n m. + Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_l. + Qed. + + Lemma mul_min_distr_nonneg_r n m p : 0 <= p -> + min (n * p) (m * p) == min n m * p. + Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_r. + Qed. + + Lemma mul_max_distr_nonpos_l n m p : p <= 0 -> + max (p * n) (p * m) == p * min n m. + Proof. + intros. destruct (le_ge_cases n m). + - rewrite min_l by trivial. rewrite max_l by now apply mul_le_mono_nonpos_l. reflexivity. + - rewrite min_r by trivial. rewrite max_r by now apply mul_le_mono_nonpos_l. reflexivity. + Qed. + + Lemma mul_max_distr_nonpos_r n m p : p <= 0 -> + max (n * p) (m * p) == min n m * p. + Proof. + intros. destruct (le_ge_cases n m). + - rewrite min_l by trivial. rewrite max_l by now apply mul_le_mono_nonpos_r. reflexivity. + - rewrite min_r by trivial. rewrite max_r by now apply mul_le_mono_nonpos_r. reflexivity. + Qed. + + Lemma mul_min_distr_nonpos_l n m p : p <= 0 -> + min (p * n) (p * m) == p * max n m. + Proof. + intros. destruct (le_ge_cases n m). + - rewrite max_r by trivial. rewrite min_r by now apply mul_le_mono_nonpos_l. reflexivity. + - rewrite max_l by trivial. rewrite min_l by now apply mul_le_mono_nonpos_l. reflexivity. + Qed. + + Lemma mul_min_distr_nonpos_r n m p : p <= 0 -> + min (n * p) (m * p) == max n m * p. + Proof. + intros. destruct (le_ge_cases n m). + - rewrite max_r by trivial. rewrite min_r by now apply mul_le_mono_nonpos_r. reflexivity. + - rewrite max_l by trivial. rewrite min_l by now apply mul_le_mono_nonpos_r. reflexivity. + Qed. End ZMaxMinProp. diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v index 1694e538a4..203a0f7d07 100644 --- a/theories/Numbers/Integer/Abstract/ZMul.v +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -13,9 +13,9 @@ From Stdlib Require Export ZAdd. Module ZMulProp (Import Z : ZAxiomsMiniSig'). -Include ZAddProp Z. + Include ZAddProp Z. -(** A note on naming: right (correspondingly, left) distributivity + (** A note on naming: right (correspondingly, left) distributivity happens when the sum is multiplied by a number on the right (left), not when the sum itself is the right (left) factor in the product (see planetmath.org and mathworld.wolfram.com). In the old @@ -24,52 +24,52 @@ Include ZAddProp Z. incorrectly. The names in Isabelle/HOL library are also incorrect. *) -(** Theorems that are either not valid on N or have different proofs + (** Theorems that are either not valid on N or have different proofs on N and Z *) -Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. -Proof. -intros n m. -rewrite <- (succ_pred m) at 2. -now rewrite mul_succ_r, <- add_sub_assoc, sub_diag, add_0_r. -Qed. + Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. + Proof. + intros n m. + rewrite <- (succ_pred m) at 2. + now rewrite mul_succ_r, <- add_sub_assoc, sub_diag, add_0_r. + Qed. -Theorem mul_pred_l : forall n m, (P n) * m == n * m - m. -Proof. -intros n m; rewrite (mul_comm (P n) m), (mul_comm n m). apply mul_pred_r. -Qed. + Theorem mul_pred_l : forall n m, (P n) * m == n * m - m. + Proof. + intros n m; rewrite (mul_comm (P n) m), (mul_comm n m). apply mul_pred_r. + Qed. -Theorem mul_opp_l : forall n m, (- n) * m == - (n * m). -Proof. -intros n m. apply add_move_0_r. -now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l. -Qed. + Theorem mul_opp_l : forall n m, (- n) * m == - (n * m). + Proof. + intros n m. apply add_move_0_r. + now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l. + Qed. -Theorem mul_opp_r : forall n m, n * (- m) == - (n * m). -Proof. -intros n m; rewrite (mul_comm n (- m)), (mul_comm n m); apply mul_opp_l. -Qed. + Theorem mul_opp_r : forall n m, n * (- m) == - (n * m). + Proof. + intros n m; rewrite (mul_comm n (- m)), (mul_comm n m); apply mul_opp_l. + Qed. -Theorem mul_opp_opp : forall n m, (- n) * (- m) == n * m. -Proof. -intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive. -Qed. + Theorem mul_opp_opp : forall n m, (- n) * (- m) == n * m. + Proof. + intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive. + Qed. -Theorem mul_opp_comm : forall n m, (- n) * m == n * (- m). -Proof. -intros n m. now rewrite mul_opp_l, <- mul_opp_r. -Qed. + Theorem mul_opp_comm : forall n m, (- n) * m == n * (- m). + Proof. + intros n m. now rewrite mul_opp_l, <- mul_opp_r. + Qed. -Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p. -Proof. -intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l. -now rewrite mul_opp_r. -Qed. + Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p. + Proof. + intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l. + now rewrite mul_opp_r. + Qed. -Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. -Proof. -intros n m p; rewrite (mul_comm (n - m) p), (mul_comm n p), (mul_comm m p); -now apply mul_sub_distr_l. -Qed. + Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. + Proof. + intros n m p; rewrite (mul_comm (n - m) p), (mul_comm n p), (mul_comm m p); + now apply mul_sub_distr_l. + Qed. End ZMulProp. diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index a18032becf..bd6cad972b 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -13,209 +13,209 @@ From Stdlib Require Export ZAddOrder. Module Type ZMulOrderProp (Import Z : ZAxiomsMiniSig'). -Include ZAddOrderProp Z. - -Theorem mul_lt_mono_nonpos : - forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q -> m * q < n * p. -Proof. -intros n m p q H1 H2 H3 H4. -apply le_lt_trans with (m * p). -- apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl]. -- apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q]. -Qed. - -Theorem mul_le_mono_nonpos : - forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. -Proof. -intros n m p q H1 H2 H3 H4. -apply le_trans with (m * p). -- now apply mul_le_mono_nonpos_l. -- apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption]. -Qed. - -Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m. -Proof. -intros n m H1 H2. -rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. -Qed. - -Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0. -Proof. -intros n m H1 H2. -rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. -Qed. - -Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0. -Proof. -intros; rewrite mul_comm; now apply mul_nonneg_nonpos. -Qed. - -Notation mul_pos := lt_0_mul (only parsing). - -Theorem lt_mul_0 : - forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. -Proof. -intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. -- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; - [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; - (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; - [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); - try (left; now split); try (right; now split). - + assert (H3 : n * m > 0) by now apply mul_neg_neg. - exfalso; now apply (lt_asymm (n * m) 0). - + assert (H3 : n * m > 0) by now apply mul_pos_pos. - exfalso; now apply (lt_asymm (n * m) 0). -- now apply mul_neg_pos. -- now apply mul_pos_neg. -Qed. - -Notation mul_neg := lt_mul_0 (only parsing). - -Theorem le_0_mul : - forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. -Proof. -assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). -intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. -rewrite lt_0_mul, eq_mul_0. -pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. -Qed. - -Notation mul_nonneg := le_0_mul (only parsing). - -Theorem le_mul_0 : - forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. -Proof. -assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). -intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. -rewrite lt_mul_0, eq_mul_0. -pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. -Qed. - -Notation mul_nonpos := le_mul_0 (only parsing). - -Notation le_0_square := square_nonneg (only parsing). - -Theorem nlt_square_0 : forall n, ~ n * n < 0. -Proof. -intros n H. apply lt_nge in H. apply H. apply square_nonneg. -Qed. - -Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m. -Proof. -intros n m H1 H2. now apply mul_lt_mono_nonpos. -Qed. - -Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m. -Proof. -intros n m H1 H2. now apply mul_le_mono_nonpos. -Qed. - -Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n. -Proof. -intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. -destruct (lt_ge_cases m n) as [LE|GT]; trivial. -apply square_le_mono_nonpos in GT; order. -Qed. - -Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n. -Proof. -intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. -destruct (le_gt_cases m n) as [LE|GT]; trivial. -apply square_lt_mono_nonpos in GT; order. -Qed. - -Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m. -Proof. -intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. -- apply opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1. - now apply lt_1_l with (- m). -- assumption. -Qed. - -Theorem lt_mul_m1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1. -Proof. -intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. -- rewrite mul_1_l in H1. now apply lt_m1_r with m. -- assumption. -Qed. - -Theorem lt_mul_m1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1. -Proof. -intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. -- rewrite mul_opp_l, mul_1_l in H1. - apply opp_neg_pos in H2. now apply lt_m1_r with (- m). -- assumption. -Qed. - -Theorem lt_1_mul_l : forall n m, 1 < n -> - n * m < -1 \/ n * m == 0 \/ 1 < n * m. -Proof. -intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. -- left. now apply lt_mul_m1_neg. -- right; left; now rewrite H1, mul_0_r. -- right; right; now apply lt_1_mul_pos. -Qed. - -Theorem lt_m1_mul_r : forall n m, n < -1 -> - n * m < -1 \/ n * m == 0 \/ 1 < n * m. -Proof. -intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. -- right; right. now apply lt_1_mul_neg. -- right; left; now rewrite H1, mul_0_r. -- left. now apply lt_mul_m1_pos. -Qed. - -Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1. -Proof. -assert (F := lt_m1_0). -intro n; zero_pos_neg n. -- (* n = 0 *) - intros m. nzsimpl. now left. -- (* 0 < n, proving P n /\ P (-n) *) - intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. - le_elim Hn; split; intros m H. - + destruct (lt_1_mul_l n m) as [|[|]]; order'. - + rewrite mul_opp_l, eq_opp_l in H. destruct (lt_1_mul_l n m) as [|[|]]; order'. - + now left. - + intros; right. now f_equiv. -Qed. - -Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n). -Proof. -intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r. -now apply mul_lt_mono_neg_l. -Qed. - -Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m). -Proof. -intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r. -now apply mul_lt_mono_pos_l. -Qed. - -Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n). -Proof. -intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r. -now apply mul_le_mono_neg_l. -Qed. - -Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m). -Proof. -intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r. -now apply mul_le_mono_pos_l. -Qed. - -Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p. -Proof. -intros n m p **. stepl (n * 1) by now rewrite mul_1_r. -apply mul_lt_mono_nonneg. -- now apply lt_le_incl. -- assumption. -- apply le_0_1. -- assumption. -Qed. - -(** Alternative name : *) - -Definition mul_eq_1 := eq_mul_1. + Include ZAddOrderProp Z. + + Theorem mul_lt_mono_nonpos : + forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q -> m * q < n * p. + Proof. + intros n m p q H1 H2 H3 H4. + apply le_lt_trans with (m * p). + - apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl]. + - apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q]. + Qed. + + Theorem mul_le_mono_nonpos : + forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. + Proof. + intros n m p q H1 H2 H3 H4. + apply le_trans with (m * p). + - now apply mul_le_mono_nonpos_l. + - apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption]. + Qed. + + Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m. + Proof. + intros n m H1 H2. + rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. + Qed. + + Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0. + Proof. + intros n m H1 H2. + rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. + Qed. + + Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0. + Proof. + intros; rewrite mul_comm; now apply mul_nonneg_nonpos. + Qed. + + Notation mul_pos := lt_0_mul (only parsing). + + Theorem lt_mul_0 : + forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. + Proof. + intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. + - destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; + (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); + try (left; now split); try (right; now split). + + assert (H3 : n * m > 0) by now apply mul_neg_neg. + exfalso; now apply (lt_asymm (n * m) 0). + + assert (H3 : n * m > 0) by now apply mul_pos_pos. + exfalso; now apply (lt_asymm (n * m) 0). + - now apply mul_neg_pos. + - now apply mul_pos_neg. + Qed. + + Notation mul_neg := lt_mul_0 (only parsing). + + Theorem le_0_mul : + forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. + Proof. + assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). + intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. + rewrite lt_0_mul, eq_mul_0. + pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. + Qed. + + Notation mul_nonneg := le_0_mul (only parsing). + + Theorem le_mul_0 : + forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. + Proof. + assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). + intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. + rewrite lt_mul_0, eq_mul_0. + pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. + Qed. + + Notation mul_nonpos := le_mul_0 (only parsing). + + Notation le_0_square := square_nonneg (only parsing). + + Theorem nlt_square_0 : forall n, ~ n * n < 0. + Proof. + intros n H. apply lt_nge in H. apply H. apply square_nonneg. + Qed. + + Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m. + Proof. + intros n m H1 H2. now apply mul_lt_mono_nonpos. + Qed. + + Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m. + Proof. + intros n m H1 H2. now apply mul_le_mono_nonpos. + Qed. + + Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n. + Proof. + intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. + destruct (lt_ge_cases m n) as [LE|GT]; trivial. + apply square_le_mono_nonpos in GT; order. + Qed. + + Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n. + Proof. + intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. + destruct (le_gt_cases m n) as [LE|GT]; trivial. + apply square_lt_mono_nonpos in GT; order. + Qed. + + Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m. + Proof. + intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. + - apply opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1. + now apply lt_1_l with (- m). + - assumption. + Qed. + + Theorem lt_mul_m1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1. + Proof. + intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. + - rewrite mul_1_l in H1. now apply lt_m1_r with m. + - assumption. + Qed. + + Theorem lt_mul_m1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1. + Proof. + intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. + - rewrite mul_opp_l, mul_1_l in H1. + apply opp_neg_pos in H2. now apply lt_m1_r with (- m). + - assumption. + Qed. + + Theorem lt_1_mul_l : forall n m, 1 < n -> + n * m < -1 \/ n * m == 0 \/ 1 < n * m. + Proof. + intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. + - left. now apply lt_mul_m1_neg. + - right; left; now rewrite H1, mul_0_r. + - right; right; now apply lt_1_mul_pos. + Qed. + + Theorem lt_m1_mul_r : forall n m, n < -1 -> + n * m < -1 \/ n * m == 0 \/ 1 < n * m. + Proof. + intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. + - right; right. now apply lt_1_mul_neg. + - right; left; now rewrite H1, mul_0_r. + - left. now apply lt_mul_m1_pos. + Qed. + + Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1. + Proof. + assert (F := lt_m1_0). + intro n; zero_pos_neg n. + - (* n = 0 *) + intros m. nzsimpl. now left. + - (* 0 < n, proving P n /\ P (-n) *) + intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. + le_elim Hn; split; intros m H. + + destruct (lt_1_mul_l n m) as [|[|]]; order'. + + rewrite mul_opp_l, eq_opp_l in H. destruct (lt_1_mul_l n m) as [|[|]]; order'. + + now left. + + intros; right. now f_equiv. + Qed. + + Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n). + Proof. + intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r. + now apply mul_lt_mono_neg_l. + Qed. + + Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m). + Proof. + intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r. + now apply mul_lt_mono_pos_l. + Qed. + + Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n). + Proof. + intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r. + now apply mul_le_mono_neg_l. + Qed. + + Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m). + Proof. + intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r. + now apply mul_le_mono_pos_l. + Qed. + + Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p. + Proof. + intros n m p **. stepl (n * 1) by now rewrite mul_1_r. + apply mul_lt_mono_nonneg. + - now apply lt_le_incl. + - assumption. + - apply le_0_1. + - assumption. + Qed. + + (** Alternative name : *) + + Definition mul_eq_1 := eq_mul_1. End ZMulOrderProp. diff --git a/theories/Numbers/Integer/Abstract/ZParity.v b/theories/Numbers/Integer/Abstract/ZParity.v index 0a8739118a..f73ada7f6f 100644 --- a/theories/Numbers/Integer/Abstract/ZParity.v +++ b/theories/Numbers/Integer/Abstract/ZParity.v @@ -13,43 +13,43 @@ From Stdlib Require Import Bool ZMulOrder NZParity. (** Some more properties of [even] and [odd]. *) Module Type ZParityProp (Import Z : ZAxiomsSig') - (Import ZP : ZMulOrderProp Z). - -Include NZParityProp Z Z ZP. - -Lemma odd_pred : forall n, odd (P n) = even n. -Proof. - intros n. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ. -Qed. - -Lemma even_pred : forall n, even (P n) = odd n. -Proof. - intros n. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ. -Qed. - -Lemma even_opp : forall n, even (-n) = even n. -Proof. - assert (H : forall n, Even n -> Even (-n)). - { intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv. } - intros n. rewrite eq_iff_eq_true, !even_spec. - split. - - rewrite <- (opp_involutive n) at 2. apply H. - - apply H. -Qed. - -Lemma odd_opp : forall n, odd (-n) = odd n. -Proof. - intros. rewrite <- !negb_even. now rewrite even_opp. -Qed. - -Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m). -Proof. - intros. now rewrite <- add_opp_r, even_add, even_opp. -Qed. - -Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m). -Proof. - intros. now rewrite <- add_opp_r, odd_add, odd_opp. -Qed. + (Import ZP : ZMulOrderProp Z). + + Include NZParityProp Z Z ZP. + + Lemma odd_pred : forall n, odd (P n) = even n. + Proof. + intros n. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ. + Qed. + + Lemma even_pred : forall n, even (P n) = odd n. + Proof. + intros n. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ. + Qed. + + Lemma even_opp : forall n, even (-n) = even n. + Proof. + assert (H : forall n, Even n -> Even (-n)). + { intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv. } + intros n. rewrite eq_iff_eq_true, !even_spec. + split. + - rewrite <- (opp_involutive n) at 2. apply H. + - apply H. + Qed. + + Lemma odd_opp : forall n, odd (-n) = odd n. + Proof. + intros. rewrite <- !negb_even. now rewrite even_opp. + Qed. + + Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m). + Proof. + intros. now rewrite <- add_opp_r, even_add, even_opp. + Qed. + + Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m). + Proof. + intros. now rewrite <- add_opp_r, odd_add, odd_opp. + Qed. End ZParityProp. diff --git a/theories/Numbers/Integer/Abstract/ZPow.v b/theories/Numbers/Integer/Abstract/ZPow.v index bae533719e..476702024a 100644 --- a/theories/Numbers/Integer/Abstract/ZPow.v +++ b/theories/Numbers/Integer/Abstract/ZPow.v @@ -13,129 +13,129 @@ From Stdlib Require Import Bool ZAxioms ZMulOrder ZParity ZSgnAbs NZPow. Module Type ZPowProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZParityProp A B) - (Import D : ZSgnAbsProp A B). - - Include NZPowProp A A B. - -(** A particular case of [pow_add_r], with no precondition *) - -Lemma pow_twice_r a b : a^(2*b) == a^b * a^b. -Proof. - rewrite two_succ. nzsimpl. - destruct (le_gt_cases 0 b). - - now rewrite pow_add_r. - - rewrite !pow_neg_r. - + now nzsimpl. - + trivial. - + now apply add_neg_neg. -Qed. - -(** Parity of power *) - -Lemma even_pow : forall a b, 0 even (a^b) = even a. -Proof. - intros a b Hb. apply lt_ind with (4:=Hb). - - solve_proper. - - now nzsimpl. - - clear b Hb. intros b Hb IH. nzsimpl; [|order]. - rewrite even_mul, IH. now destruct (even a). -Qed. - -Lemma odd_pow : forall a b, 0 odd (a^b) = odd a. -Proof. - intros. now rewrite <- !negb_even, even_pow. -Qed. - -(** Properties of power of negative numbers *) - -Lemma pow_opp_even : forall a b, Even b -> (-a)^b == a^b. -Proof. - intros a b (c,H). rewrite H. - destruct (le_gt_cases 0 c). - - rewrite 2 pow_mul_r by order'. - rewrite 2 pow_2_r. - now rewrite mul_opp_opp. - - assert (2*c < 0) by (apply mul_pos_neg; order'). - now rewrite !pow_neg_r. -Qed. - -Lemma pow_opp_odd : forall a b, Odd b -> (-a)^b == -(a^b). -Proof. - intros a b (c,H). rewrite H. - destruct (le_gt_cases 0 c) as [LE|GT]. - - assert (0 <= 2*c) by (apply mul_nonneg_nonneg; order'). - rewrite add_1_r, !pow_succ_r; trivial. - rewrite pow_opp_even by (now exists c). - apply mul_opp_l. - - apply double_above in GT. rewrite mul_0_r in GT. - rewrite !pow_neg_r by trivial. now rewrite opp_0. -Qed. - -Lemma pow_even_abs : forall a b, Even b -> a^b == (abs a)^b. -Proof. - intros a b ?. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ. - - reflexivity. - - symmetry. now apply pow_opp_even. -Qed. - -Lemma pow_even_nonneg : forall a b, Even b -> 0 <= a^b. -Proof. - intros. rewrite pow_even_abs by trivial. - apply pow_nonneg, abs_nonneg. -Qed. - -Lemma pow_odd_abs_sgn : forall a b, Odd b -> a^b == sgn a * (abs a)^b. -Proof. - intros a b H. - destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. - - nzsimpl. - rewrite abs_eq; order. - - rewrite <- EQ'. nzsimpl. - destruct (le_gt_cases 0 b). - + apply pow_0_l. - assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). - order. - + now rewrite pow_neg_r. - - rewrite abs_neq by order. - rewrite pow_opp_odd; trivial. - now rewrite mul_opp_opp, mul_1_l. -Qed. - -Lemma pow_odd_sgn : forall a b, 0<=b -> Odd b -> sgn (a^b) == sgn a. -Proof. - intros a b Hb H. - destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. - - apply sgn_pos. apply pow_pos_nonneg; trivial. - - rewrite <- EQ'. rewrite pow_0_l. - + apply sgn_0. - + assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). - order. - - apply sgn_neg. - rewrite <- (opp_involutive a). rewrite pow_opp_odd by trivial. - apply opp_neg_pos. - apply pow_pos_nonneg; trivial. - now apply opp_pos_neg. -Qed. - -Lemma abs_pow : forall a b, abs (a^b) == (abs a)^b. -Proof. - intros a b. - destruct (Even_or_Odd b) as [H|H]. - - rewrite pow_even_abs by trivial. - apply abs_eq, pow_nonneg, abs_nonneg. - - rewrite pow_odd_abs_sgn by trivial. - rewrite abs_mul. - destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. - + rewrite (sgn_pos a), (abs_eq 1), mul_1_l by order'. - apply abs_eq, pow_nonneg, abs_nonneg. - + rewrite <- Ha, sgn_0, abs_0, mul_0_l. - symmetry. apply pow_0_l'. intro Hb. rewrite Hb in H. - apply (Even_Odd_False 0); trivial. exists 0; now nzsimpl. - + rewrite (sgn_neg a), abs_opp, (abs_eq 1), mul_1_l by order'. - apply abs_eq, pow_nonneg, abs_nonneg. -Qed. + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZParityProp A B) + (Import D : ZSgnAbsProp A B). + + Include NZPowProp A A B. + + (** A particular case of [pow_add_r], with no precondition *) + + Lemma pow_twice_r a b : a^(2*b) == a^b * a^b. + Proof. + rewrite two_succ. nzsimpl. + destruct (le_gt_cases 0 b). + - now rewrite pow_add_r. + - rewrite !pow_neg_r. + + now nzsimpl. + + trivial. + + now apply add_neg_neg. + Qed. + + (** Parity of power *) + + Lemma even_pow : forall a b, 0 even (a^b) = even a. + Proof. + intros a b Hb. apply lt_ind with (4:=Hb). + - solve_proper. + - now nzsimpl. + - clear b Hb. intros b Hb IH. nzsimpl; [|order]. + rewrite even_mul, IH. now destruct (even a). + Qed. + + Lemma odd_pow : forall a b, 0 odd (a^b) = odd a. + Proof. + intros. now rewrite <- !negb_even, even_pow. + Qed. + + (** Properties of power of negative numbers *) + + Lemma pow_opp_even : forall a b, Even b -> (-a)^b == a^b. + Proof. + intros a b (c,H). rewrite H. + destruct (le_gt_cases 0 c). + - rewrite 2 pow_mul_r by order'. + rewrite 2 pow_2_r. + now rewrite mul_opp_opp. + - assert (2*c < 0) by (apply mul_pos_neg; order'). + now rewrite !pow_neg_r. + Qed. + + Lemma pow_opp_odd : forall a b, Odd b -> (-a)^b == -(a^b). + Proof. + intros a b (c,H). rewrite H. + destruct (le_gt_cases 0 c) as [LE|GT]. + - assert (0 <= 2*c) by (apply mul_nonneg_nonneg; order'). + rewrite add_1_r, !pow_succ_r; trivial. + rewrite pow_opp_even by (now exists c). + apply mul_opp_l. + - apply double_above in GT. rewrite mul_0_r in GT. + rewrite !pow_neg_r by trivial. now rewrite opp_0. + Qed. + + Lemma pow_even_abs : forall a b, Even b -> a^b == (abs a)^b. + Proof. + intros a b ?. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ. + - reflexivity. + - symmetry. now apply pow_opp_even. + Qed. + + Lemma pow_even_nonneg : forall a b, Even b -> 0 <= a^b. + Proof. + intros. rewrite pow_even_abs by trivial. + apply pow_nonneg, abs_nonneg. + Qed. + + Lemma pow_odd_abs_sgn : forall a b, Odd b -> a^b == sgn a * (abs a)^b. + Proof. + intros a b H. + destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. + - nzsimpl. + rewrite abs_eq; order. + - rewrite <- EQ'. nzsimpl. + destruct (le_gt_cases 0 b). + + apply pow_0_l. + assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). + order. + + now rewrite pow_neg_r. + - rewrite abs_neq by order. + rewrite pow_opp_odd; trivial. + now rewrite mul_opp_opp, mul_1_l. + Qed. + + Lemma pow_odd_sgn : forall a b, 0<=b -> Odd b -> sgn (a^b) == sgn a. + Proof. + intros a b Hb H. + destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. + - apply sgn_pos. apply pow_pos_nonneg; trivial. + - rewrite <- EQ'. rewrite pow_0_l. + + apply sgn_0. + + assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). + order. + - apply sgn_neg. + rewrite <- (opp_involutive a). rewrite pow_opp_odd by trivial. + apply opp_neg_pos. + apply pow_pos_nonneg; trivial. + now apply opp_pos_neg. + Qed. + + Lemma abs_pow : forall a b, abs (a^b) == (abs a)^b. + Proof. + intros a b. + destruct (Even_or_Odd b) as [H|H]. + - rewrite pow_even_abs by trivial. + apply abs_eq, pow_nonneg, abs_nonneg. + - rewrite pow_odd_abs_sgn by trivial. + rewrite abs_mul. + destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. + + rewrite (sgn_pos a), (abs_eq 1), mul_1_l by order'. + apply abs_eq, pow_nonneg, abs_nonneg. + + rewrite <- Ha, sgn_0, abs_0, mul_0_l. + symmetry. apply pow_0_l'. intro Hb. rewrite Hb in H. + apply (Even_Odd_False 0); trivial. exists 0; now nzsimpl. + + rewrite (sgn_neg a), abs_opp, (abs_eq 1), mul_1_l by order'. + apply abs_eq, pow_nonneg, abs_nonneg. + Qed. End ZPowProp. diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v index 9919e09ec0..e60598ecfa 100644 --- a/theories/Numbers/Integer/Abstract/ZSgnAbs.v +++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v @@ -15,20 +15,20 @@ From Stdlib Require Import ZMulOrder. (** Since we already have [max], we could have defined [abs]. *) Module GenericAbs (Import Z : ZAxiomsMiniSig') - (Import ZP : ZMulOrderProp Z) <: HasAbs Z. - Definition abs n := max n (-n). - Lemma abs_eq : forall n, 0<=n -> abs n == n. - Proof. - intros. unfold abs. apply max_l. - apply le_trans with 0; auto. - rewrite opp_nonpos_nonneg; auto. - Qed. - Lemma abs_neq : forall n, n<=0 -> abs n == -n. - Proof. - intros. unfold abs. apply max_r. - apply le_trans with 0; auto. - rewrite opp_nonneg_nonpos; auto. - Qed. + (Import ZP : ZMulOrderProp Z) <: HasAbs Z. + Definition abs n := max n (-n). + Lemma abs_eq : forall n, 0<=n -> abs n == n. + Proof. + intros. unfold abs. apply max_l. + apply le_trans with 0; auto. + rewrite opp_nonpos_nonneg; auto. + Qed. + Lemma abs_neq : forall n, n<=0 -> abs n == -n. + Proof. + intros. unfold abs. apply max_r. + apply le_trans with 0; auto. + rewrite opp_nonneg_nonpos; auto. + Qed. End GenericAbs. (** We can deduce a [sgn] function from a [compare] function *) @@ -37,344 +37,344 @@ Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare. Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare. Module Type GenericSgn (Import Z : ZDecAxiomsSig') - (Import ZP : ZMulOrderProp Z) <: HasSgn Z. - Definition sgn n := - match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end. - Lemma sgn_null n : n==0 -> sgn n == 0. - Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_pos n : 0 sgn n == 1. - Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_neg n : n<0 -> sgn n == -1. - Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + (Import ZP : ZMulOrderProp Z) <: HasSgn Z. + Definition sgn n := + match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end. + Lemma sgn_null n : n==0 -> sgn n == 0. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + Lemma sgn_pos n : 0 sgn n == 1. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + Lemma sgn_neg n : n<0 -> sgn n == -1. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. End GenericSgn. (** Derived properties of [abs] and [sgn] *) Module Type ZSgnAbsProp (Import Z : ZAxiomsSig') - (Import ZP : ZMulOrderProp Z). - -Ltac destruct_max n := - destruct (le_ge_cases 0 n); - [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto]. - -#[global] -Instance abs_wd : Proper (eq==>eq) abs. -Proof. - intros x y EQ. destruct_max x. - - rewrite abs_eq; trivial. now rewrite <- EQ. - - rewrite abs_neq; try order. now rewrite opp_inj_wd. -Qed. - -Lemma abs_max : forall n, abs n == max n (-n). -Proof. - intros n. destruct_max n. - - rewrite max_l; auto with relations. - apply le_trans with 0; auto. - rewrite opp_nonpos_nonneg; auto. - - rewrite max_r; auto with relations. - apply le_trans with 0; auto. - rewrite opp_nonneg_nonpos; auto. -Qed. - -Lemma abs_neq' : forall n, 0<=-n -> abs n == -n. -Proof. - intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos. -Qed. - -Lemma abs_nonneg : forall n, 0 <= abs n. -Proof. - intros n. destruct_max n; auto. - now rewrite opp_nonneg_nonpos. -Qed. - -Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n. -Proof. - split; try apply abs_eq. intros EQ. - rewrite <- EQ. apply abs_nonneg. -Qed. - -Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0. -Proof. - split; try apply abs_neq. intros EQ. - rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg. -Qed. - -Lemma abs_opp : forall n, abs (-n) == abs n. -Proof. - intros n. destruct_max n. - - rewrite (abs_neq (-n)), opp_involutive. - + reflexivity. - + now rewrite opp_nonpos_nonneg. - - rewrite (abs_eq (-n)). - + reflexivity. - + now rewrite opp_nonneg_nonpos. -Qed. - -Lemma abs_0 : abs 0 == 0. -Proof. - apply abs_eq. apply le_refl. -Qed. - -Lemma abs_0_iff : forall n, abs n == 0 <-> n==0. -Proof. - intros n; split. - - destruct_max n; auto. - now rewrite eq_opp_l, opp_0. - - intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl. -Qed. - -Lemma abs_pos : forall n, 0 < abs n <-> n~=0. -Proof. - intros n. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. - - intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0). - - assert (LE : 0 <= abs n) by apply abs_nonneg. - rewrite lt_eq_cases in LE; destruct LE; auto. - elim NEQ; auto with relations. -Qed. - -Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n. -Proof. - intros n. destruct_max n; auto with relations. -Qed. - -Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n. -Proof. - intros n. destruct_max n; rewrite ? opp_involutive; auto with relations. -Qed. - -Lemma abs_idemp : forall n, abs (abs n) == abs n. -Proof. - intros. apply abs_eq. apply abs_nonneg. -Qed. - -#[deprecated(since="8.19", note="Use abs_idemp")] -Notation abs_involutive := abs_idemp. - -Lemma abs_spec : forall n, - (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n). -Proof. - intros n. destruct (le_gt_cases 0 n). - - left; split; auto. now apply abs_eq. - - right; split; auto. apply abs_neq. now apply lt_le_incl. -Qed. - -Lemma abs_case_strong : - forall (P:t->Prop) n, Proper (eq==>iff) P -> - (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n). -Proof. - intros P n **. destruct_max n; auto. -Qed. - -Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P -> - P n -> P (-n) -> P (abs n). -Proof. intros. now apply abs_case_strong. Qed. - -Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m. -Proof. - intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn]. - - rewrite EQn, EQ. apply abs_eq_or_opp. - - rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp. -Qed. - -Lemma abs_lt : forall a b, abs a < b <-> -b < a < b. -Proof. - intros a b. - destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. - - split; try split; try destruct 1; try order. - apply lt_le_trans with 0; trivial. apply opp_neg_pos; order. - - rewrite opp_lt_mono, opp_involutive. - split; try split; try destruct 1; try order. - apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order. -Qed. - -Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b. -Proof. - intros a b. - destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. - - split; try split; try destruct 1; try order. - apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order. - - rewrite opp_le_mono, opp_involutive. - split; try split; try destruct 1; try order. - apply le_trans with 0. - + order. - + apply opp_nonpos_nonneg; order. -Qed. - -(** Triangular inequality *) - -Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m. -Proof. - intros n m. destruct_max n; destruct_max m. - - rewrite abs_eq. { apply le_refl. } now apply add_nonneg_nonneg. - - destruct_max (n+m); try rewrite opp_add_distr; - apply add_le_mono_l || apply add_le_mono_r. - + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. - + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. - - destruct_max (n+m); try rewrite opp_add_distr; - apply add_le_mono_l || apply add_le_mono_r. - + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. - + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. - - rewrite abs_neq, opp_add_distr. { apply le_refl. } - now apply add_nonpos_nonpos. -Qed. - -Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m). -Proof. - intros n m. - rewrite le_sub_le_add_l, add_comm. - rewrite <- (sub_simpl_r n m) at 1. - apply abs_triangle. -Qed. - -(** Absolute value and multiplication *) - -Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m. -Proof. - assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m). - { intros n m ?. destruct_max m. - - rewrite abs_eq. { apply eq_refl. } now apply mul_nonneg_nonneg. - - rewrite abs_neq, mul_opp_r. { reflexivity. } now apply mul_nonneg_nonpos . - } - intros n m. destruct_max n. - - now apply H. - - rewrite <- mul_opp_opp, H, abs_opp. { reflexivity. } - now apply opp_nonneg_nonpos. -Qed. - -Lemma abs_square : forall n, abs n * abs n == n * n. -Proof. - intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square. -Qed. - -(** Some results about the sign function. *) - -Ltac destruct_sgn n := - let LT := fresh "LT" in - let EQ := fresh "EQ" in - let GT := fresh "GT" in - destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]]; - [rewrite (sgn_pos n) by auto| - rewrite (sgn_null n) by auto with relations| - rewrite (sgn_neg n) by auto]. - -#[global] -Instance sgn_wd : Proper (eq==>eq) sgn. -Proof. - intros x y Hxy. destruct_sgn x. - - rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto. - - rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations. - - rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto. -Qed. - -Lemma sgn_spec : forall n, - 0 < n /\ sgn n == 1 \/ - 0 == n /\ sgn n == 0 \/ - 0 > n /\ sgn n == -1. -Proof. - intros n. - destruct_sgn n; [left|right;left|right;right]; auto with relations. -Qed. - -Lemma sgn_0 : sgn 0 == 0. -Proof. - now apply sgn_null. -Qed. - -Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0 n==0. -Proof. - intros n; split; try apply sgn_null. destruct_sgn n; auto with relations. - - intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1. - - intros. elim (lt_neq (-1) 0); auto. - rewrite opp_neg_pos. apply lt_0_1. -Qed. - -Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0. -Proof. - intros n; split; try apply sgn_neg. destruct_sgn n; auto with relations. - - intros. elim (lt_neq (-1) 1); auto with relations. - apply lt_trans with 0. - + rewrite opp_neg_pos. apply lt_0_1. - + apply lt_0_1. - - intros. elim (lt_neq (-1) 0); auto with relations. - rewrite opp_neg_pos. apply lt_0_1. -Qed. - -Lemma sgn_opp : forall n, sgn (-n) == - sgn n. -Proof. - intros n. destruct_sgn n. - - apply sgn_neg. now rewrite opp_neg_pos. - - setoid_replace n with 0 by auto with relations. - rewrite opp_0. apply sgn_0. - - rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg. -Qed. - -Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n. -Proof. - intros n; split. - - destruct_sgn n; intros. - + now apply lt_le_incl. - + order. - + elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1. - now rewrite <- opp_nonneg_nonpos. - - rewrite lt_eq_cases; destruct 1. - + rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1. - + rewrite sgn_null by auto with relations. apply le_refl. -Qed. - -Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0. -Proof. - intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg. -Qed. - -Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m. -Proof. - intros n m. destruct_sgn n; nzsimpl. - - destruct_sgn m. - + apply sgn_pos. now apply mul_pos_pos. - + apply sgn_null. rewrite eq_mul_0; auto with relations. - + apply sgn_neg. now apply mul_pos_neg. - - apply sgn_null. rewrite eq_mul_0; auto with relations. - - destruct_sgn m; try rewrite mul_opp_opp; nzsimpl. - + apply sgn_neg. now apply mul_neg_pos. - + apply sgn_null. rewrite eq_mul_0; auto with relations. - + apply sgn_pos. now apply mul_neg_neg. -Qed. - -Lemma sgn_abs : forall n, n * sgn n == abs n. -Proof. - intros n. symmetry. - destruct_sgn n; try rewrite mul_opp_r; nzsimpl. - - apply abs_eq. now apply lt_le_incl. - - rewrite abs_0_iff; auto with relations. - - apply abs_neq. now apply lt_le_incl. -Qed. - -Lemma abs_sgn : forall n, abs n * sgn n == n. -Proof. - intros n. - destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto. - - apply abs_eq. now apply lt_le_incl. - - rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. -Qed. - -Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x. -Proof. - intros x. - destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. - - apply sgn_pos, lt_0_1. - - now apply sgn_null. - - apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1. -Qed. + (Import ZP : ZMulOrderProp Z). + + Ltac destruct_max n := + destruct (le_ge_cases 0 n); + [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto]. + + #[global] + Instance abs_wd : Proper (eq==>eq) abs. + Proof. + intros x y EQ. destruct_max x. + - rewrite abs_eq; trivial. now rewrite <- EQ. + - rewrite abs_neq; try order. now rewrite opp_inj_wd. + Qed. + + Lemma abs_max : forall n, abs n == max n (-n). + Proof. + intros n. destruct_max n. + - rewrite max_l; auto with relations. + apply le_trans with 0; auto. + rewrite opp_nonpos_nonneg; auto. + - rewrite max_r; auto with relations. + apply le_trans with 0; auto. + rewrite opp_nonneg_nonpos; auto. + Qed. + + Lemma abs_neq' : forall n, 0<=-n -> abs n == -n. + Proof. + intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos. + Qed. + + Lemma abs_nonneg : forall n, 0 <= abs n. + Proof. + intros n. destruct_max n; auto. + now rewrite opp_nonneg_nonpos. + Qed. + + Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n. + Proof. + split; try apply abs_eq. intros EQ. + rewrite <- EQ. apply abs_nonneg. + Qed. + + Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0. + Proof. + split; try apply abs_neq. intros EQ. + rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg. + Qed. + + Lemma abs_opp : forall n, abs (-n) == abs n. + Proof. + intros n. destruct_max n. + - rewrite (abs_neq (-n)), opp_involutive. + + reflexivity. + + now rewrite opp_nonpos_nonneg. + - rewrite (abs_eq (-n)). + + reflexivity. + + now rewrite opp_nonneg_nonpos. + Qed. + + Lemma abs_0 : abs 0 == 0. + Proof. + apply abs_eq. apply le_refl. + Qed. + + Lemma abs_0_iff : forall n, abs n == 0 <-> n==0. + Proof. + intros n; split. + - destruct_max n; auto. + now rewrite eq_opp_l, opp_0. + - intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl. + Qed. + + Lemma abs_pos : forall n, 0 < abs n <-> n~=0. + Proof. + intros n. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. + - intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0). + - assert (LE : 0 <= abs n) by apply abs_nonneg. + rewrite lt_eq_cases in LE; destruct LE; auto. + elim NEQ; auto with relations. + Qed. + + Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n. + Proof. + intros n. destruct_max n; auto with relations. + Qed. + + Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n. + Proof. + intros n. destruct_max n; rewrite ? opp_involutive; auto with relations. + Qed. + + Lemma abs_idemp : forall n, abs (abs n) == abs n. + Proof. + intros. apply abs_eq. apply abs_nonneg. + Qed. + + #[deprecated(since="8.19", note="Use abs_idemp")] + Notation abs_involutive := abs_idemp. + + Lemma abs_spec : forall n, + (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n). + Proof. + intros n. destruct (le_gt_cases 0 n). + - left; split; auto. now apply abs_eq. + - right; split; auto. apply abs_neq. now apply lt_le_incl. + Qed. + + Lemma abs_case_strong : + forall (P:t->Prop) n, Proper (eq==>iff) P -> + (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n). + Proof. + intros P n **. destruct_max n; auto. + Qed. + + Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P -> + P n -> P (-n) -> P (abs n). + Proof. intros. now apply abs_case_strong. Qed. + + Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m. + Proof. + intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn]. + - rewrite EQn, EQ. apply abs_eq_or_opp. + - rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp. + Qed. + + Lemma abs_lt : forall a b, abs a < b <-> -b < a < b. + Proof. + intros a b. + destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. + - split; try split; try destruct 1; try order. + apply lt_le_trans with 0; trivial. apply opp_neg_pos; order. + - rewrite opp_lt_mono, opp_involutive. + split; try split; try destruct 1; try order. + apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order. + Qed. + + Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b. + Proof. + intros a b. + destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. + - split; try split; try destruct 1; try order. + apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order. + - rewrite opp_le_mono, opp_involutive. + split; try split; try destruct 1; try order. + apply le_trans with 0. + + order. + + apply opp_nonpos_nonneg; order. + Qed. + + (** Triangular inequality *) + + Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m. + Proof. + intros n m. destruct_max n; destruct_max m. + - rewrite abs_eq. { apply le_refl. } now apply add_nonneg_nonneg. + - destruct_max (n+m); try rewrite opp_add_distr; + apply add_le_mono_l || apply add_le_mono_r. + + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. + + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. + - destruct_max (n+m); try rewrite opp_add_distr; + apply add_le_mono_l || apply add_le_mono_r. + + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. + + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. + - rewrite abs_neq, opp_add_distr. { apply le_refl. } + now apply add_nonpos_nonpos. + Qed. + + Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m). + Proof. + intros n m. + rewrite le_sub_le_add_l, add_comm. + rewrite <- (sub_simpl_r n m) at 1. + apply abs_triangle. + Qed. + + (** Absolute value and multiplication *) + + Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m. + Proof. + assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m). + { intros n m ?. destruct_max m. + - rewrite abs_eq. { apply eq_refl. } now apply mul_nonneg_nonneg. + - rewrite abs_neq, mul_opp_r. { reflexivity. } now apply mul_nonneg_nonpos . + } + intros n m. destruct_max n. + - now apply H. + - rewrite <- mul_opp_opp, H, abs_opp. { reflexivity. } + now apply opp_nonneg_nonpos. + Qed. + + Lemma abs_square : forall n, abs n * abs n == n * n. + Proof. + intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square. + Qed. + + (** Some results about the sign function. *) + + Ltac destruct_sgn n := + let LT := fresh "LT" in + let EQ := fresh "EQ" in + let GT := fresh "GT" in + destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]]; + [rewrite (sgn_pos n) by auto| + rewrite (sgn_null n) by auto with relations| + rewrite (sgn_neg n) by auto]. + + #[global] + Instance sgn_wd : Proper (eq==>eq) sgn. + Proof. + intros x y Hxy. destruct_sgn x. + - rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto. + - rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations. + - rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto. + Qed. + + Lemma sgn_spec : forall n, + 0 < n /\ sgn n == 1 \/ + 0 == n /\ sgn n == 0 \/ + 0 > n /\ sgn n == -1. + Proof. + intros n. + destruct_sgn n; [left|right;left|right;right]; auto with relations. + Qed. + + Lemma sgn_0 : sgn 0 == 0. + Proof. + now apply sgn_null. + Qed. + + Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0 n==0. + Proof. + intros n; split; try apply sgn_null. destruct_sgn n; auto with relations. + - intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1. + - intros. elim (lt_neq (-1) 0); auto. + rewrite opp_neg_pos. apply lt_0_1. + Qed. + + Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0. + Proof. + intros n; split; try apply sgn_neg. destruct_sgn n; auto with relations. + - intros. elim (lt_neq (-1) 1); auto with relations. + apply lt_trans with 0. + + rewrite opp_neg_pos. apply lt_0_1. + + apply lt_0_1. + - intros. elim (lt_neq (-1) 0); auto with relations. + rewrite opp_neg_pos. apply lt_0_1. + Qed. + + Lemma sgn_opp : forall n, sgn (-n) == - sgn n. + Proof. + intros n. destruct_sgn n. + - apply sgn_neg. now rewrite opp_neg_pos. + - setoid_replace n with 0 by auto with relations. + rewrite opp_0. apply sgn_0. + - rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg. + Qed. + + Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n. + Proof. + intros n; split. + - destruct_sgn n; intros. + + now apply lt_le_incl. + + order. + + elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1. + now rewrite <- opp_nonneg_nonpos. + - rewrite lt_eq_cases; destruct 1. + + rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1. + + rewrite sgn_null by auto with relations. apply le_refl. + Qed. + + Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0. + Proof. + intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg. + Qed. + + Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m. + Proof. + intros n m. destruct_sgn n; nzsimpl. + - destruct_sgn m. + + apply sgn_pos. now apply mul_pos_pos. + + apply sgn_null. rewrite eq_mul_0; auto with relations. + + apply sgn_neg. now apply mul_pos_neg. + - apply sgn_null. rewrite eq_mul_0; auto with relations. + - destruct_sgn m; try rewrite mul_opp_opp; nzsimpl. + + apply sgn_neg. now apply mul_neg_pos. + + apply sgn_null. rewrite eq_mul_0; auto with relations. + + apply sgn_pos. now apply mul_neg_neg. + Qed. + + Lemma sgn_abs : forall n, n * sgn n == abs n. + Proof. + intros n. symmetry. + destruct_sgn n; try rewrite mul_opp_r; nzsimpl. + - apply abs_eq. now apply lt_le_incl. + - rewrite abs_0_iff; auto with relations. + - apply abs_neq. now apply lt_le_incl. + Qed. + + Lemma abs_sgn : forall n, abs n * sgn n == n. + Proof. + intros n. + destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto. + - apply abs_eq. now apply lt_le_incl. + - rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. + Qed. + + Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x. + Proof. + intros x. + destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. + - apply sgn_pos, lt_0_1. + - now apply sgn_null. + - apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1. + Qed. End ZSgnAbsProp. diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index c85aa96c37..31794e6775 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -21,329 +21,329 @@ Notation "s #1" := (fst s) (at level 1, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 1, format "s '#2'") : pair_scope. Module ZPairsAxiomsMod (Import N : NAxiomsMiniSig) <: ZAxiomsMiniSig. - Module Import NProp. - Include NSubProp N. - End NProp. - -Declare Scope NScope. -Delimit Scope NScope with N. -Bind Scope NScope with N.t. -Infix "==" := N.eq (at level 70) : NScope. -Notation "x ~= y" := (~ N.eq x y) (at level 70) : NScope. -Notation "0" := N.zero : NScope. -Notation "1" := N.one : NScope. -Notation "2" := N.two : NScope. -Infix "+" := N.add : NScope. -Infix "-" := N.sub : NScope. -Infix "*" := N.mul : NScope. -Infix "<" := N.lt : NScope. -Infix "<=" := N.le : NScope. -#[local] Open Scope NScope. - -(** The definitions of functions ([add], [mul], etc.) will be unfolded + Module Import NProp. + Include NSubProp N. + End NProp. + + Declare Scope NScope. + Delimit Scope NScope with N. + Bind Scope NScope with N.t. + Infix "==" := N.eq (at level 70) : NScope. + Notation "x ~= y" := (~ N.eq x y) (at level 70) : NScope. + Notation "0" := N.zero : NScope. + Notation "1" := N.one : NScope. + Notation "2" := N.two : NScope. + Infix "+" := N.add : NScope. + Infix "-" := N.sub : NScope. + Infix "*" := N.mul : NScope. + Infix "<" := N.lt : NScope. + Infix "<=" := N.le : NScope. + #[local] Open Scope NScope. + + (** The definitions of functions ([add], [mul], etc.) will be unfolded by the properties functor. Since we don't want [add_comm] to refer to unfolded definitions of equality: [fun p1 p2 => (fst p1 + snd p2) = (fst p2 + snd p1)], we will provide an extra layer of definitions. *) -Module Z. - -Definition t := (N.t * N.t)%type. -Definition zero : t := (0, 0). -Definition one : t := (1,0). -Definition two : t := (2,0). -Definition eq (p q : t) := (p#1 + q#2 == q#1 + p#2). -Definition succ (n : t) : t := (N.succ n#1, n#2). -Definition pred (n : t) : t := (n#1, N.succ n#2). -Definition opp (n : t) : t := (n#2, n#1). -Definition add (n m : t) : t := (n#1 + m#1, n#2 + m#2). -Definition sub (n m : t) : t := (n#1 + m#2, n#2 + m#1). -Definition mul (n m : t) : t := - (n#1 * m#1 + n#2 * m#2, n#1 * m#2 + n#2 * m#1). -Definition lt (n m : t) := n#1 + m#2 < m#1 + n#2. -Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2. -Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2). -Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2). - -(** NB : We do not have [Z.pred (Z.succ n) = n] but only [Z.pred (Z.succ n) == n]. + Module Z. + + Definition t := (N.t * N.t)%type. + Definition zero : t := (0, 0). + Definition one : t := (1,0). + Definition two : t := (2,0). + Definition eq (p q : t) := (p#1 + q#2 == q#1 + p#2). + Definition succ (n : t) : t := (N.succ n#1, n#2). + Definition pred (n : t) : t := (n#1, N.succ n#2). + Definition opp (n : t) : t := (n#2, n#1). + Definition add (n m : t) : t := (n#1 + m#1, n#2 + m#2). + Definition sub (n m : t) : t := (n#1 + m#2, n#2 + m#1). + Definition mul (n m : t) : t := + (n#1 * m#1 + n#2 * m#2, n#1 * m#2 + n#2 * m#1). + Definition lt (n m : t) := n#1 + m#2 < m#1 + n#2. + Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2. + Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2). + Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2). + + (** NB : We do not have [Z.pred (Z.succ n) = n] but only [Z.pred (Z.succ n) == n]. It could be possible to consider as canonical only pairs where one of the elements is 0, and make all operations convert canonical values into other canonical values. In that case, we could get rid of setoids and arrive at integers as signed natural numbers. *) -(** NB : Unfortunately, the elements of the pair keep increasing during + (** NB : Unfortunately, the elements of the pair keep increasing during many operations, even during subtraction. *) -End Z. - -Declare Scope ZScope. -Delimit Scope ZScope with Z. -Bind Scope ZScope with Z.t. -Infix "==" := Z.eq (at level 70) : ZScope. -Notation "x ~= y" := (~ Z.eq x y) (at level 70) : ZScope. -Notation "0" := Z.zero : ZScope. -Notation "1" := Z.one : ZScope. -Notation "2" := Z.two : ZScope. -Infix "+" := Z.add : ZScope. -Infix "-" := Z.sub : ZScope. -Infix "*" := Z.mul : ZScope. -Notation "- x" := (Z.opp x) : ZScope. -Infix "<" := Z.lt : ZScope. -Infix "<=" := Z.le : ZScope. -#[local] Open Scope ZScope. - -Lemma sub_add_opp : forall n m, Z.sub n m = Z.add n (Z.opp m). -Proof. reflexivity. Qed. - -#[global] -Instance eq_equiv : Equivalence Z.eq. -Proof. -split. -- unfold Reflexive, Z.eq. reflexivity. -- unfold Symmetric, Z.eq; now symmetry. -- unfold Transitive, Z.eq. intros (n1,n2) (m1,m2) (p1,p2) H1 H2; simpl in *. - apply (add_cancel_r _ _ (m1+m2)%N). - rewrite add_shuffle2, H1, add_shuffle1, H2. - now rewrite add_shuffle1, (add_comm m1). -Qed. - -#[global] -Instance pair_wd : Proper (N.eq==>N.eq==>Z.eq) (@pair N.t N.t). -Proof. -intros n1 n2 H1 m1 m2 H2; unfold Z.eq; simpl; now rewrite H1, H2. -Qed. - -#[global] -Instance succ_wd : Proper (Z.eq ==> Z.eq) Z.succ. -Proof. -unfold Z.succ, Z.eq; intros n m H; simpl. -do 2 rewrite add_succ_l; now rewrite H. -Qed. - -#[global] -Instance pred_wd : Proper (Z.eq ==> Z.eq) Z.pred. -Proof. -unfold Z.pred, Z.eq; intros n m H; simpl. -do 2 rewrite add_succ_r; now rewrite H. -Qed. - -#[global] -Instance add_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.add. -Proof. -unfold Z.eq, Z.add; intros n1 m1 H1 n2 m2 H2; simpl. -now rewrite add_shuffle1, H1, H2, add_shuffle1. -Qed. - -#[global] -Instance opp_wd : Proper (Z.eq ==> Z.eq) Z.opp. -Proof. -unfold Z.eq, Z.opp; intros (n1,n2) (m1,m2) H; simpl in *. -now rewrite (add_comm n2), (add_comm m2). -Qed. - -#[global] -Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub. -Proof. -intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp. now do 2 f_equiv. -Qed. - -Lemma mul_comm : forall n m, n*m == m*n. -Proof. -intros (n1,n2) (m1,m2); compute. -rewrite (add_comm (m1*n2)%N). -do 2 f_equiv; apply mul_comm. -Qed. - -#[global] -Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul. -Proof. -assert (forall n, Proper (Z.eq ==> Z.eq) (Z.mul n)). { - unfold Z.mul, Z.eq. intros (n1,n2) (p1,p2) (q1,q2) H; simpl in *. - rewrite add_shuffle1, (add_comm (n1*p1)%N). - symmetry. rewrite add_shuffle1. - rewrite <- ! mul_add_distr_l. - rewrite (add_comm p2), (add_comm q2), H. - reflexivity. -} -intros n n' Hn m m' Hm. -rewrite Hm, (mul_comm n), (mul_comm n'), Hn. -reflexivity. -Qed. - -Section Induction. -Variable A : Z.t -> Prop. -Hypothesis A_wd : Proper (Z.eq==>iff) A. - -Theorem bi_induction : - A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n. -Proof. -Open Scope NScope. -intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *. -destruct n as [n m]. -cut (forall p, A (p, 0)); [intro H1 |]. -- cut (forall p, A (0, p)); [intro H2 |]. - + destruct (add_dichotomy n m) as [[p H] | [p H]]. - * rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm). - apply H2. - * rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1. - + induct p. * assumption. - * intros p IH. - apply (A_wd (0, p) (1, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l]. - rewrite one_succ in IH. now apply AS. -- induct p. - + assumption. - + intros p IH. - replace 0 with (snd (p, 0)); [| reflexivity]. - replace (N.succ p) with (N.succ (fst (p, 0))); [| reflexivity]. now apply -> AS. - Close Scope NScope. -Qed. - -End Induction. - -(* Time to prove theorems in the language of Z *) - -Theorem pred_succ : forall n, Z.pred (Z.succ n) == n. -Proof. -unfold Z.pred, Z.succ, Z.eq; intro n; simpl; now nzsimpl. -Qed. - -Theorem succ_pred : forall n, Z.succ (Z.pred n) == n. -Proof. -intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl. -Qed. - -Theorem one_succ : 1 == Z.succ 0. -Proof. -unfold Z.eq; simpl. now nzsimpl'. -Qed. - -Theorem two_succ : 2 == Z.succ 1. -Proof. -unfold Z.eq; simpl. now nzsimpl'. -Qed. - -Theorem opp_0 : - 0 == 0. -Proof. -unfold Z.opp, Z.eq; simpl. now nzsimpl. -Qed. - -Theorem opp_succ : forall n, - (Z.succ n) == Z.pred (- n). -Proof. -reflexivity. -Qed. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intro n; unfold Z.add, Z.eq; simpl. now nzsimpl. -Qed. - -Theorem add_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m). -Proof. -intros n m; unfold Z.add, Z.eq; simpl. now nzsimpl. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intro n; unfold Z.sub, Z.eq; simpl. now nzsimpl. -Qed. - -Theorem sub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m). -Proof. -intros n m; unfold Z.sub, Z.eq; simpl. symmetry; now rewrite add_succ_r. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intros (n1,n2); unfold Z.mul, Z.eq; simpl; now nzsimpl. -Qed. - -Theorem mul_succ_l : forall n m, (Z.succ n) * m == n * m + m. -Proof. -intros (n1,n2) (m1,m2); unfold Z.mul, Z.succ, Z.eq; simpl; nzsimpl. -rewrite <- (add_assoc _ m1), (add_comm m1), (add_assoc _ _ m1). -now rewrite <- (add_assoc _ m2), (add_comm m2), (add_assoc _ (n2*m1)%N m2). -Qed. - -(** Order *) - -Lemma lt_eq_cases : forall n m, n<=m <-> n n <= m. -Proof. -intros n m; unfold Z.lt, Z.le, Z.eq; simpl; nzsimpl. apply lt_succ_r. -Qed. - -Theorem min_l : forall n m, n <= m -> Z.min n m == n. -Proof. -unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. -rewrite min_l by assumption. -now rewrite <- add_assoc, (add_comm m2). -Qed. - -Theorem min_r : forall n m, m <= n -> Z.min n m == m. -Proof. -unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. -rewrite min_r by assumption. -now rewrite add_assoc. -Qed. - -Theorem max_l : forall n m, m <= n -> Z.max n m == n. -Proof. -unfold Z.max, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. -rewrite max_l by assumption. -now rewrite <- add_assoc, (add_comm m2). -Qed. - -Theorem max_r : forall n m, n <= m -> Z.max n m == m. -Proof. -unfold Z.max, Z.le, Z.eq; simpl; intros n m H. -rewrite max_r by assumption. -now rewrite add_assoc. -Qed. - -Theorem lt_nge : forall n m, n < m <-> ~(m<=n). -Proof. -intros. apply lt_nge. -Qed. - -#[global] -Instance lt_wd : Proper (Z.eq ==> Z.eq ==> iff) Z.lt. -Proof. -assert (forall n, Proper (Z.eq==>iff) (Z.lt n)). -- intros (n1,n2). apply proper_sym_impl_iff; auto with *. - unfold Z.lt, Z.eq; intros (r1,r2) (s1,s2) Eq H; simpl in *. - apply le_lt_add_lt with (r1+r2)%N (r1+r2)%N; [apply le_refl; auto with *|]. - rewrite add_shuffle2, (add_comm s2), Eq. - rewrite (add_comm s1 n2), (add_shuffle1 n2), (add_comm n2 r1). - now rewrite <- add_lt_mono_r. -- intros n n' Hn m m' Hm. - rewrite Hm. rewrite 2 lt_nge, 2 lt_eq_cases, Hn; auto with *. -Qed. - -Definition t := Z.t. -Definition eq := Z.eq. -Definition zero := Z.zero. -Definition one := Z.one. -Definition two := Z.two. -Definition succ := Z.succ. -Definition pred := Z.pred. -Definition add := Z.add. -Definition sub := Z.sub. -Definition mul := Z.mul. -Definition opp := Z.opp. -Definition lt := Z.lt. -Definition le := Z.le. -Definition min := Z.min. -Definition max := Z.max. + End Z. + + Declare Scope ZScope. + Delimit Scope ZScope with Z. + Bind Scope ZScope with Z.t. + Infix "==" := Z.eq (at level 70) : ZScope. + Notation "x ~= y" := (~ Z.eq x y) (at level 70) : ZScope. + Notation "0" := Z.zero : ZScope. + Notation "1" := Z.one : ZScope. + Notation "2" := Z.two : ZScope. + Infix "+" := Z.add : ZScope. + Infix "-" := Z.sub : ZScope. + Infix "*" := Z.mul : ZScope. + Notation "- x" := (Z.opp x) : ZScope. + Infix "<" := Z.lt : ZScope. + Infix "<=" := Z.le : ZScope. + #[local] Open Scope ZScope. + + Lemma sub_add_opp : forall n m, Z.sub n m = Z.add n (Z.opp m). + Proof. reflexivity. Qed. + + #[global] + Instance eq_equiv : Equivalence Z.eq. + Proof. + split. + - unfold Reflexive, Z.eq. reflexivity. + - unfold Symmetric, Z.eq; now symmetry. + - unfold Transitive, Z.eq. intros (n1,n2) (m1,m2) (p1,p2) H1 H2; simpl in *. + apply (add_cancel_r _ _ (m1+m2)%N). + rewrite add_shuffle2, H1, add_shuffle1, H2. + now rewrite add_shuffle1, (add_comm m1). + Qed. + + #[global] + Instance pair_wd : Proper (N.eq==>N.eq==>Z.eq) (@pair N.t N.t). + Proof. + intros n1 n2 H1 m1 m2 H2; unfold Z.eq; simpl; now rewrite H1, H2. + Qed. + + #[global] + Instance succ_wd : Proper (Z.eq ==> Z.eq) Z.succ. + Proof. + unfold Z.succ, Z.eq; intros n m H; simpl. + do 2 rewrite add_succ_l; now rewrite H. + Qed. + + #[global] + Instance pred_wd : Proper (Z.eq ==> Z.eq) Z.pred. + Proof. + unfold Z.pred, Z.eq; intros n m H; simpl. + do 2 rewrite add_succ_r; now rewrite H. + Qed. + + #[global] + Instance add_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.add. + Proof. + unfold Z.eq, Z.add; intros n1 m1 H1 n2 m2 H2; simpl. + now rewrite add_shuffle1, H1, H2, add_shuffle1. + Qed. + + #[global] + Instance opp_wd : Proper (Z.eq ==> Z.eq) Z.opp. + Proof. + unfold Z.eq, Z.opp; intros (n1,n2) (m1,m2) H; simpl in *. + now rewrite (add_comm n2), (add_comm m2). + Qed. + + #[global] + Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub. + Proof. + intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp. now do 2 f_equiv. + Qed. + + Lemma mul_comm : forall n m, n*m == m*n. + Proof. + intros (n1,n2) (m1,m2); compute. + rewrite (add_comm (m1*n2)%N). + do 2 f_equiv; apply mul_comm. + Qed. + + #[global] + Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul. + Proof. + assert (forall n, Proper (Z.eq ==> Z.eq) (Z.mul n)). { + unfold Z.mul, Z.eq. intros (n1,n2) (p1,p2) (q1,q2) H; simpl in *. + rewrite add_shuffle1, (add_comm (n1*p1)%N). + symmetry. rewrite add_shuffle1. + rewrite <- ! mul_add_distr_l. + rewrite (add_comm p2), (add_comm q2), H. + reflexivity. + } + intros n n' Hn m m' Hm. + rewrite Hm, (mul_comm n), (mul_comm n'), Hn. + reflexivity. + Qed. + + Section Induction. + Variable A : Z.t -> Prop. + Hypothesis A_wd : Proper (Z.eq==>iff) A. + + Theorem bi_induction : + A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n. + Proof. + Open Scope NScope. + intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *. + destruct n as [n m]. + cut (forall p, A (p, 0)); [intro H1 |]. + - cut (forall p, A (0, p)); [intro H2 |]. + + destruct (add_dichotomy n m) as [[p H] | [p H]]. + * rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm). + apply H2. + * rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1. + + induct p. * assumption. + * intros p IH. + apply (A_wd (0, p) (1, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l]. + rewrite one_succ in IH. now apply AS. + - induct p. + + assumption. + + intros p IH. + replace 0 with (snd (p, 0)); [| reflexivity]. + replace (N.succ p) with (N.succ (fst (p, 0))); [| reflexivity]. now apply -> AS. + Close Scope NScope. + Qed. + + End Induction. + + (* Time to prove theorems in the language of Z *) + + Theorem pred_succ : forall n, Z.pred (Z.succ n) == n. + Proof. + unfold Z.pred, Z.succ, Z.eq; intro n; simpl; now nzsimpl. + Qed. + + Theorem succ_pred : forall n, Z.succ (Z.pred n) == n. + Proof. + intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl. + Qed. + + Theorem one_succ : 1 == Z.succ 0. + Proof. + unfold Z.eq; simpl. now nzsimpl'. + Qed. + + Theorem two_succ : 2 == Z.succ 1. + Proof. + unfold Z.eq; simpl. now nzsimpl'. + Qed. + + Theorem opp_0 : - 0 == 0. + Proof. + unfold Z.opp, Z.eq; simpl. now nzsimpl. + Qed. + + Theorem opp_succ : forall n, - (Z.succ n) == Z.pred (- n). + Proof. + reflexivity. + Qed. + + Theorem add_0_l : forall n, 0 + n == n. + Proof. + intro n; unfold Z.add, Z.eq; simpl. now nzsimpl. + Qed. + + Theorem add_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m). + Proof. + intros n m; unfold Z.add, Z.eq; simpl. now nzsimpl. + Qed. + + Theorem sub_0_r : forall n, n - 0 == n. + Proof. + intro n; unfold Z.sub, Z.eq; simpl. now nzsimpl. + Qed. + + Theorem sub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m). + Proof. + intros n m; unfold Z.sub, Z.eq; simpl. symmetry; now rewrite add_succ_r. + Qed. + + Theorem mul_0_l : forall n, 0 * n == 0. + Proof. + intros (n1,n2); unfold Z.mul, Z.eq; simpl; now nzsimpl. + Qed. + + Theorem mul_succ_l : forall n m, (Z.succ n) * m == n * m + m. + Proof. + intros (n1,n2) (m1,m2); unfold Z.mul, Z.succ, Z.eq; simpl; nzsimpl. + rewrite <- (add_assoc _ m1), (add_comm m1), (add_assoc _ _ m1). + now rewrite <- (add_assoc _ m2), (add_comm m2), (add_assoc _ (n2*m1)%N m2). + Qed. + + (** Order *) + + Lemma lt_eq_cases : forall n m, n<=m <-> n n <= m. + Proof. + intros n m; unfold Z.lt, Z.le, Z.eq; simpl; nzsimpl. apply lt_succ_r. + Qed. + + Theorem min_l : forall n m, n <= m -> Z.min n m == n. + Proof. + unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. + rewrite min_l by assumption. + now rewrite <- add_assoc, (add_comm m2). + Qed. + + Theorem min_r : forall n m, m <= n -> Z.min n m == m. + Proof. + unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. + rewrite min_r by assumption. + now rewrite add_assoc. + Qed. + + Theorem max_l : forall n m, m <= n -> Z.max n m == n. + Proof. + unfold Z.max, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. + rewrite max_l by assumption. + now rewrite <- add_assoc, (add_comm m2). + Qed. + + Theorem max_r : forall n m, n <= m -> Z.max n m == m. + Proof. + unfold Z.max, Z.le, Z.eq; simpl; intros n m H. + rewrite max_r by assumption. + now rewrite add_assoc. + Qed. + + Theorem lt_nge : forall n m, n < m <-> ~(m<=n). + Proof. + intros. apply lt_nge. + Qed. + + #[global] + Instance lt_wd : Proper (Z.eq ==> Z.eq ==> iff) Z.lt. + Proof. + assert (forall n, Proper (Z.eq==>iff) (Z.lt n)). + - intros (n1,n2). apply proper_sym_impl_iff; auto with *. + unfold Z.lt, Z.eq; intros (r1,r2) (s1,s2) Eq H; simpl in *. + apply le_lt_add_lt with (r1+r2)%N (r1+r2)%N; [apply le_refl; auto with *|]. + rewrite add_shuffle2, (add_comm s2), Eq. + rewrite (add_comm s1 n2), (add_shuffle1 n2), (add_comm n2 r1). + now rewrite <- add_lt_mono_r. + - intros n n' Hn m m' Hm. + rewrite Hm. rewrite 2 lt_nge, 2 lt_eq_cases, Hn; auto with *. + Qed. + + Definition t := Z.t. + Definition eq := Z.eq. + Definition zero := Z.zero. + Definition one := Z.one. + Definition two := Z.two. + Definition succ := Z.succ. + Definition pred := Z.pred. + Definition add := Z.add. + Definition sub := Z.sub. + Definition mul := Z.mul. + Definition opp := Z.opp. + Definition lt := Z.lt. + Definition le := Z.le. + Definition min := Z.min. + Definition max := Z.max. End ZPairsAxiomsMod. diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index 673410b7d9..915cda4983 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -29,96 +29,96 @@ From Stdlib.Numbers.NatInt Require Import NZAxioms NZBase. Module Type NZAddProp (Import NZ : NZBasicFunsSig')(Import NZBase : NZBaseProp NZ). -#[global] Hint Rewrite - pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. -#[global] Hint Rewrite one_succ two_succ : nz'. -Ltac nzsimpl := autorewrite with nz. -Ltac nzsimpl' := autorewrite with nz nz'. - -Theorem add_0_r : forall n, n + 0 == n. -Proof. - intro n; nzinduct n. - - now nzsimpl. - - intro. nzsimpl. now rewrite succ_inj_wd. -Qed. - -Theorem add_succ_r : forall n m, n + S m == S (n + m). -Proof. - intros n m; nzinduct n. - - now nzsimpl. - - intro. nzsimpl. now rewrite succ_inj_wd. -Qed. - -Theorem add_succ_comm : forall n m, S n + m == n + S m. -Proof. -intros n m. now rewrite add_succ_r, add_succ_l. -Qed. - -#[global] Hint Rewrite add_0_r add_succ_r : nz. - -Theorem add_comm : forall n m, n + m == m + n. -Proof. - intros n m; nzinduct n. - - now nzsimpl. - - intro. nzsimpl. now rewrite succ_inj_wd. -Qed. - -Theorem add_1_l : forall n, 1 + n == S n. -Proof. -intro n; now nzsimpl'. -Qed. - -Theorem add_1_r : forall n, n + 1 == S n. -Proof. -intro n; now nzsimpl'. -Qed. - -#[global] Hint Rewrite add_1_l add_1_r : nz. - -Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. -Proof. - intros n m p; nzinduct n. - - now nzsimpl. - - intro. nzsimpl. now rewrite succ_inj_wd. -Qed. - -Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m. -Proof. -intros n m p; nzinduct p. -- now nzsimpl. -- intro p. nzsimpl. now rewrite succ_inj_wd. -Qed. - -Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. -Proof. -intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l. -Qed. - -Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m. -Proof. -intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm. -Qed. - -Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q). -Proof. -intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0. -Qed. - -Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p). -Proof. -intros n m p q. rewrite (add_comm p). apply add_shuffle1. -Qed. - -Theorem add_shuffle3 : forall n m p, n + (m + p) == m + (n + p). -Proof. -intros n m p. now rewrite add_comm, <- add_assoc, (add_comm p). -Qed. - -Theorem sub_1_r : forall n, n - 1 == P n. -Proof. -intro n; now nzsimpl'. -Qed. - -#[global] Hint Rewrite sub_1_r : nz. + #[global] Hint Rewrite + pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. + #[global] Hint Rewrite one_succ two_succ : nz'. + Ltac nzsimpl := autorewrite with nz. + Ltac nzsimpl' := autorewrite with nz nz'. + + Theorem add_0_r : forall n, n + 0 == n. + Proof. + intro n; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. + Qed. + + Theorem add_succ_r : forall n m, n + S m == S (n + m). + Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. + Qed. + + Theorem add_succ_comm : forall n m, S n + m == n + S m. + Proof. + intros n m. now rewrite add_succ_r, add_succ_l. + Qed. + + #[global] Hint Rewrite add_0_r add_succ_r : nz. + + Theorem add_comm : forall n m, n + m == m + n. + Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. + Qed. + + Theorem add_1_l : forall n, 1 + n == S n. + Proof. + intro n; now nzsimpl'. + Qed. + + Theorem add_1_r : forall n, n + 1 == S n. + Proof. + intro n; now nzsimpl'. + Qed. + + #[global] Hint Rewrite add_1_l add_1_r : nz. + + Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. + Proof. + intros n m p; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. + Qed. + + Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m. + Proof. + intros n m p; nzinduct p. + - now nzsimpl. + - intro p. nzsimpl. now rewrite succ_inj_wd. + Qed. + + Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. + Proof. + intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l. + Qed. + + Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m. + Proof. + intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm. + Qed. + + Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q). + Proof. + intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0. + Qed. + + Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p). + Proof. + intros n m p q. rewrite (add_comm p). apply add_shuffle1. + Qed. + + Theorem add_shuffle3 : forall n m p, n + (m + p) == m + (n + p). + Proof. + intros n m p. now rewrite add_comm, <- add_assoc, (add_comm p). + Qed. + + Theorem sub_1_r : forall n, n - 1 == P n. + Proof. + intro n; now nzsimpl'. + Qed. + + #[global] Hint Rewrite sub_1_r : nz. End NZAddProp. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index 7546755a49..2e0bfb079a 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -21,156 +21,156 @@ This gives important basic compatibility lemmas between [add] and [lt], [le]. From Stdlib.Numbers.NatInt Require Import NZAxioms NZBase NZMul NZOrder. Module Type NZAddOrderProp (Import NZ : NZOrdAxiomsSig'). -Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ. - -Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m. -Proof. - intros n m p; nzinduct p. - now nzsimpl. - - intro p. nzsimpl. now rewrite <- succ_lt_mono. -Qed. - -Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. -Proof. -intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l. -Qed. - -Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply lt_trans with (m + p); -[now apply add_lt_mono_r | now apply add_lt_mono_l]. -Qed. - -Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. -Proof. - intros n m p; nzinduct p. - now nzsimpl. - - intro p. nzsimpl. now rewrite <- succ_le_mono. -Qed. - -Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. -Proof. -intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l. -Qed. - -Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q. -Proof. -intros n m p q H1 H2. -apply le_trans with (m + p); -[now apply add_le_mono_r | now apply add_le_mono_l]. -Qed. - -Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply lt_le_trans with (m + p); -[now apply add_lt_mono_r | now apply add_le_mono_l]. -Qed. - -Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply le_lt_trans with (m + p); -[now apply add_le_mono_r | now apply add_lt_mono_l]. -Qed. - -Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. -Qed. - -Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. -Qed. - -Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. -Qed. - -Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. -Qed. - -Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m. -Proof. -intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl. -Qed. - -Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n. -Proof. -intros; rewrite add_comm; now apply lt_add_pos_l. -Qed. - -Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q. -Proof. -intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. -contradict H2. rewrite nlt_ge. now apply add_le_mono. -Qed. - -Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q. -Proof. -intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. -contradict H2. rewrite nle_gt. now apply add_le_lt_mono. -Qed. - -Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q. -Proof. -intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |]. -contradict H2. rewrite nle_gt. now apply add_lt_le_mono. -Qed. - -Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q. -Proof. -intros n m p q H; -destruct (le_gt_cases p n) as [H1 | H1]; [| now left]. -destruct (le_gt_cases q m) as [H2 | H2]; [| now right]. -contradict H; rewrite nlt_ge. now apply add_le_mono. -Qed. - -Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. -Proof. -intros n m p q H. -destruct (le_gt_cases n p) as [H1 | H1]. - now left. -- destruct (le_gt_cases m q) as [H2 | H2]. + now right. - + contradict H; rewrite nle_gt. now apply add_lt_mono. -Qed. - -Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. -Proof. -intros n m H; apply add_lt_cases; now nzsimpl. -Qed. - -Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m. -Proof. -intros n m H; apply add_lt_cases; now nzsimpl. -Qed. - -Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0. -Proof. -intros n m H; apply add_le_cases; now nzsimpl. -Qed. - -Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m. -Proof. -intros n m H; apply add_le_cases; now nzsimpl. -Qed. - -(** Subtraction *) - -(** We can prove the existence of a subtraction of any number by + Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ. + + Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m. + Proof. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_lt_mono. + Qed. + + Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. + Proof. + intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l. + Qed. + + Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q. + Proof. + intros n m p q H1 H2. + apply lt_trans with (m + p); + [now apply add_lt_mono_r | now apply add_lt_mono_l]. + Qed. + + Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. + Proof. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_le_mono. + Qed. + + Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. + Proof. + intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l. + Qed. + + Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q. + Proof. + intros n m p q H1 H2. + apply le_trans with (m + p); + [now apply add_le_mono_r | now apply add_le_mono_l]. + Qed. + + Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q. + Proof. + intros n m p q H1 H2. + apply lt_le_trans with (m + p); + [now apply add_lt_mono_r | now apply add_le_mono_l]. + Qed. + + Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q. + Proof. + intros n m p q H1 H2. + apply le_lt_trans with (m + p); + [now apply add_le_mono_r | now apply add_lt_mono_l]. + Qed. + + Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m. + Proof. + intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. + Qed. + + Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m. + Proof. + intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. + Qed. + + Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m. + Proof. + intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. + Qed. + + Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m. + Proof. + intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. + Qed. + + Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m. + Proof. + intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl. + Qed. + + Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n. + Proof. + intros; rewrite add_comm; now apply lt_add_pos_l. + Qed. + + Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q. + Proof. + intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. + contradict H2. rewrite nlt_ge. now apply add_le_mono. + Qed. + + Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q. + Proof. + intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. + contradict H2. rewrite nle_gt. now apply add_le_lt_mono. + Qed. + + Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q. + Proof. + intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |]. + contradict H2. rewrite nle_gt. now apply add_lt_le_mono. + Qed. + + Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q. + Proof. + intros n m p q H; + destruct (le_gt_cases p n) as [H1 | H1]; [| now left]. + destruct (le_gt_cases q m) as [H2 | H2]; [| now right]. + contradict H; rewrite nlt_ge. now apply add_le_mono. + Qed. + + Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. + Proof. + intros n m p q H. + destruct (le_gt_cases n p) as [H1 | H1]. - now left. + - destruct (le_gt_cases m q) as [H2 | H2]. + now right. + + contradict H; rewrite nle_gt. now apply add_lt_mono. + Qed. + + Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. + Proof. + intros n m H; apply add_lt_cases; now nzsimpl. + Qed. + + Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m. + Proof. + intros n m H; apply add_lt_cases; now nzsimpl. + Qed. + + Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0. + Proof. + intros n m H; apply add_le_cases; now nzsimpl. + Qed. + + Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m. + Proof. + intros n m H; apply add_le_cases; now nzsimpl. + Qed. + + (** Subtraction *) + + (** We can prove the existence of a subtraction of any number by a smaller one *) -Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p. -Proof. - intros n m H. apply le_ind with (4:=H). - solve_proper. - - exists 0; nzsimpl; split; order. - - clear m H. intros m H (p & EQ & LE). exists (S p). - split. + nzsimpl. now f_equiv. + now apply le_le_succ_r. -Qed. + Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p. + Proof. + intros n m H. apply le_ind with (4:=H). - solve_proper. + - exists 0; nzsimpl; split; order. + - clear m H. intros m H (p & EQ & LE). exists (S p). + split. + nzsimpl. now f_equiv. + now apply le_le_succ_r. + Qed. -(** For the moment, it doesn't seem possible to relate + (** For the moment, it doesn't seem possible to relate this existing subtraction with [sub]. *) diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index f2737611b0..cbcaf13162 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -28,79 +28,79 @@ From Stdlib.Numbers.NatInt Require Import NZAxioms. Module Type NZBaseProp (Import NZ : NZDomainSig'). -(** This functor from [Stdlib.Structures.Equalities] gives + (** This functor from [Stdlib.Structures.Equalities] gives [eq_refl], [eq_sym] and [eq_trans]. *) -Include BackportEq NZ NZ. + Include BackportEq NZ NZ. -Lemma eq_sym_iff : forall x y, x==y <-> y==x. -Proof. -intros; split; symmetry; auto. -Qed. + Lemma eq_sym_iff : forall x y, x==y <-> y==x. + Proof. + intros; split; symmetry; auto. + Qed. -(* TODO: how register ~= (which is just a notation) as a Symmetric relation, + (* TODO: how register ~= (which is just a notation) as a Symmetric relation, hence allowing "symmetry" tac ? *) -Theorem neq_sym : forall n m, n ~= m -> m ~= n. -Proof. -intros n m H1 H2; symmetry in H2; false_hyp H2 H1. -Qed. + Theorem neq_sym : forall n m, n ~= m -> m ~= n. + Proof. + intros n m H1 H2; symmetry in H2; false_hyp H2 H1. + Qed. -(** We add entries in the [stepl] and [stepr] databases. *) + (** We add entries in the [stepl] and [stepr] databases. *) -Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y. -Proof. -intros x y z H1 H2; now rewrite <- H1. -Qed. + Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y. + Proof. + intros x y z H1 H2; now rewrite <- H1. + Qed. -Declare Left Step eq_stepl. -(* The right step lemma is just the transitivity of eq *) -Declare Right Step (@Equivalence_Transitive _ _ eq_equiv). + Declare Left Step eq_stepl. + (* The right step lemma is just the transitivity of eq *) + Declare Right Step (@Equivalence_Transitive _ _ eq_equiv). -Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2. -Proof. -intros n1 n2 H. -apply pred_wd in H. now do 2 rewrite pred_succ in H. -Qed. + Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2. + Proof. + intros n1 n2 H. + apply pred_wd in H. now do 2 rewrite pred_succ in H. + Qed. -(* The following theorem is useful as an equivalence for proving + (* The following theorem is useful as an equivalence for proving bidirectional induction steps *) -Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. -Proof. -intros; split. -- apply succ_inj. -- intros. now f_equiv. -Qed. - -Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. -Proof. -intros; now rewrite succ_inj_wd. -Qed. - -(* We cannot prove that the predecessor is injective, nor that it is + Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. + Proof. + intros; split. + - apply succ_inj. + - intros. now f_equiv. + Qed. + + Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. + Proof. + intros; now rewrite succ_inj_wd. + Qed. + + (* We cannot prove that the predecessor is injective, nor that it is left-inverse to the successor at this point *) -Section CentralInduction. + Section CentralInduction. -Variable A : t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. + Variable A : t -> Prop. + Hypothesis A_wd : Proper (eq==>iff) A. -Theorem central_induction : - forall z, A z -> - (forall n, A n <-> A (S n)) -> - forall n, A n. -Proof. -intros z Base Step; revert Base; pattern z; apply bi_induction. -- solve_proper. -- intro; now apply bi_induction. -- intro n; pose proof (Step n); tauto. -Qed. + Theorem central_induction : + forall z, A z -> + (forall n, A n <-> A (S n)) -> + forall n, A n. + Proof. + intros z Base Step; revert Base; pattern z; apply bi_induction. + - solve_proper. + - intro; now apply bi_induction. + - intro n; pose proof (Step n); tauto. + Qed. -End CentralInduction. + End CentralInduction. -Tactic Notation "nzinduct" ident(n) := - induction_maker n ltac:(apply bi_induction). + Tactic Notation "nzinduct" ident(n) := + induction_maker n ltac:(apply bi_induction). -Tactic Notation "nzinduct" ident(n) constr(u) := - induction_maker n ltac:(apply (fun A A_wd => central_induction A A_wd u)). + Tactic Notation "nzinduct" ident(n) constr(u) := + induction_maker n ltac:(apply (fun A A_wd => central_induction A A_wd u)). End NZBaseProp. diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v index 1a9cd76ef6..a2fe8ff477 100644 --- a/theories/Numbers/NatInt/NZBits.v +++ b/theories/Numbers/NatInt/NZBits.v @@ -13,39 +13,39 @@ From Stdlib Require Import Bool NZAxioms NZMulOrder NZParity NZPow NZDiv NZLog. (** Axiomatization of some bitwise operations *) Module Type Bits (Import A : Typ). - Parameter Inline testbit : t -> t -> bool. - Parameters Inline shiftl shiftr land lor ldiff lxor : t -> t -> t. - Parameter Inline div2 : t -> t. + Parameter Inline testbit : t -> t -> bool. + Parameters Inline shiftl shiftr land lor ldiff lxor : t -> t -> t. + Parameter Inline div2 : t -> t. End Bits. Module Type BitsNotation (Import A : Typ)(Import B : Bits A). - Notation "a .[ n ]" := (testbit a n) (at level 1, format "a .[ n ]"). - Infix ">>" := shiftr (at level 30, no associativity). - Infix "<<" := shiftl (at level 30, no associativity). + Notation "a .[ n ]" := (testbit a n) (at level 1, format "a .[ n ]"). + Infix ">>" := shiftr (at level 30, no associativity). + Infix "<<" := shiftl (at level 30, no associativity). End BitsNotation. Module Type Bits' (A:Typ) := Bits A <+ BitsNotation A. Module Type NZBitsSpec - (Import A : NZOrdAxiomsSig')(Import B : Bits' A). + (Import A : NZOrdAxiomsSig')(Import B : Bits' A). -#[global] - Declare Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. - Axiom testbit_odd_0 : forall a, (2*a+1).[0] = true. - Axiom testbit_even_0 : forall a, (2*a).[0] = false. - Axiom testbit_odd_succ : forall a n, 0<=n -> (2*a+1).[S n] = a.[n]. - Axiom testbit_even_succ : forall a n, 0<=n -> (2*a).[S n] = a.[n]. - Axiom testbit_neg_r : forall a n, n<0 -> a.[n] = false. + #[global] + Declare Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. + Axiom testbit_odd_0 : forall a, (2*a+1).[0] = true. + Axiom testbit_even_0 : forall a, (2*a).[0] = false. + Axiom testbit_odd_succ : forall a n, 0<=n -> (2*a+1).[S n] = a.[n]. + Axiom testbit_even_succ : forall a n, 0<=n -> (2*a).[S n] = a.[n]. + Axiom testbit_neg_r : forall a n, n<0 -> a.[n] = false. - Axiom shiftr_spec : forall a n m, 0<=m -> (a >> n).[m] = a.[m+n]. - Axiom shiftl_spec_high : forall a n m, 0<=m -> n<=m -> (a << n).[m] = a.[m-n]. - Axiom shiftl_spec_low : forall a n m, m (a << n).[m] = false. + Axiom shiftr_spec : forall a n m, 0<=m -> (a >> n).[m] = a.[m+n]. + Axiom shiftl_spec_high : forall a n m, 0<=m -> n<=m -> (a << n).[m] = a.[m-n]. + Axiom shiftl_spec_low : forall a n m, m (a << n).[m] = false. - Axiom land_spec : forall a b n, (land a b).[n] = a.[n] && b.[n]. - Axiom lor_spec : forall a b n, (lor a b).[n] = a.[n] || b.[n]. - Axiom ldiff_spec : forall a b n, (ldiff a b).[n] = a.[n] && negb b.[n]. - Axiom lxor_spec : forall a b n, (lxor a b).[n] = xorb a.[n] b.[n]. - Axiom div2_spec : forall a, div2 a == a >> 1. + Axiom land_spec : forall a b n, (land a b).[n] = a.[n] && b.[n]. + Axiom lor_spec : forall a b n, (lor a b).[n] = a.[n] || b.[n]. + Axiom ldiff_spec : forall a b n, (ldiff a b).[n] = a.[n] && negb b.[n]. + Axiom lxor_spec : forall a b n, (lxor a b).[n] = xorb a.[n] b.[n]. + Axiom div2_spec : forall a, div2 a == a >> 1. End NZBitsSpec. diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index 11c81788d8..1b4092befe 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -15,23 +15,23 @@ From Stdlib Require Import NZAxioms NZMulOrder. (** The first signatures will be common to all divisions over NZ, N and Z *) Module Type DivMod (Import A : Typ). - Parameters Inline div modulo : t -> t -> t. + Parameters Inline div modulo : t -> t -> t. End DivMod. Module Type DivModNotation (A : Typ)(Import B : DivMod A). - Infix "/" := div. - Infix "mod" := modulo (at level 40, no associativity). + Infix "/" := div. + Infix "mod" := modulo (at level 40, no associativity). End DivModNotation. Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A. Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A). -#[global] - Declare Instance div_wd : Proper (eq==>eq==>eq) div. -#[global] - Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo. - Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b). - Axiom mod_bound_pos : forall a b, 0<=a -> 0 0 <= a mod b < b. + #[global] + Declare Instance div_wd : Proper (eq==>eq==>eq) div. + #[global] + Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo. + Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b). + Axiom mod_bound_pos : forall a b, 0<=a -> 0 0 <= a mod b < b. End NZDivSpec. (** Euclidean Division with a / 0 == 0 and a mod 0 == a *) @@ -50,520 +50,520 @@ Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A. Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A. Module Type NZDivProp - (Import A : NZOrdAxiomsSig') - (Import B : NZDiv' A) - (Import C : NZMulOrderProp A). - -(** Uniqueness theorems *) - -Theorem div_mod_unique : - forall b q1 q2 r1 r2, 0<=r1 0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b. -assert (U : forall q1 q2 r1 r2, - b*q1+r1 == b*q2+r2 -> 0<=r1 0<=r2 -> q1 False). -- intros q1 q2 r1 r2 EQ LT Hr1 Hr2. - contradict EQ. - apply lt_neq. - apply lt_le_trans with (b*q1+b). - + rewrite <- add_lt_mono_l. tauto. - + apply le_trans with (b*q2). - * rewrite mul_comm, <- mul_succ_l, mul_comm. - apply mul_le_mono_nonneg_l; intuition; try order. - rewrite le_succ_l; auto. - * rewrite <- (add_0_r (b*q2)) at 1. - rewrite <- add_le_mono_l. tauto. - -- intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. - + elim (U q1 q2 r1 r2); intuition. - + split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. - + elim (U q2 q1 r2 r1); intuition auto with relations. -Qed. - -Theorem div_unique: - forall a b q r, 0<=a -> 0<=r - a == b*q + r -> q == a/b. -Proof. -intros a b q r Ha (Hb,Hr) EQ. -destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -- apply mod_bound_pos; order. -- rewrite <- div_mod; order. -Qed. - -Theorem mod_unique: - forall a b q r, 0<=a -> 0<=r - a == b*q + r -> r == a mod b. -Proof. -intros a b q r Ha (Hb,Hr) EQ. -destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -- apply mod_bound_pos; order. -- rewrite <- div_mod; order. -Qed. - -Theorem div_unique_exact a b q: - 0<=a -> 0 a == b*q -> q == a/b. -Proof. - intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split. -Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, 0 a/a == 1. -Proof. -intros. symmetry. apply div_unique_exact; nzsimpl; order. -Qed. - -Lemma mod_same : forall a, 0 a mod a == 0. -Proof. -intros. symmetry. -apply mod_unique with 1; intuition auto; try order. -now nzsimpl. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, 0<=a a/b == 0. -Proof. -intros a b ?. symmetry. -apply div_unique with a; intuition; try order. -now nzsimpl. -Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, 0<=a a mod b == a. -Proof. -intros. symmetry. -apply mod_unique with 0; intuition; try order. -now nzsimpl. -Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, 0 0/a == 0. -Proof. -intros; apply div_small; split; order. -Qed. - -Lemma mod_0_l: forall a, 0 0 mod a == 0. -Proof. -intros; apply mod_small; split; order. -Qed. - -Lemma div_1_r: forall a, 0<=a -> a/1 == a. -Proof. -intros. symmetry. apply div_unique_exact; nzsimpl; order'. -Qed. - -Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. -Proof. -intros a ?. symmetry. -apply mod_unique with a; try split; try order; try apply lt_0_1. -now nzsimpl. -Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. -intros; apply div_small; split; auto. apply le_0_1. -Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. -intros; apply mod_small; split; auto. apply le_0_1. -Qed. - -Lemma div_mul : forall a b, 0<=a -> 0 (a*b)/b == a. -Proof. -intros; symmetry. apply div_unique_exact; trivial. -- apply mul_nonneg_nonneg; order. -- apply mul_comm. -Qed. - -Lemma mod_mul : forall a b, 0<=a -> 0 (a*b) mod b == 0. -Proof. -intros a b ? ?; symmetry. -apply mod_unique with a; try split; try order. -- apply mul_nonneg_nonneg; order. -- nzsimpl; apply mul_comm. -Qed. - - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. -Proof. -intros a b ? ?. destruct (le_gt_cases b a). -- apply le_trans with b; auto. - apply lt_le_incl. destruct (mod_bound_pos a b); auto. -- rewrite lt_eq_cases; right. - apply mod_small; auto. -Qed. - - -(* Division of positive numbers is positive. *) - -Lemma div_pos: forall a b, 0<=a -> 0 0 <= a/b. -Proof. -intros a b ? ?. -rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl. -rewrite (add_le_mono_r _ _ (a mod b)). -rewrite <- div_mod by order. -nzsimpl. -apply mod_le; auto. -Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. -intros a b (Hb,Hab). -assert (LE : 0 <= a/b) by (apply div_pos; order). -assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order). -rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto. -exfalso; revert Hab. -rewrite (div_mod a b), <-EQ; nzsimpl; order. -Qed. - -Lemma div_small_iff : forall a b, 0<=a -> 0 (a/b==0 <-> a 0 (a mod b == a <-> a 0 (0 b<=a). -Proof. -intros a b Ha Hb; split; intros Hab. -- destruct (lt_ge_cases a b) as [LT|LE]; auto. - rewrite <- div_small_iff in LT; order. -- apply div_str_pos; auto. -Qed. - - -(** As soon as the divisor is strictly greater than 1, + (Import A : NZOrdAxiomsSig') + (Import B : NZDiv' A) + (Import C : NZMulOrderProp A). + + (** Uniqueness theorems *) + + Theorem div_mod_unique : + forall b q1 q2 r1 r2, 0<=r1 0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. + Proof. + intros b. + assert (U : forall q1 q2 r1 r2, + b*q1+r1 == b*q2+r2 -> 0<=r1 0<=r2 -> q1 False). + - intros q1 q2 r1 r2 EQ LT Hr1 Hr2. + contradict EQ. + apply lt_neq. + apply lt_le_trans with (b*q1+b). + + rewrite <- add_lt_mono_l. tauto. + + apply le_trans with (b*q2). + * rewrite mul_comm, <- mul_succ_l, mul_comm. + apply mul_le_mono_nonneg_l; intuition; try order. + rewrite le_succ_l; auto. + * rewrite <- (add_0_r (b*q2)) at 1. + rewrite <- add_le_mono_l. tauto. + + - intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. + + elim (U q1 q2 r1 r2); intuition. + + split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. + + elim (U q2 q1 r2 r1); intuition auto with relations. + Qed. + + Theorem div_unique: + forall a b q r, 0<=a -> 0<=r + a == b*q + r -> q == a/b. + Proof. + intros a b q r Ha (Hb,Hr) EQ. + destruct (div_mod_unique b q (a/b) r (a mod b)); auto. + - apply mod_bound_pos; order. + - rewrite <- div_mod; order. + Qed. + + Theorem mod_unique: + forall a b q r, 0<=a -> 0<=r + a == b*q + r -> r == a mod b. + Proof. + intros a b q r Ha (Hb,Hr) EQ. + destruct (div_mod_unique b q (a/b) r (a mod b)); auto. + - apply mod_bound_pos; order. + - rewrite <- div_mod; order. + Qed. + + Theorem div_unique_exact a b q: + 0<=a -> 0 a == b*q -> q == a/b. + Proof. + intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split. + Qed. + + (** A division by itself returns 1 *) + + Lemma div_same : forall a, 0 a/a == 1. + Proof. + intros. symmetry. apply div_unique_exact; nzsimpl; order. + Qed. + + Lemma mod_same : forall a, 0 a mod a == 0. + Proof. + intros. symmetry. + apply mod_unique with 1; intuition auto; try order. + now nzsimpl. + Qed. + + (** A division of a small number by a bigger one yields zero. *) + + Theorem div_small: forall a b, 0<=a a/b == 0. + Proof. + intros a b ?. symmetry. + apply div_unique with a; intuition; try order. + now nzsimpl. + Qed. + + (** Same situation, in term of modulo: *) + + Theorem mod_small: forall a b, 0<=a a mod b == a. + Proof. + intros. symmetry. + apply mod_unique with 0; intuition; try order. + now nzsimpl. + Qed. + + (** * Basic values of divisions and modulo. *) + + Lemma div_0_l: forall a, 0 0/a == 0. + Proof. + intros; apply div_small; split; order. + Qed. + + Lemma mod_0_l: forall a, 0 0 mod a == 0. + Proof. + intros; apply mod_small; split; order. + Qed. + + Lemma div_1_r: forall a, 0<=a -> a/1 == a. + Proof. + intros. symmetry. apply div_unique_exact; nzsimpl; order'. + Qed. + + Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. + Proof. + intros a ?. symmetry. + apply mod_unique with a; try split; try order; try apply lt_0_1. + now nzsimpl. + Qed. + + Lemma div_1_l: forall a, 1 1/a == 0. + Proof. + intros; apply div_small; split; auto. apply le_0_1. + Qed. + + Lemma mod_1_l: forall a, 1 1 mod a == 1. + Proof. + intros; apply mod_small; split; auto. apply le_0_1. + Qed. + + Lemma div_mul : forall a b, 0<=a -> 0 (a*b)/b == a. + Proof. + intros; symmetry. apply div_unique_exact; trivial. + - apply mul_nonneg_nonneg; order. + - apply mul_comm. + Qed. + + Lemma mod_mul : forall a b, 0<=a -> 0 (a*b) mod b == 0. + Proof. + intros a b ? ?; symmetry. + apply mod_unique with a; try split; try order. + - apply mul_nonneg_nonneg; order. + - nzsimpl; apply mul_comm. + Qed. + + + (** * Order results about mod and div *) + + (** A modulo cannot grow beyond its starting point. *) + + Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. + Proof. + intros a b ? ?. destruct (le_gt_cases b a). + - apply le_trans with b; auto. + apply lt_le_incl. destruct (mod_bound_pos a b); auto. + - rewrite lt_eq_cases; right. + apply mod_small; auto. + Qed. + + + (* Division of positive numbers is positive. *) + + Lemma div_pos: forall a b, 0<=a -> 0 0 <= a/b. + Proof. + intros a b ? ?. + rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl. + rewrite (add_le_mono_r _ _ (a mod b)). + rewrite <- div_mod by order. + nzsimpl. + apply mod_le; auto. + Qed. + + Lemma div_str_pos : forall a b, 0 0 < a/b. + Proof. + intros a b (Hb,Hab). + assert (LE : 0 <= a/b) by (apply div_pos; order). + assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order). + rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto. + exfalso; revert Hab. + rewrite (div_mod a b), <-EQ; nzsimpl; order. + Qed. + + Lemma div_small_iff : forall a b, 0<=a -> 0 (a/b==0 <-> a 0 (a mod b == a <-> a 0 (0 b<=a). + Proof. + intros a b Ha Hb; split; intros Hab. + - destruct (lt_ge_cases a b) as [LT|LE]; auto. + rewrite <- div_small_iff in LT; order. + - apply div_str_pos; auto. + Qed. + + + (** As soon as the divisor is strictly greater than 1, the division is strictly decreasing. *) -Lemma div_lt : forall a b, 0 1 a/b < a. -Proof. -intros a b ? ?. -assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). -destruct (lt_ge_cases a b). -- rewrite div_small; try split; order. -- rewrite (div_mod a b) at 2 by order. - apply lt_le_trans with (b*(a/b)). - + rewrite <- (mul_1_l (a/b)) at 1. - rewrite <- mul_lt_mono_pos_r; auto. - apply div_str_pos; auto. - + rewrite <- (add_0_r (b*(a/b))) at 1. + Lemma div_lt : forall a b, 0 1 a/b < a. + Proof. + intros a b ? ?. + assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). + destruct (lt_ge_cases a b). + - rewrite div_small; try split; order. + - rewrite (div_mod a b) at 2 by order. + apply lt_le_trans with (b*(a/b)). + + rewrite <- (mul_1_l (a/b)) at 1. + rewrite <- mul_lt_mono_pos_r; auto. + apply div_str_pos; auto. + + rewrite <- (add_0_r (b*(a/b))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. + Qed. + + (** [le] is compatible with a positive division. *) + + Lemma div_le_mono : forall a b c, 0 0<=a<=b -> a/c <= b/c. + Proof. + intros a b c Hc (Ha,Hab). + rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. + rewrite <- lt_succ_r. + rewrite (mul_lt_mono_pos_l c) by order. + nzsimpl. + rewrite (add_lt_mono_r _ _ (a mod c)). + rewrite <- div_mod by order. + apply lt_le_trans with b; auto. + rewrite (div_mod b c) at 1 by order. + rewrite <- add_assoc, <- add_le_mono_l. + apply le_trans with (c+0). + - nzsimpl; destruct (mod_bound_pos b c); order. + - rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. + Qed. + + (** The following two properties could be used as specification of div *) + + Lemma mul_div_le : forall a b, 0<=a -> 0 b*(a/b) <= a. + Proof. + intros a b ? ?. + rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order. + rewrite <- (add_0_r a) at 1. rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. -Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, 0 0<=a<=b -> a/c <= b/c. -Proof. -intros a b c Hc (Ha,Hab). -rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; - [|rewrite EQ; order]. -rewrite <- lt_succ_r. -rewrite (mul_lt_mono_pos_l c) by order. -nzsimpl. -rewrite (add_lt_mono_r _ _ (a mod c)). -rewrite <- div_mod by order. -apply lt_le_trans with b; auto. -rewrite (div_mod b c) at 1 by order. -rewrite <- add_assoc, <- add_le_mono_l. -apply le_trans with (c+0). -- nzsimpl; destruct (mod_bound_pos b c); order. -- rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. -Qed. - -(** The following two properties could be used as specification of div *) - -Lemma mul_div_le : forall a b, 0<=a -> 0 b*(a/b) <= a. -Proof. -intros a b ? ?. -rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order. -rewrite <- (add_0_r a) at 1. -rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. -Qed. - -Lemma mul_succ_div_gt : forall a b, 0<=a -> 0 a < b*(S (a/b)). -Proof. -intros a b ? ?. -rewrite (div_mod a b) at 1 by order. -rewrite (mul_succ_r). -rewrite <- add_lt_mono_l. -destruct (mod_bound_pos a b); auto. -Qed. - - -(** The previous inequality is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, 0<=a -> 0 (a == b*(a/b) <-> a mod b == 0). -Proof. -intros a b ? ?. rewrite (div_mod a b) at 1 by order. -rewrite <- (add_0_r (b*(a/b))) at 2. -apply add_cancel_l. -Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, 0<=a -> 0 a < b*q -> a/b < q. -Proof. -intros a b q ? ? ?. -rewrite (mul_lt_mono_pos_l b) by order. -apply le_lt_trans with a; auto. -apply mul_div_le; auto. -Qed. - -Theorem div_le_upper_bound: - forall a b q, 0<=a -> 0 a <= b*q -> a/b <= q. -Proof. -intros a b q ? ? ?. -rewrite (mul_le_mono_pos_l _ _ b) by order. -apply le_trans with a; auto. -apply mul_div_le; auto. -Qed. - -Theorem div_le_lower_bound: - forall a b q, 0<=a -> 0 b*q <= a -> q <= a/b. -Proof. -intros a b q Ha Hb H. -destruct (lt_ge_cases 0 q). -- rewrite <- (div_mul q b); try order. - apply div_le_mono; auto. - rewrite mul_comm; split; auto. - apply lt_le_incl, mul_pos_pos; auto. -- apply le_trans with 0; auto; apply div_pos; auto. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0<=p -> 0 - p/r <= p/q. -Proof. - intros p q r Hp (Hq,Hqr). - apply div_le_lower_bound; auto. - rewrite (div_mod p r) at 2 by order. - apply le_trans with (r*(p/r)). - - apply mul_le_mono_nonneg_r; try order. - apply div_pos; order. - - rewrite <- (add_0_r (r*(p/r))) at 1. - rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. -Qed. - - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 - (a + b * c) mod c == a mod c. -Proof. - intros a b c ? ? ?. - symmetry. - apply mod_unique with (a/c+b); auto. - - apply mod_bound_pos; auto. - - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 - (a + b * c) / c == a / c + b. -Proof. - intros a b c ? ? ?. - apply (mul_cancel_l _ _ c); try order. - apply (add_cancel_r _ _ ((a+b*c) mod c)). - rewrite <- div_mod, mod_add by order. - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0 - (a * b + c) / b == a + c / b. -Proof. - intros a b c. rewrite (add_comm _ c), (add_comm a). - intros. apply div_add; auto. -Qed. - -(** Cancellations. *) - -Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0 0 - (a*c)/(b*c) == a/b. -Proof. - intros a b c ? ? ?. - symmetry. - apply div_unique with ((a mod b)*c). - - apply mul_nonneg_nonneg; order. - - split. - + apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. - + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. - - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). -Qed. - -Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0 0 - (c*a)/(c*b) == a/b. -Proof. - intros a b c ? ? ?. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. -Qed. - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, 0<=a -> 0 - (a mod n) mod n == a mod n. -Proof. - intros a n ? ?. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 - ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n Ha Hb Hn. symmetry. - generalize (mul_nonneg_nonneg _ _ Ha Hb). - rewrite (div_mod a n) at 1 2 by order. - rewrite add_comm, (mul_comm n), (mul_comm _ b). - rewrite mul_add_distr_l, mul_assoc. - intros. rewrite mod_add; auto. - - now rewrite mul_comm. - - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 - (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros a b n ? ? ?. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. -Qed. - -Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0 - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros a b n ? ? ?. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. - - reflexivity. - - now destruct (mod_bound_pos b n). -Qed. - -Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 - ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n Ha Hb Hn. symmetry. - generalize (add_nonneg_nonneg _ _ Ha Hb). - rewrite (div_mod a n) at 1 2 by order. - rewrite <- add_assoc, add_comm, mul_comm. - intros. rewrite mod_add; trivial. - reflexivity. - - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. -Qed. - -Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 - (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros a b n ? ? ?. rewrite !(add_comm a). apply add_mod_idemp_l; auto. -Qed. - -Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0 - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros a b n ? ? ?. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. - - reflexivity. - - now destruct (mod_bound_pos b n). -Qed. - -Lemma div_div : forall a b c, 0<=a -> 0 0 - (a/b)/c == a/(b*c). -Proof. - intros a b c Ha Hb Hc. - apply div_unique with (b*((a/b) mod c) + a mod b); trivial. - (* begin 0<= ... 0 0 - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c Ha Hb Hc. - apply add_cancel_l with (b*c*(a/(b*c))). - rewrite <- div_mod by (apply neq_mul_0; split; order). - rewrite <- div_div by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- div_mod by order. - apply div_mod; order. -Qed. - -Lemma add_mul_mod_distr_l: forall a b c d, 0<=a -> 0 0<=d - (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. - intros a b c d ? ? [? ?]. - assert (0 <= a*c) by (apply mul_nonneg_nonneg; order). - assert (0 <= a*c+d) by (apply add_nonneg_nonneg; order). - rewrite (mul_comm c a), mod_mul_r, add_mod, mod_mul, div_add_l; [|order ..]. - now rewrite ? add_0_l, div_small, add_0_r, ? (mod_small d c), (add_comm d). -Qed. - -Lemma add_mul_mod_distr_r: forall a b c d, 0<=a -> 0 0<=d - (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. - intros a b c d ? ? ?. now rewrite !(mul_comm _ c), add_mul_mod_distr_l. -Qed. - -Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0 0 - (c*a) mod (c*b) == c * (a mod b). -Proof. - intros a b c ? ? ?. pose proof (E := add_mul_mod_distr_l a b c 0). - rewrite ? add_0_r in E. now apply E. -Qed. - -Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0 0 - (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros a b c ? ? ?. now rewrite !(mul_comm _ c), mul_mod_distr_l. -Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. -Proof. - intros a b c ? ? ?. - apply div_le_lower_bound; auto. - - apply mul_nonneg_nonneg; auto. - - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. - apply mul_le_mono_nonneg_l; auto. - apply mul_div_le; auto. -Qed. - -(** mod is related to divisibility *) - -Lemma mod_divides : forall a b, 0<=a -> 0 - (a mod b == 0 <-> exists c, a == b*c). -Proof. - intros a b ? ?; split. - - intros. exists (a/b). rewrite div_exact; auto. - - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. - rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. -Qed. + Qed. + + Lemma mul_succ_div_gt : forall a b, 0<=a -> 0 a < b*(S (a/b)). + Proof. + intros a b ? ?. + rewrite (div_mod a b) at 1 by order. + rewrite (mul_succ_r). + rewrite <- add_lt_mono_l. + destruct (mod_bound_pos a b); auto. + Qed. + + + (** The previous inequality is exact iff the modulo is zero. *) + + Lemma div_exact : forall a b, 0<=a -> 0 (a == b*(a/b) <-> a mod b == 0). + Proof. + intros a b ? ?. rewrite (div_mod a b) at 1 by order. + rewrite <- (add_0_r (b*(a/b))) at 2. + apply add_cancel_l. + Qed. + + (** Some additional inequalities about div. *) + + Theorem div_lt_upper_bound: + forall a b q, 0<=a -> 0 a < b*q -> a/b < q. + Proof. + intros a b q ? ? ?. + rewrite (mul_lt_mono_pos_l b) by order. + apply le_lt_trans with a; auto. + apply mul_div_le; auto. + Qed. + + Theorem div_le_upper_bound: + forall a b q, 0<=a -> 0 a <= b*q -> a/b <= q. + Proof. + intros a b q ? ? ?. + rewrite (mul_le_mono_pos_l _ _ b) by order. + apply le_trans with a; auto. + apply mul_div_le; auto. + Qed. + + Theorem div_le_lower_bound: + forall a b q, 0<=a -> 0 b*q <= a -> q <= a/b. + Proof. + intros a b q Ha Hb H. + destruct (lt_ge_cases 0 q). + - rewrite <- (div_mul q b); try order. + apply div_le_mono; auto. + rewrite mul_comm; split; auto. + apply lt_le_incl, mul_pos_pos; auto. + - apply le_trans with 0; auto; apply div_pos; auto. + Qed. + + (** A division respects opposite monotonicity for the divisor *) + + Lemma div_le_compat_l: forall p q r, 0<=p -> 0 + p/r <= p/q. + Proof. + intros p q r Hp (Hq,Hqr). + apply div_le_lower_bound; auto. + rewrite (div_mod p r) at 2 by order. + apply le_trans with (r*(p/r)). + - apply mul_le_mono_nonneg_r; try order. + apply div_pos; order. + - rewrite <- (add_0_r (r*(p/r))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. + Qed. + + + (** * Relations between usual operations and mod and div *) + + Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 + (a + b * c) mod c == a mod c. + Proof. + intros a b c ? ? ?. + symmetry. + apply mod_unique with (a/c+b); auto. + - apply mod_bound_pos; auto. + - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. + Qed. + + Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 + (a + b * c) / c == a / c + b. + Proof. + intros a b c ? ? ?. + apply (mul_cancel_l _ _ c); try order. + apply (add_cancel_r _ _ ((a+b*c) mod c)). + rewrite <- div_mod, mod_add by order. + rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. + Qed. + + Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0 + (a * b + c) / b == a + c / b. + Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + intros. apply div_add; auto. + Qed. + + (** Cancellations. *) + + Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0 0 + (a*c)/(b*c) == a/b. + Proof. + intros a b c ? ? ?. + symmetry. + apply div_unique with ((a mod b)*c). + - apply mul_nonneg_nonneg; order. + - split. + + apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. + + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. + - rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). + Qed. + + Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0 0 + (c*a)/(c*b) == a/b. + Proof. + intros a b c ? ? ?. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. + Qed. + + (** Operations modulo. *) + + Theorem mod_mod: forall a n, 0<=a -> 0 + (a mod n) mod n == a mod n. + Proof. + intros a n ? ?. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff. + Qed. + + Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 + ((a mod n)*b) mod n == (a*b) mod n. + Proof. + intros a b n Ha Hb Hn. symmetry. + generalize (mul_nonneg_nonneg _ _ Ha Hb). + rewrite (div_mod a n) at 1 2 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + intros. rewrite mod_add; auto. + - now rewrite mul_comm. + - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. + Qed. + + Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 + (a*(b mod n)) mod n == (a*b) mod n. + Proof. + intros a b n ? ? ?. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. + Qed. + + Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0 + (a * b) mod n == ((a mod n) * (b mod n)) mod n. + Proof. + intros a b n ? ? ?. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. + - reflexivity. + - now destruct (mod_bound_pos b n). + Qed. + + Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 + ((a mod n)+b) mod n == (a+b) mod n. + Proof. + intros a b n Ha Hb Hn. symmetry. + generalize (add_nonneg_nonneg _ _ Ha Hb). + rewrite (div_mod a n) at 1 2 by order. + rewrite <- add_assoc, add_comm, mul_comm. + intros. rewrite mod_add; trivial. - reflexivity. + - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. + Qed. + + Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 + (a+(b mod n)) mod n == (a+b) mod n. + Proof. + intros a b n ? ? ?. rewrite !(add_comm a). apply add_mod_idemp_l; auto. + Qed. + + Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0 + (a+b) mod n == (a mod n + b mod n) mod n. + Proof. + intros a b n ? ? ?. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. + - reflexivity. + - now destruct (mod_bound_pos b n). + Qed. + + Lemma div_div : forall a b c, 0<=a -> 0 0 + (a/b)/c == a/(b*c). + Proof. + intros a b c Ha Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b); trivial. + (* begin 0<= ... 0 0 + a mod (b*c) == a mod b + b*((a/b) mod c). + Proof. + intros a b c Ha Hb Hc. + apply add_cancel_l with (b*c*(a/(b*c))). + rewrite <- div_mod by (apply neq_mul_0; split; order). + rewrite <- div_div by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- div_mod by order. + apply div_mod; order. + Qed. + + Lemma add_mul_mod_distr_l: forall a b c d, 0<=a -> 0 0<=d + (c*a+d) mod (c*b) == c*(a mod b)+d. + Proof. + intros a b c d ? ? [? ?]. + assert (0 <= a*c) by (apply mul_nonneg_nonneg; order). + assert (0 <= a*c+d) by (apply add_nonneg_nonneg; order). + rewrite (mul_comm c a), mod_mul_r, add_mod, mod_mul, div_add_l; [|order ..]. + now rewrite ? add_0_l, div_small, add_0_r, ? (mod_small d c), (add_comm d). + Qed. + + Lemma add_mul_mod_distr_r: forall a b c d, 0<=a -> 0 0<=d + (a*c+d) mod (b*c) == (a mod b)*c+d. + Proof. + intros a b c d ? ? ?. now rewrite !(mul_comm _ c), add_mul_mod_distr_l. + Qed. + + Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0 0 + (c*a) mod (c*b) == c * (a mod b). + Proof. + intros a b c ? ? ?. pose proof (E := add_mul_mod_distr_l a b c 0). + rewrite ? add_0_r in E. now apply E. + Qed. + + Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0 0 + (a*c) mod (b*c) == (a mod b) * c. + Proof. + intros a b c ? ? ?. now rewrite !(mul_comm _ c), mul_mod_distr_l. + Qed. + + (** A last inequality: *) + + Theorem div_mul_le: + forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. + Proof. + intros a b c ? ? ?. + apply div_le_lower_bound; auto. + - apply mul_nonneg_nonneg; auto. + - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. + apply mul_le_mono_nonneg_l; auto. + apply mul_div_le; auto. + Qed. + + (** mod is related to divisibility *) + + Lemma mod_divides : forall a b, 0<=a -> 0 + (a mod b == 0 <-> exists c, a == b*c). + Proof. + intros a b ? ?; split. + - intros. exists (a/b). rewrite div_exact; auto. + - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. + rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. + Qed. End NZDivProp. diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index b7bb9061b6..c52cf5d7fb 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -24,152 +24,152 @@ From Stdlib Require Import NZBase NZOrder NZAddOrder PeanoNat. Instance nat_rect_wd n {A} (R:relation A) : Proper (R==>(R==>R)==>R) (fun x f => nat_rect (fun _ => _) x (fun _ => f) n). Proof. -intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg]. + intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg]. Qed. Module NZDomainProp (Import NZ:NZDomainSig'). -Include NZBaseProp NZ. - -(** * Relationship between points thanks to [succ] and [pred]. *) - -(** For any two points, one is an iterated successor of the other. *) - -Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. -Proof. -revert n. -apply central_induction with (z:=m). - { intros x y eq_xy; apply ex_iff_morphism. - intros n; apply or_iff_morphism. - + split; intros; etransitivity; try eassumption; now symmetry. - + split; intros; (etransitivity; [eassumption|]); [|symmetry]; - (eapply nat_rect_wd; [eassumption|apply succ_wd]). - } -- exists 0%nat. now left. -- intros n. split; intros [k [L|R]]. - + exists (Datatypes.S k). left. now apply succ_wd. - + destruct k as [|k]. - * simpl in R. exists 1%nat. left. now apply succ_wd. - * rewrite nat_rect_succ_r in R. exists k. now right. - + destruct k as [|k]; simpl in L. - * exists 1%nat. now right. - * apply succ_inj in L. exists k. now left. - + exists (Datatypes.S k). right. now rewrite nat_rect_succ_r. -Qed. - -(** Generalized version of [pred_succ] when iterating *) - -Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n. -Proof. -induction k. -- simpl; auto with *. -- simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto. - rewrite <- nat_rect_succ_r in H; auto. -Qed. - -(** From a given point, all others are iterated successors + Include NZBaseProp NZ. + + (** * Relationship between points thanks to [succ] and [pred]. *) + + (** For any two points, one is an iterated successor of the other. *) + + Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. + Proof. + revert n. + apply central_induction with (z:=m). + { intros x y eq_xy; apply ex_iff_morphism. + intros n; apply or_iff_morphism. + + split; intros; etransitivity; try eassumption; now symmetry. + + split; intros; (etransitivity; [eassumption|]); [|symmetry]; + (eapply nat_rect_wd; [eassumption|apply succ_wd]). + } + - exists 0%nat. now left. + - intros n. split; intros [k [L|R]]. + + exists (Datatypes.S k). left. now apply succ_wd. + + destruct k as [|k]. + * simpl in R. exists 1%nat. left. now apply succ_wd. + * rewrite nat_rect_succ_r in R. exists k. now right. + + destruct k as [|k]; simpl in L. + * exists 1%nat. now right. + * apply succ_inj in L. exists k. now left. + + exists (Datatypes.S k). right. now rewrite nat_rect_succ_r. + Qed. + + (** Generalized version of [pred_succ] when iterating *) + + Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n. + Proof. + induction k. + - simpl; auto with *. + - simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto. + rewrite <- nat_rect_succ_r in H; auto. + Qed. + + (** From a given point, all others are iterated successors or iterated predecessors. *) -Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m. -Proof. -intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]). -- exists k; left; auto. -- exists k; right. apply succ_swap_pred; auto. -Qed. + Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m. + Proof. + intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]). + - exists k; left; auto. + - exists k; right. apply succ_swap_pred; auto. + Qed. -(** In particular, all points are either iterated successors of [0] + (** In particular, all points are either iterated successors of [0] or iterated predecessors of [0] (or both). *) -Lemma itersucc0_or_iterpred0 : - forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0. -Proof. - intros n. exact (itersucc_or_iterpred n 0). -Qed. + Lemma itersucc0_or_iterpred0 : + forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0. + Proof. + intros n. exact (itersucc_or_iterpred n 0). + Qed. -(** * Study of initial point w.r.t. [succ] (if any). *) + (** * Study of initial point w.r.t. [succ] (if any). *) -Definition initial n := forall m, n ~= S m. + Definition initial n := forall m, n ~= S m. -Lemma initial_alt : forall n, initial n <-> S (P n) ~= n. -Proof. - split. - - intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ). - - intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *. -Qed. + Lemma initial_alt : forall n, initial n <-> S (P n) ~= n. + Proof. + split. + - intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ). + - intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *. + Qed. -Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m. -Proof. firstorder. Qed. + Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m. + Proof. firstorder. Qed. -(** First case: let's assume such an initial point exists + (** First case: let's assume such an initial point exists (i.e. [S] isn't surjective)... *) -Section InitialExists. -Hypothesis init : t. -Hypothesis Initial : initial init. - -(** ... then we have unicity of this initial point. *) - -Lemma initial_unique : forall m, initial m -> m == init. -Proof. -intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]). -- destruct p. - + now simpl in *. - + destruct (Initial _ H). -- destruct p. - + now simpl in *. - + destruct (Im _ H). -Qed. - -(** ... then all other points are descendant of it. *) - -Lemma initial_ancestor : forall m, exists p, m == (S^p) init. -Proof. -intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]). -- destruct p; simpl in *; auto. - + exists O; auto with *. - + destruct (Initial _ H). -- exists p; auto. -Qed. - -(** NB : We would like to have [pred n == n] for the initial element, + Section InitialExists. + Hypothesis init : t. + Hypothesis Initial : initial init. + + (** ... then we have unicity of this initial point. *) + + Lemma initial_unique : forall m, initial m -> m == init. + Proof. + intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]). + - destruct p. + + now simpl in *. + + destruct (Initial _ H). + - destruct p. + + now simpl in *. + + destruct (Im _ H). + Qed. + + (** ... then all other points are descendant of it. *) + + Lemma initial_ancestor : forall m, exists p, m == (S^p) init. + Proof. + intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]). + - destruct p; simpl in *; auto. + + exists O; auto with *. + + destruct (Initial _ H). + - exists p; auto. + Qed. + + (** NB : We would like to have [pred n == n] for the initial element, but nothing forces that. For instance we can have -3 as initial point, and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig]. We can hence have [n == (P^k) m] without [exists k', m == (S^k') n]. *) -(** We need decidability of [eq] (or classical reasoning) for this: *) + (** We need decidability of [eq] (or classical reasoning) for this: *) -Section SuccPred. -Hypothesis eq_decidable : forall n m, n==m \/ n~=m. -Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n. -Proof. -intros n NB. rewrite initial_alt in NB. -destruct (eq_decidable (S (P n)) n); auto. -elim NB; auto. -Qed. -End SuccPred. -End InitialExists. + Section SuccPred. + Hypothesis eq_decidable : forall n m, n==m \/ n~=m. + Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n. + Proof. + intros n NB. rewrite initial_alt in NB. + destruct (eq_decidable (S (P n)) n); auto. + elim NB; auto. + Qed. + End SuccPred. + End InitialExists. -(** Second case : let's suppose now [S] surjective, i.e. no initial point. *) + (** Second case : let's suppose now [S] surjective, i.e. no initial point. *) -Section InitialDontExists. + Section InitialDontExists. -Hypothesis succ_onto : forall n, exists m, n == S m. + Hypothesis succ_onto : forall n, exists m, n == S m. -Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n. -Proof. -intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *. -Qed. + Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n. + Proof. + intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *. + Qed. -Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m. -Proof. -intros n m. intros H; apply succ_wd in H. -rewrite !succ_onto_gives_succ_pred in H; auto. -Qed. + Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m. + Proof. + intros n m. intros H; apply succ_wd in H. + rewrite !succ_onto_gives_succ_pred in H; auto. + Qed. -End InitialDontExists. + End InitialDontExists. -(** To summarize: + (** To summarize: S is always injective, P is always surjective (thanks to [pred_succ]). @@ -186,9 +186,9 @@ End InitialDontExists. *) -(** * An alternative induction principle using [S] and [P]. *) + (** * An alternative induction principle using [S] and [P]. *) -(** It is weaker than [bi_induction]. For instance it cannot prove that + (** It is weaker than [bi_induction]. For instance it cannot prove that we can go from one point by many [S] _or_ many [P], but only by many [S] mixed with many [P]. Think of a model with two copies of N: @@ -198,28 +198,28 @@ End InitialDontExists. and P 0 = 0' and P 0' = 0. *) -Lemma bi_induction_pred : - forall A : t -> Prop, Proper (eq==>iff) A -> - A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> - forall n, A n. -Proof. -intros. apply bi_induction; auto. -clear n. intros n; split; auto. -intros G; apply H2 in G. rewrite pred_succ in G; auto. -Qed. - -Lemma central_induction_pred : - forall A : t -> Prop, Proper (eq==>iff) A -> forall n0, - A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> - forall n, A n. -Proof. -intros. -assert (A 0). -- destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk. - + clear H2. induction k; simpl in *; auto. - + clear H1. induction k; simpl in *; auto. -- apply bi_induction_pred; auto. -Qed. + Lemma bi_induction_pred : + forall A : t -> Prop, Proper (eq==>iff) A -> + A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> + forall n, A n. + Proof. + intros. apply bi_induction; auto. + clear n. intros n; split; auto. + intros G; apply H2 in G. rewrite pred_succ in G; auto. + Qed. + + Lemma central_induction_pred : + forall A : t -> Prop, Proper (eq==>iff) A -> forall n0, + A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> + forall n, A n. + Proof. + intros. + assert (A 0). + - destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk. + + clear H2. induction k; simpl in *; auto. + + clear H1. induction k; simpl in *; auto. + - apply bi_induction_pred; auto. + Qed. End NZDomainProp. @@ -229,30 +229,30 @@ End NZDomainProp. Module NZOfNat (Import NZ:NZDomainSig'). -Definition ofnat (n : nat) : t := (S^n) 0. + Definition ofnat (n : nat) : t := (S^n) 0. -Declare Scope ofnat. -#[local] Open Scope ofnat. -Notation "[ n ]" := (ofnat n) (at level 0) : ofnat. + Declare Scope ofnat. + #[local] Open Scope ofnat. + Notation "[ n ]" := (ofnat n) (at level 0) : ofnat. -Lemma ofnat_zero : [O] == 0. -Proof. -reflexivity. -Qed. + Lemma ofnat_zero : [O] == 0. + Proof. + reflexivity. + Qed. -Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n]. -Proof. - now unfold ofnat. -Qed. + Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n]. + Proof. + now unfold ofnat. + Qed. -Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n]. -Proof. - unfold ofnat. destruct n. - - destruct 1; auto. - - intros _. simpl. symmetry. apply pred_succ. -Qed. + Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n]. + Proof. + unfold ofnat. destruct n. + - destruct 1; auto. + - intros _. simpl. symmetry. apply pred_succ. + Qed. -(** Since [P 0] can be anything in NZ (either [-1], [0], or even other + (** Since [P 0] can be anything in NZ (either [-1], [0], or even other numbers, we cannot state previous lemma for [n=O]. *) End NZOfNat. @@ -263,65 +263,65 @@ End NZOfNat. (i.e. we ban Z/nZ models) *) Module NZOfNatOrd (Import NZ:NZOrdSig'). -Include NZOfNat NZ. -Include NZBaseProp NZ <+ NZOrderProp NZ. -#[local] Open Scope ofnat. - -Theorem ofnat_S_gt_0 : - forall n : nat, 0 < [Datatypes.S n]. -Proof. -unfold ofnat. -intros n; induction n as [| n IH]; simpl in *. -- apply lt_succ_diag_r. -- apply lt_trans with (S 0). - + apply lt_succ_diag_r. - + now rewrite <- succ_lt_mono. -Qed. - -Theorem ofnat_S_neq_0 : - forall n : nat, 0 ~= [Datatypes.S n]. -Proof. -intros. apply lt_neq, ofnat_S_gt_0. -Qed. - -Lemma ofnat_injective : forall n m, [n]==[m] -> n = m. -Proof. -induction n as [|n IH]; destruct m; auto. -- intros H; elim (ofnat_S_neq_0 _ H). -- intros H; symmetry in H; elim (ofnat_S_neq_0 _ H). -- intros. f_equal. apply IH. now rewrite <- succ_inj_wd. -Qed. - -Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m. -Proof. - split. - - apply ofnat_injective. - - intros; now subst. -Qed. - -(* In addition, we can prove that [ofnat] preserves order. *) - -Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n (n<=m)%nat. -Proof. -intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq. -split. -- destruct 1; subst; auto. - apply Nat.lt_le_incl; assumption. -- apply Nat.lt_eq_cases. -Qed. + Include NZOfNat NZ. + Include NZBaseProp NZ <+ NZOrderProp NZ. + #[local] Open Scope ofnat. + + Theorem ofnat_S_gt_0 : + forall n : nat, 0 < [Datatypes.S n]. + Proof. + unfold ofnat. + intros n; induction n as [| n IH]; simpl in *. + - apply lt_succ_diag_r. + - apply lt_trans with (S 0). + + apply lt_succ_diag_r. + + now rewrite <- succ_lt_mono. + Qed. + + Theorem ofnat_S_neq_0 : + forall n : nat, 0 ~= [Datatypes.S n]. + Proof. + intros. apply lt_neq, ofnat_S_gt_0. + Qed. + + Lemma ofnat_injective : forall n m, [n]==[m] -> n = m. + Proof. + induction n as [|n IH]; destruct m; auto. + - intros H; elim (ofnat_S_neq_0 _ H). + - intros H; symmetry in H; elim (ofnat_S_neq_0 _ H). + - intros. f_equal. apply IH. now rewrite <- succ_inj_wd. + Qed. + + Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m. + Proof. + split. + - apply ofnat_injective. + - intros; now subst. + Qed. + + (* In addition, we can prove that [ofnat] preserves order. *) + + Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n (n<=m)%nat. + Proof. + intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq. + split. + - destruct 1; subst; auto. + apply Nat.lt_le_incl; assumption. + - apply Nat.lt_eq_cases. + Qed. End NZOfNatOrd. @@ -330,54 +330,54 @@ End NZOfNatOrd. their counterpart in [nat]. *) Module NZOfNatOps (Import NZ:NZAxiomsSig'). -Include NZOfNat NZ. -#[local] Open Scope ofnat. - -Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m. -Proof. - induction n; intros. - - apply add_0_l. - - rewrite ofnat_succ, add_succ_l. simpl. now f_equiv. -Qed. - -Lemma ofnat_add : forall n m, [n+m] == [n]+[m]. -Proof. - intros. rewrite ofnat_add_l. - induction n; simpl. - - reflexivity. - - now f_equiv. -Qed. - -Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. -Proof. - induction n; simpl; intros. - - symmetry. apply mul_0_l. - - rewrite Nat.add_comm. - rewrite ofnat_add, mul_succ_l. - now f_equiv. -Qed. - -Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n. -Proof. - induction m; simpl; intros. - - apply sub_0_r. - - rewrite sub_succ_r. now f_equiv. -Qed. - -Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. -Proof. - intros n m H. rewrite ofnat_sub_r. - revert n H. induction m. - - intros. - rewrite Nat.sub_0_r. now simpl. - - intros. - destruct n. - + inversion H. - + rewrite nat_rect_succ_r. - simpl. - etransitivity. - * apply IHm; apply <- Nat.succ_le_mono; assumption. - * eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd]. -Qed. + Include NZOfNat NZ. + #[local] Open Scope ofnat. + + Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m. + Proof. + induction n; intros. + - apply add_0_l. + - rewrite ofnat_succ, add_succ_l. simpl. now f_equiv. + Qed. + + Lemma ofnat_add : forall n m, [n+m] == [n]+[m]. + Proof. + intros. rewrite ofnat_add_l. + induction n; simpl. + - reflexivity. + - now f_equiv. + Qed. + + Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. + Proof. + induction n; simpl; intros. + - symmetry. apply mul_0_l. + - rewrite Nat.add_comm. + rewrite ofnat_add, mul_succ_l. + now f_equiv. + Qed. + + Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n. + Proof. + induction m; simpl; intros. + - apply sub_0_r. + - rewrite sub_succ_r. now f_equiv. + Qed. + + Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. + Proof. + intros n m H. rewrite ofnat_sub_r. + revert n H. induction m. + - intros. + rewrite Nat.sub_0_r. now simpl. + - intros. + destruct n. + + inversion H. + + rewrite nat_rect_succ_r. + simpl. + etransitivity. + * apply IHm; apply <- Nat.succ_le_mono; assumption. + * eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd]. + Qed. End NZOfNatOps. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v index b8746cdd68..1f97c554eb 100644 --- a/theories/Numbers/NatInt/NZGcd.v +++ b/theories/Numbers/NatInt/NZGcd.v @@ -15,22 +15,22 @@ From Stdlib Require Import NZAxioms NZMulOrder. (** Interface of a gcd function, then its specification on naturals *) Module Type Gcd (Import A : Typ). - Parameter Inline gcd : t -> t -> t. + Parameter Inline gcd : t -> t -> t. End Gcd. Module Type NZGcdSpec (A : NZOrdAxiomsSig')(B : Gcd A). - Import A B. - Definition divide n m := exists p, m == p*n. - #[local] Notation "( n | m )" := (divide n m) (at level 0). - Axiom gcd_divide_l : forall n m, (gcd n m | n). - Axiom gcd_divide_r : forall n m, (gcd n m | m). - Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m). - Axiom gcd_nonneg : forall n m, 0 <= gcd n m. + Import A B. + Definition divide n m := exists p, m == p*n. + #[local] Notation "( n | m )" := (divide n m) (at level 0). + Axiom gcd_divide_l : forall n m, (gcd n m | n). + Axiom gcd_divide_r : forall n m, (gcd n m | m). + Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m). + Axiom gcd_nonneg : forall n m, 0 <= gcd n m. End NZGcdSpec. Module Type DivideNotation (A:NZOrdAxiomsSig')(B:Gcd A)(C:NZGcdSpec A B). - Import A B C. - Notation "( n | m )" := (divide n m) (at level 0). + Import A B C. + Notation "( n | m )" := (divide n m) (at level 0). End DivideNotation. Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A. @@ -40,274 +40,274 @@ Module Type NZGcd' (A : NZOrdAxiomsSig) := (** Derived properties of gcd *) Module NZGcdProp - (Import A : NZOrdAxiomsSig') - (Import B : NZGcd' A) - (Import C : NZMulOrderProp A). - -(** Results concerning divisibility*) - -#[global] -Instance divide_wd : Proper (eq==>eq==>iff) divide. -Proof. - unfold divide. intros x x' Hx y y' Hy. - setoid_rewrite Hx. setoid_rewrite Hy. easy. -Qed. - -Lemma divide_1_l : forall n, (1 | n). -Proof. - intros n. exists n. now nzsimpl. -Qed. - -Lemma divide_0_r : forall n, (n | 0). -Proof. - intros n. exists 0. now nzsimpl. -Qed. - -Lemma divide_0_l : forall n, (0 | n) -> n==0. -Proof. - intros n (m,Hm). revert Hm. now nzsimpl. -Qed. - -Lemma eq_mul_1_nonneg : forall n m, - 0<=n -> n*m == 1 -> n==1 /\ m==1. -Proof. - intros n m Hn H. - le_elim Hn. - - destruct (lt_ge_cases m 0) as [Hm|Hm]. - + generalize (mul_pos_neg n m Hn Hm). order'. - + le_elim Hm. - * apply le_succ_l in Hn. rewrite <- one_succ in Hn. - le_elim Hn. - -- generalize (lt_1_mul_pos n m Hn Hm). order. - -- rewrite <- Hn, mul_1_l in H. now split. - * rewrite <- Hm, mul_0_r in H. order'. - - rewrite <- Hn, mul_0_l in H. order'. -Qed. - -Lemma eq_mul_1_nonneg' : forall n m, - 0<=m -> n*m == 1 -> n==1 /\ m==1. -Proof. - intros n m Hm H. rewrite mul_comm in H. - now apply and_comm, eq_mul_1_nonneg. -Qed. - -Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1. -Proof. - intros n Hn (m,Hm). symmetry in Hm. - now apply (eq_mul_1_nonneg' m n). -Qed. - -Lemma divide_refl : forall n, (n | n). -Proof. - intros n. exists 1. now nzsimpl. -Qed. - -Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p). -Proof. - intros n m p (q,Hq) (r,Hr). exists (r*q). - now rewrite Hr, Hq, mul_assoc. -Qed. - -#[global] -Instance divide_reflexive : Reflexive divide | 5 := divide_refl. -#[global] -Instance divide_transitive : Transitive divide | 5 := divide_trans. - -(** Due to sign, no general antisymmetry result *) - -Lemma divide_antisym_nonneg : forall n m, - 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m. -Proof. - intros n m Hn Hm (q,Hq) (r,Hr). - le_elim Hn. - - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - + generalize (mul_neg_pos q n Hq' Hn). order. - + rewrite Hq, mul_assoc in Hr. symmetry in Hr. - apply mul_id_l in Hr; [|order]. - destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. - now rewrite H, mul_1_l in Hq. - - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. -Qed. - -Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m). -Proof. - intros n m p (q,Hq). exists q. now rewrite mul_shuffle3, Hq. -Qed. - -Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p). -Proof. - intros n m p (q,Hq). exists q. now rewrite mul_assoc, Hq. -Qed. - -Lemma mul_divide_cancel_l : forall n m p, p ~= 0 -> - ((p * n | p * m) <-> (n | m)). -Proof. - intros n m p Hp. split. - - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. - - apply mul_divide_mono_l. -Qed. - -Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> - ((n * p | m * p) <-> (n | m)). -Proof. - intros n m p ?. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l. -Qed. - -Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p). -Proof. - intros n m p (q,Hq) (r,Hr). exists (q+r). - now rewrite mul_add_distr_r, Hq, Hr. -Qed. - -Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p). -Proof. - intros n m p (q,Hq). exists (q*p). now rewrite mul_shuffle0, Hq. -Qed. - -Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p). -Proof. - intros n m p. rewrite mul_comm. apply divide_mul_l. -Qed. - -Lemma divide_factor_l : forall n m, (n | n * m). -Proof. - intros. apply divide_mul_l, divide_refl. -Qed. - -Lemma divide_factor_r : forall n m, (n | m * n). -Proof. - intros. apply divide_mul_r, divide_refl. -Qed. - -Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m. -Proof. - intros n m Hm (q,Hq). - destruct (le_gt_cases n 0) as [Hn|Hn]. - order. - - rewrite Hq. - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - + generalize (mul_neg_pos q n Hq' Hn). order. - + le_elim Hq'. - * rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. - now rewrite one_succ, le_succ_l. - * rewrite <- Hq', mul_0_l in Hq. order. -Qed. - -(** Basic properties of gcd *) - -Lemma gcd_unique : forall n m p, - 0<=p -> (p|n) -> (p|m) -> - (forall q, (q|n) -> (q|m) -> (q|p)) -> - gcd n m == p. -Proof. - intros n m p Hp Hn Hm H. - apply divide_antisym_nonneg; trivial. - apply gcd_nonneg. - - apply H. + apply gcd_divide_l. + apply gcd_divide_r. - - now apply gcd_greatest. -Qed. - -#[global] -Instance gcd_wd : Proper (eq==>eq==>eq) gcd. -Proof. - intros x x' Hx y y' Hy. - apply gcd_unique. - - apply gcd_nonneg. - - rewrite Hx. apply gcd_divide_l. - - rewrite Hy. apply gcd_divide_r. - - intro. rewrite Hx, Hy. apply gcd_greatest. -Qed. - -Lemma gcd_divide_iff : forall n m p, - (p | gcd n m) <-> (p | n) /\ (p | m). -Proof. - intros n m p. split. - split. - + transitivity (gcd n m); trivial using gcd_divide_l. - + transitivity (gcd n m); trivial using gcd_divide_r. - - intros (H,H'). now apply gcd_greatest. -Qed. - -Lemma gcd_unique_alt : forall n m p, 0<=p -> - (forall q, (q|p) <-> (q|n) /\ (q|m)) -> - gcd n m == p. -Proof. - intros n m p Hp H. - apply gcd_unique; trivial. - - apply H. apply divide_refl. - - apply H. apply divide_refl. - - intros. apply H. now split. -Qed. - -Lemma gcd_comm : forall n m, gcd n m == gcd m n. -Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. - intros. rewrite and_comm. apply gcd_divide_iff. -Qed. - -Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p. -Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. - intros. now rewrite !gcd_divide_iff, and_assoc. -Qed. - -Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n. -Proof. - intros. apply gcd_unique; trivial. - - apply divide_0_r. - - apply divide_refl. -Qed. - -Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n. -Proof. - intros. now rewrite gcd_comm, gcd_0_l_nonneg. -Qed. - -Lemma gcd_1_l : forall n, gcd 1 n == 1. -Proof. - intros. apply gcd_unique; trivial using divide_1_l, le_0_1. -Qed. - -Lemma gcd_1_r : forall n, gcd n 1 == 1. -Proof. - intros. now rewrite gcd_comm, gcd_1_l. -Qed. - -Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n. -Proof. - intros. apply gcd_unique; trivial using divide_refl. -Qed. - -Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0. -Proof. - intros n m H. - generalize (gcd_divide_l n m). rewrite H. apply divide_0_l. -Qed. - -Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0. -Proof. - intros n m ?. apply gcd_eq_0_l with n. now rewrite gcd_comm. -Qed. - -Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. -Proof. - intros n m. split. - - split. - + now apply gcd_eq_0_l with m. - + now apply gcd_eq_0_r with n. - - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. -Qed. - -Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n. -Proof. - intros n m Hn. apply gcd_unique_alt; trivial. - intros q. split. - split; trivial. now apply divide_mul_l. - - now destruct 1. -Qed. - -Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n). -Proof. - intros n m Hn. split. - - intros (q,Hq). rewrite Hq. - rewrite mul_comm. now apply gcd_mul_diag_l. - - intros EQ. rewrite <- EQ. apply gcd_divide_r. -Qed. + (Import A : NZOrdAxiomsSig') + (Import B : NZGcd' A) + (Import C : NZMulOrderProp A). + + (** Results concerning divisibility*) + + #[global] + Instance divide_wd : Proper (eq==>eq==>iff) divide. + Proof. + unfold divide. intros x x' Hx y y' Hy. + setoid_rewrite Hx. setoid_rewrite Hy. easy. + Qed. + + Lemma divide_1_l : forall n, (1 | n). + Proof. + intros n. exists n. now nzsimpl. + Qed. + + Lemma divide_0_r : forall n, (n | 0). + Proof. + intros n. exists 0. now nzsimpl. + Qed. + + Lemma divide_0_l : forall n, (0 | n) -> n==0. + Proof. + intros n (m,Hm). revert Hm. now nzsimpl. + Qed. + + Lemma eq_mul_1_nonneg : forall n m, + 0<=n -> n*m == 1 -> n==1 /\ m==1. + Proof. + intros n m Hn H. + le_elim Hn. + - destruct (lt_ge_cases m 0) as [Hm|Hm]. + + generalize (mul_pos_neg n m Hn Hm). order'. + + le_elim Hm. + * apply le_succ_l in Hn. rewrite <- one_succ in Hn. + le_elim Hn. + -- generalize (lt_1_mul_pos n m Hn Hm). order. + -- rewrite <- Hn, mul_1_l in H. now split. + * rewrite <- Hm, mul_0_r in H. order'. + - rewrite <- Hn, mul_0_l in H. order'. + Qed. + + Lemma eq_mul_1_nonneg' : forall n m, + 0<=m -> n*m == 1 -> n==1 /\ m==1. + Proof. + intros n m Hm H. rewrite mul_comm in H. + now apply and_comm, eq_mul_1_nonneg. + Qed. + + Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1. + Proof. + intros n Hn (m,Hm). symmetry in Hm. + now apply (eq_mul_1_nonneg' m n). + Qed. + + Lemma divide_refl : forall n, (n | n). + Proof. + intros n. exists 1. now nzsimpl. + Qed. + + Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p). + Proof. + intros n m p (q,Hq) (r,Hr). exists (r*q). + now rewrite Hr, Hq, mul_assoc. + Qed. + + #[global] + Instance divide_reflexive : Reflexive divide | 5 := divide_refl. + #[global] + Instance divide_transitive : Transitive divide | 5 := divide_trans. + + (** Due to sign, no general antisymmetry result *) + + Lemma divide_antisym_nonneg : forall n m, + 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m. + Proof. + intros n m Hn Hm (q,Hq) (r,Hr). + le_elim Hn. + - destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + rewrite Hq, mul_assoc in Hr. symmetry in Hr. + apply mul_id_l in Hr; [|order]. + destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. + now rewrite H, mul_1_l in Hq. + - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. + Qed. + + Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m). + Proof. + intros n m p (q,Hq). exists q. now rewrite mul_shuffle3, Hq. + Qed. + + Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p). + Proof. + intros n m p (q,Hq). exists q. now rewrite mul_assoc, Hq. + Qed. + + Lemma mul_divide_cancel_l : forall n m p, p ~= 0 -> + ((p * n | p * m) <-> (n | m)). + Proof. + intros n m p Hp. split. + - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. + - apply mul_divide_mono_l. + Qed. + + Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> + ((n * p | m * p) <-> (n | m)). + Proof. + intros n m p ?. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l. + Qed. + + Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p). + Proof. + intros n m p (q,Hq) (r,Hr). exists (q+r). + now rewrite mul_add_distr_r, Hq, Hr. + Qed. + + Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p). + Proof. + intros n m p (q,Hq). exists (q*p). now rewrite mul_shuffle0, Hq. + Qed. + + Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p). + Proof. + intros n m p. rewrite mul_comm. apply divide_mul_l. + Qed. + + Lemma divide_factor_l : forall n m, (n | n * m). + Proof. + intros. apply divide_mul_l, divide_refl. + Qed. + + Lemma divide_factor_r : forall n m, (n | m * n). + Proof. + intros. apply divide_mul_r, divide_refl. + Qed. + + Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m. + Proof. + intros n m Hm (q,Hq). + destruct (le_gt_cases n 0) as [Hn|Hn]. - order. + - rewrite Hq. + destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + le_elim Hq'. + * rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. + now rewrite one_succ, le_succ_l. + * rewrite <- Hq', mul_0_l in Hq. order. + Qed. + + (** Basic properties of gcd *) + + Lemma gcd_unique : forall n m p, + 0<=p -> (p|n) -> (p|m) -> + (forall q, (q|n) -> (q|m) -> (q|p)) -> + gcd n m == p. + Proof. + intros n m p Hp Hn Hm H. + apply divide_antisym_nonneg; trivial. - apply gcd_nonneg. + - apply H. + apply gcd_divide_l. + apply gcd_divide_r. + - now apply gcd_greatest. + Qed. + + #[global] + Instance gcd_wd : Proper (eq==>eq==>eq) gcd. + Proof. + intros x x' Hx y y' Hy. + apply gcd_unique. + - apply gcd_nonneg. + - rewrite Hx. apply gcd_divide_l. + - rewrite Hy. apply gcd_divide_r. + - intro. rewrite Hx, Hy. apply gcd_greatest. + Qed. + + Lemma gcd_divide_iff : forall n m p, + (p | gcd n m) <-> (p | n) /\ (p | m). + Proof. + intros n m p. split. - split. + + transitivity (gcd n m); trivial using gcd_divide_l. + + transitivity (gcd n m); trivial using gcd_divide_r. + - intros (H,H'). now apply gcd_greatest. + Qed. + + Lemma gcd_unique_alt : forall n m p, 0<=p -> + (forall q, (q|p) <-> (q|n) /\ (q|m)) -> + gcd n m == p. + Proof. + intros n m p Hp H. + apply gcd_unique; trivial. + - apply H. apply divide_refl. + - apply H. apply divide_refl. + - intros. apply H. now split. + Qed. + + Lemma gcd_comm : forall n m, gcd n m == gcd m n. + Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. rewrite and_comm. apply gcd_divide_iff. + Qed. + + Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p. + Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. now rewrite !gcd_divide_iff, and_assoc. + Qed. + + Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n. + Proof. + intros. apply gcd_unique; trivial. + - apply divide_0_r. + - apply divide_refl. + Qed. + + Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n. + Proof. + intros. now rewrite gcd_comm, gcd_0_l_nonneg. + Qed. + + Lemma gcd_1_l : forall n, gcd 1 n == 1. + Proof. + intros. apply gcd_unique; trivial using divide_1_l, le_0_1. + Qed. + + Lemma gcd_1_r : forall n, gcd n 1 == 1. + Proof. + intros. now rewrite gcd_comm, gcd_1_l. + Qed. + + Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n. + Proof. + intros. apply gcd_unique; trivial using divide_refl. + Qed. + + Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0. + Proof. + intros n m H. + generalize (gcd_divide_l n m). rewrite H. apply divide_0_l. + Qed. + + Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0. + Proof. + intros n m ?. apply gcd_eq_0_l with n. now rewrite gcd_comm. + Qed. + + Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. + Proof. + intros n m. split. + - split. + + now apply gcd_eq_0_l with m. + + now apply gcd_eq_0_r with n. + - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. + Qed. + + Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n. + Proof. + intros n m Hn. apply gcd_unique_alt; trivial. + intros q. split. - split; trivial. now apply divide_mul_l. + - now destruct 1. + Qed. + + Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n). + Proof. + intros n m Hn. split. + - intros (q,Hq). rewrite Hq. + rewrite mul_comm. now apply gcd_mul_diag_l. + - intros EQ. rewrite <- EQ. apply gcd_divide_r. + Qed. End NZGcdProp. diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v index b50b8e6161..88cf067614 100644 --- a/theories/Numbers/NatInt/NZLog.v +++ b/theories/Numbers/NatInt/NZLog.v @@ -15,13 +15,13 @@ From Stdlib Require Import NZAxioms NZMulOrder NZPow. (** Interface of a log2 function, then its specification on naturals *) Module Type Log2 (Import A : Typ). - Parameter Inline log2 : t -> t. + Parameter Inline log2 : t -> t. End Log2. Module Type NZLog2Spec (A : NZOrdAxiomsSig')(B : Pow' A)(C : Log2 A). - Import A B C. - Axiom log2_spec : forall a, 0 2^(log2 a) <= a < 2^(S (log2 a)). - Axiom log2_nonpos : forall a, a<=0 -> log2 a == 0. + Import A B C. + Axiom log2_spec : forall a, 0 2^(log2 a) <= a < 2^(S (log2 a)). + Axiom log2_nonpos : forall a, a<=0 -> log2 a == 0. End NZLog2Spec. Module Type NZLog2 (A : NZOrdAxiomsSig)(B : Pow A) := Log2 A <+ NZLog2Spec A B. @@ -29,399 +29,399 @@ Module Type NZLog2 (A : NZOrdAxiomsSig)(B : Pow A) := Log2 A <+ NZLog2Spec A B. (** Derived properties of logarithm *) Module Type NZLog2Prop - (Import A : NZOrdAxiomsSig') - (Import B : NZPow' A) - (Import C : NZLog2 A B) - (Import D : NZMulOrderProp A) - (Import E : NZPowProp A B D). - -(** log2 is always non-negative *) - -Lemma log2_nonneg : forall a, 0 <= log2 a. -Proof. - intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - - now rewrite log2_nonpos. - - destruct (log2_spec a Ha) as (_,LT). - apply lt_succ_r, (pow_gt_1 2). + order'. - + rewrite <- le_succ_l, <- one_succ in Ha. order. -Qed. - -(** A tactic for proving positivity and non-negativity *) - -Ltac order_pos := -((apply add_pos_pos || apply add_nonneg_nonneg || - apply mul_pos_pos || apply mul_nonneg_nonneg || - apply pow_nonneg || apply pow_pos_nonneg || - apply log2_nonneg || apply (le_le_succ_r 0)); - order_pos) (* in case of success of an apply, we recurse *) -|| order'. (* otherwise *) - -(** The spec of log2 indeed determines it *) - -Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b. -Proof. - intros a b Hb (LEb,LTb). - assert (Ha : 0 < a). - - apply lt_le_trans with (2^b); trivial. - apply pow_pos_nonneg; order'. - - assert (Hc := log2_nonneg a). - destruct (log2_spec a Ha) as (LEc,LTc). - assert (log2 a <= b). - + apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - + assert (b <= log2 a). - * apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - * order. -Qed. - -(** Hence log2 is a morphism. *) - -#[global] -Instance log2_wd : Proper (eq==>eq) log2. -Proof. - intros x x' Hx. - destruct (le_gt_cases x 0). - - rewrite 2 log2_nonpos; trivial. + reflexivity. + now rewrite <- Hx. - - apply log2_unique. + apply log2_nonneg. - + rewrite Hx in *. now apply log2_spec. -Qed. - -(** An alternate specification *) - -Lemma log2_spec_alt : forall a, 0 exists r, - a == 2^(log2 a) + r /\ 0 <= r < 2^(log2 a). -Proof. - intros a Ha. - destruct (log2_spec _ Ha) as (LE,LT). - destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). - exists r. - split. - now rewrite add_comm. - - split. + trivial. - + apply (add_lt_mono_r _ _ (2^log2 a)). - rewrite <- Hr. generalize LT. - rewrite pow_succ_r by order_pos. - rewrite two_succ at 1. now nzsimpl. -Qed. - -Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b -> - a == 2^b + c -> log2 a == b. -Proof. - intros a b c Hb (Hc,H) EQ. - apply log2_unique. - trivial. - - rewrite EQ. - split. - + rewrite <- add_0_r at 1. now apply add_le_mono_l. - + rewrite pow_succ_r by order. - rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. -Qed. - -(** log2 is exact on powers of 2 *) - -Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a. -Proof. - intros a Ha. - apply log2_unique' with 0; trivial. - - split; order_pos. - now nzsimpl. -Qed. - -(** log2 and predecessors of powers of 2 *) - -Lemma log2_pred_pow2 : forall a, 0 log2 (P (2^a)) == P a. -Proof. - intros a Ha. - assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0). - apply log2_unique. - - apply lt_succ_r; order. - - rewrite <-le_succ_l, <-lt_succ_r, Ha'. - rewrite lt_succ_pred with 0. - + split; try easy. apply pow_lt_mono_r_iff; try order'. - rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. - + apply pow_pos_nonneg; order'. -Qed. - -(** log2 and basic constants *) - -Lemma log2_1 : log2 1 == 0. -Proof. - rewrite <- (pow_0_r 2). now apply log2_pow2. -Qed. - -Lemma log2_2 : log2 2 == 1. -Proof. - rewrite <- (pow_1_r 2). apply log2_pow2; order'. -Qed. - -(** log2 n is strictly positive for 1 0 < log2 a. -Proof. - intros a Ha. - assert (Ha' : 0 < a) by order'. - assert (H := log2_nonneg a). le_elim H; trivial. - generalize (log2_spec a Ha'). rewrite <- H in *. nzsimpl; try order. - intros (_,H'). rewrite two_succ in H'. apply lt_succ_r in H'; order. -Qed. - -(** Said otherwise, log2 is null only below 1 *) - -Lemma log2_null : forall a, log2 a == 0 <-> a <= 1. -Proof. - intros a. split; intros H. - - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_pos a Ha); order. - - le_elim H. - + apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. - + rewrite H. apply log2_1. -Qed. - -(** log2 is a monotone function (but not a strict one) *) - -Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b. -Proof. - intros a b H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite log2_nonpos; order_pos. - - assert (Hb : 0 < b) by order. - destruct (log2_spec a Ha) as (LEa,_). - destruct (log2_spec b Hb) as (_,LTb). - apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. -Qed. - -(** No reverse result for <=, consider for instance log2 3 <= log2 2 *) - -Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b. -Proof. - intros a b H. - destruct (le_gt_cases b 0) as [Hb|Hb]. - - rewrite (log2_nonpos b) in H; trivial. - generalize (log2_nonneg a); order. - - destruct (le_gt_cases a 0) as [Ha|Ha]. + order. - + destruct (log2_spec a Ha) as (_,LTa). - destruct (log2_spec b Hb) as (LEb,_). - apply le_succ_l in H. - apply (pow_le_mono_r_iff 2) in H; order_pos. -Qed. - -(** When left side is a power of 2, we have an equivalence for <= *) - -Lemma log2_le_pow2 : forall a b, 0 (2^b<=a <-> b <= log2 a). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + generalize (log2_nonneg a); order. - + rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. - - transitivity (2^(log2 a)). - + apply pow_le_mono_r; order'. - + now destruct (log2_spec a Ha). -Qed. - -(** When right side is a square, we have an equivalence for < *) - -Lemma log2_lt_pow2 : forall a b, 0 (a<2^b <-> log2 a < b). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + rewrite pow_neg_r in H; order. - + apply (pow_lt_mono_r_iff 2); try order_pos. - apply le_lt_trans with a; trivial. - now destruct (log2_spec a Ha). - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + generalize (log2_nonneg a); order. - + apply log2_lt_cancel; try order. - now rewrite log2_pow2. -Qed. - -(** Comparing log2 and identity *) - -Lemma log2_lt_lin : forall a, 0 log2 a < a. -Proof. - intros a Ha. - apply (pow_lt_mono_r_iff 2); try order_pos. - apply le_lt_trans with a. - - now destruct (log2_spec a Ha). - - apply pow_gt_lin_r; order'. -Qed. - -Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a. -Proof. - intros a Ha. - le_elim Ha. - - now apply lt_le_incl, log2_lt_lin. - - rewrite <- Ha, log2_nonpos; order. -Qed. - -(** Log2 and multiplication. *) - -(** Due to rounding error, we don't have the usual + (Import A : NZOrdAxiomsSig') + (Import B : NZPow' A) + (Import C : NZLog2 A B) + (Import D : NZMulOrderProp A) + (Import E : NZPowProp A B D). + + (** log2 is always non-negative *) + + Lemma log2_nonneg : forall a, 0 <= log2 a. + Proof. + intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. + - now rewrite log2_nonpos. + - destruct (log2_spec a Ha) as (_,LT). + apply lt_succ_r, (pow_gt_1 2). + order'. + + rewrite <- le_succ_l, <- one_succ in Ha. order. + Qed. + + (** A tactic for proving positivity and non-negativity *) + + Ltac order_pos := + ((apply add_pos_pos || apply add_nonneg_nonneg || + apply mul_pos_pos || apply mul_nonneg_nonneg || + apply pow_nonneg || apply pow_pos_nonneg || + apply log2_nonneg || apply (le_le_succ_r 0)); + order_pos) (* in case of success of an apply, we recurse *) + || order'. (* otherwise *) + + (** The spec of log2 indeed determines it *) + + Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b. + Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 0 < a). + - apply lt_le_trans with (2^b); trivial. + apply pow_pos_nonneg; order'. + - assert (Hc := log2_nonneg a). + destruct (log2_spec a Ha) as (LEc,LTc). + assert (log2 a <= b). + + apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + + assert (b <= log2 a). + * apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + * order. + Qed. + + (** Hence log2 is a morphism. *) + + #[global] + Instance log2_wd : Proper (eq==>eq) log2. + Proof. + intros x x' Hx. + destruct (le_gt_cases x 0). + - rewrite 2 log2_nonpos; trivial. + reflexivity. + now rewrite <- Hx. + - apply log2_unique. + apply log2_nonneg. + + rewrite Hx in *. now apply log2_spec. + Qed. + + (** An alternate specification *) + + Lemma log2_spec_alt : forall a, 0 exists r, + a == 2^(log2 a) + r /\ 0 <= r < 2^(log2 a). + Proof. + intros a Ha. + destruct (log2_spec _ Ha) as (LE,LT). + destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). + exists r. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_lt_mono_r _ _ (2^log2 a)). + rewrite <- Hr. generalize LT. + rewrite pow_succ_r by order_pos. + rewrite two_succ at 1. now nzsimpl. + Qed. + + Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b -> + a == 2^b + c -> log2 a == b. + Proof. + intros a b c Hb (Hc,H) EQ. + apply log2_unique. - trivial. + - rewrite EQ. + split. + + rewrite <- add_0_r at 1. now apply add_le_mono_l. + + rewrite pow_succ_r by order. + rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. + Qed. + + (** log2 is exact on powers of 2 *) + + Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a. + Proof. + intros a Ha. + apply log2_unique' with 0; trivial. + - split; order_pos. - now nzsimpl. + Qed. + + (** log2 and predecessors of powers of 2 *) + + Lemma log2_pred_pow2 : forall a, 0 log2 (P (2^a)) == P a. + Proof. + intros a Ha. + assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0). + apply log2_unique. + - apply lt_succ_r; order. + - rewrite <-le_succ_l, <-lt_succ_r, Ha'. + rewrite lt_succ_pred with 0. + + split; try easy. apply pow_lt_mono_r_iff; try order'. + rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. + + apply pow_pos_nonneg; order'. + Qed. + + (** log2 and basic constants *) + + Lemma log2_1 : log2 1 == 0. + Proof. + rewrite <- (pow_0_r 2). now apply log2_pow2. + Qed. + + Lemma log2_2 : log2 2 == 1. + Proof. + rewrite <- (pow_1_r 2). apply log2_pow2; order'. + Qed. + + (** log2 n is strictly positive for 1 0 < log2 a. + Proof. + intros a Ha. + assert (Ha' : 0 < a) by order'. + assert (H := log2_nonneg a). le_elim H; trivial. + generalize (log2_spec a Ha'). rewrite <- H in *. nzsimpl; try order. + intros (_,H'). rewrite two_succ in H'. apply lt_succ_r in H'; order. + Qed. + + (** Said otherwise, log2 is null only below 1 *) + + Lemma log2_null : forall a, log2 a == 0 <-> a <= 1. + Proof. + intros a. split; intros H. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_pos a Ha); order. + - le_elim H. + + apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. + + rewrite H. apply log2_1. + Qed. + + (** log2 is a monotone function (but not a strict one) *) + + Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b. + Proof. + intros a b H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite log2_nonpos; order_pos. + - assert (Hb : 0 < b) by order. + destruct (log2_spec a Ha) as (LEa,_). + destruct (log2_spec b Hb) as (_,LTb). + apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. + Qed. + + (** No reverse result for <=, consider for instance log2 3 <= log2 2 *) + + Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b. + Proof. + intros a b H. + destruct (le_gt_cases b 0) as [Hb|Hb]. + - rewrite (log2_nonpos b) in H; trivial. + generalize (log2_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]. + order. + + destruct (log2_spec a Ha) as (_,LTa). + destruct (log2_spec b Hb) as (LEb,_). + apply le_succ_l in H. + apply (pow_le_mono_r_iff 2) in H; order_pos. + Qed. + + (** When left side is a power of 2, we have an equivalence for <= *) + + Lemma log2_le_pow2 : forall a b, 0 (2^b<=a <-> b <= log2 a). + Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. + - transitivity (2^(log2 a)). + + apply pow_le_mono_r; order'. + + now destruct (log2_spec a Ha). + Qed. + + (** When right side is a square, we have an equivalence for < *) + + Lemma log2_lt_pow2 : forall a b, 0 (a<2^b <-> log2 a < b). + Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + apply (pow_lt_mono_r_iff 2); try order_pos. + apply le_lt_trans with a; trivial. + now destruct (log2_spec a Ha). + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + apply log2_lt_cancel; try order. + now rewrite log2_pow2. + Qed. + + (** Comparing log2 and identity *) + + Lemma log2_lt_lin : forall a, 0 log2 a < a. + Proof. + intros a Ha. + apply (pow_lt_mono_r_iff 2); try order_pos. + apply le_lt_trans with a. + - now destruct (log2_spec a Ha). + - apply pow_gt_lin_r; order'. + Qed. + + Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a. + Proof. + intros a Ha. + le_elim Ha. + - now apply lt_le_incl, log2_lt_lin. + - rewrite <- Ha, log2_nonpos; order. + Qed. + + (** Log2 and multiplication. *) + + (** Due to rounding error, we don't have the usual [log2 (a*b) = log2 a + log2 b] but we may be off by 1 at most *) -Lemma log2_mul_below : forall a b, 0 0 - log2 a + log2 b <= log2 (a*b). -Proof. - intros a b Ha Hb. - apply log2_le_pow2; try order_pos. - rewrite pow_add_r by order_pos. - apply mul_le_mono_nonneg; try apply log2_spec; order_pos. -Qed. - -Lemma log2_mul_above : forall a b, 0<=a -> 0<=b -> - log2 (a*b) <= log2 a + log2 b + 1. -Proof. - intros a b Ha Hb. - le_elim Ha. - - le_elim Hb. - + apply lt_succ_r. - rewrite add_1_r, <- add_succ_r, <- add_succ_l. - apply log2_lt_pow2; try order_pos. - rewrite pow_add_r by order_pos. - apply mul_lt_mono_nonneg; try order; now apply log2_spec. - + rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. - - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. -Qed. - -(** And we can't find better approximations in general. + Lemma log2_mul_below : forall a b, 0 0 + log2 a + log2 b <= log2 (a*b). + Proof. + intros a b Ha Hb. + apply log2_le_pow2; try order_pos. + rewrite pow_add_r by order_pos. + apply mul_le_mono_nonneg; try apply log2_spec; order_pos. + Qed. + + Lemma log2_mul_above : forall a b, 0<=a -> 0<=b -> + log2 (a*b) <= log2 a + log2 b + 1. + Proof. + intros a b Ha Hb. + le_elim Ha. + - le_elim Hb. + + apply lt_succ_r. + rewrite add_1_r, <- add_succ_r, <- add_succ_l. + apply log2_lt_pow2; try order_pos. + rewrite pow_add_r by order_pos. + apply mul_lt_mono_nonneg; try order; now apply log2_spec. + + rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. + Qed. + + (** And we can't find better approximations in general. - The lower bound is exact for powers of 2. - Concerning the upper bound, for any c>1, take a=b=2^c-1, then log2 (a*b) = c+c -1 while (log2 a) = (log2 b) = c-1 *) -(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) - -Lemma log2_mul_pow2 : forall a b, 0 0<=b -> log2 (a*2^b) == b + log2 a. -Proof. - intros a b Ha Hb. - apply log2_unique; try order_pos. split. - - rewrite pow_add_r, mul_comm; try order_pos. - apply mul_le_mono_nonneg_r. + order_pos. + now apply log2_spec. - - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. - apply mul_lt_mono_pos_l. + order_pos. + now apply log2_spec. -Qed. - -Lemma log2_double : forall a, 0 log2 (2*a) == S (log2 a). -Proof. - intros a Ha. generalize (log2_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. -Qed. - -(** Two numbers with same log2 cannot be far away. *) - -Lemma log2_same : forall a b, 0 0 log2 a == log2 b -> a < 2*b. -Proof. - intros a b Ha Hb H. - apply log2_lt_cancel. rewrite log2_double, H by trivial. - apply lt_succ_diag_r. -Qed. - -(** Log2 and successor : + (** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) + + Lemma log2_mul_pow2 : forall a b, 0 0<=b -> log2 (a*2^b) == b + log2 a. + Proof. + intros a b Ha Hb. + apply log2_unique; try order_pos. split. + - rewrite pow_add_r, mul_comm; try order_pos. + apply mul_le_mono_nonneg_r. + order_pos. + now apply log2_spec. + - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. + apply mul_lt_mono_pos_l. + order_pos. + now apply log2_spec. + Qed. + + Lemma log2_double : forall a, 0 log2 (2*a) == S (log2 a). + Proof. + intros a Ha. generalize (log2_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. + Qed. + + (** Two numbers with same log2 cannot be far away. *) + + Lemma log2_same : forall a b, 0 0 log2 a == log2 b -> a < 2*b. + Proof. + intros a b Ha Hb H. + apply log2_lt_cancel. rewrite log2_double, H by trivial. + apply lt_succ_diag_r. + Qed. + + (** Log2 and successor : - the log2 function climbs by at most 1 at a time - otherwise it stays at the same value - the +1 steps occur for powers of two *) -Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a). -Proof. - intros a. - destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. - - apply (pow_le_mono_r_iff 2); try order_pos. - transitivity (S a). - + apply log2_spec. - apply lt_succ_r; order. - + now apply le_succ_l, log2_spec. - - rewrite <- EQ, <- one_succ, log2_1; order_pos. - - rewrite 2 log2_nonpos. + order_pos. + order'. + now rewrite le_succ_l. -Qed. - -Lemma log2_succ_or : forall a, - log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a. -Proof. - intros a. - destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. - - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (log2_succ_le a); order. -Qed. - -Lemma log2_eq_succ_is_pow2 : forall a, - log2 (S a) == S (log2 a) -> exists b, S a == 2^b. -Proof. - intros a H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite 2 (proj2 (log2_null _)) in H. + generalize (lt_succ_diag_r 0); order. - + order'. + apply le_succ_l. order'. - - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). - exists (log2 (S a)). - generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). - rewrite <- le_succ_l, <- H. order. -Qed. - -Lemma log2_eq_succ_iff_pow2 : forall a, 0 - (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b). -Proof. - intros a Ha. - split. - apply log2_eq_succ_is_pow2. - - intros (b,Hb). - assert (Hb' : 0 < b). - + apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. - + rewrite Hb, log2_pow2; try order'. - setoid_replace a with (P (2^b)). * rewrite log2_pred_pow2; trivial. - symmetry; now apply lt_succ_pred with 0. - * apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. - rewrite <- Hb, lt_succ_r; order. -Qed. - -Lemma log2_succ_double : forall a, 0 log2 (2*a+1) == S (log2 a). -Proof. - intros a Ha. - rewrite add_1_r. - destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double]. - apply log2_eq_succ_is_pow2 in H. destruct H as (b,H). - destruct (lt_trichotomy b 0) as [LT|[EQ|LT]]. - - rewrite pow_neg_r in H; trivial. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - - rewrite EQ, pow_0_r in H. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - - assert (EQ:=lt_succ_pred 0 b LT). - rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. - destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. - + generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. - + rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. - rewrite <- H in LE'. apply le_succ_l in LE'. order. -Qed. - -(** Log2 and addition *) - -Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b. -Proof. - intros a b Ha Hb. - destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - - rewrite one_succ, lt_succ_r in Ha'. - rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - + rewrite one_succ, lt_succ_r in Hb'. - rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - + clear Ha Hb. - apply lt_succ_r. - apply log2_lt_pow2; try order_pos. - rewrite pow_succ_r by order_pos. - rewrite two_succ, one_succ at 1. nzsimpl. - apply add_lt_mono. - * apply lt_le_trans with (2^(S (log2 a))). -- apply log2_spec; order'. - -- apply pow_le_mono_r. ++ order'. - ++ rewrite <- add_1_r. apply add_le_mono_l. - rewrite one_succ; now apply le_succ_l, log2_pos. - * apply lt_le_trans with (2^(S (log2 b))). - -- apply log2_spec; order'. - -- apply pow_le_mono_r. ++ order'. - ++ rewrite <- add_1_l. apply add_le_mono_r. - rewrite one_succ; now apply le_succ_l, log2_pos. -Qed. - -(** The sum of two log2 is less than twice the log2 of the sum. + Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a). + Proof. + intros a. + destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. + - apply (pow_le_mono_r_iff 2); try order_pos. + transitivity (S a). + + apply log2_spec. + apply lt_succ_r; order. + + now apply le_succ_l, log2_spec. + - rewrite <- EQ, <- one_succ, log2_1; order_pos. + - rewrite 2 log2_nonpos. + order_pos. + order'. + now rewrite le_succ_l. + Qed. + + Lemma log2_succ_or : forall a, + log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a. + Proof. + intros a. + destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. + - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_succ_le a); order. + Qed. + + Lemma log2_eq_succ_is_pow2 : forall a, + log2 (S a) == S (log2 a) -> exists b, S a == 2^b. + Proof. + intros a H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite 2 (proj2 (log2_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). + exists (log2 (S a)). + generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). + rewrite <- le_succ_l, <- H. order. + Qed. + + Lemma log2_eq_succ_iff_pow2 : forall a, 0 + (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b). + Proof. + intros a Ha. + split. - apply log2_eq_succ_is_pow2. + - intros (b,Hb). + assert (Hb' : 0 < b). + + apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. + + rewrite Hb, log2_pow2; try order'. + setoid_replace a with (P (2^b)). * rewrite log2_pred_pow2; trivial. + symmetry; now apply lt_succ_pred with 0. + * apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. + rewrite <- Hb, lt_succ_r; order. + Qed. + + Lemma log2_succ_double : forall a, 0 log2 (2*a+1) == S (log2 a). + Proof. + intros a Ha. + rewrite add_1_r. + destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double]. + apply log2_eq_succ_is_pow2 in H. destruct H as (b,H). + destruct (lt_trichotomy b 0) as [LT|[EQ|LT]]. + - rewrite pow_neg_r in H; trivial. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - rewrite EQ, pow_0_r in H. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - assert (EQ:=lt_succ_pred 0 b LT). + rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. + destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. + + generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. + + rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. + rewrite <- H in LE'. apply le_succ_l in LE'. order. + Qed. + + (** Log2 and addition *) + + Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b. + Proof. + intros a b Ha Hb. + destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. + - rewrite one_succ, lt_succ_r in Ha'. + rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite one_succ, lt_succ_r in Hb'. + rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + apply lt_succ_r. + apply log2_lt_pow2; try order_pos. + rewrite pow_succ_r by order_pos. + rewrite two_succ, one_succ at 1. nzsimpl. + apply add_lt_mono. + * apply lt_le_trans with (2^(S (log2 a))). -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_r. apply add_le_mono_l. + rewrite one_succ; now apply le_succ_l, log2_pos. + * apply lt_le_trans with (2^(S (log2 b))). + -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_l. apply add_le_mono_r. + rewrite one_succ; now apply le_succ_l, log2_pos. + Qed. + + (** The sum of two log2 is less than twice the log2 of the sum. The large inequality is obvious thanks to monotonicity. The strict one requires some more work. This is almost a convexity inequality for points [2a], [2b] and their middle [a+b] : @@ -429,446 +429,446 @@ Qed. Here, we cannot do better: consider for instance a=2 b=4, then 1+2<2*2 *) -Lemma add_log2_lt : forall a b, 0 0 - log2 a + log2 b < 2 * log2 (a+b). -Proof. - intros a b Ha Hb. nzsimpl'. - assert (H : log2 a <= log2 (a+b)). - - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - - assert (H' : log2 b <= log2 (a+b)). - + apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - + le_elim H. - * apply lt_le_trans with (log2 (a+b) + log2 b). - -- now apply add_lt_mono_r. -- now apply add_le_mono_l. - * rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'; trivial. - symmetry in H. apply log2_same in H; try order_pos. - symmetry in H'. apply log2_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. -Qed. + Lemma add_log2_lt : forall a b, 0 0 + log2 a + log2 b < 2 * log2 (a+b). + Proof. + intros a b Ha Hb. nzsimpl'. + assert (H : log2 a <= log2 (a+b)). + - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2 b <= log2 (a+b)). + + apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2 (a+b) + log2 b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'; trivial. + symmetry in H. apply log2_same in H; try order_pos. + symmetry in H'. apply log2_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. + Qed. End NZLog2Prop. Module NZLog2UpProp - (Import A : NZDecOrdAxiomsSig') - (Import B : NZPow' A) - (Import C : NZLog2 A B) - (Import D : NZMulOrderProp A) - (Import E : NZPowProp A B D) - (Import F : NZLog2Prop A B C D E). - -(** * [log2_up] : a binary logarithm that rounds up instead of down *) - -(** For once, we define instead of axiomatizing, thanks to log2 *) - -Definition log2_up a := - match compare 1 a with - | Lt => S (log2 (P a)) - | _ => 0 - end. - -Lemma log2_up_eqn0 : forall a, a<=1 -> log2_up a == 0. -Proof. - intros a Ha. unfold log2_up. case compare_spec; try order. -Qed. - -Lemma log2_up_eqn : forall a, 1 log2_up a == S (log2 (P a)). -Proof. - intros a Ha. unfold log2_up. case compare_spec; try order. -Qed. - -Lemma log2_up_spec : forall a, 1 - 2^(P (log2_up a)) < a <= 2^(log2_up a). -Proof. - intros a Ha. - rewrite log2_up_eqn; trivial. - rewrite pred_succ. - rewrite <- (lt_succ_pred 1 a Ha) at 2 3. - rewrite lt_succ_r, le_succ_l. - apply log2_spec. - apply succ_lt_mono. now rewrite (lt_succ_pred 1 a Ha), <- one_succ. -Qed. - -Lemma log2_up_nonpos : forall a, a<=0 -> log2_up a == 0. -Proof. - intros. apply log2_up_eqn0. order'. -Qed. - -#[global] -Instance log2_up_wd : Proper (eq==>eq) log2_up. -Proof. - assert (Proper (eq==>eq==>Logic.eq) compare). - - repeat red; intros; do 2 case compare_spec; trivial; order. - - intros a a' Ha. unfold log2_up. rewrite Ha at 1. - case compare; now rewrite ?Ha. -Qed. - -(** [log2_up] is always non-negative *) - -Lemma log2_up_nonneg : forall a, 0 <= log2_up a. -Proof. - intros a. unfold log2_up. case compare_spec; try order. - intros. apply le_le_succ_r, log2_nonneg. -Qed. - -(** The spec of [log2_up] indeed determines it *) - -Lemma log2_up_unique : forall a b, 0 2^(P b) log2_up a == b. -Proof. - intros a b Hb (LEb,LTb). - assert (Ha : 1 < a). - - apply le_lt_trans with (2^(P b)); trivial. - rewrite one_succ. apply le_succ_l. - apply pow_pos_nonneg. + order'. - + apply lt_succ_r. - now rewrite (lt_succ_pred 0 b Hb). - - assert (Hc := log2_up_nonneg a). - destruct (log2_up_spec a Ha) as (LTc,LEc). - assert (b <= log2_up a). - + apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - + assert (Hc' : 0 < log2_up a) by order. - assert (log2_up a <= b). - * apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - * order. -Qed. - -(** [log2_up] is exact on powers of 2 *) - -Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a. -Proof. - intros a Ha. - le_elim Ha. - - apply log2_up_unique; trivial. - split; try order. - apply pow_lt_mono_r; try order'. - rewrite <- (lt_succ_pred 0 a Ha) at 2. - now apply lt_succ_r. - - now rewrite <- Ha, pow_0_r, log2_up_eqn0. -Qed. - -(** [log2_up] and successors of powers of 2 *) - -Lemma log2_up_succ_pow2 : forall a, 0<=a -> log2_up (S (2^a)) == S a. -Proof. - intros a Ha. - rewrite log2_up_eqn, pred_succ, log2_pow2; try easy. - rewrite one_succ, <- succ_lt_mono. apply pow_pos_nonneg; order'. -Qed. - -(** Basic constants *) - -Lemma log2_up_1 : log2_up 1 == 0. -Proof. - now apply log2_up_eqn0. -Qed. - -Lemma log2_up_2 : log2_up 2 == 1. -Proof. - rewrite <- (pow_1_r 2). apply log2_up_pow2; order'. -Qed. - -(** Links between log2 and [log2_up] *) - -Lemma le_log2_log2_up : forall a, log2 a <= log2_up a. -Proof. - intros a. unfold log2_up. case compare_spec; intros H. - - rewrite <- H, log2_1. order. - - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. - - rewrite log2_nonpos. + order. + now rewrite <-lt_succ_r, <-one_succ. -Qed. - -Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a). -Proof. - intros a. unfold log2_up. case compare_spec; intros H; try order_pos. - rewrite <- succ_le_mono. apply log2_le_mono. - rewrite <- (lt_succ_pred 1 a H) at 2. apply le_succ_diag_r. -Qed. - -Lemma log2_log2_up_spec : forall a, 0 - 2^log2 a <= a <= 2^log2_up a. -Proof. - intros a H. split. - - now apply log2_spec. - - rewrite <-le_succ_l, <-one_succ in H. le_elim H. - + now apply log2_up_spec. - + now rewrite <-H, log2_up_1, pow_0_r. -Qed. - -Lemma log2_log2_up_exact : - forall a, 0 (log2 a == log2_up a <-> exists b, a == 2^b). -Proof. - intros a Ha. - split. - - intros H. exists (log2 a). - generalize (log2_log2_up_spec a Ha). rewrite <-H. - destruct 1; order. - - intros (b,Hb). rewrite Hb. - destruct (le_gt_cases 0 b). - + now rewrite log2_pow2, log2_up_pow2. - + rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. -Qed. - -(** [log2_up] n is strictly positive for 1 0 < log2_up a. -Proof. - intros. rewrite log2_up_eqn; trivial. apply lt_succ_r; order_pos. -Qed. - -(** Said otherwise, [log2_up] is null only below 1 *) - -Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1. -Proof. - intros a. split; intros H. - - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_up_pos a Ha); order. - - now apply log2_up_eqn0. -Qed. - -(** [log2_up] is a monotone function (but not a strict one) *) - -Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b. -Proof. - intros a b H. - destruct (le_gt_cases a 1) as [Ha|Ha]. - - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. - - rewrite 2 log2_up_eqn; try order. - rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. - rewrite 2 lt_succ_pred with 1; order. -Qed. - -(** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *) - -Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b. -Proof. - intros a b H. - destruct (le_gt_cases b 1) as [Hb|Hb]. - - rewrite (log2_up_eqn0 b) in H; trivial. - generalize (log2_up_nonneg a); order. - - destruct (le_gt_cases a 1) as [Ha|Ha]. + order. - + rewrite 2 log2_up_eqn in H; try order. - rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. - rewrite 2 lt_succ_pred with 1 in H; order. -Qed. - -(** When left side is a power of 2, we have an equivalence for < *) - -Lemma log2_up_lt_pow2 : forall a b, 0 (2^b b < log2_up a). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + generalize (log2_up_nonneg a); order. - + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. - * apply lt_le_trans with a; trivial. - apply (log2_up_spec a). - apply le_lt_trans with (2^b); trivial. - rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + now rewrite pow_neg_r. - + rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. -Qed. - -(** When right side is a square, we have an equivalence for <= *) - -Lemma log2_up_le_pow2 : forall a b, 0 (a<=2^b <-> log2_up a <= b). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + rewrite pow_neg_r in H; order. - + rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. - - transitivity (2^(log2_up a)). - + now apply log2_log2_up_spec. - + apply pow_le_mono_r; order'. -Qed. - -(** Comparing [log2_up] and identity *) - -Lemma log2_up_lt_lin : forall a, 0 log2_up a < a. -Proof. - intros a Ha. - assert (H : S (P a) == a) by (now apply lt_succ_pred with 0). - rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial. - rewrite <- H at 1. apply le_succ_l. - apply pow_gt_lin_r. - order'. - apply lt_succ_r; order. -Qed. - -Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a. -Proof. - intros a Ha. - le_elim Ha. - - now apply lt_le_incl, log2_up_lt_lin. - - rewrite <- Ha, log2_up_nonpos; order. -Qed. - -(** [log2_up] and multiplication. *) - -(** Due to rounding error, we don't have the usual + (Import A : NZDecOrdAxiomsSig') + (Import B : NZPow' A) + (Import C : NZLog2 A B) + (Import D : NZMulOrderProp A) + (Import E : NZPowProp A B D) + (Import F : NZLog2Prop A B C D E). + + (** * [log2_up] : a binary logarithm that rounds up instead of down *) + + (** For once, we define instead of axiomatizing, thanks to log2 *) + + Definition log2_up a := + match compare 1 a with + | Lt => S (log2 (P a)) + | _ => 0 + end. + + Lemma log2_up_eqn0 : forall a, a<=1 -> log2_up a == 0. + Proof. + intros a Ha. unfold log2_up. case compare_spec; try order. + Qed. + + Lemma log2_up_eqn : forall a, 1 log2_up a == S (log2 (P a)). + Proof. + intros a Ha. unfold log2_up. case compare_spec; try order. + Qed. + + Lemma log2_up_spec : forall a, 1 + 2^(P (log2_up a)) < a <= 2^(log2_up a). + Proof. + intros a Ha. + rewrite log2_up_eqn; trivial. + rewrite pred_succ. + rewrite <- (lt_succ_pred 1 a Ha) at 2 3. + rewrite lt_succ_r, le_succ_l. + apply log2_spec. + apply succ_lt_mono. now rewrite (lt_succ_pred 1 a Ha), <- one_succ. + Qed. + + Lemma log2_up_nonpos : forall a, a<=0 -> log2_up a == 0. + Proof. + intros. apply log2_up_eqn0. order'. + Qed. + + #[global] + Instance log2_up_wd : Proper (eq==>eq) log2_up. + Proof. + assert (Proper (eq==>eq==>Logic.eq) compare). + - repeat red; intros; do 2 case compare_spec; trivial; order. + - intros a a' Ha. unfold log2_up. rewrite Ha at 1. + case compare; now rewrite ?Ha. + Qed. + + (** [log2_up] is always non-negative *) + + Lemma log2_up_nonneg : forall a, 0 <= log2_up a. + Proof. + intros a. unfold log2_up. case compare_spec; try order. + intros. apply le_le_succ_r, log2_nonneg. + Qed. + + (** The spec of [log2_up] indeed determines it *) + + Lemma log2_up_unique : forall a b, 0 2^(P b) log2_up a == b. + Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 1 < a). + - apply le_lt_trans with (2^(P b)); trivial. + rewrite one_succ. apply le_succ_l. + apply pow_pos_nonneg. + order'. + + apply lt_succ_r. + now rewrite (lt_succ_pred 0 b Hb). + - assert (Hc := log2_up_nonneg a). + destruct (log2_up_spec a Ha) as (LTc,LEc). + assert (b <= log2_up a). + + apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + + assert (Hc' : 0 < log2_up a) by order. + assert (log2_up a <= b). + * apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + * order. + Qed. + + (** [log2_up] is exact on powers of 2 *) + + Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a. + Proof. + intros a Ha. + le_elim Ha. + - apply log2_up_unique; trivial. + split; try order. + apply pow_lt_mono_r; try order'. + rewrite <- (lt_succ_pred 0 a Ha) at 2. + now apply lt_succ_r. + - now rewrite <- Ha, pow_0_r, log2_up_eqn0. + Qed. + + (** [log2_up] and successors of powers of 2 *) + + Lemma log2_up_succ_pow2 : forall a, 0<=a -> log2_up (S (2^a)) == S a. + Proof. + intros a Ha. + rewrite log2_up_eqn, pred_succ, log2_pow2; try easy. + rewrite one_succ, <- succ_lt_mono. apply pow_pos_nonneg; order'. + Qed. + + (** Basic constants *) + + Lemma log2_up_1 : log2_up 1 == 0. + Proof. + now apply log2_up_eqn0. + Qed. + + Lemma log2_up_2 : log2_up 2 == 1. + Proof. + rewrite <- (pow_1_r 2). apply log2_up_pow2; order'. + Qed. + + (** Links between log2 and [log2_up] *) + + Lemma le_log2_log2_up : forall a, log2 a <= log2_up a. + Proof. + intros a. unfold log2_up. case compare_spec; intros H. + - rewrite <- H, log2_1. order. + - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. + - rewrite log2_nonpos. + order. + now rewrite <-lt_succ_r, <-one_succ. + Qed. + + Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a). + Proof. + intros a. unfold log2_up. case compare_spec; intros H; try order_pos. + rewrite <- succ_le_mono. apply log2_le_mono. + rewrite <- (lt_succ_pred 1 a H) at 2. apply le_succ_diag_r. + Qed. + + Lemma log2_log2_up_spec : forall a, 0 + 2^log2 a <= a <= 2^log2_up a. + Proof. + intros a H. split. + - now apply log2_spec. + - rewrite <-le_succ_l, <-one_succ in H. le_elim H. + + now apply log2_up_spec. + + now rewrite <-H, log2_up_1, pow_0_r. + Qed. + + Lemma log2_log2_up_exact : + forall a, 0 (log2 a == log2_up a <-> exists b, a == 2^b). + Proof. + intros a Ha. + split. + - intros H. exists (log2 a). + generalize (log2_log2_up_spec a Ha). rewrite <-H. + destruct 1; order. + - intros (b,Hb). rewrite Hb. + destruct (le_gt_cases 0 b). + + now rewrite log2_pow2, log2_up_pow2. + + rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. + Qed. + + (** [log2_up] n is strictly positive for 1 0 < log2_up a. + Proof. + intros. rewrite log2_up_eqn; trivial. apply lt_succ_r; order_pos. + Qed. + + (** Said otherwise, [log2_up] is null only below 1 *) + + Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1. + Proof. + intros a. split; intros H. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_up_pos a Ha); order. + - now apply log2_up_eqn0. + Qed. + + (** [log2_up] is a monotone function (but not a strict one) *) + + Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b. + Proof. + intros a b H. + destruct (le_gt_cases a 1) as [Ha|Ha]. + - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. + - rewrite 2 log2_up_eqn; try order. + rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. + rewrite 2 lt_succ_pred with 1; order. + Qed. + + (** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *) + + Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b. + Proof. + intros a b H. + destruct (le_gt_cases b 1) as [Hb|Hb]. + - rewrite (log2_up_eqn0 b) in H; trivial. + generalize (log2_up_nonneg a); order. + - destruct (le_gt_cases a 1) as [Ha|Ha]. + order. + + rewrite 2 log2_up_eqn in H; try order. + rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. + rewrite 2 lt_succ_pred with 1 in H; order. + Qed. + + (** When left side is a power of 2, we have an equivalence for < *) + + Lemma log2_up_lt_pow2 : forall a b, 0 (2^b b < log2_up a). + Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_up_nonneg a); order. + + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * apply lt_le_trans with a; trivial. + apply (log2_up_spec a). + apply le_lt_trans with (2^b); trivial. + rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + now rewrite pow_neg_r. + + rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. + Qed. + + (** When right side is a square, we have an equivalence for <= *) + + Lemma log2_up_le_pow2 : forall a b, 0 (a<=2^b <-> log2_up a <= b). + Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. + - transitivity (2^(log2_up a)). + + now apply log2_log2_up_spec. + + apply pow_le_mono_r; order'. + Qed. + + (** Comparing [log2_up] and identity *) + + Lemma log2_up_lt_lin : forall a, 0 log2_up a < a. + Proof. + intros a Ha. + assert (H : S (P a) == a) by (now apply lt_succ_pred with 0). + rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial. + rewrite <- H at 1. apply le_succ_l. + apply pow_gt_lin_r. - order'. - apply lt_succ_r; order. + Qed. + + Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a. + Proof. + intros a Ha. + le_elim Ha. + - now apply lt_le_incl, log2_up_lt_lin. + - rewrite <- Ha, log2_up_nonpos; order. + Qed. + + (** [log2_up] and multiplication. *) + + (** Due to rounding error, we don't have the usual [log2_up (a*b) = log2_up a + log2_up b] but we may be off by 1 at most *) -Lemma log2_up_mul_above : forall a b, 0<=a -> 0<=b -> - log2_up (a*b) <= log2_up a + log2_up b. -Proof. - intros a b Ha Hb. - assert (Ha':=log2_up_nonneg a). - assert (Hb':=log2_up_nonneg b). - le_elim Ha. - - le_elim Hb. - + apply log2_up_le_pow2; try order_pos. - rewrite pow_add_r; trivial. - apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. - + rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. - - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. -Qed. - -Lemma log2_up_mul_below : forall a b, 0 0 - log2_up a + log2_up b <= S (log2_up (a*b)). -Proof. - intros a b Ha Hb. - rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha. - - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. - + assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). - assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). - rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. - rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. - nzsimpl. rewrite <- succ_le_mono, le_succ_l. - apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. - * rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). - apply lt_le_trans with (a*b). - -- apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. - -- apply log2_up_spec. - setoid_replace 1 with (1*1) by now nzsimpl. - apply mul_lt_mono_nonneg; order'. - + rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. - - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. -Qed. - -(** And we can't find better approximations in general. + Lemma log2_up_mul_above : forall a b, 0<=a -> 0<=b -> + log2_up (a*b) <= log2_up a + log2_up b. + Proof. + intros a b Ha Hb. + assert (Ha':=log2_up_nonneg a). + assert (Hb':=log2_up_nonneg b). + le_elim Ha. + - le_elim Hb. + + apply log2_up_le_pow2; try order_pos. + rewrite pow_add_r; trivial. + apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. + + rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. + Qed. + + Lemma log2_up_mul_below : forall a b, 0 0 + log2_up a + log2_up b <= S (log2_up (a*b)). + Proof. + intros a b Ha Hb. + rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha. + - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. + + assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). + assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). + rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. + rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. + nzsimpl. rewrite <- succ_le_mono, le_succ_l. + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). + apply lt_le_trans with (a*b). + -- apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. + -- apply log2_up_spec. + setoid_replace 1 with (1*1) by now nzsimpl. + apply mul_lt_mono_nonneg; order'. + + rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. + - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. + Qed. + + (** And we can't find better approximations in general. - The upper bound is exact for powers of 2. - Concerning the lower bound, for any c>1, take a=b=2^c+1, then [log2_up (a*b) = c+c +1] while [(log2_up a) = (log2_up b) = c+1] *) -(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) - -Lemma log2_up_mul_pow2 : forall a b, 0 0<=b -> - log2_up (a*2^b) == b + log2_up a. -Proof. - intros a b Ha Hb. - rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha. - - apply log2_up_unique. + apply add_nonneg_pos; trivial. now apply log2_up_pos. - + split. - * assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). - rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. - -- apply mul_lt_mono_pos_r. ++ order_pos. ++ now apply log2_up_spec. - -- rewrite <- lt_succ_r, EQ. now apply log2_up_pos. - * rewrite pow_add_r, mul_comm; trivial. - -- apply mul_le_mono_nonneg_l. ++ order_pos. ++ now apply log2_up_spec. - -- apply log2_up_nonneg. - - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. -Qed. - -Lemma log2_up_double : forall a, 0 log2_up (2*a) == S (log2_up a). -Proof. - intros a Ha. generalize (log2_up_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. -Qed. - -(** Two numbers with same [log2_up] cannot be far away. *) - -Lemma log2_up_same : forall a b, 0 0 log2_up a == log2_up b -> a < 2*b. -Proof. - intros a b Ha Hb H. - apply log2_up_lt_cancel. rewrite log2_up_double, H by trivial. - apply lt_succ_diag_r. -Qed. - -(** [log2_up] and successor : + (** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) + + Lemma log2_up_mul_pow2 : forall a b, 0 0<=b -> + log2_up (a*2^b) == b + log2_up a. + Proof. + intros a b Ha Hb. + rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha. + - apply log2_up_unique. + apply add_nonneg_pos; trivial. now apply log2_up_pos. + + split. + * assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). + rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. + -- apply mul_lt_mono_pos_r. ++ order_pos. ++ now apply log2_up_spec. + -- rewrite <- lt_succ_r, EQ. now apply log2_up_pos. + * rewrite pow_add_r, mul_comm; trivial. + -- apply mul_le_mono_nonneg_l. ++ order_pos. ++ now apply log2_up_spec. + -- apply log2_up_nonneg. + - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. + Qed. + + Lemma log2_up_double : forall a, 0 log2_up (2*a) == S (log2_up a). + Proof. + intros a Ha. generalize (log2_up_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. + Qed. + + (** Two numbers with same [log2_up] cannot be far away. *) + + Lemma log2_up_same : forall a b, 0 0 log2_up a == log2_up b -> a < 2*b. + Proof. + intros a b Ha Hb H. + apply log2_up_lt_cancel. rewrite log2_up_double, H by trivial. + apply lt_succ_diag_r. + Qed. + + (** [log2_up] and successor : - the [log2_up] function climbs by at most 1 at a time - otherwise it stays at the same value - the +1 steps occur after powers of two *) -Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a). -Proof. - intros a. - destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]]. - - rewrite 2 log2_up_eqn; trivial. - + rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. - apply log2_succ_le. - + apply lt_succ_r; order. - - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. - - rewrite 2 log2_up_eqn0. + order_pos. + order'. + now rewrite le_succ_l. -Qed. - -Lemma log2_up_succ_or : forall a, - log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a. -Proof. - intros a. - destruct (le_gt_cases (log2_up (S a)) (log2_up a)) as [H|H]. - - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. -Qed. - -Lemma log2_up_eq_succ_is_pow2 : forall a, - log2_up (S a) == S (log2_up a) -> exists b, a == 2^b. -Proof. - intros a H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite 2 (proj2 (log2_up_null _)) in H. + generalize (lt_succ_diag_r 0); order. - + order'. + apply le_succ_l. order'. - - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). - exists (log2_up a). - generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). - rewrite H, pred_succ, lt_succ_r. order. -Qed. - -Lemma log2_up_eq_succ_iff_pow2 : forall a, 0 - (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b). -Proof. - intros a Ha. - split. - apply log2_up_eq_succ_is_pow2. - - intros (b,Hb). - destruct (lt_ge_cases b 0) as [Hb'|Hb']. - + rewrite pow_neg_r in Hb; order. - + rewrite Hb, log2_up_pow2; try order'. - now rewrite log2_up_succ_pow2. -Qed. - -Lemma log2_up_succ_double : forall a, 0 - log2_up (2*a+1) == 2 + log2 a. -Proof. - intros a Ha. - rewrite log2_up_eqn. - rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. - - apply le_lt_trans with (0+1). + now nzsimpl'. - + apply add_lt_mono_r. order_pos. -Qed. - -(** [log2_up] and addition *) - -Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 -> - log2_up (a+b) <= log2_up a + log2_up b. -Proof. - intros a b Ha Hb. - destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Ha'. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - + rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Hb'. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - + clear Ha Hb. - transitivity (log2_up (a*b)). - * now apply log2_up_le_mono, add_le_mul. - * apply log2_up_mul_above; order'. -Qed. - -(** The sum of two [log2_up] is less than twice the [log2_up] of the sum. + Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a). + Proof. + intros a. + destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]]. + - rewrite 2 log2_up_eqn; trivial. + + rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. + apply log2_succ_le. + + apply lt_succ_r; order. + - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. + - rewrite 2 log2_up_eqn0. + order_pos. + order'. + now rewrite le_succ_l. + Qed. + + Lemma log2_up_succ_or : forall a, + log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a. + Proof. + intros a. + destruct (le_gt_cases (log2_up (S a)) (log2_up a)) as [H|H]. + - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. + Qed. + + Lemma log2_up_eq_succ_is_pow2 : forall a, + log2_up (S a) == S (log2_up a) -> exists b, a == 2^b. + Proof. + intros a H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite 2 (proj2 (log2_up_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). + exists (log2_up a). + generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). + rewrite H, pred_succ, lt_succ_r. order. + Qed. + + Lemma log2_up_eq_succ_iff_pow2 : forall a, 0 + (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b). + Proof. + intros a Ha. + split. - apply log2_up_eq_succ_is_pow2. + - intros (b,Hb). + destruct (lt_ge_cases b 0) as [Hb'|Hb']. + + rewrite pow_neg_r in Hb; order. + + rewrite Hb, log2_up_pow2; try order'. + now rewrite log2_up_succ_pow2. + Qed. + + Lemma log2_up_succ_double : forall a, 0 + log2_up (2*a+1) == 2 + log2 a. + Proof. + intros a Ha. + rewrite log2_up_eqn. - rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. + - apply le_lt_trans with (0+1). + now nzsimpl'. + + apply add_lt_mono_r. order_pos. + Qed. + + (** [log2_up] and addition *) + + Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 -> + log2_up (a+b) <= log2_up a + log2_up b. + Proof. + intros a b Ha Hb. + destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. + - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Ha'. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Hb'. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + transitivity (log2_up (a*b)). + * now apply log2_up_le_mono, add_le_mul. + * apply log2_up_mul_above; order'. + Qed. + + (** The sum of two [log2_up] is less than twice the [log2_up] of the sum. The large inequality is obvious thanks to monotonicity. The strict one requires some more work. This is almost a convexity inequality for points [2a], [2b] and their middle [a+b] : @@ -876,22 +876,22 @@ Qed. Here, we cannot do better: consider for instance a=3 b=5, then 2+3<2*3 *) -Lemma add_log2_up_lt : forall a b, 0 0 - log2_up a + log2_up b < 2 * log2_up (a+b). -Proof. - intros a b Ha Hb. nzsimpl'. - assert (H : log2_up a <= log2_up (a+b)). - - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - - assert (H' : log2_up b <= log2_up (a+b)). - + apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - + le_elim H. - * apply lt_le_trans with (log2_up (a+b) + log2_up b). - -- now apply add_lt_mono_r. -- now apply add_le_mono_l. - * rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'. -- trivial. - -- symmetry in H. apply log2_up_same in H; try order_pos. - symmetry in H'. apply log2_up_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. -Qed. + Lemma add_log2_up_lt : forall a b, 0 0 + log2_up a + log2_up b < 2 * log2_up (a+b). + Proof. + intros a b Ha Hb. nzsimpl'. + assert (H : log2_up a <= log2_up (a+b)). + - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2_up b <= log2_up (a+b)). + + apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2_up (a+b) + log2_up b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'. -- trivial. + -- symmetry in H. apply log2_up_same in H; try order_pos. + symmetry in H'. apply log2_up_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. + Qed. End NZLog2UpProp. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 9c9798eef8..a7f439bd1f 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -30,82 +30,82 @@ Notice that [NZMulProp] itself [Include]s [NZAddProp]. From Stdlib.Numbers.NatInt Require Import NZAxioms NZBase NZAdd. Module Type NZMulProp (Import NZ : NZBasicFunsSig')(Import NZBase : NZBaseProp NZ). -Include NZAddProp NZ NZBase. - -Theorem mul_0_r : forall n, n * 0 == 0. -Proof. -intro n; nzinduct n; intros; now nzsimpl. -Qed. - -Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. -Proof. - intros n m; nzinduct n. - - now nzsimpl. - - intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. - now rewrite add_cancel_r. -Qed. - -#[global] Hint Rewrite mul_0_r mul_succ_r : nz. - -Theorem mul_comm : forall n m, n * m == m * n. -Proof. - intros n m; nzinduct n. - - now nzsimpl. - - intro. nzsimpl. now rewrite add_cancel_r. -Qed. - -Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p. -Proof. - intros n m p; nzinduct n. - - now nzsimpl. - - intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. - now rewrite add_cancel_r. -Qed. - -Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p. -Proof. -intros n m p. -rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p). -apply mul_add_distr_r. -Qed. - -Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p. -Proof. - intros n m p; nzinduct n. - now nzsimpl. - - intro n. nzsimpl. rewrite mul_add_distr_r. - now rewrite add_cancel_r. -Qed. - -Theorem mul_1_l : forall n, 1 * n == n. -Proof. -intro n. now nzsimpl'. -Qed. - -Theorem mul_1_r : forall n, n * 1 == n. -Proof. -intro n. now nzsimpl'. -Qed. - -#[global] Hint Rewrite mul_1_l mul_1_r : nz. - -Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m. -Proof. -intros n m p. now rewrite <- 2 mul_assoc, (mul_comm m). -Qed. - -Theorem mul_shuffle1 : forall n m p q, (n * m) * (p * q) == (n * p) * (m * q). -Proof. -intros n m p q. now rewrite 2 mul_assoc, (mul_shuffle0 n). -Qed. - -Theorem mul_shuffle2 : forall n m p q, (n * m) * (p * q) == (n * q) * (m * p). -Proof. -intros n m p q. rewrite (mul_comm p). apply mul_shuffle1. -Qed. - -Theorem mul_shuffle3 : forall n m p, n * (m * p) == m * (n * p). -Proof. -intros n m p. now rewrite mul_assoc, (mul_comm n), mul_assoc. -Qed. + Include NZAddProp NZ NZBase. + + Theorem mul_0_r : forall n, n * 0 == 0. + Proof. + intro n; nzinduct n; intros; now nzsimpl. + Qed. + + Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. + Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. + now rewrite add_cancel_r. + Qed. + + #[global] Hint Rewrite mul_0_r mul_succ_r : nz. + + Theorem mul_comm : forall n m, n * m == m * n. + Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite add_cancel_r. + Qed. + + Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p. + Proof. + intros n m p; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. + now rewrite add_cancel_r. + Qed. + + Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p. + Proof. + intros n m p. + rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p). + apply mul_add_distr_r. + Qed. + + Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p. + Proof. + intros n m p; nzinduct n. - now nzsimpl. + - intro n. nzsimpl. rewrite mul_add_distr_r. + now rewrite add_cancel_r. + Qed. + + Theorem mul_1_l : forall n, 1 * n == n. + Proof. + intro n. now nzsimpl'. + Qed. + + Theorem mul_1_r : forall n, n * 1 == n. + Proof. + intro n. now nzsimpl'. + Qed. + + #[global] Hint Rewrite mul_1_l mul_1_r : nz. + + Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m. + Proof. + intros n m p. now rewrite <- 2 mul_assoc, (mul_comm m). + Qed. + + Theorem mul_shuffle1 : forall n m p q, (n * m) * (p * q) == (n * p) * (m * q). + Proof. + intros n m p q. now rewrite 2 mul_assoc, (mul_shuffle0 n). + Qed. + + Theorem mul_shuffle2 : forall n m p q, (n * m) * (p * q) == (n * q) * (m * p). + Proof. + intros n m p q. rewrite (mul_comm p). apply mul_shuffle1. + Qed. + + Theorem mul_shuffle3 : forall n m p, n * (m * p) == m * (n * p). + Proof. + intros n m p. now rewrite mul_assoc, (mul_comm n), mul_assoc. + Qed. End NZMulProp. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index 2fce717eaa..bd50e7ece2 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -29,402 +29,402 @@ From Stdlib Require Import NZAxioms. From Stdlib Require Import NZAddOrder. Module Type NZMulOrderProp (Import NZ : NZOrdAxiomsSig'). -Include NZAddOrderProp NZ. - -Theorem mul_lt_pred : - forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). -Proof. -intros p q n m H. rewrite <- H. nzsimpl. -rewrite <- ! add_assoc, (add_comm n m). -now rewrite <- add_lt_mono_r. -Qed. - -Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). -Proof. - intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). - solve_proper. - - intros. now nzsimpl. - - clear p Hp. intros p Hp IH n m. nzsimpl. - assert (LR : forall n m, n < m -> p * n + n < p * m + m) - by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). - split; intros H. - + now apply LR. - + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. - * rewrite EQ in H. order. - * apply LR in GT. order. -Qed. - -Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). -Proof. -intros p n m. -rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l. -Qed. - -Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). -Proof. -intro p; nzord_induct p. -- order. -- intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. -- intros p Hp IH n m _. apply le_succ_l in Hp. - le_elim Hp. - + assert (LR : forall n m, n < m -> p * m < p * n). - * intros n1 m1 H. apply (le_lt_add_lt n1 m1). - -- now apply lt_le_incl. - -- rewrite <- 2 mul_succ_l. now rewrite <- IH. - * split; intros H. - -- now apply LR. - -- destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. - ++ rewrite EQ in H. order. - ++ apply LR in GT. order. - + rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. -Qed. - -Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). -Proof. -intros p n m. -rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l. -Qed. - -Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. -Proof. -intros n m p H1 H2. le_elim H1. -- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_pos_l. - + apply eq_le_incl; now rewrite H2. -- apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. -Qed. - -Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. -Proof. -intros n m p H1 H2. le_elim H1. -- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_neg_l. - + apply eq_le_incl; now rewrite H2. -- apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. -Qed. - -Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. -Proof. -intros n m p H1 H2; -rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l. -Qed. - -Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p. -Proof. -intros n m p H1 H2; -rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l. -Qed. - -Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m). -Proof. -intros n m p Hp; split; intro H; [|now f_equiv]. -apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp]; - destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -- apply (mul_lt_mono_neg_l p) in LT; order. -- apply (mul_lt_mono_neg_l p) in GT; order. -- apply (mul_lt_mono_pos_l p) in LT; order. -- apply (mul_lt_mono_pos_l p) in GT; order. -Qed. - -Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). -Proof. -intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l. -Qed. - -Lemma mul_reg_l n m p : p ~= 0 -> p * n == p * m -> n == m. -Proof. - exact (fun Hp => proj1 (mul_cancel_l n m p Hp)). -Qed. - -Lemma mul_reg_r n m p : p ~= 0 -> n * p == m * p -> n == m. -Proof. - exact (fun Hp => proj1 (mul_cancel_r n m p Hp)). -Qed. - -Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1). -Proof. -intros n m H. -stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r. -Qed. - -Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1). -Proof. -intros n m; rewrite mul_comm; apply mul_id_l. -Qed. - -Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m). -Proof. -intros n m p H; do 2 rewrite lt_eq_cases. -rewrite (mul_lt_mono_pos_l p n m) by assumption. -now rewrite -> (mul_cancel_l n m p) by -(intro H1; rewrite H1 in H; false_hyp H lt_irrefl). -Qed. - -Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p). -Proof. -intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l. -Qed. - -Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n). -Proof. -intros n m p H; do 2 rewrite lt_eq_cases. -rewrite (mul_lt_mono_neg_l p n m); [| assumption]. -rewrite -> (mul_cancel_l m n p) - by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl). -now setoid_replace (n == m) with (m == n) by (split; now intro). -Qed. - -Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p). -Proof. -intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l. -Qed. - -Theorem mul_lt_mono_nonneg : - forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. -Proof. -intros n m p q H1 H2 H3 H4. -apply le_lt_trans with (m * p). -- apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -- apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. -Qed. - -(* There are still many variants of the theorem above. One can assume 0 < n + Include NZAddOrderProp NZ. + + Theorem mul_lt_pred : + forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). + Proof. + intros p q n m H. rewrite <- H. nzsimpl. + rewrite <- ! add_assoc, (add_comm n m). + now rewrite <- add_lt_mono_r. + Qed. + + Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). + Proof. + intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). - solve_proper. + - intros. now nzsimpl. + - clear p Hp. intros p Hp IH n m. nzsimpl. + assert (LR : forall n m, n < m -> p * n + n < p * m + m) + by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). + split; intros H. + + now apply LR. + + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + * rewrite EQ in H. order. + * apply LR in GT. order. + Qed. + + Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). + Proof. + intros p n m. + rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l. + Qed. + + Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). + Proof. + intro p; nzord_induct p. + - order. + - intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. + - intros p Hp IH n m _. apply le_succ_l in Hp. + le_elim Hp. + + assert (LR : forall n m, n < m -> p * m < p * n). + * intros n1 m1 H. apply (le_lt_add_lt n1 m1). + -- now apply lt_le_incl. + -- rewrite <- 2 mul_succ_l. now rewrite <- IH. + * split; intros H. + -- now apply LR. + -- destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + ++ rewrite EQ in H. order. + ++ apply LR in GT. order. + + rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. + Qed. + + Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). + Proof. + intros p n m. + rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l. + Qed. + + Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. + Proof. + intros n m p H1 H2. le_elim H1. + - le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_pos_l. + + apply eq_le_incl; now rewrite H2. + - apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. + Qed. + + Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. + Proof. + intros n m p H1 H2. le_elim H1. + - le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_neg_l. + + apply eq_le_incl; now rewrite H2. + - apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. + Qed. + + Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. + Proof. + intros n m p H1 H2; + rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l. + Qed. + + Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p. + Proof. + intros n m p H1 H2; + rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l. + Qed. + + Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m). + Proof. + intros n m p Hp; split; intro H; [|now f_equiv]. + apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp]; + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + - apply (mul_lt_mono_neg_l p) in LT; order. + - apply (mul_lt_mono_neg_l p) in GT; order. + - apply (mul_lt_mono_pos_l p) in LT; order. + - apply (mul_lt_mono_pos_l p) in GT; order. + Qed. + + Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). + Proof. + intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l. + Qed. + + Lemma mul_reg_l n m p : p ~= 0 -> p * n == p * m -> n == m. + Proof. + exact (fun Hp => proj1 (mul_cancel_l n m p Hp)). + Qed. + + Lemma mul_reg_r n m p : p ~= 0 -> n * p == m * p -> n == m. + Proof. + exact (fun Hp => proj1 (mul_cancel_r n m p Hp)). + Qed. + + Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1). + Proof. + intros n m H. + stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r. + Qed. + + Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1). + Proof. + intros n m; rewrite mul_comm; apply mul_id_l. + Qed. + + Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m). + Proof. + intros n m p H; do 2 rewrite lt_eq_cases. + rewrite (mul_lt_mono_pos_l p n m) by assumption. + now rewrite -> (mul_cancel_l n m p) by + (intro H1; rewrite H1 in H; false_hyp H lt_irrefl). + Qed. + + Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p). + Proof. + intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l. + Qed. + + Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n). + Proof. + intros n m p H; do 2 rewrite lt_eq_cases. + rewrite (mul_lt_mono_neg_l p n m); [| assumption]. + rewrite -> (mul_cancel_l m n p) + by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl). + now setoid_replace (n == m) with (m == n) by (split; now intro). + Qed. + + Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p). + Proof. + intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l. + Qed. + + Theorem mul_lt_mono_nonneg : + forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. + Proof. + intros n m p q H1 H2 H3 H4. + apply le_lt_trans with (m * p). + - apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. + - apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. + Qed. + + (* There are still many variants of the theorem above. One can assume 0 < n or 0 < p or n <= m or p <= q. *) -Theorem mul_le_mono_nonneg : - forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. -Proof. -intros n m p q H1 H2 H3 H4. -le_elim H2; le_elim H4. -- apply lt_le_incl; now apply mul_lt_mono_nonneg. -- rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -- rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. -- rewrite H2; rewrite H4; now apply eq_le_incl. -Qed. - -Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. -Proof. -intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r. -Qed. - -Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m. -Proof. -intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. -Qed. - -Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0. -Proof. -intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. -Qed. - -Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0. -Proof. -intros; rewrite mul_comm; now apply mul_pos_neg. -Qed. - -Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m. -Proof. -intros n m Hn Hm. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. -Qed. - -Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m). -Proof. -intros n m Hn. rewrite <- (mul_0_r n) at 1. - symmetry. now apply mul_lt_mono_pos_l. -Qed. - -Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n). -Proof. -intros n m Hn. rewrite <- (mul_0_l m) at 1. - symmetry. now apply mul_lt_mono_pos_r. -Qed. - -Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m). -Proof. -intros n m Hn. rewrite <- (mul_0_r n) at 1. - symmetry. now apply mul_le_mono_pos_l. -Qed. - -Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n). -Proof. -intros n m Hn. rewrite <- (mul_0_l m) at 1. - symmetry. now apply mul_le_mono_pos_r. -Qed. - -Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. -Proof. -intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. -- rewrite mul_1_l in H1. now apply lt_1_l with m. -- assumption. -Qed. - -Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. -Proof. -intros n m; split. -- intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; - destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; - try (now right); try (now left). - + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. - + exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. - + exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. - + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. -- intros [H | H]. + now rewrite H, mul_0_l. + now rewrite H, mul_0_r. -Qed. - -Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. -Proof. -intros n m; split; intro H. -- intro H1; apply eq_mul_0 in H1. tauto. -- split; intro H1; rewrite H1 in H; - (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. -Qed. - -Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. -Proof. -intro n; rewrite eq_mul_0; tauto. -Qed. - -Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. -Proof. -intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -- assumption. - false_hyp H1 H2. -Qed. - -Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. -Proof. -intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -- false_hyp H1 H2. - assumption. -Qed. - -(* Some alternative names: *) - -Notation mul_eq_0 := eq_mul_0. -Notation mul_eq_0_l := eq_mul_0_l. -Notation mul_eq_0_r := eq_mul_0_r. - -Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). -Proof. -split; [intro H | intros [[H1 H2] | [H1 H2]]]. -- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; - [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; - (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; - [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); - try (left; now split); try (right; now split). - + assert (H3 : n * m < 0) by now apply mul_neg_pos. - exfalso; now apply (lt_asymm (n * m) 0). - + assert (H3 : n * m < 0) by now apply mul_pos_neg. - exfalso; now apply (lt_asymm (n * m) 0). -- now apply mul_pos_pos. - now apply mul_neg_neg. -Qed. - -Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. -Proof. -intros n m H1 H2. now apply mul_lt_mono_nonneg. -Qed. - -Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m. -Proof. -intros n m H1 H2. now apply mul_le_mono_nonneg. -Qed. - -(* The converse theorems require nonnegativity (or nonpositivity) of the + Theorem mul_le_mono_nonneg : + forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. + Proof. + intros n m p q H1 H2 H3 H4. + le_elim H2; le_elim H4. + - apply lt_le_incl; now apply mul_lt_mono_nonneg. + - rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. + - rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. + - rewrite H2; rewrite H4; now apply eq_le_incl. + Qed. + + Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. + Proof. + intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r. + Qed. + + Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m. + Proof. + intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. + Qed. + + Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0. + Proof. + intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. + Qed. + + Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0. + Proof. + intros; rewrite mul_comm; now apply mul_pos_neg. + Qed. + + Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m. + Proof. + intros n m Hn Hm. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. + Qed. + + Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m). + Proof. + intros n m Hn. rewrite <- (mul_0_r n) at 1. + symmetry. now apply mul_lt_mono_pos_l. + Qed. + + Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n). + Proof. + intros n m Hn. rewrite <- (mul_0_l m) at 1. + symmetry. now apply mul_lt_mono_pos_r. + Qed. + + Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m). + Proof. + intros n m Hn. rewrite <- (mul_0_r n) at 1. + symmetry. now apply mul_le_mono_pos_l. + Qed. + + Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n). + Proof. + intros n m Hn. rewrite <- (mul_0_l m) at 1. + symmetry. now apply mul_le_mono_pos_r. + Qed. + + Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. + Proof. + intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. + - rewrite mul_1_l in H1. now apply lt_1_l with m. + - assumption. + Qed. + + Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. + Proof. + intros n m; split. + - intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + try (now right); try (now left). + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. + - intros [H | H]. + now rewrite H, mul_0_l. + now rewrite H, mul_0_r. + Qed. + + Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. + Proof. + intros n m; split; intro H. + - intro H1; apply eq_mul_0 in H1. tauto. + - split; intro H1; rewrite H1 in H; + (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. + Qed. + + Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. + Proof. + intro n; rewrite eq_mul_0; tauto. + Qed. + + Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. + Proof. + intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. + - assumption. - false_hyp H1 H2. + Qed. + + Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. + Proof. + intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. + - false_hyp H1 H2. - assumption. + Qed. + + (* Some alternative names: *) + + Notation mul_eq_0 := eq_mul_0. + Notation mul_eq_0_l := eq_mul_0_l. + Notation mul_eq_0_r := eq_mul_0_r. + + Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). + Proof. + split; [intro H | intros [[H1 H2] | [H1 H2]]]. + - destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; + (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); + try (left; now split); try (right; now split). + + assert (H3 : n * m < 0) by now apply mul_neg_pos. + exfalso; now apply (lt_asymm (n * m) 0). + + assert (H3 : n * m < 0) by now apply mul_pos_neg. + exfalso; now apply (lt_asymm (n * m) 0). + - now apply mul_pos_pos. - now apply mul_neg_neg. + Qed. + + Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. + Proof. + intros n m H1 H2. now apply mul_lt_mono_nonneg. + Qed. + + Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m. + Proof. + intros n m H1 H2. now apply mul_le_mono_nonneg. + Qed. + + (* The converse theorems require nonnegativity (or nonpositivity) of the other variable *) -Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. -Proof. -intros n m H1 H2. destruct (lt_ge_cases n 0). -- now apply lt_le_trans with 0. -- destruct (lt_ge_cases n m) as [LT|LE]; trivial. - apply square_le_mono_nonneg in LE; order. -Qed. - -Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. -Proof. -intros n m H1 H2. destruct (lt_ge_cases n 0). -- apply lt_le_incl; now apply lt_le_trans with 0. -- destruct (le_gt_cases n m) as [LE|LT]; trivial. - apply square_lt_mono_nonneg in LT; order. -Qed. - -Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m. -Proof. -intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two). -- rewrite two_succ. nzsimpl. now rewrite le_succ_l. -- order'. -Qed. - -Lemma add_le_mul : forall a b, 1 1 a+b <= a*b. -Proof. - assert (AUX : forall a b, 0 0 (S a)+(S b) <= (S a)*(S b)). - - intros a b Ha Hb. - nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. - rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). - apply add_lt_mono_r. - now apply mul_pos_pos. - - intros a b Ha Hb. - assert (Ha' := lt_succ_pred 1 a Ha). - assert (Hb' := lt_succ_pred 1 b Hb). - rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. -Qed. - -(** A few results about squares *) - -Lemma square_nonneg : forall a, 0 <= a * a. -Proof. - intro a. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). - - now apply mul_le_mono_nonpos_l. - - apply mul_le_mono_nonneg_l; order. -Qed. - -Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b. -Proof. - assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b). - - intros a b (Ha,H). - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. order. - - intros a b Ha Hb. - destruct (le_gt_cases a b). - + apply AUX; split; order. - + rewrite (add_comm (b*a)), (add_comm (a*a)). - apply AUX; split; order. -Qed. - -Lemma add_square_le : forall a b, 0<=a -> 0<=b -> - a*a + b*b <= (a+b)*(a+b). -Proof. - intros a b Ha Hb. - rewrite mul_add_distr_r, !mul_add_distr_l. - rewrite add_assoc. - apply add_le_mono_r. - rewrite <- add_assoc. - rewrite <- (add_0_r (a*a)) at 1. - apply add_le_mono_l. - apply add_nonneg_nonneg; now apply mul_nonneg_nonneg. -Qed. - -Lemma square_add_le : forall a b, 0<=a -> 0<=b -> - (a+b)*(a+b) <= 2*(a*a + b*b). -Proof. - intros a b Ha Hb. - rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. - rewrite <- !add_assoc. apply add_le_mono_l. - rewrite !add_assoc. apply add_le_mono_r. - apply crossmul_le_addsquare; order. -Qed. - -Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b -> - 2*2*a*b <= (a+b)*(a+b). -Proof. - intros a b Ha Hb. - nzsimpl'. - rewrite !mul_add_distr_l, !mul_add_distr_r. - rewrite (add_comm _ (b*b)), add_assoc. - apply add_le_mono_r. - rewrite (add_shuffle0 (a*a)), (mul_comm b a). - apply add_le_mono_r. - rewrite (mul_comm a b) at 1. - now apply crossmul_le_addsquare. -Qed. + Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. + Proof. + intros n m H1 H2. destruct (lt_ge_cases n 0). + - now apply lt_le_trans with 0. + - destruct (lt_ge_cases n m) as [LT|LE]; trivial. + apply square_le_mono_nonneg in LE; order. + Qed. + + Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. + Proof. + intros n m H1 H2. destruct (lt_ge_cases n 0). + - apply lt_le_incl; now apply lt_le_trans with 0. + - destruct (le_gt_cases n m) as [LE|LT]; trivial. + apply square_lt_mono_nonneg in LT; order. + Qed. + + Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m. + Proof. + intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two). + - rewrite two_succ. nzsimpl. now rewrite le_succ_l. + - order'. + Qed. + + Lemma add_le_mul : forall a b, 1 1 a+b <= a*b. + Proof. + assert (AUX : forall a b, 0 0 (S a)+(S b) <= (S a)*(S b)). + - intros a b Ha Hb. + nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. + rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). + apply add_lt_mono_r. + now apply mul_pos_pos. + - intros a b Ha Hb. + assert (Ha' := lt_succ_pred 1 a Ha). + assert (Hb' := lt_succ_pred 1 b Hb). + rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. + Qed. + + (** A few results about squares *) + + Lemma square_nonneg : forall a, 0 <= a * a. + Proof. + intro a. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). + - now apply mul_le_mono_nonpos_l. + - apply mul_le_mono_nonneg_l; order. + Qed. + + Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b. + Proof. + assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b). + - intros a b (Ha,H). + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. order. + - intros a b Ha Hb. + destruct (le_gt_cases a b). + + apply AUX; split; order. + + rewrite (add_comm (b*a)), (add_comm (a*a)). + apply AUX; split; order. + Qed. + + Lemma add_square_le : forall a b, 0<=a -> 0<=b -> + a*a + b*b <= (a+b)*(a+b). + Proof. + intros a b Ha Hb. + rewrite mul_add_distr_r, !mul_add_distr_l. + rewrite add_assoc. + apply add_le_mono_r. + rewrite <- add_assoc. + rewrite <- (add_0_r (a*a)) at 1. + apply add_le_mono_l. + apply add_nonneg_nonneg; now apply mul_nonneg_nonneg. + Qed. + + Lemma square_add_le : forall a b, 0<=a -> 0<=b -> + (a+b)*(a+b) <= 2*(a*a + b*b). + Proof. + intros a b Ha Hb. + rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. + rewrite <- !add_assoc. apply add_le_mono_l. + rewrite !add_assoc. apply add_le_mono_r. + apply crossmul_le_addsquare; order. + Qed. + + Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b -> + 2*2*a*b <= (a+b)*(a+b). + Proof. + intros a b Ha Hb. + nzsimpl'. + rewrite !mul_add_distr_l, !mul_add_distr_r. + rewrite (add_comm _ (b*b)), add_assoc. + apply add_le_mono_r. + rewrite (add_shuffle0 (a*a)), (mul_comm b a). + apply add_le_mono_r. + rewrite (mul_comm a b) at 1. + now apply crossmul_le_addsquare. + Qed. End NZMulOrderProp. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 722e607a01..69646a6b87 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -35,637 +35,637 @@ From Stdlib.Logic Require Import Decidable. From Stdlib.Structures Require Import OrdersTac. Module Type NZOrderProp - (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ). - -(** ** Basic facts about [le], [lt], [eq] and [succ] *) - -(** *** Direct consequences of the specifications of [lt] and [le] *) -#[global] -Instance le_wd : Proper (eq==>eq==>iff) le. -Proof. -intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm. -Qed. - -Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H]. - -Theorem lt_le_incl : forall n m, n < m -> n <= m. -Proof. -intros. apply lt_eq_cases. now left. -Qed. - -Theorem le_refl : forall n, n <= n. -Proof. -intro. apply lt_eq_cases. now right. -Qed. - -Theorem lt_succ_diag_r : forall n, n < S n. -Proof. -intro n. rewrite lt_succ_r. apply le_refl. -Qed. - -Theorem le_succ_diag_r : forall n, n <= S n. -Proof. -intro; apply lt_le_incl; apply lt_succ_diag_r. -Qed. - -Theorem neq_succ_diag_l : forall n, S n ~= n. -Proof. -intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r. -Qed. - -Theorem neq_succ_diag_r : forall n, n ~= S n. -Proof. -intro n; apply neq_sym, neq_succ_diag_l. -Qed. - -Theorem nlt_succ_diag_l : forall n, ~ S n < n. -Proof. -intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl. -Qed. - -Theorem nle_succ_diag_l : forall n, ~ S n <= n. -Proof. -intros n H; le_elim H. -+ false_hyp H nlt_succ_diag_l. + false_hyp H neq_succ_diag_l. -Qed. - -Theorem le_succ_l : forall n m, S n <= m <-> n < m. -Proof. -intros n m; nzinduct m n. -- split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. -- intro m. - rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. - rewrite or_cancel_r. - + reflexivity. - + intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. - + intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. -Qed. - -(** Trichotomy *) - -Theorem le_gt_cases : forall n m, n <= m \/ n > m. -Proof. -intros n m; nzinduct n m. -- left; apply le_refl. -- intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition auto with relations. -Qed. - -Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. -Proof. -intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto. -Qed. - -Notation lt_eq_gt_cases := lt_trichotomy (only parsing). - -(** *** Asymmetry and transitivity. *) - -Theorem lt_asymm : forall n m, n < m -> ~ m < n. -Proof. -intros n m; nzinduct n m. -- intros H; false_hyp H lt_irrefl. -- intro n; split; intros H H1 H2. - + apply lt_succ_r in H2. le_elim H2. - * apply H; auto. apply le_succ_l. now apply lt_le_incl. - * rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. - + apply le_succ_l in H1. le_elim H1. - * apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. - * rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. -Qed. - -Notation lt_ngt := lt_asymm (only parsing). - -Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. -Proof. -intros n m p; nzinduct p m. -- intros _ H; false_hyp H lt_irrefl. -- intro p. rewrite 2 lt_succ_r. - split; intros H H1 H2. - + apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. - + assert (n <= p) as H3 by (auto using lt_le_incl). - le_elim H3. - * assumption. - * rewrite <- H3 in H2. - elim (lt_asymm n m); auto. -Qed. - -Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. -Proof. -intros n m p. rewrite 3 lt_eq_cases. -intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ'; - generalize (lt_trans n m p); auto with relations. -Qed. - -(** *** Some type classes about order *) - -#[global] -Instance lt_strorder : StrictOrder lt. -Proof. split. - exact lt_irrefl. - exact lt_trans. Qed. - -#[global] -Instance le_preorder : PreOrder le. -Proof. split. - exact le_refl. - exact le_trans. Qed. - -#[global] -Instance le_partialorder : PartialOrder _ le. -Proof. -intros x y. compute. split. -- intro EQ; now rewrite EQ. -- rewrite 2 lt_eq_cases. intuition auto with relations. elim (lt_irrefl x). now transitivity y. -Qed. - -(** *** Making the generic [order] tactic *) - -Definition lt_compat := lt_wd. -Definition lt_total := lt_trichotomy. -Definition le_lteq := lt_eq_cases. - -Module Private_OrderTac. -Module IsTotal. - Definition eq_equiv := eq_equiv. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition lt_total := lt_total. - Definition le_lteq := le_lteq. -End IsTotal. -Module Tac := !MakeOrderTac NZ IsTotal. -End Private_OrderTac. -Ltac order := Private_OrderTac.Tac.order. - -(** *** Some direct consequences of [order] *) - -Theorem lt_neq : forall n m, n < m -> n ~= m. -Proof. order. Qed. - -Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m. -Proof. intuition order. Qed. - -Theorem eq_le_incl : forall n m, n == m -> n <= m. -Proof. order. Qed. - -Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y. -Proof. order. Qed. - -Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z. -Proof. order. Qed. - -Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y. -Proof. order. Qed. - -Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z. -Proof. order. Qed. - -Declare Left Step lt_stepl. -Declare Right Step lt_stepr. -Declare Left Step le_stepl. -Declare Right Step le_stepr. - -Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p. -Proof. order. Qed. - -Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p. -Proof. order. Qed. - -Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m. -Proof. order. Qed. - -(** *** More properties of [<] and [<=] with respect to [S] and [0] *) - -Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m. -Proof. -intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r. -Qed. - -Theorem lt_succ_l : forall n m, S n < m -> n < m. -Proof. -intros n m H; apply le_succ_l; order. -Qed. - -Theorem le_le_succ_r : forall n m, n <= m -> n <= S m. -Proof. -intros n m LE. apply lt_succ_r in LE. order. -Qed. - -Theorem lt_lt_succ_r : forall n m, n < m -> n < S m. -Proof. -intros. rewrite lt_succ_r. order. -Qed. - -Theorem succ_lt_mono : forall n m, n < m <-> S n < S m. -Proof. -intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r. -Qed. + (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ). + + (** ** Basic facts about [le], [lt], [eq] and [succ] *) + + (** *** Direct consequences of the specifications of [lt] and [le] *) + #[global] + Instance le_wd : Proper (eq==>eq==>iff) le. + Proof. + intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm. + Qed. + + Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H]. + + Theorem lt_le_incl : forall n m, n < m -> n <= m. + Proof. + intros. apply lt_eq_cases. now left. + Qed. + + Theorem le_refl : forall n, n <= n. + Proof. + intro. apply lt_eq_cases. now right. + Qed. + + Theorem lt_succ_diag_r : forall n, n < S n. + Proof. + intro n. rewrite lt_succ_r. apply le_refl. + Qed. + + Theorem le_succ_diag_r : forall n, n <= S n. + Proof. + intro; apply lt_le_incl; apply lt_succ_diag_r. + Qed. + + Theorem neq_succ_diag_l : forall n, S n ~= n. + Proof. + intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r. + Qed. + + Theorem neq_succ_diag_r : forall n, n ~= S n. + Proof. + intro n; apply neq_sym, neq_succ_diag_l. + Qed. + + Theorem nlt_succ_diag_l : forall n, ~ S n < n. + Proof. + intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl. + Qed. + + Theorem nle_succ_diag_l : forall n, ~ S n <= n. + Proof. + intros n H; le_elim H. + + false_hyp H nlt_succ_diag_l. + false_hyp H neq_succ_diag_l. + Qed. + + Theorem le_succ_l : forall n m, S n <= m <-> n < m. + Proof. + intros n m; nzinduct m n. + - split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. + - intro m. + rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. + rewrite or_cancel_r. + + reflexivity. + + intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. + + intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. + Qed. + + (** Trichotomy *) + + Theorem le_gt_cases : forall n m, n <= m \/ n > m. + Proof. + intros n m; nzinduct n m. + - left; apply le_refl. + - intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition auto with relations. + Qed. + + Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. + Proof. + intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto. + Qed. + + Notation lt_eq_gt_cases := lt_trichotomy (only parsing). + + (** *** Asymmetry and transitivity. *) + + Theorem lt_asymm : forall n m, n < m -> ~ m < n. + Proof. + intros n m; nzinduct n m. + - intros H; false_hyp H lt_irrefl. + - intro n; split; intros H H1 H2. + + apply lt_succ_r in H2. le_elim H2. + * apply H; auto. apply le_succ_l. now apply lt_le_incl. + * rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. + + apply le_succ_l in H1. le_elim H1. + * apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. + * rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. + Qed. + + Notation lt_ngt := lt_asymm (only parsing). + + Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. + Proof. + intros n m p; nzinduct p m. + - intros _ H; false_hyp H lt_irrefl. + - intro p. rewrite 2 lt_succ_r. + split; intros H H1 H2. + + apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. + + assert (n <= p) as H3 by (auto using lt_le_incl). + le_elim H3. + * assumption. + * rewrite <- H3 in H2. + elim (lt_asymm n m); auto. + Qed. + + Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. + Proof. + intros n m p. rewrite 3 lt_eq_cases. + intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ'; + generalize (lt_trans n m p); auto with relations. + Qed. + + (** *** Some type classes about order *) + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. split. - exact lt_irrefl. - exact lt_trans. Qed. + + #[global] + Instance le_preorder : PreOrder le. + Proof. split. - exact le_refl. - exact le_trans. Qed. + + #[global] + Instance le_partialorder : PartialOrder _ le. + Proof. + intros x y. compute. split. + - intro EQ; now rewrite EQ. + - rewrite 2 lt_eq_cases. intuition auto with relations. elim (lt_irrefl x). now transitivity y. + Qed. + + (** *** Making the generic [order] tactic *) + + Definition lt_compat := lt_wd. + Definition lt_total := lt_trichotomy. + Definition le_lteq := lt_eq_cases. + + Module Private_OrderTac. + Module IsTotal. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Definition le_lteq := le_lteq. + End IsTotal. + Module Tac := !MakeOrderTac NZ IsTotal. + End Private_OrderTac. + Ltac order := Private_OrderTac.Tac.order. + + (** *** Some direct consequences of [order] *) + + Theorem lt_neq : forall n m, n < m -> n ~= m. + Proof. order. Qed. + + Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m. + Proof. intuition order. Qed. + + Theorem eq_le_incl : forall n m, n == m -> n <= m. + Proof. order. Qed. + + Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y. + Proof. order. Qed. + + Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z. + Proof. order. Qed. + + Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y. + Proof. order. Qed. + + Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z. + Proof. order. Qed. + + Declare Left Step lt_stepl. + Declare Right Step lt_stepr. + Declare Left Step le_stepl. + Declare Right Step le_stepr. + + Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p. + Proof. order. Qed. + + Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p. + Proof. order. Qed. + + Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m. + Proof. order. Qed. + + (** *** More properties of [<] and [<=] with respect to [S] and [0] *) + + Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m. + Proof. + intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r. + Qed. + + Theorem lt_succ_l : forall n m, S n < m -> n < m. + Proof. + intros n m H; apply le_succ_l; order. + Qed. + + Theorem le_le_succ_r : forall n m, n <= m -> n <= S m. + Proof. + intros n m LE. apply lt_succ_r in LE. order. + Qed. + + Theorem lt_lt_succ_r : forall n m, n < m -> n < S m. + Proof. + intros. rewrite lt_succ_r. order. + Qed. + + Theorem succ_lt_mono : forall n m, n < m <-> S n < S m. + Proof. + intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r. + Qed. -Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m. -Proof. -intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd. -Qed. + Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m. + Proof. + intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd. + Qed. -Theorem lt_0_1 : 0 < 1. -Proof. -rewrite one_succ. apply lt_succ_diag_r. -Qed. + Theorem lt_0_1 : 0 < 1. + Proof. + rewrite one_succ. apply lt_succ_diag_r. + Qed. -Theorem le_0_1 : 0 <= 1. -Proof. -apply lt_le_incl, lt_0_1. -Qed. + Theorem le_0_1 : 0 <= 1. + Proof. + apply lt_le_incl, lt_0_1. + Qed. -Theorem lt_1_2 : 1 < 2. -Proof. -rewrite two_succ. apply lt_succ_diag_r. -Qed. + Theorem lt_1_2 : 1 < 2. + Proof. + rewrite two_succ. apply lt_succ_diag_r. + Qed. -Theorem lt_0_2 : 0 < 2. -Proof. - transitivity 1. - apply lt_0_1. - apply lt_1_2. -Qed. + Theorem lt_0_2 : 0 < 2. + Proof. + transitivity 1. - apply lt_0_1. - apply lt_1_2. + Qed. -Theorem le_0_2 : 0 <= 2. -Proof. -apply lt_le_incl, lt_0_2. -Qed. + Theorem le_0_2 : 0 <= 2. + Proof. + apply lt_le_incl, lt_0_2. + Qed. -(** The order tactic enriched with some knowledge of 0,1,2 *) + (** The order tactic enriched with some knowledge of 0,1,2 *) -Ltac order' := generalize lt_0_1 lt_1_2; order. + Ltac order' := generalize lt_0_1 lt_1_2; order. -Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m. -Proof. -intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order. -Qed. + Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m. + Proof. + intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order. + Qed. -(** *** More Trichotomy, decidability and double negation elimination *) + (** *** More Trichotomy, decidability and double negation elimination *) -(** The following theorem is cleary redundant, but helps not to + (** The following theorem is cleary redundant, but helps not to remember whether one has to say [le_gt_cases] or [lt_ge_cases]. *) -Theorem lt_ge_cases : forall n m, n < m \/ n >= m. -Proof. -intros n m; destruct (le_gt_cases m n); intuition order. -Qed. + Theorem lt_ge_cases : forall n m, n < m \/ n >= m. + Proof. + intros n m; destruct (le_gt_cases m n); intuition order. + Qed. -Theorem le_ge_cases : forall n m, n <= m \/ n >= m. -Proof. -intros n m; destruct (le_gt_cases n m); intuition order. -Qed. + Theorem le_ge_cases : forall n m, n <= m \/ n >= m. + Proof. + intros n m; destruct (le_gt_cases n m); intuition order. + Qed. -Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m. -Proof. -intros n m; destruct (lt_trichotomy n m); intuition order. -Qed. + Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m. + Proof. + intros n m; destruct (lt_trichotomy n m); intuition order. + Qed. -(** Decidability of equality, even though true in each finite ring, does not + (** Decidability of equality, even though true in each finite ring, does not have a uniform proof. Otherwise, the proof for two fixed numbers would reduce to a normal form that will say if the numbers are equal or not, which cannot be true in all finite rings. Therefore, we prove decidability in the presence of order. *) -Theorem eq_decidable : forall n m, decidable (n == m). -Proof. -intros n m; destruct (lt_trichotomy n m) as [ | [ | ]]; - (right; order) || (left; order). -Qed. + Theorem eq_decidable : forall n m, decidable (n == m). + Proof. + intros n m; destruct (lt_trichotomy n m) as [ | [ | ]]; + (right; order) || (left; order). + Qed. -(** DNE stands for double-negation elimination. *) + (** DNE stands for double-negation elimination. *) -Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. -Proof. -intros n m; split; intro H. -- destruct (eq_decidable n m) as [H1 | H1]. - + assumption. + false_hyp H1 H. -- intro H1; now apply H1. -Qed. + Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. + Proof. + intros n m; split; intro H. + - destruct (eq_decidable n m) as [H1 | H1]. + + assumption. + false_hyp H1 H. + - intro H1; now apply H1. + Qed. -Theorem le_ngt : forall n m, n <= m <-> ~ n > m. -Proof. intuition order. Qed. + Theorem le_ngt : forall n m, n <= m <-> ~ n > m. + Proof. intuition order. Qed. -(** Redundant but useful *) + (** Redundant but useful *) -Theorem nlt_ge : forall n m, ~ n < m <-> n >= m. -Proof. intuition order. Qed. + Theorem nlt_ge : forall n m, ~ n < m <-> n >= m. + Proof. intuition order. Qed. -Theorem lt_decidable : forall n m, decidable (n < m). -Proof. -intros n m; destruct (le_gt_cases m n); [right|left]; order. -Qed. + Theorem lt_decidable : forall n m, decidable (n < m). + Proof. + intros n m; destruct (le_gt_cases m n); [right|left]; order. + Qed. -Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. -Proof. -intros n m; split; intro H. -- destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -- intro H1; false_hyp H H1. -Qed. + Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. + Proof. + intros n m; split; intro H. + - destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. + - intro H1; false_hyp H H1. + Qed. -Theorem nle_gt : forall n m, ~ n <= m <-> n > m. -Proof. intuition order. Qed. + Theorem nle_gt : forall n m, ~ n <= m <-> n > m. + Proof. intuition order. Qed. -(** Redundant but useful *) + (** Redundant but useful *) -Theorem lt_nge : forall n m, n < m <-> ~ n >= m. -Proof. intuition order. Qed. + Theorem lt_nge : forall n m, n < m <-> ~ n >= m. + Proof. intuition order. Qed. -Theorem le_decidable : forall n m, decidable (n <= m). -Proof. -intros n m; destruct (le_gt_cases n m); [left|right]; order. -Qed. + Theorem le_decidable : forall n m, decidable (n <= m). + Proof. + intros n m; destruct (le_gt_cases n m); [left|right]; order. + Qed. -Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. -Proof. -intros n m; split; intro H. -- destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -- intro H1; false_hyp H H1. -Qed. + Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. + Proof. + intros n m; split; intro H. + - destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. + - intro H1; false_hyp H H1. + Qed. -Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. -Proof. -intros n m; rewrite lt_succ_r. intuition order. -Qed. + Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. + Proof. + intros n m; rewrite lt_succ_r. intuition order. + Qed. -(** The difference between integers and natural numbers is that for + (** The difference between integers and natural numbers is that for every integer there is a predecessor, which is not true for natural numbers. However, for both classes, every number that is bigger than some other number has a predecessor. The proof of this fact by regular induction does not go through, so we need to use strong (course-of-value) induction. *) -Theorem lt_exists_pred : - forall z n, z < n -> exists k, n == S k /\ z <= k. -Proof. -intros z n Hzn. assert (exists m, n <= m) as [m Hnm] by now exists n. -revert n Hzn Hnm. nzinduct m z. -- order. -- intro m; split; intros IH n H1 H2. - + apply le_succ_r in H2. destruct H2 as [H2 | H2]. - * now apply IH. * exists m. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. - + apply IH. * assumption. * now apply le_le_succ_r. -Qed. - -Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n. -Proof. - intros z n H. - destruct (lt_exists_pred _ _ H) as (n' & EQ & LE). - rewrite EQ. now rewrite pred_succ. -Qed. - -(** ** Order-based induction principles *) - -Section WF. - -Variable z : t. - -Let Rlt (n m : t) := z <= n < m. -Let Rgt (n m : t) := m < n <= z. - -Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt. -Proof. -intros x1 x2 H1 x3 x4 H2; unfold Rlt. now rewrite H1, H2. -Qed. - -Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt. -Proof. -intros x1 x2 H1 x3 x4 H2; unfold Rgt; now rewrite H1, H2. -Qed. - -Theorem lt_wf : well_founded Rlt. -Proof. -intros a. constructor. revert a. -refine (central_induction _ _ z _ _). -- solve_proper. -- intros y [??]. order. -- intros x. split. - + intros IH y [? [? | ->]%lt_succ_r%lt_eq_cases]. - * now apply IH. - * now constructor. - + intros IH y [? ?%lt_lt_succ_r]. now apply IH. -Qed. - -Theorem gt_wf : well_founded Rgt. -Proof. -intros a. constructor. revert a. -refine (central_induction _ _ z _ _). -- solve_proper. -- intros y [??]. order. -- intros x. split. - + intros IH y [?%lt_succ_l ?]. now apply IH. - + intros IH y [[? | <-]%le_succ_l%lt_eq_cases ?]. - * now apply IH. - * now constructor. -Qed. - -End WF. - -(** Stronger variant of induction with assumptions [n >= 0] ([n < 0]) + Theorem lt_exists_pred : + forall z n, z < n -> exists k, n == S k /\ z <= k. + Proof. + intros z n Hzn. assert (exists m, n <= m) as [m Hnm] by now exists n. + revert n Hzn Hnm. nzinduct m z. + - order. + - intro m; split; intros IH n H1 H2. + + apply le_succ_r in H2. destruct H2 as [H2 | H2]. + * now apply IH. * exists m. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. + + apply IH. * assumption. * now apply le_le_succ_r. + Qed. + + Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n. + Proof. + intros z n H. + destruct (lt_exists_pred _ _ H) as (n' & EQ & LE). + rewrite EQ. now rewrite pred_succ. + Qed. + + (** ** Order-based induction principles *) + + Section WF. + + Variable z : t. + + Let Rlt (n m : t) := z <= n < m. + Let Rgt (n m : t) := m < n <= z. + + Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt. + Proof. + intros x1 x2 H1 x3 x4 H2; unfold Rlt. now rewrite H1, H2. + Qed. + + Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt. + Proof. + intros x1 x2 H1 x3 x4 H2; unfold Rgt; now rewrite H1, H2. + Qed. + + Theorem lt_wf : well_founded Rlt. + Proof. + intros a. constructor. revert a. + refine (central_induction _ _ z _ _). + - solve_proper. + - intros y [??]. order. + - intros x. split. + + intros IH y [? [? | ->]%lt_succ_r%lt_eq_cases]. + * now apply IH. + * now constructor. + + intros IH y [? ?%lt_lt_succ_r]. now apply IH. + Qed. + + Theorem gt_wf : well_founded Rgt. + Proof. + intros a. constructor. revert a. + refine (central_induction _ _ z _ _). + - solve_proper. + - intros y [??]. order. + - intros x. split. + + intros IH y [?%lt_succ_l ?]. now apply IH. + + intros IH y [[? | <-]%le_succ_l%lt_eq_cases ?]. + * now apply IH. + * now constructor. + Qed. + + End WF. + + (** Stronger variant of induction with assumptions [n >= 0] ([n < 0]) in the induction step *) -Section Induction. - -Variable A : t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. - -Section Center. - -Variable z : t. (* A z is the basis of induction *) - -Section RightInduction. - -Let A' (n : t) := forall m, z <= m -> m < n -> A m. -Let right_step := forall n, z <= n -> A n -> A (S n). -Let right_step' := forall n, z <= n -> A' n -> A n. -Let right_step'' := forall n, A' n <-> A' (S n). - -Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n. -Proof. -intros Hstep. refine (well_founded_induction (lt_wf z) _ _). -intros x IH Hzx. apply Hstep; [trivial|]. -intros y ??. apply IH; [split|]; order. -Qed. - -Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n. -Proof. -intros Az RS; apply strong_right_induction. -intros n H1 H2. -le_elim H1. -- apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. - rewrite H3. apply RS; trivial. apply H2; trivial. - rewrite H3; apply lt_succ_diag_r. -- rewrite <- H1; apply Az. -Qed. - -Theorem right_induction' : - (forall n, n <= z -> A n) -> right_step -> forall n, A n. -Proof. -intros L R n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply L; now apply lt_le_incl. -- apply L; now apply eq_le_incl. -- apply right_induction. - + apply L; now apply eq_le_incl. - + assumption. - + now apply lt_le_incl. -Qed. - -Theorem strong_right_induction' : - (forall n, n <= z -> A n) -> right_step' -> forall n, A n. -Proof. -intros L R n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply L; now apply lt_le_incl. -- apply L; now apply eq_le_incl. -- apply strong_right_induction. - + assumption. + now apply lt_le_incl. -Qed. - -End RightInduction. - -Section LeftInduction. - -Let A' (n : t) := forall m, m <= z -> n <= m -> A m. -Let left_step := forall n, n < z -> A (S n) -> A n. -Let left_step' := forall n, n <= z -> A' (S n) -> A n. -Let left_step'' := forall n, A' n <-> A' (S n). - -Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. -Proof. -intros Hstep. refine (well_founded_induction (gt_wf z) _ _). -intros x IH Hzx. apply Hstep; [trivial|]. -intros y ? ?%le_succ_l. apply IH; [split|]; order. -Qed. - -Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n. -Proof. -intros Az LS; apply strong_left_induction. -intros n H1 H2. le_elim H1. -- apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. -- rewrite H1; apply Az. -Qed. - -Theorem left_induction' : - (forall n, z <= n -> A n) -> left_step -> forall n, A n. -Proof. -intros R L n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply left_induction. - + apply R. now apply eq_le_incl. - + assumption. - + now apply lt_le_incl. -- rewrite H; apply R; now apply eq_le_incl. -- apply R; now apply lt_le_incl. -Qed. - -Theorem strong_left_induction' : - (forall n, z <= n -> A n) -> left_step' -> forall n, A n. -Proof. -intros R L n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply strong_left_induction. - + trivial. + now apply lt_le_incl. -- rewrite H; apply R; now apply eq_le_incl. -- apply R; now apply lt_le_incl. -Qed. - -End LeftInduction. - -Theorem order_induction : - A z -> - (forall n, z <= n -> A n -> A (S n)) -> - (forall n, n < z -> A (S n) -> A n) -> - forall n, A n. -Proof. -intros Az RS LS n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- now apply left_induction; [| | apply lt_le_incl]. -- now rewrite H. -- now apply right_induction; [| | apply lt_le_incl]. -Qed. - -Theorem order_induction' : - A z -> - (forall n, z <= n -> A n -> A (S n)) -> - (forall n, n <= z -> A n -> A (P n)) -> - forall n, A n. -Proof. -intros Az AS AP n; apply order_induction; try assumption. -intros m H1 H2. apply AP in H2; [|now apply le_succ_l]. -now rewrite pred_succ in H2. -Qed. - -End Center. - -Theorem order_induction_0 : - A 0 -> - (forall n, 0 <= n -> A n -> A (S n)) -> - (forall n, n < 0 -> A (S n) -> A n) -> - forall n, A n. -Proof. exact (order_induction 0). Qed. - -Theorem order_induction'_0 : - A 0 -> - (forall n, 0 <= n -> A n -> A (S n)) -> - (forall n, n <= 0 -> A n -> A (P n)) -> - forall n, A n. -Proof. exact (order_induction' 0). Qed. - -(** Elimination principle for [<] *) - -Theorem lt_ind : forall (n : t), - A (S n) -> - (forall m, n < m -> A m -> A (S m)) -> - forall m, n < m -> A m. -Proof. -intros n H1 H2 m H3. -apply right_induction with (S n); [assumption | | now apply le_succ_l]. -intros; apply H2; try assumption. now apply le_succ_l. -Qed. - -(** Elimination principle for [<=] *) - -Theorem le_ind : forall (n : t), - A n -> - (forall m, n <= m -> A m -> A (S m)) -> - forall m, n <= m -> A m. -Proof. -intros n H1 H2 m H3. -now apply right_induction with n. -Qed. - -End Induction. - -Tactic Notation "nzord_induct" ident(n) := - induction_maker n ltac:(apply order_induction_0). - -Tactic Notation "nzord_induct" ident(n) constr(z) := - induction_maker n ltac:(apply order_induction with z). - -(** Induction principles with respect to a measure *) - -Section MeasureInduction. - -Variable X : Type. -Variable f : X -> t. - -Theorem measure_right_induction : forall (A : X -> Type) (z : t), - (forall x, z <= f x -> (forall y, z <= f y < f x -> A y) -> A x) -> - forall x, z <= f x -> A x. -Proof. - intros A z IH x Hx. - enough (H : forall y, f y = f x -> A y) by now apply H. - induction (lt_wf z (f x)) as [n _ IH']. - intros y Hy. subst n. apply (IH y Hx). - intros y' Hy'. now apply (IH' _ Hy'). -Defined. - -Lemma measure_left_induction : forall (A : X -> Type) (z : t), - (forall x, f x <= z -> (forall y, f x < f y <= z -> A y) -> A x) -> - forall x, f x <= z -> A x. -Proof. - intros A z IH x Hx. - enough (H : forall y, f y = f x -> A y) by now apply H. - induction (gt_wf z (f x)) as [n _ IH']. - intros y Hy. subst n. apply (IH y Hx). - intros y' Hy'. now apply (IH' _ Hy'). -Defined. - -End MeasureInduction. + Section Induction. + + Variable A : t -> Prop. + Hypothesis A_wd : Proper (eq==>iff) A. + + Section Center. + + Variable z : t. (* A z is the basis of induction *) + + Section RightInduction. + + Let A' (n : t) := forall m, z <= m -> m < n -> A m. + Let right_step := forall n, z <= n -> A n -> A (S n). + Let right_step' := forall n, z <= n -> A' n -> A n. + Let right_step'' := forall n, A' n <-> A' (S n). + + Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n. + Proof. + intros Hstep. refine (well_founded_induction (lt_wf z) _ _). + intros x IH Hzx. apply Hstep; [trivial|]. + intros y ??. apply IH; [split|]; order. + Qed. + + Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n. + Proof. + intros Az RS; apply strong_right_induction. + intros n H1 H2. + le_elim H1. + - apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. + rewrite H3. apply RS; trivial. apply H2; trivial. + rewrite H3; apply lt_succ_diag_r. + - rewrite <- H1; apply Az. + Qed. + + Theorem right_induction' : + (forall n, n <= z -> A n) -> right_step -> forall n, A n. + Proof. + intros L R n. + destruct (lt_trichotomy n z) as [H | [H | H]]. + - apply L; now apply lt_le_incl. + - apply L; now apply eq_le_incl. + - apply right_induction. + + apply L; now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. + Qed. + + Theorem strong_right_induction' : + (forall n, n <= z -> A n) -> right_step' -> forall n, A n. + Proof. + intros L R n. + destruct (lt_trichotomy n z) as [H | [H | H]]. + - apply L; now apply lt_le_incl. + - apply L; now apply eq_le_incl. + - apply strong_right_induction. + + assumption. + now apply lt_le_incl. + Qed. + + End RightInduction. + + Section LeftInduction. + + Let A' (n : t) := forall m, m <= z -> n <= m -> A m. + Let left_step := forall n, n < z -> A (S n) -> A n. + Let left_step' := forall n, n <= z -> A' (S n) -> A n. + Let left_step'' := forall n, A' n <-> A' (S n). + + Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. + Proof. + intros Hstep. refine (well_founded_induction (gt_wf z) _ _). + intros x IH Hzx. apply Hstep; [trivial|]. + intros y ? ?%le_succ_l. apply IH; [split|]; order. + Qed. + + Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n. + Proof. + intros Az LS; apply strong_left_induction. + intros n H1 H2. le_elim H1. + - apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. + - rewrite H1; apply Az. + Qed. + + Theorem left_induction' : + (forall n, z <= n -> A n) -> left_step -> forall n, A n. + Proof. + intros R L n. + destruct (lt_trichotomy n z) as [H | [H | H]]. + - apply left_induction. + + apply R. now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. + - rewrite H; apply R; now apply eq_le_incl. + - apply R; now apply lt_le_incl. + Qed. + + Theorem strong_left_induction' : + (forall n, z <= n -> A n) -> left_step' -> forall n, A n. + Proof. + intros R L n. + destruct (lt_trichotomy n z) as [H | [H | H]]. + - apply strong_left_induction. + + trivial. + now apply lt_le_incl. + - rewrite H; apply R; now apply eq_le_incl. + - apply R; now apply lt_le_incl. + Qed. + + End LeftInduction. + + Theorem order_induction : + A z -> + (forall n, z <= n -> A n -> A (S n)) -> + (forall n, n < z -> A (S n) -> A n) -> + forall n, A n. + Proof. + intros Az RS LS n. + destruct (lt_trichotomy n z) as [H | [H | H]]. + - now apply left_induction; [| | apply lt_le_incl]. + - now rewrite H. + - now apply right_induction; [| | apply lt_le_incl]. + Qed. + + Theorem order_induction' : + A z -> + (forall n, z <= n -> A n -> A (S n)) -> + (forall n, n <= z -> A n -> A (P n)) -> + forall n, A n. + Proof. + intros Az AS AP n; apply order_induction; try assumption. + intros m H1 H2. apply AP in H2; [|now apply le_succ_l]. + now rewrite pred_succ in H2. + Qed. + + End Center. + + Theorem order_induction_0 : + A 0 -> + (forall n, 0 <= n -> A n -> A (S n)) -> + (forall n, n < 0 -> A (S n) -> A n) -> + forall n, A n. + Proof. exact (order_induction 0). Qed. + + Theorem order_induction'_0 : + A 0 -> + (forall n, 0 <= n -> A n -> A (S n)) -> + (forall n, n <= 0 -> A n -> A (P n)) -> + forall n, A n. + Proof. exact (order_induction' 0). Qed. + + (** Elimination principle for [<] *) + + Theorem lt_ind : forall (n : t), + A (S n) -> + (forall m, n < m -> A m -> A (S m)) -> + forall m, n < m -> A m. + Proof. + intros n H1 H2 m H3. + apply right_induction with (S n); [assumption | | now apply le_succ_l]. + intros; apply H2; try assumption. now apply le_succ_l. + Qed. + + (** Elimination principle for [<=] *) + + Theorem le_ind : forall (n : t), + A n -> + (forall m, n <= m -> A m -> A (S m)) -> + forall m, n <= m -> A m. + Proof. + intros n H1 H2 m H3. + now apply right_induction with n. + Qed. + + End Induction. + + Tactic Notation "nzord_induct" ident(n) := + induction_maker n ltac:(apply order_induction_0). + + Tactic Notation "nzord_induct" ident(n) constr(z) := + induction_maker n ltac:(apply order_induction with z). + + (** Induction principles with respect to a measure *) + + Section MeasureInduction. + + Variable X : Type. + Variable f : X -> t. + + Theorem measure_right_induction : forall (A : X -> Type) (z : t), + (forall x, z <= f x -> (forall y, z <= f y < f x -> A y) -> A x) -> + forall x, z <= f x -> A x. + Proof. + intros A z IH x Hx. + enough (H : forall y, f y = f x -> A y) by now apply H. + induction (lt_wf z (f x)) as [n _ IH']. + intros y Hy. subst n. apply (IH y Hx). + intros y' Hy'. now apply (IH' _ Hy'). + Defined. + + Lemma measure_left_induction : forall (A : X -> Type) (z : t), + (forall x, f x <= z -> (forall y, f x < f y <= z -> A y) -> A x) -> + forall x, f x <= z -> A x. + Proof. + intros A z IH x Hx. + enough (H : forall y, f y = f x -> A y) by now apply H. + induction (gt_wf z (f x)) as [n _ IH']. + intros y Hy. subst n. apply (IH y Hx). + intros y' Hy'. now apply (IH' _ Hy'). + Defined. + + End MeasureInduction. End NZOrderProp. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index 3f6385e628..975cc46db3 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -13,271 +13,271 @@ From Stdlib Require Import Bool NZAxioms NZMulOrder. (** Parity functions *) Module Type NZParity (Import A : NZAxiomsSig'). - Parameter Inline even odd : t -> bool. - Definition Even n := exists m, n == 2*m. - Definition Odd n := exists m, n == 2*m+1. - Axiom even_spec : forall n, even n = true <-> Even n. - Axiom odd_spec : forall n, odd n = true <-> Odd n. + Parameter Inline even odd : t -> bool. + Definition Even n := exists m, n == 2*m. + Definition Odd n := exists m, n == 2*m+1. + Axiom even_spec : forall n, even n = true <-> Even n. + Axiom odd_spec : forall n, odd n = true <-> Odd n. End NZParity. Module Type NZParityProp - (Import A : NZOrdAxiomsSig') - (Import B : NZParity A) - (Import C : NZMulOrderProp A). - -(** Morphisms *) - -#[global] -Instance Even_wd : Proper (eq==>iff) Even. -Proof. unfold Even. solve_proper. Qed. - -#[global] -Instance Odd_wd : Proper (eq==>iff) Odd. -Proof. unfold Odd. solve_proper. Qed. - -#[global] -Instance even_wd : Proper (eq==>Logic.eq) even. -Proof. - intros x x' EQ. rewrite eq_iff_eq_true, 2 even_spec. now f_equiv. -Qed. - -#[global] -Instance odd_wd : Proper (eq==>Logic.eq) odd. -Proof. - intros x x' EQ. rewrite eq_iff_eq_true, 2 odd_spec. now f_equiv. -Qed. - -(** Evenness and oddity are dual notions *) - -Lemma Even_or_Odd : forall x, Even x \/ Odd x. -Proof. - intro x; nzinduct x. - - left. exists 0. now nzsimpl. - - intros x. - split; intros [(y,H)|(y,H)]. - + right. exists y. rewrite H. now nzsimpl. - + left. exists (S y). rewrite H. now nzsimpl'. - + right. - assert (LT : exists z, z 2*n < 2*m+1. -Proof. - intros. nzsimpl'. apply lt_succ_r. now apply add_le_mono. -Qed. - -Lemma double_above : forall n m, n 2*n+1 < 2*m. -Proof. - intros. nzsimpl'. - rewrite <- le_succ_l, <- add_succ_l, <- add_succ_r. - apply add_le_mono; now apply le_succ_l. -Qed. - -Lemma Even_Odd_False : forall x, Even x -> Odd x -> False. -Proof. -intros x (y,E) (z,O). rewrite O in E; clear O. -destruct (le_gt_cases y z) as [LE|GT]. -- generalize (double_below _ _ LE); order. -- generalize (double_above _ _ GT); order. -Qed. - -Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. -Proof. - intros n. - destruct (Even_or_Odd n) as [H|H]. - - rewrite <- even_spec in H. now rewrite H. - - rewrite <- odd_spec in H. now rewrite H, orb_true_r. -Qed. - -Lemma negb_odd : forall n, negb (odd n) = even n. -Proof. - intros n. - generalize (Even_or_Odd n) (Even_Odd_False n). - rewrite <- even_spec, <- odd_spec. - destruct (odd n), (even n) ; simpl; intuition. -Qed. - -Lemma negb_even : forall n, negb (even n) = odd n. -Proof. - intros. rewrite <- negb_odd. apply negb_involutive. -Qed. - -(** Constants *) - -Lemma even_0 : even 0 = true. -Proof. - rewrite even_spec. exists 0. now nzsimpl. -Qed. - -Lemma odd_0 : odd 0 = false. -Proof. - now rewrite <- negb_even, even_0. -Qed. - -Lemma odd_1 : odd 1 = true. -Proof. - rewrite odd_spec. exists 0. now nzsimpl'. -Qed. - -Lemma even_1 : even 1 = false. -Proof. - now rewrite <- negb_odd, odd_1. -Qed. - -Lemma even_2 : even 2 = true. -Proof. - rewrite even_spec. exists 1. now nzsimpl'. -Qed. - -Lemma odd_2 : odd 2 = false. -Proof. - now rewrite <- negb_even, even_2. -Qed. - -(** Parity and successor *) - -Lemma Odd_succ : forall n, Odd (S n) <-> Even n. -Proof. - split; intros (m,H). - - exists m. apply succ_inj. now rewrite add_1_r in H. - - exists m. rewrite add_1_r. now f_equiv. -Qed. - -Lemma odd_succ : forall n, odd (S n) = even n. -Proof. - intros. apply eq_iff_eq_true. rewrite even_spec, odd_spec. - apply Odd_succ. -Qed. - -Lemma even_succ : forall n, even (S n) = odd n. -Proof. - intros. now rewrite <- negb_odd, odd_succ, negb_even. -Qed. - -Lemma Even_succ : forall n, Even (S n) <-> Odd n. -Proof. - intros. now rewrite <- even_spec, even_succ, odd_spec. -Qed. - -(** Parity and successor of successor *) - -Lemma Even_succ_succ : forall n, Even (S (S n)) <-> Even n. -Proof. - intros. now rewrite Even_succ, Odd_succ. -Qed. - -Lemma Odd_succ_succ : forall n, Odd (S (S n)) <-> Odd n. -Proof. - intros. now rewrite Odd_succ, Even_succ. -Qed. - -Lemma even_succ_succ : forall n, even (S (S n)) = even n. -Proof. - intros. now rewrite even_succ, odd_succ. -Qed. - -Lemma odd_succ_succ : forall n, odd (S (S n)) = odd n. -Proof. - intros. now rewrite odd_succ, even_succ. -Qed. - -(** Parity and addition *) - -Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m). -Proof. - intros n m. - case_eq (even n); case_eq (even m); - rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; - intros (m',Hm) (n',Hn). - - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. - - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. - - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. - - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. -Qed. - -Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). -Proof. - intros n m. rewrite <- !negb_even. rewrite even_add. - now destruct (even n), (even m). -Qed. - -(** Parity and multiplication *) - -Lemma even_mul : forall n m, even (mul n m) = even n || even m. -Proof. - intros n m. - case_eq (even n); simpl; rewrite ?even_spec. - - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. - - case_eq (even m); simpl; rewrite ?even_spec. - + intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). - (* odd / odd *) - + rewrite <- !negb_true_iff, !negb_even, !odd_spec. - intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). - rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. - now rewrite add_shuffle1, add_assoc, !mul_assoc. -Qed. - -Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. -Proof. - intros n m. rewrite <- !negb_even. rewrite even_mul. - now destruct (even n), (even m). -Qed. - -(** A particular case : adding by an even number *) - -Lemma even_add_even : forall n m, Even m -> even (n+m) = even n. -Proof. - intros n m Hm. apply even_spec in Hm. - rewrite even_add, Hm. now destruct (even n). -Qed. - -Lemma odd_add_even : forall n m, Even m -> odd (n+m) = odd n. -Proof. - intros n m Hm. apply even_spec in Hm. - rewrite odd_add, <- (negb_even m), Hm. now destruct (odd n). -Qed. - -Lemma even_add_mul_even : forall n m p, Even m -> even (n+m*p) = even n. -Proof. - intros n m p Hm. apply even_spec in Hm. - apply even_add_even. apply even_spec. now rewrite even_mul, Hm. -Qed. - -Lemma odd_add_mul_even : forall n m p, Even m -> odd (n+m*p) = odd n. -Proof. - intros n m p Hm. apply even_spec in Hm. - apply odd_add_even. apply even_spec. now rewrite even_mul, Hm. -Qed. - -Lemma even_add_mul_2 : forall n m, even (n+2*m) = even n. -Proof. - intros. apply even_add_mul_even. apply even_spec, even_2. -Qed. - -Lemma odd_add_mul_2 : forall n m, odd (n+2*m) = odd n. -Proof. - intros. apply odd_add_mul_even. apply even_spec, even_2. -Qed. - -(** Parity of [2 * n] and [2 * n + 1] *) - -Lemma even_even : forall n, even (2 * n) = true. -Proof. intros n; apply even_spec; exists n; reflexivity. Qed. - -Lemma odd_even : forall n, odd (2 * n) = false. -Proof. intros n; rewrite <-(negb_even), even_even; reflexivity. Qed. - -Lemma odd_odd : forall n, odd (2 * n + 1) = true. -Proof. intros n; rewrite odd_spec; exists n; reflexivity. Qed. - -Lemma even_odd : forall n, even (2 * n + 1) = false. -Proof. intros n; rewrite <-(negb_odd), odd_odd; reflexivity. Qed. + (Import A : NZOrdAxiomsSig') + (Import B : NZParity A) + (Import C : NZMulOrderProp A). + + (** Morphisms *) + + #[global] + Instance Even_wd : Proper (eq==>iff) Even. + Proof. unfold Even. solve_proper. Qed. + + #[global] + Instance Odd_wd : Proper (eq==>iff) Odd. + Proof. unfold Odd. solve_proper. Qed. + + #[global] + Instance even_wd : Proper (eq==>Logic.eq) even. + Proof. + intros x x' EQ. rewrite eq_iff_eq_true, 2 even_spec. now f_equiv. + Qed. + + #[global] + Instance odd_wd : Proper (eq==>Logic.eq) odd. + Proof. + intros x x' EQ. rewrite eq_iff_eq_true, 2 odd_spec. now f_equiv. + Qed. + + (** Evenness and oddity are dual notions *) + + Lemma Even_or_Odd : forall x, Even x \/ Odd x. + Proof. + intro x; nzinduct x. + - left. exists 0. now nzsimpl. + - intros x. + split; intros [(y,H)|(y,H)]. + + right. exists y. rewrite H. now nzsimpl. + + left. exists (S y). rewrite H. now nzsimpl'. + + right. + assert (LT : exists z, z 2*n < 2*m+1. + Proof. + intros. nzsimpl'. apply lt_succ_r. now apply add_le_mono. + Qed. + + Lemma double_above : forall n m, n 2*n+1 < 2*m. + Proof. + intros. nzsimpl'. + rewrite <- le_succ_l, <- add_succ_l, <- add_succ_r. + apply add_le_mono; now apply le_succ_l. + Qed. + + Lemma Even_Odd_False : forall x, Even x -> Odd x -> False. + Proof. + intros x (y,E) (z,O). rewrite O in E; clear O. + destruct (le_gt_cases y z) as [LE|GT]. + - generalize (double_below _ _ LE); order. + - generalize (double_above _ _ GT); order. + Qed. + + Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. + Proof. + intros n. + destruct (Even_or_Odd n) as [H|H]. + - rewrite <- even_spec in H. now rewrite H. + - rewrite <- odd_spec in H. now rewrite H, orb_true_r. + Qed. + + Lemma negb_odd : forall n, negb (odd n) = even n. + Proof. + intros n. + generalize (Even_or_Odd n) (Even_Odd_False n). + rewrite <- even_spec, <- odd_spec. + destruct (odd n), (even n) ; simpl; intuition. + Qed. + + Lemma negb_even : forall n, negb (even n) = odd n. + Proof. + intros. rewrite <- negb_odd. apply negb_involutive. + Qed. + + (** Constants *) + + Lemma even_0 : even 0 = true. + Proof. + rewrite even_spec. exists 0. now nzsimpl. + Qed. + + Lemma odd_0 : odd 0 = false. + Proof. + now rewrite <- negb_even, even_0. + Qed. + + Lemma odd_1 : odd 1 = true. + Proof. + rewrite odd_spec. exists 0. now nzsimpl'. + Qed. + + Lemma even_1 : even 1 = false. + Proof. + now rewrite <- negb_odd, odd_1. + Qed. + + Lemma even_2 : even 2 = true. + Proof. + rewrite even_spec. exists 1. now nzsimpl'. + Qed. + + Lemma odd_2 : odd 2 = false. + Proof. + now rewrite <- negb_even, even_2. + Qed. + + (** Parity and successor *) + + Lemma Odd_succ : forall n, Odd (S n) <-> Even n. + Proof. + split; intros (m,H). + - exists m. apply succ_inj. now rewrite add_1_r in H. + - exists m. rewrite add_1_r. now f_equiv. + Qed. + + Lemma odd_succ : forall n, odd (S n) = even n. + Proof. + intros. apply eq_iff_eq_true. rewrite even_spec, odd_spec. + apply Odd_succ. + Qed. + + Lemma even_succ : forall n, even (S n) = odd n. + Proof. + intros. now rewrite <- negb_odd, odd_succ, negb_even. + Qed. + + Lemma Even_succ : forall n, Even (S n) <-> Odd n. + Proof. + intros. now rewrite <- even_spec, even_succ, odd_spec. + Qed. + + (** Parity and successor of successor *) + + Lemma Even_succ_succ : forall n, Even (S (S n)) <-> Even n. + Proof. + intros. now rewrite Even_succ, Odd_succ. + Qed. + + Lemma Odd_succ_succ : forall n, Odd (S (S n)) <-> Odd n. + Proof. + intros. now rewrite Odd_succ, Even_succ. + Qed. + + Lemma even_succ_succ : forall n, even (S (S n)) = even n. + Proof. + intros. now rewrite even_succ, odd_succ. + Qed. + + Lemma odd_succ_succ : forall n, odd (S (S n)) = odd n. + Proof. + intros. now rewrite odd_succ, even_succ. + Qed. + + (** Parity and addition *) + + Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m). + Proof. + intros n m. + case_eq (even n); case_eq (even m); + rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; + intros (m',Hm) (n',Hn). + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. + - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. + Qed. + + Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). + Proof. + intros n m. rewrite <- !negb_even. rewrite even_add. + now destruct (even n), (even m). + Qed. + + (** Parity and multiplication *) + + Lemma even_mul : forall n m, even (mul n m) = even n || even m. + Proof. + intros n m. + case_eq (even n); simpl; rewrite ?even_spec. + - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. + - case_eq (even m); simpl; rewrite ?even_spec. + + intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). + (* odd / odd *) + + rewrite <- !negb_true_iff, !negb_even, !odd_spec. + intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). + rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. + now rewrite add_shuffle1, add_assoc, !mul_assoc. + Qed. + + Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. + Proof. + intros n m. rewrite <- !negb_even. rewrite even_mul. + now destruct (even n), (even m). + Qed. + + (** A particular case : adding by an even number *) + + Lemma even_add_even : forall n m, Even m -> even (n+m) = even n. + Proof. + intros n m Hm. apply even_spec in Hm. + rewrite even_add, Hm. now destruct (even n). + Qed. + + Lemma odd_add_even : forall n m, Even m -> odd (n+m) = odd n. + Proof. + intros n m Hm. apply even_spec in Hm. + rewrite odd_add, <- (negb_even m), Hm. now destruct (odd n). + Qed. + + Lemma even_add_mul_even : forall n m p, Even m -> even (n+m*p) = even n. + Proof. + intros n m p Hm. apply even_spec in Hm. + apply even_add_even. apply even_spec. now rewrite even_mul, Hm. + Qed. + + Lemma odd_add_mul_even : forall n m p, Even m -> odd (n+m*p) = odd n. + Proof. + intros n m p Hm. apply even_spec in Hm. + apply odd_add_even. apply even_spec. now rewrite even_mul, Hm. + Qed. + + Lemma even_add_mul_2 : forall n m, even (n+2*m) = even n. + Proof. + intros. apply even_add_mul_even. apply even_spec, even_2. + Qed. + + Lemma odd_add_mul_2 : forall n m, odd (n+2*m) = odd n. + Proof. + intros. apply odd_add_mul_even. apply even_spec, even_2. + Qed. + + (** Parity of [2 * n] and [2 * n + 1] *) + + Lemma even_even : forall n, even (2 * n) = true. + Proof. intros n; apply even_spec; exists n; reflexivity. Qed. + + Lemma odd_even : forall n, odd (2 * n) = false. + Proof. intros n; rewrite <-(negb_even), even_even; reflexivity. Qed. + + Lemma odd_odd : forall n, odd (2 * n + 1) = true. + Proof. intros n; rewrite odd_spec; exists n; reflexivity. Qed. + + Lemma even_odd : forall n, even (2 * n + 1) = false. + Proof. intros n; rewrite <-(negb_odd), odd_odd; reflexivity. Qed. End NZParityProp. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index f9b2f44d67..555a7fdc16 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -15,21 +15,21 @@ From Stdlib Require Import NZAxioms NZMulOrder. (** Interface of a power function, then its specification on naturals *) Module Type Pow (Import A : Typ). - Parameters Inline pow : t -> t -> t. + Parameters Inline pow : t -> t -> t. End Pow. Module Type PowNotation (A : Typ)(Import B : Pow A). - Infix "^" := pow. + Infix "^" := pow. End PowNotation. Module Type Pow' (A : Typ) := Pow A <+ PowNotation A. Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A). -#[global] - Declare Instance pow_wd : Proper (eq==>eq==>eq) pow. - Axiom pow_0_r : forall a, a^0 == 1. - Axiom pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. - Axiom pow_neg_r : forall a b, b<0 -> a^b == 0. + #[global] + Declare Instance pow_wd : Proper (eq==>eq==>eq) pow. + Axiom pow_0_r : forall a, a^0 == 1. + Axiom pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. + Axiom pow_neg_r : forall a b, b<0 -> a^b == 0. End NZPowSpec. (** The above [pow_neg_r] specification is useless (and trivially @@ -42,373 +42,373 @@ Module Type NZPow' (A : NZOrdAxiomsSig) := Pow' A <+ NZPowSpec A. (** Derived properties of power *) Module Type NZPowProp - (Import A : NZOrdAxiomsSig') - (Import B : NZPow' A) - (Import C : NZMulOrderProp A). - -#[global] Hint Rewrite pow_0_r pow_succ_r : nz. - -(** Power and basic constants *) - -Lemma pow_0_l : forall a, 0 0^a == 0. -Proof. - intros a Ha. - destruct (lt_exists_pred _ _ Ha) as (a' & EQ & Ha'). - rewrite EQ. now nzsimpl. -Qed. - -Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0. -Proof. - intros a Ha. - destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order. - - now rewrite pow_neg_r. - - now apply pow_0_l. -Qed. - -Lemma pow_1_r : forall a, a^1 == a. -Proof. - intros. now nzsimpl'. -Qed. - -Lemma pow_1_l : forall a, 0<=a -> 1^a == 1. -Proof. - apply le_ind; intros. - solve_proper. - - now nzsimpl. - - now nzsimpl. -Qed. - -#[global] Hint Rewrite pow_1_r pow_1_l : nz. - -Lemma pow_2_r : forall a, a^2 == a*a. -Proof. - intros. rewrite two_succ. nzsimpl; order'. -Qed. - -#[global] Hint Rewrite pow_2_r : nz. - -(** Power and nullity *) - -Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0. -Proof. - intros a b Hb. apply le_ind with (4:=Hb). - - solve_proper. - - rewrite pow_0_r. order'. - - clear b Hb. intros b Hb IH. - rewrite pow_succ_r by trivial. - intros H. apply eq_mul_0 in H. destruct H; trivial. - now apply IH. -Qed. - -Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0. -Proof. - intros a b Ha Hb. contradict Ha. now apply pow_eq_0 with b. -Qed. - -Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0 0<=c -> - a^(b+c) == a^b * a^c. -Proof. - intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. - - now nzsimpl. - - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - + rewrite IH; trivial. apply mul_assoc. - + now apply add_nonneg_nonneg. -Qed. - -Lemma pow_mul_l : forall a b c, - (a*b)^c == a^c * b^c. -Proof. - intros a b c. - destruct (lt_ge_cases c 0) as [Hc|Hc]. - - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. - - apply le_ind with (4:=Hc). + solve_proper. - + now nzsimpl. - + clear c Hc. intros c Hc IH. - nzsimpl; trivial. - rewrite IH; trivial. apply mul_shuffle1. -Qed. - -Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c -> - a^(b*c) == (a^b)^c. -Proof. - intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. - - intros. now nzsimpl. - - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - rewrite pow_add_r, IH, pow_mul_l; trivial. + apply mul_comm. - + now apply mul_nonneg_nonneg. -Qed. - -(** Positivity *) - -Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b. -Proof. - intros a b Ha. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - now rewrite !(pow_neg_r _ _ Hb). - - apply le_ind with (4:=Hb). + solve_proper. - + nzsimpl; order'. - + clear b Hb. intros b Hb IH. - nzsimpl; trivial. now apply mul_nonneg_nonneg. -Qed. - -Lemma pow_pos_nonneg : forall a b, 0 0<=b -> 0 0<=a a^c < b^c. -Proof. - intros a b c Hc. apply lt_ind with (4:=Hc). - solve_proper. - - intros (Ha,H). nzsimpl; trivial; order. - - clear c Hc. intros c Hc IH (Ha,H). - nzsimpl; try order. - apply mul_lt_mono_nonneg; trivial. - + apply pow_nonneg; try order. - + apply IH. now split. -Qed. - -Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c. -Proof. - intros a b c (Ha,H). - destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]]. - - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. - - rewrite Hc; now nzsimpl. - - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_l; now try split. -Qed. - -Lemma pow_gt_1 : forall a b, 1 (0 1 0<=c -> b a^b < a^c. -Proof. - intros a b c Ha Hc H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. - - assert (H' : b<=c) by order. - destruct (le_exists_sub _ _ H') as (d & EQ & Hd). - rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. - apply mul_lt_mono_pos_r. - + apply pow_pos_nonneg; order'. - + apply pow_gt_1; trivial. - apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. - rewrite <- EQ' in *. rewrite add_0_l in EQ. order. -Qed. - -(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) - -Lemma pow_le_mono_r : forall a b c, 0 b<=c -> a^b <= a^c. -Proof. - intros a b c Ha H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. - - apply le_succ_l in Ha; rewrite <- one_succ in Ha. - apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - + apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_r; order. - + nzsimpl; order. -Qed. - -Lemma pow_le_mono : forall a b c d, 0 b<=d -> - a^b <= c^d. -Proof. - intros a b c d ? ?. transitivity (a^d). - - apply pow_le_mono_r; intuition order. - - apply pow_le_mono_l; intuition order. -Qed. - -Lemma pow_lt_mono : forall a b c d, 0 0 - a^b < c^d. -Proof. - intros a b c d (Ha,Hac) (Hb,Hbd). - apply le_succ_l in Ha; rewrite <- one_succ in Ha. - apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - - transitivity (a^d). - + apply pow_lt_mono_r; intuition order. - + apply pow_lt_mono_l; try split; order'. - - nzsimpl; try order. apply pow_gt_1; order. -Qed. - -(** Injectivity *) - -Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0 - a^c == b^c -> a == b. -Proof. - intros a b c Ha Hb Hc EQ. - destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial. - - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). - order. - - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. -Qed. - -Lemma pow_inj_r : forall a b c, 1 0<=b -> 0<=c -> - a^b == a^c -> b == c. -Proof. - intros a b c Ha Hb Hc EQ. - destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial. - - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). - order. - - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). - order. -Qed. - -(** Monotonicity results, both ways *) - -Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0 - (a a^c < b^c). -Proof. - intros a b c Ha Hb Hc. - split; intro LT. - - apply pow_lt_mono_l; try split; trivial. - - destruct (le_gt_cases b a) as [LE|GT]; trivial. - assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). - order. -Qed. - -Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0 - (a<=b <-> a^c <= b^c). -Proof. - intros a b c Ha Hb Hc. - split; intro LE. - - apply pow_le_mono_l; try split; trivial. - - destruct (le_gt_cases a b) as [LE'|GT]; trivial. - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. -Qed. - -Lemma pow_lt_mono_r_iff : forall a b c, 1 0<=c -> - (b a^b < a^c). -Proof. - intros a b c Ha Hc. - split; intro LT. - - now apply pow_lt_mono_r. - - destruct (le_gt_cases c b) as [LE|GT]; trivial. - assert (a^c <= a^b) by (apply pow_le_mono_r; order'). - order. -Qed. - -Lemma pow_le_mono_r_iff : forall a b c, 1 0<=c -> - (b<=c <-> a^b <= a^c). -Proof. - intros a b c Ha Hc. - split; intro LE. - - apply pow_le_mono_r; order'. - - destruct (le_gt_cases b c) as [LE'|GT]; trivial. - assert (a^c < a^b) by (apply pow_lt_mono_r; order'). - order. -Qed. - -(** For any a>1, the a^x function is above the identity function *) - -Lemma pow_gt_lin_r : forall a b, 1 0<=b -> b < a^b. -Proof. - intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. - - nzsimpl. order'. - - clear b Hb. intros b Hb IH. nzsimpl; trivial. - rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. - transitivity (2*(S b)). - + nzsimpl'. rewrite <- 2 succ_le_mono. - rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - + apply mul_le_mono_nonneg; trivial. - * order'. - * now apply lt_le_incl, lt_succ_r. -Qed. - -(** Someday, we should say something about the full Newton formula. + (Import A : NZOrdAxiomsSig') + (Import B : NZPow' A) + (Import C : NZMulOrderProp A). + + #[global] Hint Rewrite pow_0_r pow_succ_r : nz. + + (** Power and basic constants *) + + Lemma pow_0_l : forall a, 0 0^a == 0. + Proof. + intros a Ha. + destruct (lt_exists_pred _ _ Ha) as (a' & EQ & Ha'). + rewrite EQ. now nzsimpl. + Qed. + + Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0. + Proof. + intros a Ha. + destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order. + - now rewrite pow_neg_r. + - now apply pow_0_l. + Qed. + + Lemma pow_1_r : forall a, a^1 == a. + Proof. + intros. now nzsimpl'. + Qed. + + Lemma pow_1_l : forall a, 0<=a -> 1^a == 1. + Proof. + apply le_ind; intros. - solve_proper. + - now nzsimpl. + - now nzsimpl. + Qed. + + #[global] Hint Rewrite pow_1_r pow_1_l : nz. + + Lemma pow_2_r : forall a, a^2 == a*a. + Proof. + intros. rewrite two_succ. nzsimpl; order'. + Qed. + + #[global] Hint Rewrite pow_2_r : nz. + + (** Power and nullity *) + + Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0. + Proof. + intros a b Hb. apply le_ind with (4:=Hb). + - solve_proper. + - rewrite pow_0_r. order'. + - clear b Hb. intros b Hb IH. + rewrite pow_succ_r by trivial. + intros H. apply eq_mul_0 in H. destruct H; trivial. + now apply IH. + Qed. + + Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0. + Proof. + intros a b Ha Hb. contradict Ha. now apply pow_eq_0 with b. + Qed. + + Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0 0<=c -> + a^(b+c) == a^b * a^c. + Proof. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + + rewrite IH; trivial. apply mul_assoc. + + now apply add_nonneg_nonneg. + Qed. + + Lemma pow_mul_l : forall a b c, + (a*b)^c == a^c * b^c. + Proof. + intros a b c. + destruct (lt_ge_cases c 0) as [Hc|Hc]. + - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. + - apply le_ind with (4:=Hc). + solve_proper. + + now nzsimpl. + + clear c Hc. intros c Hc IH. + nzsimpl; trivial. + rewrite IH; trivial. apply mul_shuffle1. + Qed. + + Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c -> + a^(b*c) == (a^b)^c. + Proof. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - intros. now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + rewrite pow_add_r, IH, pow_mul_l; trivial. + apply mul_comm. + + now apply mul_nonneg_nonneg. + Qed. + + (** Positivity *) + + Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b. + Proof. + intros a b Ha. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - now rewrite !(pow_neg_r _ _ Hb). + - apply le_ind with (4:=Hb). + solve_proper. + + nzsimpl; order'. + + clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_nonneg_nonneg. + Qed. + + Lemma pow_pos_nonneg : forall a b, 0 0<=b -> 0 0<=a a^c < b^c. + Proof. + intros a b c Hc. apply lt_ind with (4:=Hc). - solve_proper. + - intros (Ha,H). nzsimpl; trivial; order. + - clear c Hc. intros c Hc IH (Ha,H). + nzsimpl; try order. + apply mul_lt_mono_nonneg; trivial. + + apply pow_nonneg; try order. + + apply IH. now split. + Qed. + + Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c. + Proof. + intros a b c (Ha,H). + destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]]. + - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. + - rewrite Hc; now nzsimpl. + - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_l; now try split. + Qed. + + Lemma pow_gt_1 : forall a b, 1 (0 1 0<=c -> b a^b < a^c. + Proof. + intros a b c Ha Hc H. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. + - assert (H' : b<=c) by order. + destruct (le_exists_sub _ _ H') as (d & EQ & Hd). + rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. + apply mul_lt_mono_pos_r. + + apply pow_pos_nonneg; order'. + + apply pow_gt_1; trivial. + apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. + rewrite <- EQ' in *. rewrite add_0_l in EQ. order. + Qed. + + (** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) + + Lemma pow_le_mono_r : forall a b c, 0 b<=c -> a^b <= a^c. + Proof. + intros a b c Ha H. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. + - apply le_succ_l in Ha; rewrite <- one_succ in Ha. + apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. + + apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_r; order. + + nzsimpl; order. + Qed. + + Lemma pow_le_mono : forall a b c d, 0 b<=d -> + a^b <= c^d. + Proof. + intros a b c d ? ?. transitivity (a^d). + - apply pow_le_mono_r; intuition order. + - apply pow_le_mono_l; intuition order. + Qed. + + Lemma pow_lt_mono : forall a b c d, 0 0 + a^b < c^d. + Proof. + intros a b c d (Ha,Hac) (Hb,Hbd). + apply le_succ_l in Ha; rewrite <- one_succ in Ha. + apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. + - transitivity (a^d). + + apply pow_lt_mono_r; intuition order. + + apply pow_lt_mono_l; try split; order'. + - nzsimpl; try order. apply pow_gt_1; order. + Qed. + + (** Injectivity *) + + Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0 + a^c == b^c -> a == b. + Proof. + intros a b c Ha Hb Hc EQ. + destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial. + - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). + order. + - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. + Qed. + + Lemma pow_inj_r : forall a b c, 1 0<=b -> 0<=c -> + a^b == a^c -> b == c. + Proof. + intros a b c Ha Hb Hc EQ. + destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial. + - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). + order. + - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). + order. + Qed. + + (** Monotonicity results, both ways *) + + Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0 + (a a^c < b^c). + Proof. + intros a b c Ha Hb Hc. + split; intro LT. + - apply pow_lt_mono_l; try split; trivial. + - destruct (le_gt_cases b a) as [LE|GT]; trivial. + assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). + order. + Qed. + + Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0 + (a<=b <-> a^c <= b^c). + Proof. + intros a b c Ha Hb Hc. + split; intro LE. + - apply pow_le_mono_l; try split; trivial. + - destruct (le_gt_cases a b) as [LE'|GT]; trivial. + assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. + Qed. + + Lemma pow_lt_mono_r_iff : forall a b c, 1 0<=c -> + (b a^b < a^c). + Proof. + intros a b c Ha Hc. + split; intro LT. + - now apply pow_lt_mono_r. + - destruct (le_gt_cases c b) as [LE|GT]; trivial. + assert (a^c <= a^b) by (apply pow_le_mono_r; order'). + order. + Qed. + + Lemma pow_le_mono_r_iff : forall a b c, 1 0<=c -> + (b<=c <-> a^b <= a^c). + Proof. + intros a b c Ha Hc. + split; intro LE. + - apply pow_le_mono_r; order'. + - destruct (le_gt_cases b c) as [LE'|GT]; trivial. + assert (a^c < a^b) by (apply pow_lt_mono_r; order'). + order. + Qed. + + (** For any a>1, the a^x function is above the identity function *) + + Lemma pow_gt_lin_r : forall a b, 1 0<=b -> b < a^b. + Proof. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl. order'. + - clear b Hb. intros b Hb IH. nzsimpl; trivial. + rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. + transitivity (2*(S b)). + + nzsimpl'. rewrite <- 2 succ_le_mono. + rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + apply mul_le_mono_nonneg; trivial. + * order'. + * now apply lt_le_incl, lt_succ_r. + Qed. + + (** Someday, we should say something about the full Newton formula. In the meantime, we can at least provide some inequalities about (a+b)^c. *) -Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0 - a^c + b^c <= (a+b)^c. -Proof. - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). - solve_proper. - - nzsimpl; order. - - clear c Hc. intros c Hc IH. - assert (0<=c) by order'. - nzsimpl; trivial. - transitivity ((a+b)*(a^c + b^c)). - + rewrite mul_add_distr_r, !mul_add_distr_l. - apply add_le_mono. - * rewrite <- add_0_r at 1. apply add_le_mono_l. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - * rewrite <- add_0_l at 1. apply add_le_mono_r. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - + apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. -Qed. - -(** This upper bound can also be seen as a convexity proof for x^c : + Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0 + a^c + b^c <= (a+b)^c. + Proof. + intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). - solve_proper. + - nzsimpl; order. + - clear c Hc. intros c Hc IH. + assert (0<=c) by order'. + nzsimpl; trivial. + transitivity ((a+b)*(a^c + b^c)). + + rewrite mul_add_distr_r, !mul_add_distr_l. + apply add_le_mono. + * rewrite <- add_0_r at 1. apply add_le_mono_l. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + * rewrite <- add_0_l at 1. apply add_le_mono_r. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + + apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. + Qed. + + (** This upper bound can also be seen as a convexity proof for x^c : image of (a+b)/2 is below the middle of the images of a and b *) -Lemma pow_add_upper : forall a b c, 0<=a -> 0<=b -> 0 - (a+b)^c <= 2^(pred c) * (a^c + b^c). -Proof. - assert (aux : forall a b c, 0<=a<=b -> 0 - (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)). - (* begin *) - - intros a b c (Ha,H) Hc. - rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. - rewrite <- !add_assoc. apply add_le_mono_l. - rewrite !add_assoc. apply add_le_mono_r. - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. - apply pow_le_mono_l; try split; order. - (* end *) - - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). + solve_proper. - + nzsimpl; order. - + clear c Hc. intros c Hc IH. - assert (0<=c) by order. - nzsimpl; trivial. - transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). - * apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. - * rewrite mul_assoc. rewrite (mul_comm (a+b)). - assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). - assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). - assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). - rewrite EQ', <- !mul_assoc. - apply mul_le_mono_nonneg_l. - -- apply pow_nonneg; order'. - -- destruct (le_gt_cases a b). - ++ apply aux; try split; order'. - ++ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). - apply aux; try split; order'. -Qed. + Lemma pow_add_upper : forall a b c, 0<=a -> 0<=b -> 0 + (a+b)^c <= 2^(pred c) * (a^c + b^c). + Proof. + assert (aux : forall a b c, 0<=a<=b -> 0 + (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)). + (* begin *) + - intros a b c (Ha,H) Hc. + rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. + rewrite <- !add_assoc. apply add_le_mono_l. + rewrite !add_assoc. apply add_le_mono_r. + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. + apply pow_le_mono_l; try split; order. + (* end *) + - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). + solve_proper. + + nzsimpl; order. + + clear c Hc. intros c Hc IH. + assert (0<=c) by order. + nzsimpl; trivial. + transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). + * apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. + * rewrite mul_assoc. rewrite (mul_comm (a+b)). + assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). + assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). + assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). + rewrite EQ', <- !mul_assoc. + apply mul_le_mono_nonneg_l. + -- apply pow_nonneg; order'. + -- destruct (le_gt_cases a b). + ++ apply aux; try split; order'. + ++ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). + apply aux; try split; order'. + Qed. End NZPowProp. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index b8a9f66cad..08ba9a6fd8 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -15,18 +15,18 @@ From Stdlib Require Import NZAxioms NZMulOrder. (** Interface of a sqrt function, then its specification on naturals *) Module Type Sqrt (Import A : Typ). - Parameter Inline sqrt : t -> t. + Parameter Inline sqrt : t -> t. End Sqrt. Module Type SqrtNotation (A : Typ)(Import B : Sqrt A). - Notation "√ x" := (sqrt x) (at level 6). + Notation "√ x" := (sqrt x) (at level 6). End SqrtNotation. Module Type Sqrt' (A : Typ) := Sqrt A <+ SqrtNotation A. Module Type NZSqrtSpec (Import A : NZOrdAxiomsSig')(Import B : Sqrt' A). - Axiom sqrt_spec : forall a, 0<=a -> √a * √a <= a < S (√a) * S (√a). - Axiom sqrt_neg : forall a, a<0 -> √a == 0. + Axiom sqrt_spec : forall a, 0<=a -> √a * √a <= a < S (√a) * S (√a). + Axiom sqrt_neg : forall a, a<0 -> √a == 0. End NZSqrtSpec. Module Type NZSqrt (A : NZOrdAxiomsSig) := Sqrt A <+ NZSqrtSpec A. @@ -35,703 +35,703 @@ Module Type NZSqrt' (A : NZOrdAxiomsSig) := Sqrt' A <+ NZSqrtSpec A. (** Derived properties of power *) Module Type NZSqrtProp - (Import A : NZOrdAxiomsSig') - (Import B : NZSqrt' A) - (Import C : NZMulOrderProp A). - -#[local] Notation "a ²" := (a*a) (no associativity, format "a ²"). - -(** First, sqrt is non-negative *) - -Lemma sqrt_spec_nonneg : forall b, - b² < (S b)² -> 0 <= b. -Proof. - intros b LT. - destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso. - assert ((S b)² < b²). - - rewrite mul_succ_l, <- (add_0_r b²). - apply add_lt_le_mono. - + apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. - + now apply le_succ_l. - - order. -Qed. - -Lemma sqrt_nonneg : forall a, 0<=√a. -Proof. - intros a. destruct (lt_ge_cases a 0) as [Ha|Ha]. - - now rewrite (sqrt_neg _ Ha). - - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. -Qed. - -(** The spec of sqrt indeed determines it *) - -Lemma sqrt_unique : forall a b, b² <= a < (S b)² -> √a == b. -Proof. - intros a b (LEb,LTb). - assert (Ha : 0<=a) by (transitivity (b²); trivial using square_nonneg). - assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order). - assert (Ha': 0<=√a) by now apply sqrt_nonneg. - destruct (sqrt_spec a Ha) as (LEa,LTa). - assert (b <= √a). - - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - - assert (√a <= b). - + apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - + order. -Qed. - -(** Hence sqrt is a morphism *) - -#[global] -Instance sqrt_wd : Proper (eq==>eq) sqrt. -Proof. - intros x x' Hx. - destruct (lt_ge_cases x 0) as [H|H]. - - rewrite 2 sqrt_neg; trivial. + reflexivity. - + now rewrite <- Hx. - - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. -Qed. - -(** An alternate specification *) - -Lemma sqrt_spec_alt : forall a, 0<=a -> exists r, - a == (√a)² + r /\ 0 <= r <= 2*√a. -Proof. - intros a Ha. - destruct (sqrt_spec _ Ha) as (LE,LT). - destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). - exists r. - split. - now rewrite add_comm. - - split. + trivial. - + apply (add_le_mono_r _ _ (√a)²). - rewrite <- Hr, add_comm. - generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. -Qed. - -Lemma sqrt_unique' : forall a b c, 0<=c<=2*b -> - a == b² + c -> √a == b. -Proof. - intros a b c (Hc,H) EQ. - apply sqrt_unique. - rewrite EQ. - split. - - rewrite <- add_0_r at 1. now apply add_le_mono_l. - - nzsimpl. apply lt_succ_r. - rewrite <- add_assoc. apply add_le_mono_l. - generalize H; now nzsimpl'. -Qed. - -(** Sqrt is exact on squares *) - -Lemma sqrt_square : forall a, 0<=a -> √(a²) == a. -Proof. - intros a Ha. - apply sqrt_unique' with 0. - - split. + order. + apply mul_nonneg_nonneg; order'. - now nzsimpl. -Qed. - -(** Sqrt and predecessors of squares *) - -Lemma sqrt_pred_square : forall a, 0 √(P a²) == P a. -Proof. - intros a Ha. - apply sqrt_unique. - assert (EQ := lt_succ_pred 0 a Ha). - rewrite EQ. split. - - apply lt_succ_r. - rewrite (lt_succ_pred 0). - + assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). - assert (P a < a) by (now rewrite <- le_succ_l, EQ). - apply mul_lt_mono_nonneg; trivial. - + now apply mul_pos_pos. - - apply le_succ_l. - rewrite (lt_succ_pred 0). + reflexivity. + now apply mul_pos_pos. -Qed. - -(** Sqrt is a monotone function (but not a strict one) *) - -Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b. -Proof. - intros a b Hab. - destruct (lt_ge_cases a 0) as [Ha|Ha]. - - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. - - assert (Hb : 0 <= b) by order. - destruct (sqrt_spec a Ha) as (LE,_). - destruct (sqrt_spec b Hb) as (_,LT). - apply lt_succ_r. - apply square_lt_simpl_nonneg; try order. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. -Qed. - -(** No reverse result for <=, consider for instance √2 <= √1 *) - -Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b. -Proof. - intros a b H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. - - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. - destruct (sqrt_spec a Ha) as (_,LT). - destruct (sqrt_spec b Hb) as (LE,_). - apply le_succ_l in H. - assert ((S (√a))² <= (√b)²). - + apply mul_le_mono_nonneg; trivial. - * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - + order. -Qed. - -(** When left side is a square, we have an equivalence for <= *) - -Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a). -Proof. - intros a b Ha Hb. split; intros H. - - rewrite <- (sqrt_square b); trivial. - now apply sqrt_le_mono. - - destruct (sqrt_spec a Ha) as (LE,LT). - transitivity (√a)²; trivial. - now apply mul_le_mono_nonneg. -Qed. - -(** When right side is a square, we have an equivalence for < *) - -Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a √a < b). -Proof. - intros a b Ha Hb. split; intros H. - - destruct (sqrt_spec a Ha) as (LE,_). - apply square_lt_simpl_nonneg; try order. - - rewrite <- (sqrt_square b Hb) in H. - now apply sqrt_lt_cancel. -Qed. - -(** Sqrt and basic constants *) - -Lemma sqrt_0 : √0 == 0. -Proof. - rewrite <- (mul_0_l 0) at 1. now apply sqrt_square. -Qed. - -Lemma sqrt_1 : √1 == 1. -Proof. - rewrite <- (mul_1_l 1) at 1. apply sqrt_square. order'. -Qed. - -Lemma sqrt_2 : √2 == 1. -Proof. - apply sqrt_unique' with 1. - nzsimpl; split; order'. - now nzsimpl'. -Qed. - -Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a. -Proof. - intros a. split; intros Ha. - apply sqrt_lt_cancel. now rewrite sqrt_0. - - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. - now rewrite one_succ, le_succ_l. -Qed. - -Lemma sqrt_lt_lin : forall a, 1 √a √a<=a. -Proof. - intros a Ha. - destruct (le_gt_cases a 0) as [H|H]. - - setoid_replace a with 0 by order. now rewrite sqrt_0. - - destruct (le_gt_cases a 1) as [H'|H']. - + rewrite <- le_succ_l, <- one_succ in H. - setoid_replace a with 1 by order. now rewrite sqrt_1. - + now apply lt_le_incl, sqrt_lt_lin. -Qed. - -(** Sqrt and multiplication. *) - -(** Due to rounding error, we don't have the usual √(a*b) = √a*√b + (Import A : NZOrdAxiomsSig') + (Import B : NZSqrt' A) + (Import C : NZMulOrderProp A). + + #[local] Notation "a ²" := (a*a) (no associativity, format "a ²"). + + (** First, sqrt is non-negative *) + + Lemma sqrt_spec_nonneg : forall b, + b² < (S b)² -> 0 <= b. + Proof. + intros b LT. + destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso. + assert ((S b)² < b²). + - rewrite mul_succ_l, <- (add_0_r b²). + apply add_lt_le_mono. + + apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. + + now apply le_succ_l. + - order. + Qed. + + Lemma sqrt_nonneg : forall a, 0<=√a. + Proof. + intros a. destruct (lt_ge_cases a 0) as [Ha|Ha]. + - now rewrite (sqrt_neg _ Ha). + - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. + Qed. + + (** The spec of sqrt indeed determines it *) + + Lemma sqrt_unique : forall a b, b² <= a < (S b)² -> √a == b. + Proof. + intros a b (LEb,LTb). + assert (Ha : 0<=a) by (transitivity (b²); trivial using square_nonneg). + assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order). + assert (Ha': 0<=√a) by now apply sqrt_nonneg. + destruct (sqrt_spec a Ha) as (LEa,LTa). + assert (b <= √a). + - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + - assert (√a <= b). + + apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + + order. + Qed. + + (** Hence sqrt is a morphism *) + + #[global] + Instance sqrt_wd : Proper (eq==>eq) sqrt. + Proof. + intros x x' Hx. + destruct (lt_ge_cases x 0) as [H|H]. + - rewrite 2 sqrt_neg; trivial. + reflexivity. + + now rewrite <- Hx. + - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. + Qed. + + (** An alternate specification *) + + Lemma sqrt_spec_alt : forall a, 0<=a -> exists r, + a == (√a)² + r /\ 0 <= r <= 2*√a. + Proof. + intros a Ha. + destruct (sqrt_spec _ Ha) as (LE,LT). + destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). + exists r. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_le_mono_r _ _ (√a)²). + rewrite <- Hr, add_comm. + generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. + Qed. + + Lemma sqrt_unique' : forall a b c, 0<=c<=2*b -> + a == b² + c -> √a == b. + Proof. + intros a b c (Hc,H) EQ. + apply sqrt_unique. + rewrite EQ. + split. + - rewrite <- add_0_r at 1. now apply add_le_mono_l. + - nzsimpl. apply lt_succ_r. + rewrite <- add_assoc. apply add_le_mono_l. + generalize H; now nzsimpl'. + Qed. + + (** Sqrt is exact on squares *) + + Lemma sqrt_square : forall a, 0<=a -> √(a²) == a. + Proof. + intros a Ha. + apply sqrt_unique' with 0. + - split. + order. + apply mul_nonneg_nonneg; order'. - now nzsimpl. + Qed. + + (** Sqrt and predecessors of squares *) + + Lemma sqrt_pred_square : forall a, 0 √(P a²) == P a. + Proof. + intros a Ha. + apply sqrt_unique. + assert (EQ := lt_succ_pred 0 a Ha). + rewrite EQ. split. + - apply lt_succ_r. + rewrite (lt_succ_pred 0). + + assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). + assert (P a < a) by (now rewrite <- le_succ_l, EQ). + apply mul_lt_mono_nonneg; trivial. + + now apply mul_pos_pos. + - apply le_succ_l. + rewrite (lt_succ_pred 0). + reflexivity. + now apply mul_pos_pos. + Qed. + + (** Sqrt is a monotone function (but not a strict one) *) + + Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b. + Proof. + intros a b Hab. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. + - assert (Hb : 0 <= b) by order. + destruct (sqrt_spec a Ha) as (LE,_). + destruct (sqrt_spec b Hb) as (_,LT). + apply lt_succ_r. + apply square_lt_simpl_nonneg; try order. + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + Qed. + + (** No reverse result for <=, consider for instance √2 <= √1 *) + + Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b. + Proof. + intros a b H. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. + - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. + destruct (sqrt_spec a Ha) as (_,LT). + destruct (sqrt_spec b Hb) as (LE,_). + apply le_succ_l in H. + assert ((S (√a))² <= (√b)²). + + apply mul_le_mono_nonneg; trivial. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + order. + Qed. + + (** When left side is a square, we have an equivalence for <= *) + + Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a). + Proof. + intros a b Ha Hb. split; intros H. + - rewrite <- (sqrt_square b); trivial. + now apply sqrt_le_mono. + - destruct (sqrt_spec a Ha) as (LE,LT). + transitivity (√a)²; trivial. + now apply mul_le_mono_nonneg. + Qed. + + (** When right side is a square, we have an equivalence for < *) + + Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a √a < b). + Proof. + intros a b Ha Hb. split; intros H. + - destruct (sqrt_spec a Ha) as (LE,_). + apply square_lt_simpl_nonneg; try order. + - rewrite <- (sqrt_square b Hb) in H. + now apply sqrt_lt_cancel. + Qed. + + (** Sqrt and basic constants *) + + Lemma sqrt_0 : √0 == 0. + Proof. + rewrite <- (mul_0_l 0) at 1. now apply sqrt_square. + Qed. + + Lemma sqrt_1 : √1 == 1. + Proof. + rewrite <- (mul_1_l 1) at 1. apply sqrt_square. order'. + Qed. + + Lemma sqrt_2 : √2 == 1. + Proof. + apply sqrt_unique' with 1. - nzsimpl; split; order'. - now nzsimpl'. + Qed. + + Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a. + Proof. + intros a. split; intros Ha. - apply sqrt_lt_cancel. now rewrite sqrt_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. + now rewrite one_succ, le_succ_l. + Qed. + + Lemma sqrt_lt_lin : forall a, 1 √a √a<=a. + Proof. + intros a Ha. + destruct (le_gt_cases a 0) as [H|H]. + - setoid_replace a with 0 by order. now rewrite sqrt_0. + - destruct (le_gt_cases a 1) as [H'|H']. + + rewrite <- le_succ_l, <- one_succ in H. + setoid_replace a with 1 by order. now rewrite sqrt_1. + + now apply lt_le_incl, sqrt_lt_lin. + Qed. + + (** Sqrt and multiplication. *) + + (** Due to rounding error, we don't have the usual √(a*b) = √a*√b but only lower and upper bounds. *) -Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b). -Proof. - intros a b. - destruct (lt_ge_cases a 0) as [Ha|Ha]. - - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. - + assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - apply sqrt_le_square; try now apply mul_nonneg_nonneg. - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. - * now apply sqrt_spec. - * now apply sqrt_spec. -Qed. - -Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b). -Proof. - intros a b Ha Hb. - apply sqrt_lt_square. - - now apply mul_nonneg_nonneg. - - apply mul_nonneg_nonneg. - + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. -Qed. - -(** And we can't find better approximations in general. + Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b). + Proof. + intros a b. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. + + assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + apply sqrt_le_square; try now apply mul_nonneg_nonneg. + rewrite mul_shuffle1. + apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. + * now apply sqrt_spec. + * now apply sqrt_spec. + Qed. + + Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b). + Proof. + intros a b Ha Hb. + apply sqrt_lt_square. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. + Qed. + + (** And we can't find better approximations in general. - The lower bound is exact for squares - Concerning the upper bound, for any c>0, take a=b=c²-1, then √(a*b) = c² -1 while S √a = S √b = c *) -(** Sqrt and successor : + (** Sqrt and successor : - the sqrt function climbs by at most 1 at a time - otherwise it stays at the same value - the +1 steps occur for squares *) -Lemma sqrt_succ_le : forall a, 0<=a -> √(S a) <= S (√a). -Proof. - intros a Ha. - apply lt_succ_r. - apply sqrt_lt_square. - - now apply le_le_succ_r. - - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. - - rewrite <- (add_1_l (S (√a))). - apply lt_le_trans with (1²+(S (√a))²). - + rewrite mul_1_l, add_1_l, <- succ_lt_mono. - now apply sqrt_spec. - + apply add_square_le. * order'. * apply le_le_succ_r, sqrt_nonneg. -Qed. - -Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a. -Proof. - intros a Ha. - destruct (le_gt_cases (√(S a)) (√a)) as [H|H]. - - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. -Qed. - -Lemma sqrt_eq_succ_iff_square : forall a, 0<=a -> - (√(S a) == S (√a) <-> exists b, 0 √(a+b) <= √a + √b). - - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. - apply sqrt_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - - intros a b. - destruct (lt_ge_cases a 0) as [Ha|Ha]. + now apply AUX. - + destruct (lt_ge_cases b 0) as [Hb|Hb]. - * rewrite (add_comm a), (add_comm (√a)); now apply AUX. - * assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - rewrite <- lt_succ_r. - apply sqrt_lt_square. - -- now apply add_nonneg_nonneg. - -- now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. - -- destruct (sqrt_spec a Ha) as (_,LTa). - destruct (sqrt_spec b Hb) as (_,LTb). - revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. - intros LTa LTb. - assert (H:=add_le_mono _ _ _ _ LTa LTb). - etransitivity; [eexact H|]. clear LTa LTb H. - rewrite <- (add_assoc _ (√a) (√a)). - rewrite <- (add_assoc _ (√b) (√b)). - rewrite add_shuffle1. - rewrite <- (add_assoc _ (√a + √b)). - rewrite (add_shuffle1 (√a) (√b)). - apply add_le_mono_r. - now apply add_square_le. -Qed. - -(** convexity inequality for sqrt: sqrt of middle is above middle + Lemma sqrt_succ_le : forall a, 0<=a -> √(S a) <= S (√a). + Proof. + intros a Ha. + apply lt_succ_r. + apply sqrt_lt_square. + - now apply le_le_succ_r. + - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. + - rewrite <- (add_1_l (S (√a))). + apply lt_le_trans with (1²+(S (√a))²). + + rewrite mul_1_l, add_1_l, <- succ_lt_mono. + now apply sqrt_spec. + + apply add_square_le. * order'. * apply le_le_succ_r, sqrt_nonneg. + Qed. + + Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a. + Proof. + intros a Ha. + destruct (le_gt_cases (√(S a)) (√a)) as [H|H]. + - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. + Qed. + + Lemma sqrt_eq_succ_iff_square : forall a, 0<=a -> + (√(S a) == S (√a) <-> exists b, 0 √(a+b) <= √a + √b). + - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. + apply sqrt_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (lt_ge_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√a)); now apply AUX. + * assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + rewrite <- lt_succ_r. + apply sqrt_lt_square. + -- now apply add_nonneg_nonneg. + -- now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. + -- destruct (sqrt_spec a Ha) as (_,LTa). + destruct (sqrt_spec b Hb) as (_,LTb). + revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. + intros LTa LTb. + assert (H:=add_le_mono _ _ _ _ LTa LTb). + etransitivity; [eexact H|]. clear LTa LTb H. + rewrite <- (add_assoc _ (√a) (√a)). + rewrite <- (add_assoc _ (√b) (√b)). + rewrite add_shuffle1. + rewrite <- (add_assoc _ (√a + √b)). + rewrite (add_shuffle1 (√a) (√b)). + apply add_le_mono_r. + now apply add_square_le. + Qed. + + (** convexity inequality for sqrt: sqrt of middle is above middle of square roots. *) -Lemma add_sqrt_le : forall a b, 0<=a -> 0<=b -> √a + √b <= √(2*(a+b)). -Proof. - intros a b Ha Hb. - assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - apply sqrt_le_square. - - apply mul_nonneg_nonneg. + order'. + now apply add_nonneg_nonneg. - - now apply add_nonneg_nonneg. - - transitivity (2*((√a)² + (√b)²)). - + now apply square_add_le. - + apply mul_le_mono_nonneg_l. * order'. - * apply add_le_mono; now apply sqrt_spec. -Qed. + Lemma add_sqrt_le : forall a b, 0<=a -> 0<=b -> √a + √b <= √(2*(a+b)). + Proof. + intros a b Ha Hb. + assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + apply sqrt_le_square. + - apply mul_nonneg_nonneg. + order'. + now apply add_nonneg_nonneg. + - now apply add_nonneg_nonneg. + - transitivity (2*((√a)² + (√b)²)). + + now apply square_add_le. + + apply mul_le_mono_nonneg_l. * order'. + * apply add_le_mono; now apply sqrt_spec. + Qed. End NZSqrtProp. Module Type NZSqrtUpProp - (Import A : NZDecOrdAxiomsSig') - (Import B : NZSqrt' A) - (Import C : NZMulOrderProp A) - (Import D : NZSqrtProp A B C). - -(** * [sqrt_up] : a square root that rounds up instead of down *) - -#[local] Notation "a ²" := (a*a) (no associativity, format "a ²"). - -(** For once, we define instead of axiomatizing, thanks to sqrt *) - -Definition sqrt_up a := - match compare 0 a with - | Lt => S √(P a) - | _ => 0 - end. - -#[local] Notation "√° a" := (sqrt_up a) (at level 6, no associativity). - -Lemma sqrt_up_eqn0 : forall a, a<=0 -> √°a == 0. -Proof. - intros a Ha. unfold sqrt_up. case compare_spec; try order. -Qed. - -Lemma sqrt_up_eqn : forall a, 0 √°a == S √(P a). -Proof. - intros a Ha. unfold sqrt_up. case compare_spec; try order. -Qed. - -Lemma sqrt_up_spec : forall a, 0 (P √°a)² < a <= (√°a)². -Proof. - intros a Ha. - rewrite sqrt_up_eqn, pred_succ; trivial. - assert (Ha' := lt_succ_pred 0 a Ha). - rewrite <- Ha' at 3 4. - rewrite le_succ_l, lt_succ_r. - apply sqrt_spec. - now rewrite <- lt_succ_r, Ha'. -Qed. - -(** First, [sqrt_up] is non-negative *) - -Lemma sqrt_up_nonneg : forall a, 0<=√°a. -Proof. - intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - - now rewrite sqrt_up_eqn0. - - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. -Qed. - -(** [sqrt_up] is a morphism *) - -#[global] -Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. -Proof. - assert (Proper (eq==>eq==>Logic.eq) compare). - - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. - - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. -Qed. - -(** The spec of [sqrt_up] indeed determines it *) - -Lemma sqrt_up_unique : forall a b, 0 (P b)² < a <= b² -> √°a == b. -Proof. - intros a b Hb (LEb,LTb). - assert (Ha : 0 √°(a²) == a. -Proof. - intros a Ha. - le_elim Ha. - - rewrite sqrt_up_eqn by (now apply mul_pos_pos). - rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. - - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. -Qed. - -(** [sqrt_up] and successors of squares *) - -Lemma sqrt_up_succ_square : forall a, 0<=a -> √°(S a²) == S a. -Proof. - intros a Ha. - rewrite sqrt_up_eqn by (now apply lt_succ_r, mul_nonneg_nonneg). - now rewrite pred_succ, sqrt_square. -Qed. - -(** Basic constants *) - -Lemma sqrt_up_0 : √°0 == 0. -Proof. - rewrite <- (mul_0_l 0) at 1. now apply sqrt_up_square. -Qed. - -Lemma sqrt_up_1 : √°1 == 1. -Proof. - rewrite <- (mul_1_l 1) at 1. apply sqrt_up_square. order'. -Qed. - -Lemma sqrt_up_2 : √°2 == 2. -Proof. - rewrite sqrt_up_eqn by order'. - now rewrite two_succ, pred_succ, sqrt_1. -Qed. - -(** Links between sqrt and [sqrt_up] *) - -Lemma le_sqrt_sqrt_up : forall a, √a <= √°a. -Proof. - intros a. unfold sqrt_up. case compare_spec; intros H. - - rewrite <- H, sqrt_0. order. - - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. - apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). - - now rewrite sqrt_neg. -Qed. - -Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a). -Proof. - intros a. unfold sqrt_up. - case compare_spec; intros H; try apply le_le_succ_r, sqrt_nonneg. - rewrite <- succ_le_mono. apply sqrt_le_mono. - rewrite <- (lt_succ_pred 0 a H) at 2. apply le_succ_diag_r. -Qed. - -Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)². -Proof. - intros a H. split. - - now apply sqrt_spec. - - le_elim H. - + now apply sqrt_up_spec. - + now rewrite <-H, sqrt_up_0, mul_0_l. -Qed. - -Lemma sqrt_sqrt_up_exact : - forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²). -Proof. - intros a Ha. - split. - intros H. exists √a. - split. + apply sqrt_nonneg. - + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. - - intros (b & Hb & Hb'). rewrite Hb'. - now rewrite sqrt_square, sqrt_up_square. -Qed. - -(** [sqrt_up] is a monotone function (but not a strict one) *) - -Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b. -Proof. - intros a b H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. - - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. - apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. -Qed. - -(** No reverse result for <=, consider for instance √°3 <= √°2 *) - -Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b. -Proof. - intros a b H. - destruct (le_gt_cases b 0) as [Hb|Hb]. - - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. - - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. - rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. - apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. -Qed. - -(** When left side is a square, we have an equivalence for < *) - -Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a). -Proof. - intros a b Ha Hb. split; intros H. - - destruct (sqrt_up_spec a) as (LE,LT). - + apply le_lt_trans with b²; trivial using square_nonneg. - + apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. - - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. -Qed. - -(** When right side is a square, we have an equivalence for <= *) - -Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b). -Proof. - intros a b Ha Hb. split; intros H. - - rewrite <- (sqrt_up_square b Hb). - now apply sqrt_up_le_mono. - - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. - transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. -Qed. - -Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a. -Proof. - intros a. split; intros Ha. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. - - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. - now rewrite one_succ, le_succ_l. -Qed. - -Lemma sqrt_up_lt_lin : forall a, 2 √°a < a. -Proof. - intros a Ha. - rewrite sqrt_up_eqn by order'. - assert (Ha' := lt_succ_pred 2 a Ha). - rewrite <- Ha' at 2. rewrite <- succ_lt_mono. - apply sqrt_lt_lin. rewrite succ_lt_mono. now rewrite Ha', <- two_succ. -Qed. - -Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a. -Proof. - intros a Ha. - le_elim Ha. - - rewrite sqrt_up_eqn; trivial. apply le_succ_l. - apply le_lt_trans with (P a). + apply sqrt_le_lin. - now rewrite <- lt_succ_r, (lt_succ_pred 0). - + rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. - - now rewrite <- Ha, sqrt_up_0. -Qed. - -(** [sqrt_up] and multiplication. *) - -(** Due to rounding error, we don't have the usual [√(a*b) = √a*√b] + (Import A : NZDecOrdAxiomsSig') + (Import B : NZSqrt' A) + (Import C : NZMulOrderProp A) + (Import D : NZSqrtProp A B C). + + (** * [sqrt_up] : a square root that rounds up instead of down *) + + #[local] Notation "a ²" := (a*a) (no associativity, format "a ²"). + + (** For once, we define instead of axiomatizing, thanks to sqrt *) + + Definition sqrt_up a := + match compare 0 a with + | Lt => S √(P a) + | _ => 0 + end. + + #[local] Notation "√° a" := (sqrt_up a) (at level 6, no associativity). + + Lemma sqrt_up_eqn0 : forall a, a<=0 -> √°a == 0. + Proof. + intros a Ha. unfold sqrt_up. case compare_spec; try order. + Qed. + + Lemma sqrt_up_eqn : forall a, 0 √°a == S √(P a). + Proof. + intros a Ha. unfold sqrt_up. case compare_spec; try order. + Qed. + + Lemma sqrt_up_spec : forall a, 0 (P √°a)² < a <= (√°a)². + Proof. + intros a Ha. + rewrite sqrt_up_eqn, pred_succ; trivial. + assert (Ha' := lt_succ_pred 0 a Ha). + rewrite <- Ha' at 3 4. + rewrite le_succ_l, lt_succ_r. + apply sqrt_spec. + now rewrite <- lt_succ_r, Ha'. + Qed. + + (** First, [sqrt_up] is non-negative *) + + Lemma sqrt_up_nonneg : forall a, 0<=√°a. + Proof. + intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. + - now rewrite sqrt_up_eqn0. + - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. + Qed. + + (** [sqrt_up] is a morphism *) + + #[global] + Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. + Proof. + assert (Proper (eq==>eq==>Logic.eq) compare). + - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. + - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. + Qed. + + (** The spec of [sqrt_up] indeed determines it *) + + Lemma sqrt_up_unique : forall a b, 0 (P b)² < a <= b² -> √°a == b. + Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 0 √°(a²) == a. + Proof. + intros a Ha. + le_elim Ha. + - rewrite sqrt_up_eqn by (now apply mul_pos_pos). + rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. + - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. + Qed. + + (** [sqrt_up] and successors of squares *) + + Lemma sqrt_up_succ_square : forall a, 0<=a -> √°(S a²) == S a. + Proof. + intros a Ha. + rewrite sqrt_up_eqn by (now apply lt_succ_r, mul_nonneg_nonneg). + now rewrite pred_succ, sqrt_square. + Qed. + + (** Basic constants *) + + Lemma sqrt_up_0 : √°0 == 0. + Proof. + rewrite <- (mul_0_l 0) at 1. now apply sqrt_up_square. + Qed. + + Lemma sqrt_up_1 : √°1 == 1. + Proof. + rewrite <- (mul_1_l 1) at 1. apply sqrt_up_square. order'. + Qed. + + Lemma sqrt_up_2 : √°2 == 2. + Proof. + rewrite sqrt_up_eqn by order'. + now rewrite two_succ, pred_succ, sqrt_1. + Qed. + + (** Links between sqrt and [sqrt_up] *) + + Lemma le_sqrt_sqrt_up : forall a, √a <= √°a. + Proof. + intros a. unfold sqrt_up. case compare_spec; intros H. + - rewrite <- H, sqrt_0. order. + - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. + apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). + - now rewrite sqrt_neg. + Qed. + + Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a). + Proof. + intros a. unfold sqrt_up. + case compare_spec; intros H; try apply le_le_succ_r, sqrt_nonneg. + rewrite <- succ_le_mono. apply sqrt_le_mono. + rewrite <- (lt_succ_pred 0 a H) at 2. apply le_succ_diag_r. + Qed. + + Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)². + Proof. + intros a H. split. + - now apply sqrt_spec. + - le_elim H. + + now apply sqrt_up_spec. + + now rewrite <-H, sqrt_up_0, mul_0_l. + Qed. + + Lemma sqrt_sqrt_up_exact : + forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²). + Proof. + intros a Ha. + split. - intros H. exists √a. + split. + apply sqrt_nonneg. + + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. + - intros (b & Hb & Hb'). rewrite Hb'. + now rewrite sqrt_square, sqrt_up_square. + Qed. + + (** [sqrt_up] is a monotone function (but not a strict one) *) + + Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b. + Proof. + intros a b H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. + - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. + apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. + Qed. + + (** No reverse result for <=, consider for instance √°3 <= √°2 *) + + Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b. + Proof. + intros a b H. + destruct (le_gt_cases b 0) as [Hb|Hb]. + - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. + rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. + apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. + Qed. + + (** When left side is a square, we have an equivalence for < *) + + Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a). + Proof. + intros a b Ha Hb. split; intros H. + - destruct (sqrt_up_spec a) as (LE,LT). + + apply le_lt_trans with b²; trivial using square_nonneg. + + apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. + - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. + Qed. + + (** When right side is a square, we have an equivalence for <= *) + + Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b). + Proof. + intros a b Ha Hb. split; intros H. + - rewrite <- (sqrt_up_square b Hb). + now apply sqrt_up_le_mono. + - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. + transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. + Qed. + + Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a. + Proof. + intros a. split; intros Ha. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. + now rewrite one_succ, le_succ_l. + Qed. + + Lemma sqrt_up_lt_lin : forall a, 2 √°a < a. + Proof. + intros a Ha. + rewrite sqrt_up_eqn by order'. + assert (Ha' := lt_succ_pred 2 a Ha). + rewrite <- Ha' at 2. rewrite <- succ_lt_mono. + apply sqrt_lt_lin. rewrite succ_lt_mono. now rewrite Ha', <- two_succ. + Qed. + + Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a. + Proof. + intros a Ha. + le_elim Ha. + - rewrite sqrt_up_eqn; trivial. apply le_succ_l. + apply le_lt_trans with (P a). + apply sqrt_le_lin. + now rewrite <- lt_succ_r, (lt_succ_pred 0). + + rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. + - now rewrite <- Ha, sqrt_up_0. + Qed. + + (** [sqrt_up] and multiplication. *) + + (** Due to rounding error, we don't have the usual [√(a*b) = √a*√b] but only lower and upper bounds. *) -Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √°b. -Proof. - intros a b Ha Hb. - apply sqrt_up_le_square. - - now apply mul_nonneg_nonneg. - - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. - - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. -Qed. - -Lemma sqrt_up_mul_below : forall a b, 0 0 (P √°a)*(P √°b) < √°(a*b). -Proof. - intros a b Ha Hb. - apply sqrt_up_lt_square. - - apply mul_nonneg_nonneg; order. - - apply mul_nonneg_nonneg; apply lt_succ_r. - + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial using square_nonneg; - now apply sqrt_up_spec. -Qed. - -(** And we can't find better approximations in general. + Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √°b. + Proof. + intros a b Ha Hb. + apply sqrt_up_le_square. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. + - rewrite mul_shuffle1. + apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. + Qed. + + Lemma sqrt_up_mul_below : forall a b, 0 0 (P √°a)*(P √°b) < √°(a*b). + Proof. + intros a b Ha Hb. + apply sqrt_up_lt_square. + - apply mul_nonneg_nonneg; order. + - apply mul_nonneg_nonneg; apply lt_succ_r. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial using square_nonneg; + now apply sqrt_up_spec. + Qed. + + (** And we can't find better approximations in general. - The upper bound is exact for squares - Concerning the lower bound, for any c>0, take [a=b=c²+1], then [√°(a*b) = c²+1] while [P √°a = P √°b = c] *) -(** [sqrt_up] and successor : + (** [sqrt_up] and successor : - the [sqrt_up] function climbs by at most 1 at a time - otherwise it stays at the same value - the +1 steps occur after squares *) -Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a). -Proof. - intros a Ha. - apply sqrt_up_le_square. - - now apply le_le_succ_r. - - apply le_le_succ_r, sqrt_up_nonneg. - - rewrite <- (add_1_l (√°a)). - apply le_trans with (1²+(√°a)²). - + rewrite mul_1_l, add_1_l, <- succ_le_mono. - now apply sqrt_sqrt_up_spec. - + apply add_square_le. * order'. * apply sqrt_up_nonneg. -Qed. - -Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a. -Proof. - intros a Ha. - destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H]. - - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. -Qed. - -Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a -> - (√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²). -Proof. - intros a Ha. split. - - intros EQ. - le_elim Ha. - + exists (√°a). split. * apply sqrt_up_nonneg. - * generalize (proj2 (sqrt_up_spec a Ha)). - assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). - generalize (proj1 (sqrt_up_spec (S a) Ha')). - rewrite EQ, pred_succ, lt_succ_r. order. - + exists 0. nzsimpl. now split. - - intros (b & Hb & H). - now rewrite H, sqrt_up_succ_square, sqrt_up_square. -Qed. - -(** [sqrt_up] and addition *) - -Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b. -Proof. - assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b). - - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. - apply sqrt_up_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - - intros a b. - destruct (le_gt_cases a 0) as [Ha|Ha]. + now apply AUX. - + destruct (le_gt_cases b 0) as [Hb|Hb]. - * rewrite (add_comm a), (add_comm (√°a)); now apply AUX. - * rewrite 2 sqrt_up_eqn; trivial. - -- nzsimpl. rewrite <- succ_le_mono. - transitivity (√(P a) + √b). - ++ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. - ++ apply add_le_mono_l. - apply le_sqrt_sqrt_up. - -- now apply add_pos_pos. -Qed. - -(** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle + Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a). + Proof. + intros a Ha. + apply sqrt_up_le_square. + - now apply le_le_succ_r. + - apply le_le_succ_r, sqrt_up_nonneg. + - rewrite <- (add_1_l (√°a)). + apply le_trans with (1²+(√°a)²). + + rewrite mul_1_l, add_1_l, <- succ_le_mono. + now apply sqrt_sqrt_up_spec. + + apply add_square_le. * order'. * apply sqrt_up_nonneg. + Qed. + + Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a. + Proof. + intros a Ha. + destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H]. + - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. + Qed. + + Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a -> + (√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²). + Proof. + intros a Ha. split. + - intros EQ. + le_elim Ha. + + exists (√°a). split. * apply sqrt_up_nonneg. + * generalize (proj2 (sqrt_up_spec a Ha)). + assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). + generalize (proj1 (sqrt_up_spec (S a) Ha')). + rewrite EQ, pred_succ, lt_succ_r. order. + + exists 0. nzsimpl. now split. + - intros (b & Hb & H). + now rewrite H, sqrt_up_succ_square, sqrt_up_square. + Qed. + + (** [sqrt_up] and addition *) + + Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b. + Proof. + assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b). + - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. + apply sqrt_up_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (le_gt_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (le_gt_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√°a)); now apply AUX. + * rewrite 2 sqrt_up_eqn; trivial. + -- nzsimpl. rewrite <- succ_le_mono. + transitivity (√(P a) + √b). + ++ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. + ++ apply add_le_mono_l. + apply le_sqrt_sqrt_up. + -- now apply add_pos_pos. + Qed. + + (** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle of square roots. We cannot say more, for instance take a=b=2, then 2+2 <= S 3 *) -Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)). -Proof. - intros a b Ha Hb. - le_elim Ha;[le_elim Hb|]. - - rewrite 3 sqrt_up_eqn; trivial. - + nzsimpl. rewrite <- 2 succ_le_mono. - etransitivity; [eapply add_sqrt_le|]. - * apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). - * apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). - * apply sqrt_le_mono. - apply lt_succ_r. rewrite (lt_succ_pred 0). - -- apply mul_lt_mono_pos_l. ++ order'. - ++ apply add_lt_mono. - ** apply le_succ_l. now rewrite (lt_succ_pred 0). - ** apply le_succ_l. now rewrite (lt_succ_pred 0). - -- apply mul_pos_pos. ++ order'. ++ now apply add_pos_pos. - + apply mul_pos_pos. * order'. * now apply add_pos_pos. - - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. - - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. -Qed. + Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)). + Proof. + intros a b Ha Hb. + le_elim Ha;[le_elim Hb|]. + - rewrite 3 sqrt_up_eqn; trivial. + + nzsimpl. rewrite <- 2 succ_le_mono. + etransitivity; [eapply add_sqrt_le|]. + * apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). + * apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). + * apply sqrt_le_mono. + apply lt_succ_r. rewrite (lt_succ_pred 0). + -- apply mul_lt_mono_pos_l. ++ order'. + ++ apply add_lt_mono. + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + -- apply mul_pos_pos. ++ order'. ++ now apply add_pos_pos. + + apply mul_pos_pos. * order'. * now apply add_pos_pos. + - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. + - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. + Qed. End NZSqrtUpProp. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index 5eccf9c66a..628f7264ba 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -13,68 +13,68 @@ From Stdlib Require Export NBase. Module NAddProp (Import N : NAxiomsMiniSig'). -Include NBaseProp N. + Include NBaseProp N. -(** For theorems about [add] that are both valid for [N] and [Z], see [NZAdd] *) -(** Now comes theorems valid for natural numbers but not for Z *) + (** For theorems about [add] that are both valid for [N] and [Z], see [NZAdd] *) + (** Now comes theorems valid for natural numbers but not for Z *) -Theorem eq_add_0 : forall n m, n + m == 0 <-> n == 0 /\ m == 0. -Proof. -intros n m; induct n. -- nzsimpl; intuition auto with relations. -- intros n IH. nzsimpl. -setoid_replace (S (n + m) == 0) with False by - (apply neg_false; apply neq_succ_0). -setoid_replace (S n == 0) with False by - (apply neg_false; apply neq_succ_0). tauto. -Qed. + Theorem eq_add_0 : forall n m, n + m == 0 <-> n == 0 /\ m == 0. + Proof. + intros n m; induct n. + - nzsimpl; intuition auto with relations. + - intros n IH. nzsimpl. + setoid_replace (S (n + m) == 0) with False by + (apply neg_false; apply neq_succ_0). + setoid_replace (S n == 0) with False by + (apply neg_false; apply neq_succ_0). tauto. + Qed. -Theorem eq_add_succ : - forall n m, (exists p, n + m == S p) <-> - (exists n', n == S n') \/ (exists m', m == S m'). -Proof. -intros n m; cases n. -- split; intro H. - + destruct H as [p H]. rewrite add_0_l in H; right; now exists p. - + destruct H as [[n' H] | [m' H]]. - * symmetry in H; false_hyp H neq_succ_0. - * exists m'; now rewrite add_0_l. -- intro n; split; intro H. - + left; now exists n. - + exists (n + m); now rewrite add_succ_l. -Qed. + Theorem eq_add_succ : + forall n m, (exists p, n + m == S p) <-> + (exists n', n == S n') \/ (exists m', m == S m'). + Proof. + intros n m; cases n. + - split; intro H. + + destruct H as [p H]. rewrite add_0_l in H; right; now exists p. + + destruct H as [[n' H] | [m' H]]. + * symmetry in H; false_hyp H neq_succ_0. + * exists m'; now rewrite add_0_l. + - intro n; split; intro H. + + left; now exists n. + + exists (n + m); now rewrite add_succ_l. + Qed. -Theorem eq_add_1 : forall n m, - n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. -Proof. -intros n m. rewrite one_succ. intro H. -assert (H1 : exists p, n + m == S p) by now exists 0. -apply eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]]. -- left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H. - apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split. -- right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H. - apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split. -Qed. + Theorem eq_add_1 : forall n m, + n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. + Proof. + intros n m. rewrite one_succ. intro H. + assert (H1 : exists p, n + m == S p) by now exists 0. + apply eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]]. + - left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H. + apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split. + - right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H. + apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split. + Qed. -Theorem succ_add_discr : forall n m, m ~= S (n + m). -Proof. -intros n m; induct m. -- apply neq_sym. apply neq_succ_0. -- intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. - unfold not in IH; now apply IH. -Qed. + Theorem succ_add_discr : forall n m, m ~= S (n + m). + Proof. + intros n m; induct m. + - apply neq_sym. apply neq_succ_0. + - intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. + unfold not in IH; now apply IH. + Qed. -Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m). -Proof. -intros n m; cases n. -- intro H; now elim H. -- intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ. -Qed. + Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m). + Proof. + intros n m; cases n. + - intro H; now elim H. + - intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ. + Qed. -Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m). -Proof. -intros n m H; rewrite (add_comm n (P m)); -rewrite (add_comm n m); now apply add_pred_l. -Qed. + Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m). + Proof. + intros n m H; rewrite (add_comm n (P m)); + rewrite (add_comm n m); now apply add_pred_l. + Qed. End NAddProp. diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index e51c4d1429..1a0968db66 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -13,45 +13,45 @@ From Stdlib Require Export NOrder. Module NAddOrderProp (Import N : NAxiomsMiniSig'). -Include NOrderProp N. - -(** Theorems true for natural numbers, not for integers *) - -Theorem le_add_r : forall n m, n <= n + m. -Proof. -intros n m; induct m. -- rewrite add_0_r; now apply eq_le_incl. -- intros m IH. rewrite add_succ_r; now apply le_le_succ_r. -Qed. - -Theorem le_add_l : forall n m, n <= m + n. -Proof. -intros n m; rewrite add_comm; apply le_add_r. -Qed. - -Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p. -Proof. -intros n m p H; rewrite <- (add_0_r n). -apply add_lt_le_mono; [assumption | apply le_0_l]. -Qed. - -Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m. -Proof. -intros n m p; rewrite add_comm; apply lt_lt_add_r. -Qed. - -Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m. -Proof. - intros; apply add_pos_nonneg. - - assumption. - - apply le_0_l. -Qed. - -Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m. -Proof. - intros; apply add_nonneg_pos. - - apply le_0_l. - - assumption. -Qed. + Include NOrderProp N. + + (** Theorems true for natural numbers, not for integers *) + + Theorem le_add_r : forall n m, n <= n + m. + Proof. + intros n m; induct m. + - rewrite add_0_r; now apply eq_le_incl. + - intros m IH. rewrite add_succ_r; now apply le_le_succ_r. + Qed. + + Theorem le_add_l : forall n m, n <= m + n. + Proof. + intros n m; rewrite add_comm; apply le_add_r. + Qed. + + Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p. + Proof. + intros n m p H; rewrite <- (add_0_r n). + apply add_lt_le_mono; [assumption | apply le_0_l]. + Qed. + + Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m. + Proof. + intros n m p; rewrite add_comm; apply lt_lt_add_r. + Qed. + + Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m. + Proof. + intros; apply add_pos_nonneg. + - assumption. + - apply le_0_l. + Qed. + + Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m. + Proof. + intros; apply add_nonneg_pos. + - apply le_0_l. + - assumption. + Qed. End NAddOrderProp. diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v index 571778367f..b0469589b8 100644 --- a/theories/Numbers/Natural/Abstract/NAxioms.v +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -15,7 +15,7 @@ From Stdlib Require Export Bool NZAxioms NZParity NZPow NZSqrt NZLog NZDiv NZGcd (** From [NZ], we obtain natural numbers just by stating that [pred 0] == 0 *) Module Type NAxiom (Import NZ : NZDomainSig'). - Axiom pred_0 : P 0 == 0. + Axiom pred_0 : P 0 == 0. End NAxiom. Module Type NAxiomsMiniSig := NZOrdAxiomsSig <+ NAxiom. @@ -27,7 +27,7 @@ Module Type NAxiomsMiniSig' := NZOrdAxiomsSig' <+ NAxiom. and add to that a N-specific constraint. *) Module Type NDivSpecific (Import N : NAxiomsMiniSig')(Import DM : DivMod' N). - Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. + Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. End NDivSpecific. (** For all other functions, the NZ axiomatizations are enough. *) @@ -47,19 +47,19 @@ Module Type NAxiomsSig' := NAxiomsMiniSig' <+ OrderFunctions' Module Type NAxiomsRec (Import NZ : NZDomainSig'). -Parameter Inline recursion : forall {A : Type}, A -> (t -> A -> A) -> t -> A. + Parameter Inline recursion : forall {A : Type}, A -> (t -> A -> A) -> t -> A. -#[global] -Declare Instance recursion_wd {A : Type} (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. + #[global] + Declare Instance recursion_wd {A : Type} (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. -Axiom recursion_0 : - forall {A} (a : A) (f : t -> A -> A), recursion a f 0 = a. + Axiom recursion_0 : + forall {A} (a : A) (f : t -> A -> A), recursion a f 0 = a. -Axiom recursion_succ : - forall {A} (Aeq : relation A) (a : A) (f : t -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)). + Axiom recursion_succ : + forall {A} (Aeq : relation A) (a : A) (f : t -> A -> A), + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> + forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)). End NAxiomsRec. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index d00633cc4e..1d562e2ab5 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -15,178 +15,178 @@ From Stdlib Require Export NAxioms. From Stdlib Require Import NZMulOrder. Module NBaseProp (Import N : NAxiomsMiniSig'). -(** First, we import all known facts about both natural numbers and integers. *) -Include NZMulOrderProp N. - -(** From [pred_0] and order facts, we can prove that 0 isn't a successor. *) - -Theorem neq_succ_0 : forall n, S n ~= 0. -Proof. - intros n EQ. - assert (EQ' := pred_succ n). - rewrite EQ, pred_0 in EQ'. - rewrite <- EQ' in EQ. - now apply (neq_succ_diag_l 0). -Qed. - -Theorem neq_0_succ : forall n, 0 ~= S n. -Proof. -intro n; apply neq_sym; apply neq_succ_0. -Qed. - -(** Next, we show that all numbers are nonnegative and recover regular + (** First, we import all known facts about both natural numbers and integers. *) + Include NZMulOrderProp N. + + (** From [pred_0] and order facts, we can prove that 0 isn't a successor. *) + + Theorem neq_succ_0 : forall n, S n ~= 0. + Proof. + intros n EQ. + assert (EQ' := pred_succ n). + rewrite EQ, pred_0 in EQ'. + rewrite <- EQ' in EQ. + now apply (neq_succ_diag_l 0). + Qed. + + Theorem neq_0_succ : forall n, 0 ~= S n. + Proof. + intro n; apply neq_sym; apply neq_succ_0. + Qed. + + (** Next, we show that all numbers are nonnegative and recover regular induction from the bidirectional induction on NZ *) -Theorem le_0_l : forall n, 0 <= n. -Proof. -intro n; nzinduct n. -- now apply eq_le_incl. -- intro n; split. - + apply le_le_succ_r. - + intro H; apply le_succ_r in H; destruct H as [H | H]. - * assumption. - * symmetry in H; false_hyp H neq_succ_0. -Qed. - -Theorem induction : - forall A : N.t -> Prop, Proper (N.eq==>iff) A -> - A 0 -> (forall n, A n -> A (S n)) -> forall n, A n. -Proof. -intros A A_wd A0 AS n; apply right_induction with 0; try assumption. -- intros; auto; apply le_0_l. -- apply le_0_l. -Qed. - -(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct] + Theorem le_0_l : forall n, 0 <= n. + Proof. + intro n; nzinduct n. + - now apply eq_le_incl. + - intro n; split. + + apply le_le_succ_r. + + intro H; apply le_succ_r in H; destruct H as [H | H]. + * assumption. + * symmetry in H; false_hyp H neq_succ_0. + Qed. + + Theorem induction : + forall A : N.t -> Prop, Proper (N.eq==>iff) A -> + A 0 -> (forall n, A n -> A (S n)) -> forall n, A n. + Proof. + intros A A_wd A0 AS n; apply right_induction with 0; try assumption. + - intros; auto; apply le_0_l. + - apply le_0_l. + Qed. + + (** The theorems [bi_induction], [central_induction] and the tactic [nzinduct] refer to bidirectional induction, which is not useful on natural numbers. Therefore, we define a new induction tactic for natural numbers. We do not have to call "Declare Left Step" and "Declare Right Step" commands again, since the data for stepl and stepr tactics is inherited from NZ. *) -Ltac induct n := induction_maker n ltac:(apply induction). - -Theorem case_analysis : - forall A : N.t -> Prop, Proper (N.eq==>iff) A -> - A 0 -> (forall n, A (S n)) -> forall n, A n. -Proof. -intros; apply induction; auto. -Qed. - -Ltac cases n := induction_maker n ltac:(apply case_analysis). - -Theorem neq_0 : ~ forall n, n == 0. -Proof. -intro H; apply (neq_succ_0 0). apply H. -Qed. - -Theorem neq_0_r n : n ~= 0 <-> exists m, n == S m. -Proof. - cases n. - - split; intro H;[now elim H | destruct H as [m H]; - symmetry in H; false_hyp H neq_succ_0]. - - intro n; split; intro H; [now exists n | apply neq_succ_0]. -Qed. - -Theorem zero_or_succ n : n == 0 \/ exists m, n == S m. -Proof. -cases n. -- now left. -- intro n; right; now exists n. -Qed. - -Theorem eq_pred_0 n : P n == 0 <-> n == 0 \/ n == 1. -Proof. -cases n. -- rewrite pred_0. now split; [left|]. -- intro n. rewrite pred_succ. - split. - + intros H; right. now rewrite H, one_succ. - + intros [H|H]. - * elim (neq_succ_0 _ H). - * apply succ_inj_wd. now rewrite <- one_succ. -Qed. - -Theorem succ_pred n : n ~= 0 -> S (P n) == n. -Proof. -cases n. -- intro H; exfalso; now apply H. -- intros; now rewrite pred_succ. -Qed. - -Theorem pred_inj n m : n ~= 0 -> m ~= 0 -> P n == P m -> n == m. -Proof. -cases n. -- intros H; exfalso; now apply H. -- intros n _; cases m. - + intros H; exfalso; now apply H. - + intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3. -Qed. - -(** The following induction principle is useful for reasoning about, e.g., + Ltac induct n := induction_maker n ltac:(apply induction). + + Theorem case_analysis : + forall A : N.t -> Prop, Proper (N.eq==>iff) A -> + A 0 -> (forall n, A (S n)) -> forall n, A n. + Proof. + intros; apply induction; auto. + Qed. + + Ltac cases n := induction_maker n ltac:(apply case_analysis). + + Theorem neq_0 : ~ forall n, n == 0. + Proof. + intro H; apply (neq_succ_0 0). apply H. + Qed. + + Theorem neq_0_r n : n ~= 0 <-> exists m, n == S m. + Proof. + cases n. + - split; intro H;[now elim H | destruct H as [m H]; + symmetry in H; false_hyp H neq_succ_0]. + - intro n; split; intro H; [now exists n | apply neq_succ_0]. + Qed. + + Theorem zero_or_succ n : n == 0 \/ exists m, n == S m. + Proof. + cases n. + - now left. + - intro n; right; now exists n. + Qed. + + Theorem eq_pred_0 n : P n == 0 <-> n == 0 \/ n == 1. + Proof. + cases n. + - rewrite pred_0. now split; [left|]. + - intro n. rewrite pred_succ. + split. + + intros H; right. now rewrite H, one_succ. + + intros [H|H]. + * elim (neq_succ_0 _ H). + * apply succ_inj_wd. now rewrite <- one_succ. + Qed. + + Theorem succ_pred n : n ~= 0 -> S (P n) == n. + Proof. + cases n. + - intro H; exfalso; now apply H. + - intros; now rewrite pred_succ. + Qed. + + Theorem pred_inj n m : n ~= 0 -> m ~= 0 -> P n == P m -> n == m. + Proof. + cases n. + - intros H; exfalso; now apply H. + - intros n _; cases m. + + intros H; exfalso; now apply H. + + intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3. + Qed. + + (** The following induction principle is useful for reasoning about, e.g., Fibonacci numbers *) -Section PairInduction. + Section PairInduction. -Variable A : N.t -> Prop. -Hypothesis A_wd : Proper (N.eq==>iff) A. + Variable A : N.t -> Prop. + Hypothesis A_wd : Proper (N.eq==>iff) A. -Theorem pair_induction : - A 0 -> A 1 -> - (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n. -Proof. -rewrite one_succ. -intros until 3. -assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))]. -intro n; induct n; [ | intros n [IH1 IH2]]; auto. -Qed. + Theorem pair_induction : + A 0 -> A 1 -> + (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n. + Proof. + rewrite one_succ. + intros until 3. + assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))]. + intro n; induct n; [ | intros n [IH1 IH2]]; auto. + Qed. -End PairInduction. + End PairInduction. -(** The following is useful for reasoning about, e.g., Ackermann function *) + (** The following is useful for reasoning about, e.g., Ackermann function *) -Section TwoDimensionalInduction. + Section TwoDimensionalInduction. -Variable R : N.t -> N.t -> Prop. -Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. + Variable R : N.t -> N.t -> Prop. + Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. -Theorem two_dim_induction : - R 0 0 -> - (forall n m, R n m -> R n (S m)) -> - (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. -Proof. -intros H1 H2 H3. intro n; induct n. -- intro m; induct m. - + exact H1. - + exact (H2 0). -- intros n IH. intro m; induct m. - + now apply H3. - + exact (H2 (S n)). -Qed. + Theorem two_dim_induction : + R 0 0 -> + (forall n m, R n m -> R n (S m)) -> + (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. + Proof. + intros H1 H2 H3. intro n; induct n. + - intro m; induct m. + + exact H1. + + exact (H2 0). + - intros n IH. intro m; induct m. + + now apply H3. + + exact (H2 (S n)). + Qed. -End TwoDimensionalInduction. + End TwoDimensionalInduction. -Section DoubleInduction. + Section DoubleInduction. -Variable R : N.t -> N.t -> Prop. -Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. + Variable R : N.t -> N.t -> Prop. + Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. -Theorem double_induction : - (forall m, R 0 m) -> - (forall n, R (S n) 0) -> - (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. -Proof. -intros H1 H2 H3 n; induct n; auto. -intros n H m; cases m; auto. -Qed. + Theorem double_induction : + (forall m, R 0 m) -> + (forall n, R (S n) 0) -> + (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. + Proof. + intros H1 H2 H3 n; induct n; auto. + intros n H m; cases m; auto. + Qed. -End DoubleInduction. + End DoubleInduction. -Ltac double_induct n m := - try intros until n; - try intros until m; - pattern n, m; apply double_induction; clear n m; - [solve_proper | | | ]. + Ltac double_induct n m := + try intros until n; + try intros until m; + pattern n, m; apply double_induction; clear n m; + [solve_proper | | | ]. End NBaseProp. diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v index b85bab19e4..56e72a6f91 100644 --- a/theories/Numbers/Natural/Abstract/NBits.v +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -13,1782 +13,1782 @@ From Stdlib Require Import Bool NAxioms NSub NPow NDiv NParity NLog. (** Derived properties of bitwise operations *) Module Type NBitsProp - (Import A : NAxiomsSig') - (Import B : NSubProp A) - (Import C : NParityProp A B) - (Import D : NPowProp A B C) - (Import E : NDivProp A B) - (Import F : NLog2Prop A B C D). - -Include BoolEqualityFacts A. - -Ltac order_nz := try apply pow_nonzero; order'. -#[global] Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. - -(** Some properties of power and division *) - -Lemma pow_sub_r : forall a b c, a~=0 -> c<=b -> a^(b-c) == a^b / a^c. -Proof. - intros a b c Ha H. - apply div_unique with 0. - - generalize (pow_nonzero a c Ha) (le_0_l (a^c)); order'. - - nzsimpl. now rewrite <- pow_add_r, add_comm, sub_add. -Qed. - -Lemma pow_div_l : forall a b c, b~=0 -> a mod b == 0 -> - (a/b)^c == a^c / b^c. -Proof. - intros a b c Hb H. - apply div_unique with 0. - - generalize (pow_nonzero b c Hb) (le_0_l (b^c)); order'. - - nzsimpl. rewrite <- pow_mul_l. f_equiv. now apply div_exact. -Qed. - -(** An injection from bits [true] and [false] to numbers 1 and 0. + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import C : NParityProp A B) + (Import D : NPowProp A B C) + (Import E : NDivProp A B) + (Import F : NLog2Prop A B C D). + + Include BoolEqualityFacts A. + + Ltac order_nz := try apply pow_nonzero; order'. + #[global] Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. + + (** Some properties of power and division *) + + Lemma pow_sub_r : forall a b c, a~=0 -> c<=b -> a^(b-c) == a^b / a^c. + Proof. + intros a b c Ha H. + apply div_unique with 0. + - generalize (pow_nonzero a c Ha) (le_0_l (a^c)); order'. + - nzsimpl. now rewrite <- pow_add_r, add_comm, sub_add. + Qed. + + Lemma pow_div_l : forall a b c, b~=0 -> a mod b == 0 -> + (a/b)^c == a^c / b^c. + Proof. + intros a b c Hb H. + apply div_unique with 0. + - generalize (pow_nonzero b c Hb) (le_0_l (b^c)); order'. + - nzsimpl. rewrite <- pow_mul_l. f_equiv. now apply div_exact. + Qed. + + (** An injection from bits [true] and [false] to numbers 1 and 0. We declare it as a (local) coercion for shorter statements. *) -Definition b2n (b:bool) := if b then 1 else 0. -#[local] Coercion b2n : bool >-> t. + Definition b2n (b:bool) := if b then 1 else 0. + #[local] Coercion b2n : bool >-> t. -#[global] -Instance b2n_proper : Proper (Logic.eq ==> eq) b2n. -Proof. solve_proper. Qed. + #[global] + Instance b2n_proper : Proper (Logic.eq ==> eq) b2n. + Proof. solve_proper. Qed. -Lemma b2n_le_1 (b : bool) : b <= 1. -Proof. destruct b as [|]; [exact (le_refl _) | exact le_0_1]. Qed. + Lemma b2n_le_1 (b : bool) : b <= 1. + Proof. destruct b as [|]; [exact (le_refl _) | exact le_0_1]. Qed. -Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. -Proof. - elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. - - exists a'. exists false. now nzsimpl. - - exists a'. exists true. now simpl. -Qed. + Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. + Proof. + elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. + - exists a'. exists false. now nzsimpl. + - exists a'. exists true. now simpl. + Qed. -(* This is kept private in order to drop the `Proper` condition in + (* This is kept private in order to drop the `Proper` condition in implementations. *) -(* begin hide *) -Lemma Private_binary_induction (A : t -> Prop) : - (Proper (eq ==> iff) A) -> A 0 -> (forall n, A n -> A (2 * n)) -> - (forall n, A n -> A (2 * n + 1)) -> (forall n, A n). -Proof. - intros H H0 I J. - apply Private_strong_induction_le; [exact H | exact H0 |]; intros n Hm. - pose proof (exists_div2 (S n)) as [m [[|] Hmb]]; simpl in Hmb; rewrite Hmb. - - apply J, Hm. - rewrite add_1_r in Hmb; apply succ_inj in Hmb; rewrite Hmb, two_succ. - apply le_mul_l; exact (neq_succ_0 1). - - rewrite add_0_r in *; apply I, Hm; apply <-succ_le_mono; rewrite Hmb. - rewrite <-(add_1_r), two_succ, mul_succ_l, mul_1_l. - apply add_le_mono_l, neq_0_le_1; intros C; rewrite C, mul_0_r in Hmb. - exact (neq_succ_0 _ Hmb). -Qed. -(* end hide *) - -(** We can compact [testbit_odd_0] [testbit_even_0] + (* begin hide *) + Lemma Private_binary_induction (A : t -> Prop) : + (Proper (eq ==> iff) A) -> A 0 -> (forall n, A n -> A (2 * n)) -> + (forall n, A n -> A (2 * n + 1)) -> (forall n, A n). + Proof. + intros H H0 I J. + apply Private_strong_induction_le; [exact H | exact H0 |]; intros n Hm. + pose proof (exists_div2 (S n)) as [m [[|] Hmb]]; simpl in Hmb; rewrite Hmb. + - apply J, Hm. + rewrite add_1_r in Hmb; apply succ_inj in Hmb; rewrite Hmb, two_succ. + apply le_mul_l; exact (neq_succ_0 1). + - rewrite add_0_r in *; apply I, Hm; apply <-succ_le_mono; rewrite Hmb. + rewrite <-(add_1_r), two_succ, mul_succ_l, mul_1_l. + apply add_le_mono_l, neq_0_le_1; intros C; rewrite C, mul_0_r in Hmb. + exact (neq_succ_0 _ Hmb). + Qed. + (* end hide *) + + (** We can compact [testbit_odd_0] [testbit_even_0] [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *) -Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - apply testbit_odd_0. - - apply testbit_even_0. -Qed. + Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. + Proof. + destruct b; simpl; rewrite ?add_0_r. + - apply testbit_odd_0. + - apply testbit_even_0. + Qed. -Lemma testbit_succ_r a (b:bool) n : - testbit (2*a+b) (succ n) = testbit a n. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - apply testbit_odd_succ, le_0_l. - - apply testbit_even_succ, le_0_l. -Qed. + Lemma testbit_succ_r a (b:bool) n : + testbit (2*a+b) (succ n) = testbit a n. + Proof. + destruct b; simpl; rewrite ?add_0_r. + - apply testbit_odd_succ, le_0_l. + - apply testbit_even_succ, le_0_l. + Qed. -(** Specification without useless condition on the bit number *) -Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n. -Proof. apply testbit_odd_succ; exact (le_0_l n). Qed. + (** Specification without useless condition on the bit number *) + Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n. + Proof. apply testbit_odd_succ; exact (le_0_l n). Qed. -Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n. -Proof. apply testbit_even_succ; exact (le_0_l n). Qed. + Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n. + Proof. apply testbit_even_succ; exact (le_0_l n). Qed. -(** Alternative characterisations of [testbit] *) + (** Alternative characterisations of [testbit] *) -(** This concise equation could have been taken as specification + (** This concise equation could have been taken as specification for testbit in the interface, but it would have been hard to implement with little initial knowledge about div and mod *) -Lemma testbit_spec' a n : a.[n] == (a / 2^n) mod 2. -Proof. - revert a. induct n. - - intros a. nzsimpl. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_0_r. apply mod_unique with a'; trivial. - destruct b; order'. - - intros n IH a. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_succ_r, IH. f_equiv. - rewrite pow_succ_r', <- div_div by order_nz. f_equiv. - apply div_unique with b; trivial. - destruct b; order'. -Qed. - -(** This characterisation that uses only basic operations and + Lemma testbit_spec' a n : a.[n] == (a / 2^n) mod 2. + Proof. + revert a. induct n. + - intros a. nzsimpl. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_0_r. apply mod_unique with a'; trivial. + destruct b; order'. + - intros n IH a. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_succ_r, IH. f_equiv. + rewrite pow_succ_r', <- div_div by order_nz. f_equiv. + apply div_unique with b; trivial. + destruct b; order'. + Qed. + + (** This characterisation that uses only basic operations and power was initially taken as specification for testbit. We describe [a] as having a low part and a high part, with the corresponding bit in the middle. This characterisation is moderatly complex to implement, but also moderately usable... *) -Lemma testbit_spec a n : - exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. -Proof. - exists (a mod 2^n). exists (a / 2^n / 2). split. - - split; [apply le_0_l | apply mod_upper_bound; order_nz]. - - rewrite add_comm, mul_comm, (add_comm a.[n]). - rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. - rewrite testbit_spec'. apply div_mod. order'. -Qed. - -Lemma testbit_true : forall a n, - a.[n] = true <-> (a / 2^n) mod 2 == 1. -Proof. - intros a n. - rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_false : forall a n, - a.[n] = false <-> (a / 2^n) mod 2 == 0. -Proof. - intros a n. - rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_eqb : forall a n, - a.[n] = eqb ((a / 2^n) mod 2) 1. -Proof. - intros a n. - apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. -Qed. - -(** Results about the injection [b2n] *) - -Lemma b2n_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. -Proof. - intros [|] [|]; simpl; trivial; order'. -Qed. - -Lemma add_b2n_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. -Proof. - intros a0 a. rewrite mul_comm, div_add by order'. - now rewrite div_small, add_0_l by (destruct a0; order'). -Qed. - -Lemma add_b2n_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. -Proof. - intros a0 a. apply b2n_inj. - rewrite testbit_spec'. nzsimpl. rewrite mul_comm, mod_add by order'. - now rewrite mod_small by (destruct a0; order'). -Qed. - -Lemma b2n_div2 : forall (a0:bool), a0/2 == 0. -Proof. - intros a0. rewrite <- (add_b2n_double_div2 a0 0). now nzsimpl. -Qed. - -Lemma b2n_bit0 : forall (a0:bool), a0.[0] = a0. -Proof. - intros a0. rewrite <- (add_b2n_double_bit0 a0 0) at 2. now nzsimpl. -Qed. - -(** The specification of testbit by low and high parts is complete *) - -Lemma testbit_unique : forall a n (a0:bool) l h, - l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. -Proof. - intros a n a0 l h Hl EQ. - apply b2n_inj. rewrite testbit_spec' by trivial. - symmetry. apply mod_unique with h. - - destruct a0; simpl; order'. - - symmetry. apply div_unique with l; trivial. - now rewrite add_comm, (add_comm _ a0), mul_comm. -Qed. - -(** All bits of number 0 are 0 *) - -Lemma bits_0 : forall n, 0.[n] = false. -Proof. - intros n. apply testbit_false. nzsimpl; order_nz. -Qed. - -(** Various ways to refer to the lowest bit of a number *) - -Lemma bit0_odd : forall a, a.[0] = odd a. -Proof. - intros a. symmetry. - destruct (exists_div2 a) as (a' & b & EQ). - rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. - destruct b; simpl; apply odd_1 || apply odd_0. -Qed. - -Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. -Proof. - intros a. rewrite testbit_eqb. now nzsimpl. -Qed. - -Lemma bit0_mod : forall a, a.[0] == a mod 2. -Proof. - intros a. rewrite testbit_spec'. now nzsimpl. -Qed. - -(** Hence testing a bit is equivalent to shifting and testing parity *) - -Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). -Proof. - intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. -Qed. - -(** [log2] gives the highest nonzero bit *) - -Lemma bit_log2 : forall a, a~=0 -> a.[log2 a] = true. -Proof. - intros a Ha. - assert (Ha' : 0 < a) by (generalize (le_0_l a); order). - destruct (log2_spec_alt a Ha') as (r & EQ & (_,Hr)). - rewrite EQ at 1. - rewrite testbit_true, add_comm. - rewrite <- (mul_1_l (2^log2 a)) at 1. - rewrite div_add by order_nz. - rewrite div_small by trivial. - rewrite add_0_l. apply mod_small. order'. -Qed. - -Lemma bits_above_log2 : forall a n, log2 a < n -> - a.[n] = false. -Proof. - intros a n H. - rewrite testbit_false. - rewrite div_small. - - nzsimpl; order'. - - apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. -Qed. - -(** Hence the number of bits of [a] is [1+log2 a] + Lemma testbit_spec a n : + exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. + Proof. + exists (a mod 2^n). exists (a / 2^n / 2). split. + - split; [apply le_0_l | apply mod_upper_bound; order_nz]. + - rewrite add_comm, mul_comm, (add_comm a.[n]). + rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. + rewrite testbit_spec'. apply div_mod. order'. + Qed. + + Lemma testbit_true : forall a n, + a.[n] = true <-> (a / 2^n) mod 2 == 1. + Proof. + intros a n. + rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. + Qed. + + Lemma testbit_false : forall a n, + a.[n] = false <-> (a / 2^n) mod 2 == 0. + Proof. + intros a n. + rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. + Qed. + + Lemma testbit_eqb : forall a n, + a.[n] = eqb ((a / 2^n) mod 2) 1. + Proof. + intros a n. + apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. + Qed. + + (** Results about the injection [b2n] *) + + Lemma b2n_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. + Proof. + intros [|] [|]; simpl; trivial; order'. + Qed. + + Lemma add_b2n_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. + Proof. + intros a0 a. rewrite mul_comm, div_add by order'. + now rewrite div_small, add_0_l by (destruct a0; order'). + Qed. + + Lemma add_b2n_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. + Proof. + intros a0 a. apply b2n_inj. + rewrite testbit_spec'. nzsimpl. rewrite mul_comm, mod_add by order'. + now rewrite mod_small by (destruct a0; order'). + Qed. + + Lemma b2n_div2 : forall (a0:bool), a0/2 == 0. + Proof. + intros a0. rewrite <- (add_b2n_double_div2 a0 0). now nzsimpl. + Qed. + + Lemma b2n_bit0 : forall (a0:bool), a0.[0] = a0. + Proof. + intros a0. rewrite <- (add_b2n_double_bit0 a0 0) at 2. now nzsimpl. + Qed. + + (** The specification of testbit by low and high parts is complete *) + + Lemma testbit_unique : forall a n (a0:bool) l h, + l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. + Proof. + intros a n a0 l h Hl EQ. + apply b2n_inj. rewrite testbit_spec' by trivial. + symmetry. apply mod_unique with h. + - destruct a0; simpl; order'. + - symmetry. apply div_unique with l; trivial. + now rewrite add_comm, (add_comm _ a0), mul_comm. + Qed. + + (** All bits of number 0 are 0 *) + + Lemma bits_0 : forall n, 0.[n] = false. + Proof. + intros n. apply testbit_false. nzsimpl; order_nz. + Qed. + + (** Various ways to refer to the lowest bit of a number *) + + Lemma bit0_odd : forall a, a.[0] = odd a. + Proof. + intros a. symmetry. + destruct (exists_div2 a) as (a' & b & EQ). + rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. + destruct b; simpl; apply odd_1 || apply odd_0. + Qed. + + Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. + Proof. + intros a. rewrite testbit_eqb. now nzsimpl. + Qed. + + Lemma bit0_mod : forall a, a.[0] == a mod 2. + Proof. + intros a. rewrite testbit_spec'. now nzsimpl. + Qed. + + (** Hence testing a bit is equivalent to shifting and testing parity *) + + Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). + Proof. + intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. + Qed. + + (** [log2] gives the highest nonzero bit *) + + Lemma bit_log2 : forall a, a~=0 -> a.[log2 a] = true. + Proof. + intros a Ha. + assert (Ha' : 0 < a) by (generalize (le_0_l a); order). + destruct (log2_spec_alt a Ha') as (r & EQ & (_,Hr)). + rewrite EQ at 1. + rewrite testbit_true, add_comm. + rewrite <- (mul_1_l (2^log2 a)) at 1. + rewrite div_add by order_nz. + rewrite div_small by trivial. + rewrite add_0_l. apply mod_small. order'. + Qed. + + Lemma bits_above_log2 : forall a n, log2 a < n -> + a.[n] = false. + Proof. + intros a n H. + rewrite testbit_false. + rewrite div_small. + - nzsimpl; order'. + - apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. + Qed. + + (** Hence the number of bits of [a] is [1+log2 a] (see [Pos.size_nat] and [Pos.size]). *) -(** Testing bits after division or multiplication by a power of two *) - -Lemma testbit_div2 : forall a n, (div2 a).[n] = a.[S n]. -Proof. - intros a n; rewrite div2_spec, shiftr_spec, add_1_r by (exact (le_0_l _)); - reflexivity. -Qed. - -Lemma div2_bits : forall a n, (a/2).[n] = a.[S n]. -Proof. - intros. apply eq_true_iff_eq. - rewrite 2 testbit_true. - rewrite pow_succ_r by apply le_0_l. - now rewrite div_div by order_nz. -Qed. - -Lemma div_pow2_bits : forall a n m, (a/2^n).[m] = a.[m+n]. -Proof. - intros a n. revert a. induct n. - - intros a m. now nzsimpl. - - intros n IH a m. nzsimpl; try apply le_0_l. - rewrite <- div_div by order_nz. - now rewrite IH, div2_bits. -Qed. - -Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. -Proof. - intros. rewrite <- div2_bits. now rewrite mul_comm, div_mul by order'. -Qed. - -Lemma mul_pow2_bits_add : forall a n m, (a*2^n).[m+n] = a.[m]. -Proof. - intros. rewrite <- div_pow2_bits. now rewrite div_mul by order_nz. -Qed. - -Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n]. -Proof. - intros a n m ?. - rewrite <- (sub_add n m) at 1 by order'. - now rewrite mul_pow2_bits_add. -Qed. - -Lemma mul_pow2_bits_low : forall a n m, m (a*2^n).[m] = false. -Proof. - intros a n m H. apply testbit_false. - rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc. - rewrite div_mul by order_nz. - rewrite <- (succ_pred (n-m)). - - rewrite pow_succ_r. - + now rewrite (mul_comm 2), mul_assoc, mod_mul by order'. - + apply lt_le_pred. - apply sub_gt in H. generalize (le_0_l (n-m)); order. - - now apply sub_gt. -Qed. - -(** Selecting the low part of a number can be done by a modulo *) - -Lemma mod_pow2_bits_high : forall a n m, n<=m -> - (a mod 2^n).[m] = false. -Proof. - intros a n m H. - destruct (eq_0_gt_0_cases (a mod 2^n)) as [EQ|LT]. - - now rewrite EQ, bits_0. - - apply bits_above_log2. - apply lt_le_trans with n; trivial. - apply log2_lt_pow2; trivial. - apply mod_upper_bound; order_nz. -Qed. - -Lemma mod_pow2_bits_low : forall a n m, m - (a mod 2^n).[m] = a.[m]. -Proof. - intros a n m H. - rewrite testbit_eqb. - rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. - rewrite <- div_add by order_nz. - rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r', succ_pred - by now apply sub_gt. - rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add - by order. - rewrite add_comm, <- div_mod by order_nz. - symmetry. apply testbit_eqb. -Qed. - -(** We now prove that having the same bits implies equality. + (** Testing bits after division or multiplication by a power of two *) + + Lemma testbit_div2 : forall a n, (div2 a).[n] = a.[S n]. + Proof. + intros a n; rewrite div2_spec, shiftr_spec, add_1_r by (exact (le_0_l _)); + reflexivity. + Qed. + + Lemma div2_bits : forall a n, (a/2).[n] = a.[S n]. + Proof. + intros. apply eq_true_iff_eq. + rewrite 2 testbit_true. + rewrite pow_succ_r by apply le_0_l. + now rewrite div_div by order_nz. + Qed. + + Lemma div_pow2_bits : forall a n m, (a/2^n).[m] = a.[m+n]. + Proof. + intros a n. revert a. induct n. + - intros a m. now nzsimpl. + - intros n IH a m. nzsimpl; try apply le_0_l. + rewrite <- div_div by order_nz. + now rewrite IH, div2_bits. + Qed. + + Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. + Proof. + intros. rewrite <- div2_bits. now rewrite mul_comm, div_mul by order'. + Qed. + + Lemma mul_pow2_bits_add : forall a n m, (a*2^n).[m+n] = a.[m]. + Proof. + intros. rewrite <- div_pow2_bits. now rewrite div_mul by order_nz. + Qed. + + Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n]. + Proof. + intros a n m ?. + rewrite <- (sub_add n m) at 1 by order'. + now rewrite mul_pow2_bits_add. + Qed. + + Lemma mul_pow2_bits_low : forall a n m, m (a*2^n).[m] = false. + Proof. + intros a n m H. apply testbit_false. + rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc. + rewrite div_mul by order_nz. + rewrite <- (succ_pred (n-m)). + - rewrite pow_succ_r. + + now rewrite (mul_comm 2), mul_assoc, mod_mul by order'. + + apply lt_le_pred. + apply sub_gt in H. generalize (le_0_l (n-m)); order. + - now apply sub_gt. + Qed. + + (** Selecting the low part of a number can be done by a modulo *) + + Lemma mod_pow2_bits_high : forall a n m, n<=m -> + (a mod 2^n).[m] = false. + Proof. + intros a n m H. + destruct (eq_0_gt_0_cases (a mod 2^n)) as [EQ|LT]. + - now rewrite EQ, bits_0. + - apply bits_above_log2. + apply lt_le_trans with n; trivial. + apply log2_lt_pow2; trivial. + apply mod_upper_bound; order_nz. + Qed. + + Lemma mod_pow2_bits_low : forall a n m, m + (a mod 2^n).[m] = a.[m]. + Proof. + intros a n m H. + rewrite testbit_eqb. + rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. + rewrite <- div_add by order_nz. + rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r', succ_pred + by now apply sub_gt. + rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add + by order. + rewrite add_comm, <- div_mod by order_nz. + symmetry. apply testbit_eqb. + Qed. + + (** We now prove that having the same bits implies equality. For that we use a notion of equality over functional streams of bits. *) -Definition eqf (f g:t -> bool) := forall n:t, f n = g n. - -#[global] -Instance eqf_equiv : Equivalence eqf. -Proof. - split; congruence. -Qed. - -#[local] Infix "===" := eqf (at level 70, no associativity). - -#[global] -Instance testbit_eqf : Proper (eq==>eqf) testbit. -Proof. - intros a a' Ha n. now rewrite Ha. -Qed. - -(** Only zero corresponds to the always-false stream. *) - -Lemma bits_inj_0 : - forall a, (forall n, a.[n] = false) -> a == 0. -Proof. - intros a H. destruct (eq_decidable a 0) as [EQ|NEQ]; trivial. - apply bit_log2 in NEQ. now rewrite H in NEQ. -Qed. - -(** If two numbers produce the same stream of bits, they are equal. *) - -Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. -Proof. - intros a. pattern a. - apply strong_right_induction with 0;[clear a|apply le_0_l]. - intros a _ IH b H. - destruct (eq_0_gt_0_cases a) as [EQ|LT]. - - rewrite EQ in H |- *. symmetry. apply bits_inj_0. - intros n. now rewrite <- H, bits_0. - - rewrite (div_mod a 2), (div_mod b 2) by order'. - f_equiv; [ | now rewrite <- 2 bit0_mod, H]. - f_equiv. - apply IH; trivial using le_0_l. - + apply div_lt; order'. - + intro n. rewrite 2 div2_bits. apply H. -Qed. - -Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. -Proof. - split. - - apply bits_inj. - - intros EQ; now rewrite EQ. -Qed. - -#[global] Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. - -Tactic Notation "bitwise" "as" simple_intropattern(m) - := apply bits_inj; intros m; autorewrite with bitwise. - -Ltac bitwise := bitwise as ?m. - -(** The streams of bits that correspond to a natural numbers are + Definition eqf (f g:t -> bool) := forall n:t, f n = g n. + + #[global] + Instance eqf_equiv : Equivalence eqf. + Proof. + split; congruence. + Qed. + + #[local] Infix "===" := eqf (at level 70, no associativity). + + #[global] + Instance testbit_eqf : Proper (eq==>eqf) testbit. + Proof. + intros a a' Ha n. now rewrite Ha. + Qed. + + (** Only zero corresponds to the always-false stream. *) + + Lemma bits_inj_0 : + forall a, (forall n, a.[n] = false) -> a == 0. + Proof. + intros a H. destruct (eq_decidable a 0) as [EQ|NEQ]; trivial. + apply bit_log2 in NEQ. now rewrite H in NEQ. + Qed. + + (** If two numbers produce the same stream of bits, they are equal. *) + + Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. + Proof. + intros a. pattern a. + apply strong_right_induction with 0;[clear a|apply le_0_l]. + intros a _ IH b H. + destruct (eq_0_gt_0_cases a) as [EQ|LT]. + - rewrite EQ in H |- *. symmetry. apply bits_inj_0. + intros n. now rewrite <- H, bits_0. + - rewrite (div_mod a 2), (div_mod b 2) by order'. + f_equiv; [ | now rewrite <- 2 bit0_mod, H]. + f_equiv. + apply IH; trivial using le_0_l. + + apply div_lt; order'. + + intro n. rewrite 2 div2_bits. apply H. + Qed. + + Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. + Proof. + split. + - apply bits_inj. + - intros EQ; now rewrite EQ. + Qed. + + #[global] Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. + + Tactic Notation "bitwise" "as" simple_intropattern(m) + := apply bits_inj; intros m; autorewrite with bitwise. + + Ltac bitwise := bitwise as ?m. + + (** The streams of bits that correspond to a natural numbers are exactly the ones that are always 0 after some point *) -Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> - ((exists n, f === testbit n) <-> - (exists k, forall m, k<=m -> f m = false)). -Proof. - intros f Hf. split. - - intros (a,H). - exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. - rewrite H, bits_above_log2; trivial using lt_succ_diag_r. - - intros (k,Hk). - revert f Hf Hk. induct k. - + intros f Hf H0. - exists 0. intros m. rewrite bits_0, H0; trivial. apply le_0_l. - + intros k IH f Hf Hk. - destruct (IH (fun m => f (S m))) as (n, Hn). - * solve_proper. - * intros m Hm. apply Hk. now rewrite <- succ_le_mono. - * { exists (f 0 + 2*n). intros m. - destruct (zero_or_succ m) as [Hm|(m', Hm)]; rewrite Hm. - - symmetry. apply add_b2n_double_bit0. - - rewrite Hn, <- div2_bits. - rewrite mul_comm, div_add, b2n_div2, add_0_l; trivial. order'. - } -Qed. - -(** Properties of shifts *) - -Lemma shiftr_spec' : forall a n m, (a >> n).[m] = a.[m+n]. -Proof. - intros. apply shiftr_spec. apply le_0_l. -Qed. - -Lemma shiftl_spec_high' : forall a n m, n<=m -> (a << n).[m] = a.[m-n]. -Proof. - intros. apply shiftl_spec_high; trivial. apply le_0_l. -Qed. - -Lemma shiftr_div_pow2 : forall a n, a >> n == a / 2^n. -Proof. - intros. bitwise. rewrite shiftr_spec'. - symmetry. apply div_pow2_bits. -Qed. - -Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n. -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m) as [H|H]. - - now rewrite shiftl_spec_high', mul_pow2_bits_high. - - now rewrite shiftl_spec_low, mul_pow2_bits_low. -Qed. - -Lemma shiftl_spec_alt : forall a n m, (a << n).[m+n] = a.[m]. -Proof. - intros. now rewrite shiftl_mul_pow2, mul_pow2_bits_add. -Qed. - -#[global] -Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. -Proof. - intros a a' Ha b b' Hb. now rewrite 2 shiftr_div_pow2, Ha, Hb. -Qed. - -#[global] -Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. -Proof. - intros a a' Ha b b' Hb. now rewrite 2 shiftl_mul_pow2, Ha, Hb. -Qed. - -Lemma shiftl_shiftl : forall a n m, - (a << n) << m == a << (n+m). -Proof. - intros. now rewrite !shiftl_mul_pow2, pow_add_r, mul_assoc. -Qed. - -Lemma shiftr_shiftr : forall a n m, - (a >> n) >> m == a >> (n+m). -Proof. - intros. - now rewrite !shiftr_div_pow2, pow_add_r, div_div by order_nz. -Qed. - -Lemma shiftr_shiftl_l : forall a n m, m<=n -> - (a << n) >> m == a << (n-m). -Proof. - intros a n m ?. - rewrite shiftr_div_pow2, !shiftl_mul_pow2. - rewrite <- (sub_add m n) at 1 by trivial. - now rewrite pow_add_r, mul_assoc, div_mul by order_nz. -Qed. - -Lemma shiftr_shiftl_r : forall a n m, n<=m -> - (a << n) >> m == a >> (m-n). -Proof. - intros a n m ?. - rewrite !shiftr_div_pow2, shiftl_mul_pow2. - rewrite <- (sub_add n m) at 1 by trivial. - rewrite pow_add_r, (mul_comm (2^(m-n))). - now rewrite <- div_div, div_mul by order_nz. -Qed. - -(** shifts and constants *) - -Lemma shiftl_1_l : forall n, 1 << n == 2^n. -Proof. - intros. now rewrite shiftl_mul_pow2, mul_1_l. -Qed. - -Lemma shiftl_0_r : forall a, a << 0 == a. -Proof. - intros. rewrite shiftl_mul_pow2. now nzsimpl. -Qed. - -Lemma shiftr_0_r : forall a, a >> 0 == a. -Proof. - intros. rewrite shiftr_div_pow2. now nzsimpl. -Qed. - -Lemma shiftl_0_l : forall n, 0 << n == 0. -Proof. - intros. rewrite shiftl_mul_pow2. now nzsimpl. -Qed. - -Lemma shiftr_0_l : forall n, 0 >> n == 0. -Proof. - intros. rewrite shiftr_div_pow2. nzsimpl; order_nz. -Qed. - -Lemma shiftl_eq_0_iff : forall a n, a << n == 0 <-> a == 0. -Proof. - intros a n. rewrite shiftl_mul_pow2. rewrite eq_mul_0. split. - - intros [H | H]; trivial. contradict H; order_nz. - - intros H. now left. -Qed. - -Lemma shiftr_eq_0_iff : forall a n, - a >> n == 0 <-> a==0 \/ (0 a >> n == 0. -Proof. - intros a n H. rewrite shiftr_eq_0_iff. - destruct (eq_0_gt_0_cases a) as [EQ|LT]. - - now left. - - right; now split. -Qed. - -(** Properties of [div2]. *) - -Lemma div2_div : forall a, div2 a == a/2. -Proof. - intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl. -Qed. - -Lemma div2_0 : div2 0 == 0. -Proof. - rewrite div2_div, div_0_l by (rewrite two_succ; exact (neq_succ_0 _)). - reflexivity. -Qed. - -Lemma div2_1 : div2 1 == 0. -Proof. rewrite div2_div, div_small by (exact lt_1_2); reflexivity. Qed. - -Lemma div2_le_mono : forall a b, a <= b -> div2 a <= div2 b. -Proof. - intros a b H; rewrite 2!div2_div; apply div_le_mono; [| exact H]. - rewrite two_succ; exact (neq_succ_0 1). -Qed. - -#[global] -Instance div2_wd : Proper (eq==>eq) div2. -Proof. - intros a a' Ha. now rewrite 2 div2_div, Ha. -Qed. - -Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. -Proof. - intros a. rewrite div2_div, <- bit0_odd, bit0_mod. - apply div_mod. order'. -Qed. - -Lemma div2_even : forall a, div2 (2 * a) == a. -Proof. - intros a; rewrite div2_div, mul_comm, div_mul - by (rewrite two_succ; exact (neq_succ_0 _)); reflexivity. -Qed. - -Lemma div2_odd' : forall a, div2 (2 * a + 1) == a. -Proof. - intros a; rewrite div2_div; symmetry; apply (div_unique _ _ _ 1); - [exact lt_1_2 | reflexivity]. -Qed. - -Lemma le_div2_diag_l a : div2 a <= a. -Proof. - rewrite (div2_odd a) at 2; rewrite <-(mul_1_l (div2 a)) at 1. - apply (le_trans _ (2 * (div2 a))). - - apply mul_le_mono_r, lt_le_incl; exact lt_1_2. - - exact (le_add_r _ _). -Qed. - -Lemma div2_le_upper_bound a q : a <= 2 * q -> div2 a <= q. -Proof. - rewrite div2_div, two_succ; apply div_le_upper_bound; exact (neq_succ_0 _). -Qed. - -Lemma div2_le_lower_bound a q : 2 * q <= a -> q <= div2 a. -Proof. - rewrite div2_div, two_succ; apply div_le_lower_bound; exact (neq_succ_0 _). -Qed. - -Lemma lt_div2_diag_l a : a ~= 0 -> div2 a < a. -Proof. - destruct (zero_or_succ a) as [| [b ->]]; [| clear a]. { - intros H'; contradict H'; rewrite H; reflexivity. - } - destruct (zero_or_succ b) as [| [c ->]]; [| clear b]. { - intros _; rewrite H, <-one_succ, div2_1; exact lt_0_1. - } - intros _; rewrite (div2_odd (S (S c))) at 2. - rewrite <-(mul_1_l (div2 _)) at 1; apply lt_lt_add_r, mul_lt_mono_pos_r; - [| exact lt_1_2]. - apply lt_le_trans with (1 := lt_0_1). - apply div2_le_lower_bound; rewrite mul_1_r, two_succ, one_succ. - apply ->succ_le_mono; apply ->succ_le_mono; exact (le_0_l _). -Qed. - -Lemma le_div2 n : div2 (S n) <= n. -Proof. - destruct (zero_or_succ n) as [-> | [k ->]]; [| clear n]. { - rewrite <-one_succ, div2_1; exact (le_0_l 0). - } - apply div2_le_upper_bound. - setoid_replace (2 * (S k)) with (S k + S k); cycle 1. { - rewrite two_succ, <-(add_1_r 1), mul_add_distr_r, mul_1_l; reflexivity. - } - rewrite add_succ_r; apply ->succ_le_mono; exact (le_add_r _ _). -Qed. - -Lemma lt_div2 n : 0 < n -> div2 n < n. -Proof. intros H%lt_neq%neq_sym; exact (lt_div2_diag_l _ H). Qed. - -Lemma div2_decr a n : a <= S n -> div2 a <= n. -Proof. - destruct (zero_or_succ a) as [-> | [b ->]]; [intros _ | clear a]. { - rewrite div2_0; exact (le_0_l _). - } - intros H%div2_le_mono; apply le_trans with (1 := H); exact (le_div2 n). -Qed. - -(** Properties of [lxor] and others, directly deduced + Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> + ((exists n, f === testbit n) <-> + (exists k, forall m, k<=m -> f m = false)). + Proof. + intros f Hf. split. + - intros (a,H). + exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. + rewrite H, bits_above_log2; trivial using lt_succ_diag_r. + - intros (k,Hk). + revert f Hf Hk. induct k. + + intros f Hf H0. + exists 0. intros m. rewrite bits_0, H0; trivial. apply le_0_l. + + intros k IH f Hf Hk. + destruct (IH (fun m => f (S m))) as (n, Hn). + * solve_proper. + * intros m Hm. apply Hk. now rewrite <- succ_le_mono. + * { exists (f 0 + 2*n). intros m. + destruct (zero_or_succ m) as [Hm|(m', Hm)]; rewrite Hm. + - symmetry. apply add_b2n_double_bit0. + - rewrite Hn, <- div2_bits. + rewrite mul_comm, div_add, b2n_div2, add_0_l; trivial. order'. + } + Qed. + + (** Properties of shifts *) + + Lemma shiftr_spec' : forall a n m, (a >> n).[m] = a.[m+n]. + Proof. + intros. apply shiftr_spec. apply le_0_l. + Qed. + + Lemma shiftl_spec_high' : forall a n m, n<=m -> (a << n).[m] = a.[m-n]. + Proof. + intros. apply shiftl_spec_high; trivial. apply le_0_l. + Qed. + + Lemma shiftr_div_pow2 : forall a n, a >> n == a / 2^n. + Proof. + intros. bitwise. rewrite shiftr_spec'. + symmetry. apply div_pow2_bits. + Qed. + + Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n. + Proof. + intros a n. bitwise as m. + destruct (le_gt_cases n m) as [H|H]. + - now rewrite shiftl_spec_high', mul_pow2_bits_high. + - now rewrite shiftl_spec_low, mul_pow2_bits_low. + Qed. + + Lemma shiftl_spec_alt : forall a n m, (a << n).[m+n] = a.[m]. + Proof. + intros. now rewrite shiftl_mul_pow2, mul_pow2_bits_add. + Qed. + + #[global] + Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. + Proof. + intros a a' Ha b b' Hb. now rewrite 2 shiftr_div_pow2, Ha, Hb. + Qed. + + #[global] + Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. + Proof. + intros a a' Ha b b' Hb. now rewrite 2 shiftl_mul_pow2, Ha, Hb. + Qed. + + Lemma shiftl_shiftl : forall a n m, + (a << n) << m == a << (n+m). + Proof. + intros. now rewrite !shiftl_mul_pow2, pow_add_r, mul_assoc. + Qed. + + Lemma shiftr_shiftr : forall a n m, + (a >> n) >> m == a >> (n+m). + Proof. + intros. + now rewrite !shiftr_div_pow2, pow_add_r, div_div by order_nz. + Qed. + + Lemma shiftr_shiftl_l : forall a n m, m<=n -> + (a << n) >> m == a << (n-m). + Proof. + intros a n m ?. + rewrite shiftr_div_pow2, !shiftl_mul_pow2. + rewrite <- (sub_add m n) at 1 by trivial. + now rewrite pow_add_r, mul_assoc, div_mul by order_nz. + Qed. + + Lemma shiftr_shiftl_r : forall a n m, n<=m -> + (a << n) >> m == a >> (m-n). + Proof. + intros a n m ?. + rewrite !shiftr_div_pow2, shiftl_mul_pow2. + rewrite <- (sub_add n m) at 1 by trivial. + rewrite pow_add_r, (mul_comm (2^(m-n))). + now rewrite <- div_div, div_mul by order_nz. + Qed. + + (** shifts and constants *) + + Lemma shiftl_1_l : forall n, 1 << n == 2^n. + Proof. + intros. now rewrite shiftl_mul_pow2, mul_1_l. + Qed. + + Lemma shiftl_0_r : forall a, a << 0 == a. + Proof. + intros. rewrite shiftl_mul_pow2. now nzsimpl. + Qed. + + Lemma shiftr_0_r : forall a, a >> 0 == a. + Proof. + intros. rewrite shiftr_div_pow2. now nzsimpl. + Qed. + + Lemma shiftl_0_l : forall n, 0 << n == 0. + Proof. + intros. rewrite shiftl_mul_pow2. now nzsimpl. + Qed. + + Lemma shiftr_0_l : forall n, 0 >> n == 0. + Proof. + intros. rewrite shiftr_div_pow2. nzsimpl; order_nz. + Qed. + + Lemma shiftl_eq_0_iff : forall a n, a << n == 0 <-> a == 0. + Proof. + intros a n. rewrite shiftl_mul_pow2. rewrite eq_mul_0. split. + - intros [H | H]; trivial. contradict H; order_nz. + - intros H. now left. + Qed. + + Lemma shiftr_eq_0_iff : forall a n, + a >> n == 0 <-> a==0 \/ (0 a >> n == 0. + Proof. + intros a n H. rewrite shiftr_eq_0_iff. + destruct (eq_0_gt_0_cases a) as [EQ|LT]. + - now left. + - right; now split. + Qed. + + (** Properties of [div2]. *) + + Lemma div2_div : forall a, div2 a == a/2. + Proof. + intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl. + Qed. + + Lemma div2_0 : div2 0 == 0. + Proof. + rewrite div2_div, div_0_l by (rewrite two_succ; exact (neq_succ_0 _)). + reflexivity. + Qed. + + Lemma div2_1 : div2 1 == 0. + Proof. rewrite div2_div, div_small by (exact lt_1_2); reflexivity. Qed. + + Lemma div2_le_mono : forall a b, a <= b -> div2 a <= div2 b. + Proof. + intros a b H; rewrite 2!div2_div; apply div_le_mono; [| exact H]. + rewrite two_succ; exact (neq_succ_0 1). + Qed. + + #[global] + Instance div2_wd : Proper (eq==>eq) div2. + Proof. + intros a a' Ha. now rewrite 2 div2_div, Ha. + Qed. + + Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. + Proof. + intros a. rewrite div2_div, <- bit0_odd, bit0_mod. + apply div_mod. order'. + Qed. + + Lemma div2_even : forall a, div2 (2 * a) == a. + Proof. + intros a; rewrite div2_div, mul_comm, div_mul + by (rewrite two_succ; exact (neq_succ_0 _)); reflexivity. + Qed. + + Lemma div2_odd' : forall a, div2 (2 * a + 1) == a. + Proof. + intros a; rewrite div2_div; symmetry; apply (div_unique _ _ _ 1); + [exact lt_1_2 | reflexivity]. + Qed. + + Lemma le_div2_diag_l a : div2 a <= a. + Proof. + rewrite (div2_odd a) at 2; rewrite <-(mul_1_l (div2 a)) at 1. + apply (le_trans _ (2 * (div2 a))). + - apply mul_le_mono_r, lt_le_incl; exact lt_1_2. + - exact (le_add_r _ _). + Qed. + + Lemma div2_le_upper_bound a q : a <= 2 * q -> div2 a <= q. + Proof. + rewrite div2_div, two_succ; apply div_le_upper_bound; exact (neq_succ_0 _). + Qed. + + Lemma div2_le_lower_bound a q : 2 * q <= a -> q <= div2 a. + Proof. + rewrite div2_div, two_succ; apply div_le_lower_bound; exact (neq_succ_0 _). + Qed. + + Lemma lt_div2_diag_l a : a ~= 0 -> div2 a < a. + Proof. + destruct (zero_or_succ a) as [| [b ->]]; [| clear a]. { + intros H'; contradict H'; rewrite H; reflexivity. + } + destruct (zero_or_succ b) as [| [c ->]]; [| clear b]. { + intros _; rewrite H, <-one_succ, div2_1; exact lt_0_1. + } + intros _; rewrite (div2_odd (S (S c))) at 2. + rewrite <-(mul_1_l (div2 _)) at 1; apply lt_lt_add_r, mul_lt_mono_pos_r; + [| exact lt_1_2]. + apply lt_le_trans with (1 := lt_0_1). + apply div2_le_lower_bound; rewrite mul_1_r, two_succ, one_succ. + apply ->succ_le_mono; apply ->succ_le_mono; exact (le_0_l _). + Qed. + + Lemma le_div2 n : div2 (S n) <= n. + Proof. + destruct (zero_or_succ n) as [-> | [k ->]]; [| clear n]. { + rewrite <-one_succ, div2_1; exact (le_0_l 0). + } + apply div2_le_upper_bound. + setoid_replace (2 * (S k)) with (S k + S k); cycle 1. { + rewrite two_succ, <-(add_1_r 1), mul_add_distr_r, mul_1_l; reflexivity. + } + rewrite add_succ_r; apply ->succ_le_mono; exact (le_add_r _ _). + Qed. + + Lemma lt_div2 n : 0 < n -> div2 n < n. + Proof. intros H%lt_neq%neq_sym; exact (lt_div2_diag_l _ H). Qed. + + Lemma div2_decr a n : a <= S n -> div2 a <= n. + Proof. + destruct (zero_or_succ a) as [-> | [b ->]]; [intros _ | clear a]. { + rewrite div2_0; exact (le_0_l _). + } + intros H%div2_le_mono; apply le_trans with (1 := H); exact (le_div2 n). + Qed. + + (** Properties of [lxor] and others, directly deduced from properties of [xorb] and others. *) -#[global] -Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance land_wd : Proper (eq ==> eq ==> eq) land. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance lor_wd : Proper (eq ==> eq ==> eq) lor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. -Proof. - intros a a' H. bitwise. apply xorb_eq. - now rewrite <- lxor_spec, H, bits_0. -Qed. - -Lemma lxor_nilpotent : forall a, lxor a a == 0. -Proof. - intros. bitwise. apply xorb_nilpotent. -Qed. - -Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. -Proof. - split. - - apply lxor_eq. - - intros EQ; rewrite EQ; apply lxor_nilpotent. -Qed. - -Lemma lxor_0_l : forall a, lxor 0 a == a. -Proof. - intros. bitwise. apply xorb_false_l. -Qed. - -Lemma lxor_0_r : forall a, lxor a 0 == a. -Proof. - intros. bitwise. apply xorb_false_r. -Qed. - -Lemma lxor_comm : forall a b, lxor a b == lxor b a. -Proof. - intros. bitwise. apply xorb_comm. -Qed. - -Lemma lxor_assoc : - forall a b c, lxor (lxor a b) c == lxor a (lxor b c). -Proof. - intros. bitwise. apply xorb_assoc. -Qed. - -Lemma lor_0_l : forall a, lor 0 a == a. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma lor_0_r : forall a, lor a 0 == a. -Proof. - intros. bitwise. apply orb_false_r. -Qed. - -Lemma lor_comm : forall a b, lor a b == lor b a. -Proof. - intros. bitwise. apply orb_comm. -Qed. - -Lemma lor_assoc : - forall a b c, lor a (lor b c) == lor (lor a b) c. -Proof. - intros. bitwise. apply orb_assoc. -Qed. - -Lemma lor_diag : forall a, lor a a == a. -Proof. - intros. bitwise. apply orb_diag. -Qed. - -Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. -Proof. - intros a b H. bitwise as m. - apply (orb_false_iff a.[m] b.[m]). - now rewrite <- lor_spec, H, bits_0. -Qed. - -Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. -Proof. - intros a b. split. - - intro H; split. - + now apply lor_eq_0_l in H. - + rewrite lor_comm in H. now apply lor_eq_0_l in H. - - intros (EQ,EQ'). now rewrite EQ, lor_0_l. -Qed. - -Lemma land_0_l : forall a, land 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma land_0_r : forall a, land a 0 == 0. -Proof. - intros. bitwise. apply andb_false_r. -Qed. - -Lemma land_comm : forall a b, land a b == land b a. -Proof. - intros. bitwise. apply andb_comm. -Qed. - -Lemma land_assoc : - forall a b c, land a (land b c) == land (land a b) c. -Proof. - intros. bitwise. apply andb_assoc. -Qed. - -Lemma land_diag : forall a, land a a == a. -Proof. - intros. bitwise. apply andb_diag. -Qed. - -Lemma land_even_l : - forall a b, land (2 * a) b == 2 * (land a (div2 b)). -Proof. - intros a b; rewrite (div2_odd b) at 1; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite !land_spec. - - rewrite 2!testbit_even_0; reflexivity. - - rewrite 2!testbit_even_succ, testbit_succ_r, land_spec by exact (le_0_l _). - reflexivity. -Qed. - -Lemma land_even_r : - forall a b, land a (2 * b) == 2 * (land (div2 a) b). -Proof. - intros a b; rewrite (land_comm a _), (land_comm _ b); exact (land_even_l _ _). -Qed. - -Lemma land_odd_l : - forall a b, land (2 * a + 1) b == 2 * (land a (div2 b)) + odd b. -Proof. - intros a b; rewrite (div2_odd b) at 1; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite !land_spec. - - rewrite 2!testbit_0_r, testbit_odd_0; reflexivity. - - rewrite 2!testbit_succ_r, land_spec, testbit_odd_succ by (exact (le_0_l _)). - reflexivity. -Qed. - -Lemma land_odd_r : - forall a b, land a (2 * b + 1) == 2 * (land (div2 a) b) + odd a. -Proof. - intros a b; rewrite (land_comm a _), (land_comm _ b); exact (land_odd_l _ _). -Qed. - -Lemma land_even_even : forall a b, land (2 * a) (2 * b) == 2 * land a b. -Proof. intros a b; rewrite land_even_l, div2_even; reflexivity. Qed. - -Lemma land_odd_even : forall a b, land (2 * a + 1) (2 * b) == 2 * land a b. -Proof. intros a b; rewrite land_even_r, div2_odd'; reflexivity. Qed. - -Lemma land_even_odd : forall a b, land (2 * a) (2 * b + 1) == 2 * land a b. -Proof. intros a b; rewrite land_even_l, div2_odd'; reflexivity. Qed. - -Lemma land_odd_odd : - forall a b, land (2 * a + 1) (2 * b + 1) == 2 * (land a b) + 1. -Proof. intros a b; rewrite land_odd_l, div2_odd', odd_odd; reflexivity. Qed. - -Lemma land_le_l : - forall a b, land a b <= a. -Proof. - apply (Private_binary_induction (fun a => forall b, _)); [| | intros a H b..]. - - intros x y eq; split; intros H b; [rewrite <-eq | rewrite eq]; now apply H. - - intros b; rewrite land_0_l; exact (le_refl _). - - rewrite land_even_l; apply mul_le_mono_l; exact (H _). - - rewrite land_odd_l; apply add_le_mono; - [apply mul_le_mono_l; exact (H _) | exact (b2n_le_1 _)]. -Qed. - -Lemma land_le_r : - forall a b, land a b <= b. -Proof. intros a b; rewrite land_comm; exact (land_le_l _ _). Qed. - -Lemma ldiff_0_l : forall a, ldiff 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma ldiff_0_r : forall a, ldiff a 0 == a. -Proof. - intros. bitwise. now rewrite andb_true_r. -Qed. - -Lemma ldiff_diag : forall a, ldiff a a == 0. -Proof. - intros. bitwise. apply andb_negb_r. -Qed. - -Lemma ldiff_even_l : forall a b, ldiff (2 * a) b == 2 * ldiff a (div2 b). -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite 2!testbit_even_0; reflexivity. - - rewrite 2!testbit_even_succ, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_odd_l : - forall a b, ldiff (2 * a + 1) b == 2 * ldiff a (div2 b) + even b. -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite testbit_odd_0, testbit_0_r, bit0_odd, negb_odd; reflexivity. - - rewrite testbit_odd_succ, testbit_succ_r, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_even_r : - forall a b, ldiff a (2 * b) == 2 * ldiff (div2 a) b + odd a. -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite testbit_0_r, testbit_even_0, bit0_odd; simpl; rewrite andb_true_r; + #[global] + Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + #[global] + Instance land_wd : Proper (eq ==> eq ==> eq) land. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + #[global] + Instance lor_wd : Proper (eq ==> eq ==> eq) lor. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + #[global] + Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. + Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. + Qed. + + Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. + Proof. + intros a a' H. bitwise. apply xorb_eq. + now rewrite <- lxor_spec, H, bits_0. + Qed. + + Lemma lxor_nilpotent : forall a, lxor a a == 0. + Proof. + intros. bitwise. apply xorb_nilpotent. + Qed. + + Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. + Proof. + split. + - apply lxor_eq. + - intros EQ; rewrite EQ; apply lxor_nilpotent. + Qed. + + Lemma lxor_0_l : forall a, lxor 0 a == a. + Proof. + intros. bitwise. apply xorb_false_l. + Qed. + + Lemma lxor_0_r : forall a, lxor a 0 == a. + Proof. + intros. bitwise. apply xorb_false_r. + Qed. + + Lemma lxor_comm : forall a b, lxor a b == lxor b a. + Proof. + intros. bitwise. apply xorb_comm. + Qed. + + Lemma lxor_assoc : + forall a b c, lxor (lxor a b) c == lxor a (lxor b c). + Proof. + intros. bitwise. apply xorb_assoc. + Qed. + + Lemma lor_0_l : forall a, lor 0 a == a. + Proof. + intros. bitwise. trivial. + Qed. + + Lemma lor_0_r : forall a, lor a 0 == a. + Proof. + intros. bitwise. apply orb_false_r. + Qed. + + Lemma lor_comm : forall a b, lor a b == lor b a. + Proof. + intros. bitwise. apply orb_comm. + Qed. + + Lemma lor_assoc : + forall a b c, lor a (lor b c) == lor (lor a b) c. + Proof. + intros. bitwise. apply orb_assoc. + Qed. + + Lemma lor_diag : forall a, lor a a == a. + Proof. + intros. bitwise. apply orb_diag. + Qed. + + Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. + Proof. + intros a b H. bitwise as m. + apply (orb_false_iff a.[m] b.[m]). + now rewrite <- lor_spec, H, bits_0. + Qed. + + Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. + Proof. + intros a b. split. + - intro H; split. + + now apply lor_eq_0_l in H. + + rewrite lor_comm in H. now apply lor_eq_0_l in H. + - intros (EQ,EQ'). now rewrite EQ, lor_0_l. + Qed. + + Lemma land_0_l : forall a, land 0 a == 0. + Proof. + intros. bitwise. trivial. + Qed. + + Lemma land_0_r : forall a, land a 0 == 0. + Proof. + intros. bitwise. apply andb_false_r. + Qed. + + Lemma land_comm : forall a b, land a b == land b a. + Proof. + intros. bitwise. apply andb_comm. + Qed. + + Lemma land_assoc : + forall a b c, land a (land b c) == land (land a b) c. + Proof. + intros. bitwise. apply andb_assoc. + Qed. + + Lemma land_diag : forall a, land a a == a. + Proof. + intros. bitwise. apply andb_diag. + Qed. + + Lemma land_even_l : + forall a b, land (2 * a) b == 2 * (land a (div2 b)). + Proof. + intros a b; rewrite (div2_odd b) at 1; apply bits_inj; intros m. + destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite !land_spec. + - rewrite 2!testbit_even_0; reflexivity. + - rewrite 2!testbit_even_succ, testbit_succ_r, land_spec by exact (le_0_l _). reflexivity. - - rewrite testbit_succ_r, testbit_even_succ, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_odd_r : - forall a b, ldiff a (2 * b + 1) == 2 * ldiff (div2 a) b. -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite testbit_odd_0, testbit_even_0; simpl; rewrite andb_false_r; + Qed. + + Lemma land_even_r : + forall a b, land a (2 * b) == 2 * (land (div2 a) b). + Proof. + intros a b; rewrite (land_comm a _), (land_comm _ b); exact (land_even_l _ _). + Qed. + + Lemma land_odd_l : + forall a b, land (2 * a + 1) b == 2 * (land a (div2 b)) + odd b. + Proof. + intros a b; rewrite (div2_odd b) at 1; apply bits_inj; intros m. + destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite !land_spec. + - rewrite 2!testbit_0_r, testbit_odd_0; reflexivity. + - rewrite 2!testbit_succ_r, land_spec, testbit_odd_succ by (exact (le_0_l _)). reflexivity. - - rewrite testbit_odd_succ, testbit_even_succ, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_even_even : forall a b, ldiff (2 * a) (2 * b) == 2 * ldiff a b. -Proof. intros a b; rewrite ldiff_even_l, div2_even; reflexivity. Qed. - -Lemma ldiff_odd_even : - forall a b, ldiff (2 * a + 1) (2 * b) == 2 * (ldiff a b) + 1. -Proof. intros a b; rewrite ldiff_even_r, div2_odd', odd_odd; reflexivity. Qed. - -Lemma ldiff_even_odd : forall a b, ldiff (2 * a) (2 * b + 1) == 2 * ldiff a b. -Proof. intros a b; rewrite ldiff_even_l, div2_odd'; reflexivity. Qed. - -Lemma ldiff_odd_odd : - forall a b, ldiff (2 * a + 1) (2 * b + 1) == 2 * ldiff a b. -Proof. intros a b; rewrite ldiff_odd_r, div2_odd'; reflexivity. Qed. - -Lemma ldiff_le_l : - forall a b, ldiff a b <= a. -Proof. - apply (Private_binary_induction (fun a => forall b, _)); [| | intros a H b..]. - - intros x y eq; split; intros H b; [rewrite <-eq | rewrite eq]; now apply H. - - intros b; rewrite ldiff_0_l; exact (le_0_l _). - - rewrite ldiff_even_l; apply mul_le_mono_l; exact (H _). - - rewrite ldiff_odd_l; apply add_le_mono; - [ apply mul_le_mono_l; exact (H _) | exact (b2n_le_1 _)]. -Qed. - -Lemma lor_land_distr_l : forall a b c, - lor (land a b) c == land (lor a c) (lor b c). -Proof. - intros. bitwise. apply orb_andb_distrib_l. -Qed. - -Lemma lor_land_distr_r : forall a b c, - lor a (land b c) == land (lor a b) (lor a c). -Proof. - intros. bitwise. apply orb_andb_distrib_r. -Qed. - -Lemma land_lor_distr_l : forall a b c, - land (lor a b) c == lor (land a c) (land b c). -Proof. - intros. bitwise. apply andb_orb_distrib_l. -Qed. - -Lemma land_lor_distr_r : forall a b c, - land a (lor b c) == lor (land a b) (land a c). -Proof. - intros. bitwise. apply andb_orb_distrib_r. -Qed. - -Lemma ldiff_ldiff_l : forall a b c, - ldiff (ldiff a b) c == ldiff a (lor b c). -Proof. - intros. bitwise. now rewrite negb_orb, andb_assoc. -Qed. - -Lemma lor_ldiff_and : forall a b, - lor (ldiff a b) (land a b) == a. -Proof. - intros. bitwise. - now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. -Qed. - -Lemma land_ldiff : forall a b, - land (ldiff a b) b == 0. -Proof. - intros. bitwise. - now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. -Qed. - -(** Properties of [setbit] and [clearbit] *) - -Definition setbit a n := lor a (1<eq==>eq) setbit. -Proof. unfold setbit. solve_proper. Qed. - -#[global] -Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. -Proof. unfold clearbit. solve_proper. Qed. - -Lemma pow2_bits_true : forall n, (2^n).[n] = true. -Proof. - intros n. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. - now rewrite mul_pow2_bits_add, bit0_odd, odd_1. -Qed. - -Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. -Proof. - intros n m ?. - rewrite <- (mul_1_l (2^n)). - destruct (le_gt_cases n m). - - rewrite mul_pow2_bits_high; trivial. - rewrite <- (succ_pred (m-n)) by (apply sub_gt; order). - now rewrite <- div2_bits, div_small, bits_0 by order'. - - rewrite mul_pow2_bits_low; trivial. -Qed. - -Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m. -Proof. - intros n m. apply eq_true_iff_eq. rewrite eqb_eq. split. - - destruct (eq_decidable n m) as [H|H]. { trivial. } - now rewrite (pow2_bits_false _ _ H). - - intros EQ. rewrite EQ. apply pow2_bits_true. -Qed. - -Lemma setbit_eqb : forall a n m, - (setbit a n).[m] = eqb n m || a.[m]. -Proof. - intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. -Qed. - -Lemma setbit_iff : forall a n m, - (setbit a n).[m] = true <-> n==m \/ a.[m] = true. -Proof. - intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. -Qed. - -Lemma setbit_eq : forall a n, (setbit a n).[n] = true. -Proof. - intros. apply setbit_iff. now left. -Qed. - -Lemma setbit_neq : forall a n m, n~=m -> - (setbit a n).[m] = a.[m]. -Proof. - intros a n m H. rewrite setbit_eqb. - rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. -Qed. - -Lemma clearbit_eqb : forall a n m, - (clearbit a n).[m] = a.[m] && negb (eqb n m). -Proof. - intros. now rewrite clearbit_spec', ldiff_spec, pow2_bits_eqb. -Qed. - -Lemma clearbit_iff : forall a n m, - (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. -Proof. - intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. - now rewrite negb_true_iff, not_true_iff_false. -Qed. - -Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. -Proof. - intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). - apply andb_false_r. -Qed. - -Lemma clearbit_neq : forall a n m, n~=m -> - (clearbit a n).[m] = a.[m]. -Proof. - intros a n m H. rewrite clearbit_eqb. - rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. - apply andb_true_r. -Qed. - -(** Shifts of bitwise operations *) - -Lemma shiftl_lxor : forall a b n, - (lxor a b) << n == lxor (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', lxor_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_lxor : forall a b n, - (lxor a b) >> n == lxor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', lxor_spec. -Qed. - -Lemma shiftl_land : forall a b n, - (land a b) << n == land (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', land_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_land : forall a b n, - (land a b) >> n == land (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', land_spec. -Qed. - -Lemma shiftl_lor : forall a b n, - (lor a b) << n == lor (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', lor_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_lor : forall a b n, - (lor a b) >> n == lor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', lor_spec. -Qed. - -Lemma shiftl_ldiff : forall a b n, - (ldiff a b) << n == ldiff (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', ldiff_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_ldiff : forall a b n, - (ldiff a b) >> n == ldiff (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', ldiff_spec. -Qed. - -(** Shifts and order *) - -Lemma shiftl_lower_bound : forall a n, a <= a << n. -Proof. - intros a n; rewrite shiftl_mul_pow2, two_succ; rewrite <-(mul_1_r a) at 1. - apply mul_le_mono_l, pow_lower_bound; exact (neq_succ_0 _). -Qed. - -Lemma shiftr_upper_bound : forall a n, a >> n <= a. -Proof. - intros a n; rewrite shiftr_div_pow2, two_succ; apply div_le_upper_bound; - [| apply le_mul_l]; apply pow_nonzero; exact (neq_succ_0 _). -Qed. - -(** We cannot have a function complementing all bits of a number, + Qed. + + Lemma land_odd_r : + forall a b, land a (2 * b + 1) == 2 * (land (div2 a) b) + odd a. + Proof. + intros a b; rewrite (land_comm a _), (land_comm _ b); exact (land_odd_l _ _). + Qed. + + Lemma land_even_even : forall a b, land (2 * a) (2 * b) == 2 * land a b. + Proof. intros a b; rewrite land_even_l, div2_even; reflexivity. Qed. + + Lemma land_odd_even : forall a b, land (2 * a + 1) (2 * b) == 2 * land a b. + Proof. intros a b; rewrite land_even_r, div2_odd'; reflexivity. Qed. + + Lemma land_even_odd : forall a b, land (2 * a) (2 * b + 1) == 2 * land a b. + Proof. intros a b; rewrite land_even_l, div2_odd'; reflexivity. Qed. + + Lemma land_odd_odd : + forall a b, land (2 * a + 1) (2 * b + 1) == 2 * (land a b) + 1. + Proof. intros a b; rewrite land_odd_l, div2_odd', odd_odd; reflexivity. Qed. + + Lemma land_le_l : + forall a b, land a b <= a. + Proof. + apply (Private_binary_induction (fun a => forall b, _)); [| | intros a H b..]. + - intros x y eq; split; intros H b; [rewrite <-eq | rewrite eq]; now apply H. + - intros b; rewrite land_0_l; exact (le_refl _). + - rewrite land_even_l; apply mul_le_mono_l; exact (H _). + - rewrite land_odd_l; apply add_le_mono; + [apply mul_le_mono_l; exact (H _) | exact (b2n_le_1 _)]. + Qed. + + Lemma land_le_r : + forall a b, land a b <= b. + Proof. intros a b; rewrite land_comm; exact (land_le_l _ _). Qed. + + Lemma ldiff_0_l : forall a, ldiff 0 a == 0. + Proof. + intros. bitwise. trivial. + Qed. + + Lemma ldiff_0_r : forall a, ldiff a 0 == a. + Proof. + intros. bitwise. now rewrite andb_true_r. + Qed. + + Lemma ldiff_diag : forall a, ldiff a a == 0. + Proof. + intros. bitwise. apply andb_negb_r. + Qed. + + Lemma ldiff_even_l : forall a b, ldiff (2 * a) b == 2 * ldiff a (div2 b). + Proof. + intros a b; apply bits_inj; intros m. + destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. + - rewrite 2!testbit_even_0; reflexivity. + - rewrite 2!testbit_even_succ, ldiff_spec, testbit_div2 + by (exact (le_0_l _)); reflexivity. + Qed. + + Lemma ldiff_odd_l : + forall a b, ldiff (2 * a + 1) b == 2 * ldiff a (div2 b) + even b. + Proof. + intros a b; apply bits_inj; intros m. + destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. + - rewrite testbit_odd_0, testbit_0_r, bit0_odd, negb_odd; reflexivity. + - rewrite testbit_odd_succ, testbit_succ_r, ldiff_spec, testbit_div2 + by (exact (le_0_l _)); reflexivity. + Qed. + + Lemma ldiff_even_r : + forall a b, ldiff a (2 * b) == 2 * ldiff (div2 a) b + odd a. + Proof. + intros a b; apply bits_inj; intros m. + destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. + - rewrite testbit_0_r, testbit_even_0, bit0_odd; simpl; rewrite andb_true_r; + reflexivity. + - rewrite testbit_succ_r, testbit_even_succ, ldiff_spec, testbit_div2 + by (exact (le_0_l _)); reflexivity. + Qed. + + Lemma ldiff_odd_r : + forall a b, ldiff a (2 * b + 1) == 2 * ldiff (div2 a) b. + Proof. + intros a b; apply bits_inj; intros m. + destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. + - rewrite testbit_odd_0, testbit_even_0; simpl; rewrite andb_false_r; + reflexivity. + - rewrite testbit_odd_succ, testbit_even_succ, ldiff_spec, testbit_div2 + by (exact (le_0_l _)); reflexivity. + Qed. + + Lemma ldiff_even_even : forall a b, ldiff (2 * a) (2 * b) == 2 * ldiff a b. + Proof. intros a b; rewrite ldiff_even_l, div2_even; reflexivity. Qed. + + Lemma ldiff_odd_even : + forall a b, ldiff (2 * a + 1) (2 * b) == 2 * (ldiff a b) + 1. + Proof. intros a b; rewrite ldiff_even_r, div2_odd', odd_odd; reflexivity. Qed. + + Lemma ldiff_even_odd : forall a b, ldiff (2 * a) (2 * b + 1) == 2 * ldiff a b. + Proof. intros a b; rewrite ldiff_even_l, div2_odd'; reflexivity. Qed. + + Lemma ldiff_odd_odd : + forall a b, ldiff (2 * a + 1) (2 * b + 1) == 2 * ldiff a b. + Proof. intros a b; rewrite ldiff_odd_r, div2_odd'; reflexivity. Qed. + + Lemma ldiff_le_l : + forall a b, ldiff a b <= a. + Proof. + apply (Private_binary_induction (fun a => forall b, _)); [| | intros a H b..]. + - intros x y eq; split; intros H b; [rewrite <-eq | rewrite eq]; now apply H. + - intros b; rewrite ldiff_0_l; exact (le_0_l _). + - rewrite ldiff_even_l; apply mul_le_mono_l; exact (H _). + - rewrite ldiff_odd_l; apply add_le_mono; + [ apply mul_le_mono_l; exact (H _) | exact (b2n_le_1 _)]. + Qed. + + Lemma lor_land_distr_l : forall a b c, + lor (land a b) c == land (lor a c) (lor b c). + Proof. + intros. bitwise. apply orb_andb_distrib_l. + Qed. + + Lemma lor_land_distr_r : forall a b c, + lor a (land b c) == land (lor a b) (lor a c). + Proof. + intros. bitwise. apply orb_andb_distrib_r. + Qed. + + Lemma land_lor_distr_l : forall a b c, + land (lor a b) c == lor (land a c) (land b c). + Proof. + intros. bitwise. apply andb_orb_distrib_l. + Qed. + + Lemma land_lor_distr_r : forall a b c, + land a (lor b c) == lor (land a b) (land a c). + Proof. + intros. bitwise. apply andb_orb_distrib_r. + Qed. + + Lemma ldiff_ldiff_l : forall a b c, + ldiff (ldiff a b) c == ldiff a (lor b c). + Proof. + intros. bitwise. now rewrite negb_orb, andb_assoc. + Qed. + + Lemma lor_ldiff_and : forall a b, + lor (ldiff a b) (land a b) == a. + Proof. + intros. bitwise. + now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. + Qed. + + Lemma land_ldiff : forall a b, + land (ldiff a b) b == 0. + Proof. + intros. bitwise. + now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. + Qed. + + (** Properties of [setbit] and [clearbit] *) + + Definition setbit a n := lor a (1<eq==>eq) setbit. + Proof. unfold setbit. solve_proper. Qed. + + #[global] + Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. + Proof. unfold clearbit. solve_proper. Qed. + + Lemma pow2_bits_true : forall n, (2^n).[n] = true. + Proof. + intros n. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. + now rewrite mul_pow2_bits_add, bit0_odd, odd_1. + Qed. + + Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. + Proof. + intros n m ?. + rewrite <- (mul_1_l (2^n)). + destruct (le_gt_cases n m). + - rewrite mul_pow2_bits_high; trivial. + rewrite <- (succ_pred (m-n)) by (apply sub_gt; order). + now rewrite <- div2_bits, div_small, bits_0 by order'. + - rewrite mul_pow2_bits_low; trivial. + Qed. + + Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m. + Proof. + intros n m. apply eq_true_iff_eq. rewrite eqb_eq. split. + - destruct (eq_decidable n m) as [H|H]. { trivial. } + now rewrite (pow2_bits_false _ _ H). + - intros EQ. rewrite EQ. apply pow2_bits_true. + Qed. + + Lemma setbit_eqb : forall a n m, + (setbit a n).[m] = eqb n m || a.[m]. + Proof. + intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. + Qed. + + Lemma setbit_iff : forall a n m, + (setbit a n).[m] = true <-> n==m \/ a.[m] = true. + Proof. + intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. + Qed. + + Lemma setbit_eq : forall a n, (setbit a n).[n] = true. + Proof. + intros. apply setbit_iff. now left. + Qed. + + Lemma setbit_neq : forall a n m, n~=m -> + (setbit a n).[m] = a.[m]. + Proof. + intros a n m H. rewrite setbit_eqb. + rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. + Qed. + + Lemma clearbit_eqb : forall a n m, + (clearbit a n).[m] = a.[m] && negb (eqb n m). + Proof. + intros. now rewrite clearbit_spec', ldiff_spec, pow2_bits_eqb. + Qed. + + Lemma clearbit_iff : forall a n m, + (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. + Proof. + intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. + now rewrite negb_true_iff, not_true_iff_false. + Qed. + + Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. + Proof. + intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + apply andb_false_r. + Qed. + + Lemma clearbit_neq : forall a n m, n~=m -> + (clearbit a n).[m] = a.[m]. + Proof. + intros a n m H. rewrite clearbit_eqb. + rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. + apply andb_true_r. + Qed. + + (** Shifts of bitwise operations *) + + Lemma shiftl_lxor : forall a b n, + (lxor a b) << n == lxor (a << n) (b << n). + Proof. + intros a b n. bitwise as m. + destruct (le_gt_cases n m). + - now rewrite !shiftl_spec_high', lxor_spec. + - now rewrite !shiftl_spec_low. + Qed. + + Lemma shiftr_lxor : forall a b n, + (lxor a b) >> n == lxor (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec', lxor_spec. + Qed. + + Lemma shiftl_land : forall a b n, + (land a b) << n == land (a << n) (b << n). + Proof. + intros a b n. bitwise as m. + destruct (le_gt_cases n m). + - now rewrite !shiftl_spec_high', land_spec. + - now rewrite !shiftl_spec_low. + Qed. + + Lemma shiftr_land : forall a b n, + (land a b) >> n == land (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec', land_spec. + Qed. + + Lemma shiftl_lor : forall a b n, + (lor a b) << n == lor (a << n) (b << n). + Proof. + intros a b n. bitwise as m. + destruct (le_gt_cases n m). + - now rewrite !shiftl_spec_high', lor_spec. + - now rewrite !shiftl_spec_low. + Qed. + + Lemma shiftr_lor : forall a b n, + (lor a b) >> n == lor (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec', lor_spec. + Qed. + + Lemma shiftl_ldiff : forall a b n, + (ldiff a b) << n == ldiff (a << n) (b << n). + Proof. + intros a b n. bitwise as m. + destruct (le_gt_cases n m). + - now rewrite !shiftl_spec_high', ldiff_spec. + - now rewrite !shiftl_spec_low. + Qed. + + Lemma shiftr_ldiff : forall a b n, + (ldiff a b) >> n == ldiff (a >> n) (b >> n). + Proof. + intros. bitwise. now rewrite !shiftr_spec', ldiff_spec. + Qed. + + (** Shifts and order *) + + Lemma shiftl_lower_bound : forall a n, a <= a << n. + Proof. + intros a n; rewrite shiftl_mul_pow2, two_succ; rewrite <-(mul_1_r a) at 1. + apply mul_le_mono_l, pow_lower_bound; exact (neq_succ_0 _). + Qed. + + Lemma shiftr_upper_bound : forall a n, a >> n <= a. + Proof. + intros a n; rewrite shiftr_div_pow2, two_succ; apply div_le_upper_bound; + [| apply le_mul_l]; apply pow_nonzero; exact (neq_succ_0 _). + Qed. + + (** We cannot have a function complementing all bits of a number, otherwise it would have an infinity of bit 1. Nonetheless, we can design a bounded complement *) -Definition ones n := P (1 << n). - -Definition lnot a n := lxor a (ones n). - -#[global] -Instance ones_wd : Proper (eq==>eq) ones. -Proof. unfold ones. solve_proper. Qed. - -#[global] -Instance lnot_wd : Proper (eq==>eq==>eq) lnot. -Proof. unfold lnot. solve_proper. Qed. - -Lemma ones_equiv : forall n, ones n == P (2^n). -Proof. - intros; unfold ones; now rewrite shiftl_1_l. -Qed. - -Lemma ones_0 : ones 0 == 0. -Proof. - rewrite ones_equiv, pow_0_r, one_succ, pred_succ; reflexivity. -Qed. - -Lemma ones_add : forall n m, ones (m+n) == 2^m * ones n + ones m. -Proof. - intros n m. rewrite !ones_equiv. - rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r. - rewrite add_sub_assoc, sub_add. - - reflexivity. - - apply pow_le_mono_r. { order'. } - rewrite <- (add_0_r m) at 1. apply add_le_mono_l, le_0_l. - - rewrite <- (pow_0_r 2). apply pow_le_mono_r. { order'. } apply le_0_l. -Qed. - -Lemma ones_div_pow2 : forall n m, m<=n -> ones n / 2^m == ones (n-m). -Proof. - intros n m H. symmetry. apply div_unique with (ones m). - - rewrite ones_equiv. - apply le_succ_l. rewrite succ_pred; order_nz. - - rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). - apply ones_add. -Qed. - -Lemma ones_mod_pow2 : forall n m, m<=n -> (ones n) mod (2^m) == ones m. -Proof. - intros n m H. symmetry. apply mod_unique with (ones (n-m)). - - rewrite ones_equiv. - apply le_succ_l. rewrite succ_pred; order_nz. - - rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). - apply ones_add. -Qed. - -Lemma ones_spec_low : forall n m, m (ones n).[m] = true. -Proof. - intros. apply testbit_true. rewrite ones_div_pow2 by order. - rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. - - rewrite ones_equiv. now nzsimpl'. - - apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. -Qed. - -Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false. -Proof. - intros n m ?. - destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv. - - now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0. - - apply bits_above_log2. - rewrite log2_pred_pow2; trivial. rewrite <-le_succ_l, succ_pred; order. -Qed. - -Lemma ones_spec_iff : forall n m, (ones n).[m] = true <-> m - (lnot a n).[m] = negb a.[m]. -Proof. - intros. unfold lnot. now rewrite lxor_spec, ones_spec_low. -Qed. - -Lemma lnot_spec_high : forall a n m, n<=m -> - (lnot a n).[m] = a.[m]. -Proof. - intros. unfold lnot. now rewrite lxor_spec, ones_spec_high, xorb_false_r. -Qed. - -Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a. -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite 2 lnot_spec_high. - - now rewrite 2 lnot_spec_low, negb_involutive. -Qed. - -Lemma lnot_0_l : forall n, lnot 0 n == ones n. -Proof. - intros. unfold lnot. apply lxor_0_l. -Qed. - -Lemma lnot_ones : forall n, lnot (ones n) n == 0. -Proof. - intros. unfold lnot. apply lxor_nilpotent. -Qed. - -Lemma ones_succ : forall n, ones (S n) == 2 * (ones n) + 1. -Proof. - intros n; rewrite 2!ones_equiv, <-2!sub_1_r, mul_sub_distr_l. - rewrite mul_1_r, <-pow_succ_r, two_succ, one_succ by (exact (le_0_l _)). - rewrite <-sub_sub_distr, sub_succ, sub_0_r; [reflexivity | |]. - - apply ->succ_le_mono; exact (le_0_l _). - - rewrite <-(pow_1_r (S (S 0))) at 1; apply pow_le_mono_r; - [exact (neq_succ_0 _) | exact (le_1_succ _)]. -Qed. - -(** Bounded complement and other operations *) - -Lemma lor_ones_low : forall a n, log2 a < n -> - lor a (ones n) == ones n. -Proof. - intros a n H. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - now apply lt_le_trans with n. - - now rewrite ones_spec_low, orb_true_r. -Qed. - -Lemma land_ones : forall a n, land a (ones n) == a mod 2^n. -Proof. - intros a n. bitwise as m. destruct (le_gt_cases n m). - - now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r. - - now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r. -Qed. - -Lemma testbit_false_mod_pow2 : - forall a n j, testbit a n = false -> testbit (a mod 2 ^ j) n = false. -Proof. - intros a n j H. rewrite <- land_ones. rewrite land_spec. - rewrite H. rewrite Bool.andb_false_l. reflexivity. -Qed. - -Lemma land_ones_low : forall a n, log2 a < n -> - land a (ones n) == a. -Proof. - intros; rewrite land_ones. apply mod_small. - apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. -Qed. - -Lemma ldiff_ones_r : forall a n, - ldiff a (ones n) == (a >> n) << n. -Proof. - intros a n. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial. - rewrite sub_add; trivial. apply andb_true_r. - - now rewrite ones_spec_low, shiftl_spec_low, andb_false_r. -Qed. - -Lemma ldiff_ones_r_low : forall a n, log2 a < n -> - ldiff a (ones n) == 0. -Proof. - intros a n H. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - now apply lt_le_trans with n. - - now rewrite ones_spec_low, andb_false_r. -Qed. - -Lemma ldiff_ones_l_low : forall a n, log2 a < n -> - ldiff (ones n) a == lnot a n. -Proof. - intros a n H. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial. - now apply lt_le_trans with n. - - now rewrite ones_spec_low, lnot_spec_low. -Qed. - -Lemma lor_lnot_diag : forall a n, - lor a (lnot a n) == lor a (ones n). -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m). - - rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. - - rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. -Qed. - -Lemma lor_lnot_diag_low : forall a n, log2 a < n -> - lor a (lnot a n) == ones n. -Proof. - intros a n H. now rewrite lor_lnot_diag, lor_ones_low. -Qed. - -Lemma land_lnot_diag : forall a n, - land a (lnot a n) == ldiff a (ones n). -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m). - - rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. - - rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. -Qed. - -Lemma land_lnot_diag_low : forall a n, log2 a < n -> - land a (lnot a n) == 0. -Proof. - intros. now rewrite land_lnot_diag, ldiff_ones_r_low. -Qed. - -Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n -> - lnot (lor a b) n == land (lnot a n) (lnot b n). -Proof. - intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial. - + now apply lt_le_trans with n. - + now apply lt_le_trans with n. - - now rewrite !lnot_spec_low, lor_spec, negb_orb. -Qed. - -Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n -> - lnot (land a b) n == lor (lnot a n) (lnot b n). -Proof. - intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial. - + now apply lt_le_trans with n. - + now apply lt_le_trans with n. - - now rewrite !lnot_spec_low, land_spec, negb_andb. -Qed. - -Lemma ldiff_land_low : forall a b n, log2 a < n -> - ldiff a b == land a (lnot b n). -Proof. - intros a b n Ha. bitwise as m. destruct (le_gt_cases n m). - - rewrite (bits_above_log2 a m). - + trivial. - + now apply lt_le_trans with n. - - rewrite !lnot_spec_low; trivial. -Qed. - -Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n -> - lnot (ldiff a b) n == lor (lnot a n) b. -Proof. - intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial. - + now apply lt_le_trans with n. - + now apply lt_le_trans with n. - - now rewrite !lnot_spec_low, ldiff_spec, negb_andb, negb_involutive. -Qed. - -Lemma lxor_lnot_lnot : forall a b n, - lxor (lnot a n) (lnot b n) == lxor a b. -Proof. - intros a b n. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high; trivial. - - rewrite !lnot_spec_low, xorb_negb_negb; trivial. -Qed. - -Lemma lnot_lxor_l : forall a b n, - lnot (lxor a b) n == lxor (lnot a n) b. -Proof. - intros a b n. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, lxor_spec; trivial. - - rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial. -Qed. - -Lemma lnot_lxor_r : forall a b n, - lnot (lxor a b) n == lxor a (lnot b n). -Proof. - intros a b n. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, lxor_spec; trivial. - - rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial. -Qed. - -Lemma lxor_lor : forall a b, land a b == 0 -> - lxor a b == lor a b. -Proof. - intros a b H. bitwise as m. - assert (a.[m] && b.[m] = false) - by now rewrite <- land_spec, H, bits_0. - now destruct a.[m], b.[m]. -Qed. - -(** Bitwise operations and log2 *) - -Lemma log2_bits_unique : forall a n, - a.[n] = true -> - (forall m, n a.[m] = false) -> - log2 a == n. -Proof. - intros a n H H'. - destruct (eq_0_gt_0_cases a) as [Ha|Ha]. - - now rewrite Ha, bits_0 in H. - - apply le_antisymm; apply le_ngt; intros LT. - + specialize (H' _ LT). now rewrite bit_log2 in H' by order. - + now rewrite bits_above_log2 in H by order. -Qed. - -Lemma log2_shiftr : forall a n, log2 (a >> n) == log2 a - n. -Proof. - intros a n. - destruct (eq_0_gt_0_cases a) as [Ha|Ha]. - - now rewrite Ha, shiftr_0_l, log2_nonpos, sub_0_l by order. - - destruct (lt_ge_cases (log2 a) n). - + rewrite shiftr_eq_0, log2_nonpos by order. - symmetry. rewrite sub_0_le; order. - + apply log2_bits_unique. - * now rewrite shiftr_spec', sub_add, bit_log2 by order. - * intros m Hm. - rewrite shiftr_spec'; trivial. apply bits_above_log2; try order. - now apply lt_sub_lt_add_r. -Qed. - -Lemma log2_shiftl : forall a n, a~=0 -> log2 (a << n) == log2 a + n. -Proof. - intros a n Ha. - rewrite shiftl_mul_pow2, add_comm by trivial. - apply log2_mul_pow2. - - generalize (le_0_l a); order. - - apply le_0_l. -Qed. - -Lemma log2_lor : forall a b, - log2 (lor a b) == max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, a<=b -> log2 (lor a b) == log2 b). { - intros a b H. + Definition ones n := P (1 << n). + + Definition lnot a n := lxor a (ones n). + + #[global] + Instance ones_wd : Proper (eq==>eq) ones. + Proof. unfold ones. solve_proper. Qed. + + #[global] + Instance lnot_wd : Proper (eq==>eq==>eq) lnot. + Proof. unfold lnot. solve_proper. Qed. + + Lemma ones_equiv : forall n, ones n == P (2^n). + Proof. + intros; unfold ones; now rewrite shiftl_1_l. + Qed. + + Lemma ones_0 : ones 0 == 0. + Proof. + rewrite ones_equiv, pow_0_r, one_succ, pred_succ; reflexivity. + Qed. + + Lemma ones_add : forall n m, ones (m+n) == 2^m * ones n + ones m. + Proof. + intros n m. rewrite !ones_equiv. + rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r. + rewrite add_sub_assoc, sub_add. + - reflexivity. + - apply pow_le_mono_r. { order'. } + rewrite <- (add_0_r m) at 1. apply add_le_mono_l, le_0_l. + - rewrite <- (pow_0_r 2). apply pow_le_mono_r. { order'. } apply le_0_l. + Qed. + + Lemma ones_div_pow2 : forall n m, m<=n -> ones n / 2^m == ones (n-m). + Proof. + intros n m H. symmetry. apply div_unique with (ones m). + - rewrite ones_equiv. + apply le_succ_l. rewrite succ_pred; order_nz. + - rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). + apply ones_add. + Qed. + + Lemma ones_mod_pow2 : forall n m, m<=n -> (ones n) mod (2^m) == ones m. + Proof. + intros n m H. symmetry. apply mod_unique with (ones (n-m)). + - rewrite ones_equiv. + apply le_succ_l. rewrite succ_pred; order_nz. + - rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). + apply ones_add. + Qed. + + Lemma ones_spec_low : forall n m, m (ones n).[m] = true. + Proof. + intros. apply testbit_true. rewrite ones_div_pow2 by order. + rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. + - rewrite ones_equiv. now nzsimpl'. + - apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. + Qed. + + Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false. + Proof. + intros n m ?. + destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv. + - now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0. + - apply bits_above_log2. + rewrite log2_pred_pow2; trivial. rewrite <-le_succ_l, succ_pred; order. + Qed. + + Lemma ones_spec_iff : forall n m, (ones n).[m] = true <-> m + (lnot a n).[m] = negb a.[m]. + Proof. + intros. unfold lnot. now rewrite lxor_spec, ones_spec_low. + Qed. + + Lemma lnot_spec_high : forall a n m, n<=m -> + (lnot a n).[m] = a.[m]. + Proof. + intros. unfold lnot. now rewrite lxor_spec, ones_spec_high, xorb_false_r. + Qed. + + Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a. + Proof. + intros a n. bitwise as m. + destruct (le_gt_cases n m). + - now rewrite 2 lnot_spec_high. + - now rewrite 2 lnot_spec_low, negb_involutive. + Qed. + + Lemma lnot_0_l : forall n, lnot 0 n == ones n. + Proof. + intros. unfold lnot. apply lxor_0_l. + Qed. + + Lemma lnot_ones : forall n, lnot (ones n) n == 0. + Proof. + intros. unfold lnot. apply lxor_nilpotent. + Qed. + + Lemma ones_succ : forall n, ones (S n) == 2 * (ones n) + 1. + Proof. + intros n; rewrite 2!ones_equiv, <-2!sub_1_r, mul_sub_distr_l. + rewrite mul_1_r, <-pow_succ_r, two_succ, one_succ by (exact (le_0_l _)). + rewrite <-sub_sub_distr, sub_succ, sub_0_r; [reflexivity | |]. + - apply ->succ_le_mono; exact (le_0_l _). + - rewrite <-(pow_1_r (S (S 0))) at 1; apply pow_le_mono_r; + [exact (neq_succ_0 _) | exact (le_1_succ _)]. + Qed. + + (** Bounded complement and other operations *) + + Lemma lor_ones_low : forall a n, log2 a < n -> + lor a (ones n) == ones n. + Proof. + intros a n H. bitwise as m. destruct (le_gt_cases n m). + - rewrite ones_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + - now rewrite ones_spec_low, orb_true_r. + Qed. + + Lemma land_ones : forall a n, land a (ones n) == a mod 2^n. + Proof. + intros a n. bitwise as m. destruct (le_gt_cases n m). + - now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r. + - now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r. + Qed. + + Lemma testbit_false_mod_pow2 : + forall a n j, testbit a n = false -> testbit (a mod 2 ^ j) n = false. + Proof. + intros a n j H. rewrite <- land_ones. rewrite land_spec. + rewrite H. rewrite Bool.andb_false_l. reflexivity. + Qed. + + Lemma land_ones_low : forall a n, log2 a < n -> + land a (ones n) == a. + Proof. + intros; rewrite land_ones. apply mod_small. + apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. + Qed. + + Lemma ldiff_ones_r : forall a n, + ldiff a (ones n) == (a >> n) << n. + Proof. + intros a n. bitwise as m. destruct (le_gt_cases n m). + - rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial. + rewrite sub_add; trivial. apply andb_true_r. + - now rewrite ones_spec_low, shiftl_spec_low, andb_false_r. + Qed. + + Lemma ldiff_ones_r_low : forall a n, log2 a < n -> + ldiff a (ones n) == 0. + Proof. + intros a n H. bitwise as m. destruct (le_gt_cases n m). + - rewrite ones_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + - now rewrite ones_spec_low, andb_false_r. + Qed. + + Lemma ldiff_ones_l_low : forall a n, log2 a < n -> + ldiff (ones n) a == lnot a n. + Proof. + intros a n H. bitwise as m. destruct (le_gt_cases n m). + - rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + - now rewrite ones_spec_low, lnot_spec_low. + Qed. + + Lemma lor_lnot_diag : forall a n, + lor a (lnot a n) == lor a (ones n). + Proof. + intros a n. bitwise as m. + destruct (le_gt_cases n m). + - rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. + - rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. + Qed. + + Lemma lor_lnot_diag_low : forall a n, log2 a < n -> + lor a (lnot a n) == ones n. + Proof. + intros a n H. now rewrite lor_lnot_diag, lor_ones_low. + Qed. + + Lemma land_lnot_diag : forall a n, + land a (lnot a n) == ldiff a (ones n). + Proof. + intros a n. bitwise as m. + destruct (le_gt_cases n m). + - rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. + - rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. + Qed. + + Lemma land_lnot_diag_low : forall a n, log2 a < n -> + land a (lnot a n) == 0. + Proof. + intros. now rewrite land_lnot_diag, ldiff_ones_r_low. + Qed. + + Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n -> + lnot (lor a b) n == land (lnot a n) (lnot b n). + Proof. + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). + - rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial. + + now apply lt_le_trans with n. + + now apply lt_le_trans with n. + - now rewrite !lnot_spec_low, lor_spec, negb_orb. + Qed. + + Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n -> + lnot (land a b) n == lor (lnot a n) (lnot b n). + Proof. + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). + - rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial. + + now apply lt_le_trans with n. + + now apply lt_le_trans with n. + - now rewrite !lnot_spec_low, land_spec, negb_andb. + Qed. + + Lemma ldiff_land_low : forall a b n, log2 a < n -> + ldiff a b == land a (lnot b n). + Proof. + intros a b n Ha. bitwise as m. destruct (le_gt_cases n m). + - rewrite (bits_above_log2 a m). + + trivial. + + now apply lt_le_trans with n. + - rewrite !lnot_spec_low; trivial. + Qed. + + Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n -> + lnot (ldiff a b) n == lor (lnot a n) b. + Proof. + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). + - rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial. + + now apply lt_le_trans with n. + + now apply lt_le_trans with n. + - now rewrite !lnot_spec_low, ldiff_spec, negb_andb, negb_involutive. + Qed. + + Lemma lxor_lnot_lnot : forall a b n, + lxor (lnot a n) (lnot b n) == lxor a b. + Proof. + intros a b n. bitwise as m. destruct (le_gt_cases n m). + - rewrite !lnot_spec_high; trivial. + - rewrite !lnot_spec_low, xorb_negb_negb; trivial. + Qed. + + Lemma lnot_lxor_l : forall a b n, + lnot (lxor a b) n == lxor (lnot a n) b. + Proof. + intros a b n. bitwise as m. destruct (le_gt_cases n m). + - rewrite !lnot_spec_high, lxor_spec; trivial. + - rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial. + Qed. + + Lemma lnot_lxor_r : forall a b n, + lnot (lxor a b) n == lxor a (lnot b n). + Proof. + intros a b n. bitwise as m. destruct (le_gt_cases n m). + - rewrite !lnot_spec_high, lxor_spec; trivial. + - rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial. + Qed. + + Lemma lxor_lor : forall a b, land a b == 0 -> + lxor a b == lor a b. + Proof. + intros a b H. bitwise as m. + assert (a.[m] && b.[m] = false) + by now rewrite <- land_spec, H, bits_0. + now destruct a.[m], b.[m]. + Qed. + + (** Bitwise operations and log2 *) + + Lemma log2_bits_unique : forall a n, + a.[n] = true -> + (forall m, n a.[m] = false) -> + log2 a == n. + Proof. + intros a n H H'. destruct (eq_0_gt_0_cases a) as [Ha|Ha]. - - now rewrite Ha, lor_0_l. - - apply log2_bits_unique. - + now rewrite lor_spec, bit_log2, orb_true_r by order. - + intros m Hm. assert (H' := log2_le_mono _ _ H). - now rewrite lor_spec, 2 bits_above_log2 by order. - } - (* main *) - intros a b. destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. - now apply AUX. - - rewrite max_l by now apply log2_le_mono. - rewrite lor_comm. now apply AUX. -Qed. - -Lemma log2_land : forall a b, - log2 (land a b) <= min (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, a<=b -> log2 (land a b) <= log2 a). { - intros a b H. - apply le_ngt. intros H'. - destruct (eq_decidable (land a b) 0) as [EQ|NEQ]. - - rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. - - generalize (bit_log2 (land a b) NEQ). - now rewrite land_spec, bits_above_log2. - } - (* main *) - intros a b. - destruct (le_ge_cases a b) as [H|H]. - - rewrite min_l by now apply log2_le_mono. now apply AUX. - - rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. -Qed. - -Lemma log2_lxor : forall a b, - log2 (lxor a b) <= max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, a<=b -> log2 (lxor a b) <= log2 b). { - intros a b H. - apply le_ngt. intros H'. - destruct (eq_decidable (lxor a b) 0) as [EQ|NEQ]. - - rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. - - generalize (bit_log2 (lxor a b) NEQ). - rewrite lxor_spec, 2 bits_above_log2; try order. - + discriminate. - + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. - } - (* main *) - intros a b. - destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. now apply AUX. - - rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. -Qed. - -(** Bitwise operations and arithmetical operations *) - -#[local] Notation xor3 a b c := (xorb (xorb a b) c). -#[local] Notation lxor3 a b c := (lxor (lxor a b) c). - -#[local] Notation nextcarry a b c := ((a&&b) || (c && (a||b))). -#[local] Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). - -Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. -Proof. - intros. now rewrite !bit0_odd, odd_add. -Qed. - -Lemma add3_bit0 : forall a b c, - (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. -Proof. - intros. now rewrite !add_bit0. -Qed. - -Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), - (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. -Proof. - assert (H : 1+1 == 2) by now nzsimpl'. - intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; - (apply div_same; order') || (apply div_small; order') || idtac. - symmetry. apply div_unique with 1. { order'. } now nzsimpl'. -Qed. - -Lemma add_carry_div2 : forall a b (c0:bool), - (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. -Proof. - intros a b c0. - rewrite <- add3_bits_div2. - rewrite (add_comm ((a/2)+_)). - rewrite <- div_add by order'. - f_equiv. - rewrite <- !div2_div, mul_comm, mul_add_distr_l. - rewrite (div2_odd a), <- bit0_odd at 1. fold (b2n a.[0]). - rewrite (div2_odd b), <- bit0_odd at 1. fold (b2n b.[0]). - rewrite add_shuffle1. - rewrite <-(add_assoc _ _ c0). apply add_comm. -Qed. - -(** The main result concerning addition: we express the bits of the sum + - now rewrite Ha, bits_0 in H. + - apply le_antisymm; apply le_ngt; intros LT. + + specialize (H' _ LT). now rewrite bit_log2 in H' by order. + + now rewrite bits_above_log2 in H by order. + Qed. + + Lemma log2_shiftr : forall a n, log2 (a >> n) == log2 a - n. + Proof. + intros a n. + destruct (eq_0_gt_0_cases a) as [Ha|Ha]. + - now rewrite Ha, shiftr_0_l, log2_nonpos, sub_0_l by order. + - destruct (lt_ge_cases (log2 a) n). + + rewrite shiftr_eq_0, log2_nonpos by order. + symmetry. rewrite sub_0_le; order. + + apply log2_bits_unique. + * now rewrite shiftr_spec', sub_add, bit_log2 by order. + * intros m Hm. + rewrite shiftr_spec'; trivial. apply bits_above_log2; try order. + now apply lt_sub_lt_add_r. + Qed. + + Lemma log2_shiftl : forall a n, a~=0 -> log2 (a << n) == log2 a + n. + Proof. + intros a n Ha. + rewrite shiftl_mul_pow2, add_comm by trivial. + apply log2_mul_pow2. + - generalize (le_0_l a); order. + - apply le_0_l. + Qed. + + Lemma log2_lor : forall a b, + log2 (lor a b) == max (log2 a) (log2 b). + Proof. + assert (AUX : forall a b, a<=b -> log2 (lor a b) == log2 b). { + intros a b H. + destruct (eq_0_gt_0_cases a) as [Ha|Ha]. + - now rewrite Ha, lor_0_l. + - apply log2_bits_unique. + + now rewrite lor_spec, bit_log2, orb_true_r by order. + + intros m Hm. assert (H' := log2_le_mono _ _ H). + now rewrite lor_spec, 2 bits_above_log2 by order. + } + (* main *) + intros a b. destruct (le_ge_cases a b) as [H|H]. + - rewrite max_r by now apply log2_le_mono. + now apply AUX. + - rewrite max_l by now apply log2_le_mono. + rewrite lor_comm. now apply AUX. + Qed. + + Lemma log2_land : forall a b, + log2 (land a b) <= min (log2 a) (log2 b). + Proof. + assert (AUX : forall a b, a<=b -> log2 (land a b) <= log2 a). { + intros a b H. + apply le_ngt. intros H'. + destruct (eq_decidable (land a b) 0) as [EQ|NEQ]. + - rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. + - generalize (bit_log2 (land a b) NEQ). + now rewrite land_spec, bits_above_log2. + } + (* main *) + intros a b. + destruct (le_ge_cases a b) as [H|H]. + - rewrite min_l by now apply log2_le_mono. now apply AUX. + - rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. + Qed. + + Lemma log2_lxor : forall a b, + log2 (lxor a b) <= max (log2 a) (log2 b). + Proof. + assert (AUX : forall a b, a<=b -> log2 (lxor a b) <= log2 b). { + intros a b H. + apply le_ngt. intros H'. + destruct (eq_decidable (lxor a b) 0) as [EQ|NEQ]. + - rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. + - generalize (bit_log2 (lxor a b) NEQ). + rewrite lxor_spec, 2 bits_above_log2; try order. + + discriminate. + + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. + } + (* main *) + intros a b. + destruct (le_ge_cases a b) as [H|H]. + - rewrite max_r by now apply log2_le_mono. now apply AUX. + - rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. + Qed. + + (** Bitwise operations and arithmetical operations *) + + #[local] Notation xor3 a b c := (xorb (xorb a b) c). + #[local] Notation lxor3 a b c := (lxor (lxor a b) c). + + #[local] Notation nextcarry a b c := ((a&&b) || (c && (a||b))). + #[local] Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). + + Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. + Proof. + intros. now rewrite !bit0_odd, odd_add. + Qed. + + Lemma add3_bit0 : forall a b c, + (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. + Proof. + intros. now rewrite !add_bit0. + Qed. + + Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), + (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. + Proof. + assert (H : 1+1 == 2) by now nzsimpl'. + intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; + (apply div_same; order') || (apply div_small; order') || idtac. + symmetry. apply div_unique with 1. { order'. } now nzsimpl'. + Qed. + + Lemma add_carry_div2 : forall a b (c0:bool), + (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. + Proof. + intros a b c0. + rewrite <- add3_bits_div2. + rewrite (add_comm ((a/2)+_)). + rewrite <- div_add by order'. + f_equiv. + rewrite <- !div2_div, mul_comm, mul_add_distr_l. + rewrite (div2_odd a), <- bit0_odd at 1. fold (b2n a.[0]). + rewrite (div2_odd b), <- bit0_odd at 1. fold (b2n b.[0]). + rewrite add_shuffle1. + rewrite <-(add_assoc _ _ c0). apply add_comm. + Qed. + + (** The main result concerning addition: we express the bits of the sum in term of bits of [a] and [b] and of some carry stream which is also recursively determined by another equation. *) -Lemma add_carry_bits : forall a b (c0:bool), exists c, - a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. -Proof. - intros a b c0. - (* induction over some n such that [a<2^n] and [b<2^n] *) - set (n:=max a b). - assert (Ha : a<2^n). { - apply lt_le_trans with (2^a). - - apply pow_gt_lin_r, lt_1_2. - - apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. - } - assert (Hb : b<2^n). { - apply lt_le_trans with (2^b). - - apply pow_gt_lin_r, lt_1_2. - - apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. - } - clearbody n. - revert a b c0 Ha Hb. induct n. - - (*base*) - intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r. intros Ha Hb. - exists c0. - setoid_replace a with 0 by (generalize (le_0_l a); order'). - setoid_replace b with 0 by (generalize (le_0_l b); order'). - rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. - rewrite b2n_div2, b2n_bit0; now repeat split. - - (*step*) - intros n IH a b c0 Ha Hb. - set (c1:=nextcarry a.[0] b.[0] c0). - destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. - + apply div_lt_upper_bound; trivial. { order'. } now rewrite <- pow_succ_r'. - + apply div_lt_upper_bound; trivial. { order'. } now rewrite <- pow_succ_r'. - + exists (c0 + 2*c). repeat split. - * { (* - add *) - bitwise as m. - destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. - - now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0. - - rewrite <- !div2_bits, <- 2 lxor_spec. - f_equiv. - rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2. - } - * { (* - carry *) - rewrite add_b2n_double_div2. - bitwise as m. - destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. - - now rewrite add_b2n_double_bit0. - - rewrite <- !div2_bits, IH2. autorewrite with bitwise. - now rewrite add_b2n_double_div2. - } - * (* - carry0 *) - apply add_b2n_double_bit0. -Qed. - -(** Particular case : the second bit of an addition *) - -Lemma add_bit1 : forall a b, - (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). -Proof. - intros a b. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - autorewrite with bitwise. f_equal. - rewrite one_succ, <- div2_bits, EQ2. - autorewrite with bitwise. - rewrite Hc. simpl. apply orb_false_r. -Qed. - -(** In an addition, there will be no carries iff there is + Lemma add_carry_bits : forall a b (c0:bool), exists c, + a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. + Proof. + intros a b c0. + (* induction over some n such that [a<2^n] and [b<2^n] *) + set (n:=max a b). + assert (Ha : a<2^n). { + apply lt_le_trans with (2^a). + - apply pow_gt_lin_r, lt_1_2. + - apply pow_le_mono_r. { order'. } unfold n. + destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. + } + assert (Hb : b<2^n). { + apply lt_le_trans with (2^b). + - apply pow_gt_lin_r, lt_1_2. + - apply pow_le_mono_r. { order'. } unfold n. + destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. + } + clearbody n. + revert a b c0 Ha Hb. induct n. + - (*base*) + intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r. intros Ha Hb. + exists c0. + setoid_replace a with 0 by (generalize (le_0_l a); order'). + setoid_replace b with 0 by (generalize (le_0_l b); order'). + rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. + rewrite b2n_div2, b2n_bit0; now repeat split. + - (*step*) + intros n IH a b c0 Ha Hb. + set (c1:=nextcarry a.[0] b.[0] c0). + destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. + + apply div_lt_upper_bound; trivial. { order'. } now rewrite <- pow_succ_r'. + + apply div_lt_upper_bound; trivial. { order'. } now rewrite <- pow_succ_r'. + + exists (c0 + 2*c). repeat split. + * { (* - add *) + bitwise as m. + destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. + - now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0. + - rewrite <- !div2_bits, <- 2 lxor_spec. + f_equiv. + rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2. + } + * { (* - carry *) + rewrite add_b2n_double_div2. + bitwise as m. + destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. + - now rewrite add_b2n_double_bit0. + - rewrite <- !div2_bits, IH2. autorewrite with bitwise. + now rewrite add_b2n_double_div2. + } + * (* - carry0 *) + apply add_b2n_double_bit0. + Qed. + + (** Particular case : the second bit of an addition *) + + Lemma add_bit1 : forall a b, + (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). + Proof. + intros a b. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + autorewrite with bitwise. f_equal. + rewrite one_succ, <- div2_bits, EQ2. + autorewrite with bitwise. + rewrite Hc. simpl. apply orb_false_r. + Qed. + + (** In an addition, there will be no carries iff there is no common bits in the numbers to add *) -Lemma nocarry_equiv : forall a b c, - c/2 == lnextcarry a b c -> c.[0] = false -> - (c == 0 <-> land a b == 0). -Proof. - intros a b c H H'. - split. - - intros EQ; rewrite EQ in *. - rewrite div_0_l in H by order'. - symmetry in H. now apply lor_eq_0_l in H. - - intros EQ. rewrite EQ, lor_0_l in H. - apply bits_inj_0. - intro n; induct n. - + trivial. - + intros n IH. - rewrite <- div2_bits, H. - autorewrite with bitwise. - now rewrite IH. -Qed. - -(** When there is no common bits, the addition is just a xor *) - -Lemma add_nocarry_lxor : forall a b, land a b == 0 -> - a+b == lxor a b. -Proof. - intros a b H. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - apply (nocarry_equiv a b c) in H; trivial. - rewrite H. now rewrite lxor_0_r. -Qed. - -(** A null [ldiff] implies being smaller *) - -Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b. -Proof. - cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b). { - intros H a b. apply (H a), pow_gt_lin_r; order'. - } - intro n; induct n. - - intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. - assert (Ha' : a == 0) by (generalize (le_0_l a); order'). - rewrite Ha'. apply le_0_l. - - intros n IH a b Ha H. - assert (NEQ : 2 ~= 0) by order'. - rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). - apply add_le_mono. - + apply mul_le_mono_l. - apply IH. - * apply div_lt_upper_bound; trivial. now rewrite <- pow_succ_r'. - * rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2. - now rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l. - + rewrite <- 2 bit0_mod. - apply bits_inj_iff in H. specialize (H 0). - rewrite ldiff_spec, bits_0 in H. - destruct a.[0], b.[0]; try discriminate; simpl; order'. -Qed. - -(** Subtraction can be a ldiff when the opposite ldiff is null. *) - -Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> - a-b == ldiff a b. -Proof. - intros a b H. - apply add_cancel_r with b. - rewrite sub_add. - - symmetry. - rewrite add_nocarry_lxor. - + bitwise as m. - apply bits_inj_iff in H. specialize (H m). - rewrite ldiff_spec, bits_0 in H. - now destruct a.[m], b.[m]. - + apply land_ldiff. - - now apply ldiff_le. -Qed. - -(** We can express lnot in term of subtraction *) - -Lemma add_lnot_diag_low : forall a n, log2 a < n -> - a + lnot a n == ones n. -Proof. - intros a n H. - assert (H' := land_lnot_diag_low a n H). - rewrite add_nocarry_lxor, lxor_lor by trivial. - now apply lor_lnot_diag_low. -Qed. - -Lemma lnot_sub_low : forall a n, log2 a < n -> - lnot a n == ones n - a. -Proof. - intros a n H. - now rewrite <- (add_lnot_diag_low a n H), add_comm, add_sub. -Qed. - -(** Adding numbers with no common bits cannot lead to a much bigger number *) - -Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> - a < 2^n -> b < 2^n -> a+b < 2^n. -Proof. - intros a b n H Ha Hb. - rewrite add_nocarry_lxor by trivial. - apply div_small_iff. { order_nz. } - rewrite <- shiftr_div_pow2, shiftr_lxor, !shiftr_div_pow2. - rewrite 2 div_small by trivial. - apply lxor_0_l. -Qed. - -Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 -> - a mod 2^n + b mod 2^n < 2^n. -Proof. - intros a b n H. - apply add_nocarry_lt_pow2. - - bitwise as m. - destruct (le_gt_cases n m). - + now rewrite mod_pow2_bits_high. - + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. - - apply mod_upper_bound; order_nz. - - apply mod_upper_bound; order_nz. -Qed. + Lemma nocarry_equiv : forall a b c, + c/2 == lnextcarry a b c -> c.[0] = false -> + (c == 0 <-> land a b == 0). + Proof. + intros a b c H H'. + split. + - intros EQ; rewrite EQ in *. + rewrite div_0_l in H by order'. + symmetry in H. now apply lor_eq_0_l in H. + - intros EQ. rewrite EQ, lor_0_l in H. + apply bits_inj_0. + intro n; induct n. + + trivial. + + intros n IH. + rewrite <- div2_bits, H. + autorewrite with bitwise. + now rewrite IH. + Qed. + + (** When there is no common bits, the addition is just a xor *) + + Lemma add_nocarry_lxor : forall a b, land a b == 0 -> + a+b == lxor a b. + Proof. + intros a b H. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + apply (nocarry_equiv a b c) in H; trivial. + rewrite H. now rewrite lxor_0_r. + Qed. + + (** A null [ldiff] implies being smaller *) + + Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b. + Proof. + cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b). { + intros H a b. apply (H a), pow_gt_lin_r; order'. + } + intro n; induct n. + - intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. + assert (Ha' : a == 0) by (generalize (le_0_l a); order'). + rewrite Ha'. apply le_0_l. + - intros n IH a b Ha H. + assert (NEQ : 2 ~= 0) by order'. + rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). + apply add_le_mono. + + apply mul_le_mono_l. + apply IH. + * apply div_lt_upper_bound; trivial. now rewrite <- pow_succ_r'. + * rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2. + now rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l. + + rewrite <- 2 bit0_mod. + apply bits_inj_iff in H. specialize (H 0). + rewrite ldiff_spec, bits_0 in H. + destruct a.[0], b.[0]; try discriminate; simpl; order'. + Qed. + + (** Subtraction can be a ldiff when the opposite ldiff is null. *) + + Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> + a-b == ldiff a b. + Proof. + intros a b H. + apply add_cancel_r with b. + rewrite sub_add. + - symmetry. + rewrite add_nocarry_lxor. + + bitwise as m. + apply bits_inj_iff in H. specialize (H m). + rewrite ldiff_spec, bits_0 in H. + now destruct a.[m], b.[m]. + + apply land_ldiff. + - now apply ldiff_le. + Qed. + + (** We can express lnot in term of subtraction *) + + Lemma add_lnot_diag_low : forall a n, log2 a < n -> + a + lnot a n == ones n. + Proof. + intros a n H. + assert (H' := land_lnot_diag_low a n H). + rewrite add_nocarry_lxor, lxor_lor by trivial. + now apply lor_lnot_diag_low. + Qed. + + Lemma lnot_sub_low : forall a n, log2 a < n -> + lnot a n == ones n - a. + Proof. + intros a n H. + now rewrite <- (add_lnot_diag_low a n H), add_comm, add_sub. + Qed. + + (** Adding numbers with no common bits cannot lead to a much bigger number *) + + Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> + a < 2^n -> b < 2^n -> a+b < 2^n. + Proof. + intros a b n H Ha Hb. + rewrite add_nocarry_lxor by trivial. + apply div_small_iff. { order_nz. } + rewrite <- shiftr_div_pow2, shiftr_lxor, !shiftr_div_pow2. + rewrite 2 div_small by trivial. + apply lxor_0_l. + Qed. + + Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 -> + a mod 2^n + b mod 2^n < 2^n. + Proof. + intros a b n H. + apply add_nocarry_lt_pow2. + - bitwise as m. + destruct (le_gt_cases n m). + + now rewrite mod_pow2_bits_high. + + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. + - apply mod_upper_bound; order_nz. + - apply mod_upper_bound; order_nz. + Qed. End NBitsProp. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index bd886fbf2b..feb298ddb8 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -20,435 +20,435 @@ From Stdlib Require Export NStrongRec. just via the use of a [recursion] function. *) Module NdefOpsProp (Import N : NAxiomsRecSig'). -Include NStrongRecProp N. - -(** Nullity Test *) - -Definition if_zero (A : Type) (a b : A) (n : N.t) : A := - recursion a (fun _ _ => b) n. - -Arguments if_zero [A] a b n. - -#[global] -Instance if_zero_wd (A : Type) : - Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A). -Proof. -unfold if_zero. (* TODO : solve_proper : SLOW + BUG *) -f_equiv'. -Qed. - -Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a. -Proof. -unfold if_zero; intros; now rewrite recursion_0. -Qed. - -Theorem if_zero_succ : - forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b. -Proof. -intros; unfold if_zero. -now rewrite recursion_succ. -Qed. - -(*****************************************************) -(** Addition *) - -Definition def_add (x y : N.t) := recursion y (fun _ => S) x. - -#[local] Infix "+++" := def_add (at level 50, left associativity). - -#[global] -Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add. -Proof. -unfold def_add. f_equiv'. -Qed. - -Theorem def_add_0_l : forall y, 0 +++ y == y. -Proof. -intro y. unfold def_add. now rewrite recursion_0. -Qed. - -Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y). -Proof. -intros x y; unfold def_add. -rewrite recursion_succ; f_equiv'. -Qed. - -Theorem def_add_add : forall n m, n +++ m == n + m. -Proof. -intros n m; induct n. -- now rewrite def_add_0_l, add_0_l. -- intros n H. now rewrite def_add_succ_l, add_succ_l, H. -Qed. - -(*****************************************************) -(** Multiplication *) - -Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y. - -#[local] Infix "**" := def_mul (at level 40, left associativity). - -#[global] -Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul. -Proof. -unfold def_mul. (* TODO : solve_proper SLOW + BUG *) -f_equiv'. -Qed. - -Theorem def_mul_0_r : forall x, x ** 0 == 0. -Proof. -intro. unfold def_mul. now rewrite recursion_0. -Qed. - -Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x. -Proof. -intros x y; unfold def_mul. -rewrite recursion_succ; auto with *. -f_equiv'. -Qed. - -Theorem def_mul_mul : forall n m, n ** m == n * m. -Proof. -intros n m; induct m. -- now rewrite def_mul_0_r, mul_0_r. -- intros m IH; now rewrite def_mul_succ_r, mul_succ_r, def_add_add, IH. -Qed. - -(*****************************************************) -(** Order *) - -Definition ltb (m : N.t) : N.t -> bool := -recursion - (if_zero false true) - (fun _ f n => recursion false (fun n' _ => f n') n) - m. - -#[local] Infix "<<" := ltb (at level 70, no associativity). - -#[global] -Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb. -Proof. -unfold ltb. f_equiv'. -Qed. - -Theorem ltb_base : forall n, (0 << n) = if_zero false true n. -Proof. -intro n; unfold ltb; now rewrite recursion_0. -Qed. - -Theorem ltb_step : - forall m n, (S m << n) = recursion false (fun n' _ => m << n') n. -Proof. -intros m n; unfold ltb at 1. -f_equiv. -rewrite recursion_succ; f_equiv'. -Qed. - -(* Above, we rewrite applications of function. Is it possible to rewrite + Include NStrongRecProp N. + + (** Nullity Test *) + + Definition if_zero (A : Type) (a b : A) (n : N.t) : A := + recursion a (fun _ _ => b) n. + + Arguments if_zero [A] a b n. + + #[global] + Instance if_zero_wd (A : Type) : + Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A). + Proof. + unfold if_zero. (* TODO : solve_proper : SLOW + BUG *) + f_equiv'. + Qed. + + Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a. + Proof. + unfold if_zero; intros; now rewrite recursion_0. + Qed. + + Theorem if_zero_succ : + forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b. + Proof. + intros; unfold if_zero. + now rewrite recursion_succ. + Qed. + + (*****************************************************) + (** Addition *) + + Definition def_add (x y : N.t) := recursion y (fun _ => S) x. + + #[local] Infix "+++" := def_add (at level 50, left associativity). + + #[global] + Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add. + Proof. + unfold def_add. f_equiv'. + Qed. + + Theorem def_add_0_l : forall y, 0 +++ y == y. + Proof. + intro y. unfold def_add. now rewrite recursion_0. + Qed. + + Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y). + Proof. + intros x y; unfold def_add. + rewrite recursion_succ; f_equiv'. + Qed. + + Theorem def_add_add : forall n m, n +++ m == n + m. + Proof. + intros n m; induct n. + - now rewrite def_add_0_l, add_0_l. + - intros n H. now rewrite def_add_succ_l, add_succ_l, H. + Qed. + + (*****************************************************) + (** Multiplication *) + + Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y. + + #[local] Infix "**" := def_mul (at level 40, left associativity). + + #[global] + Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul. + Proof. + unfold def_mul. (* TODO : solve_proper SLOW + BUG *) + f_equiv'. + Qed. + + Theorem def_mul_0_r : forall x, x ** 0 == 0. + Proof. + intro. unfold def_mul. now rewrite recursion_0. + Qed. + + Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x. + Proof. + intros x y; unfold def_mul. + rewrite recursion_succ; auto with *. + f_equiv'. + Qed. + + Theorem def_mul_mul : forall n m, n ** m == n * m. + Proof. + intros n m; induct m. + - now rewrite def_mul_0_r, mul_0_r. + - intros m IH; now rewrite def_mul_succ_r, mul_succ_r, def_add_add, IH. + Qed. + + (*****************************************************) + (** Order *) + + Definition ltb (m : N.t) : N.t -> bool := + recursion + (if_zero false true) + (fun _ f n => recursion false (fun n' _ => f n') n) + m. + + #[local] Infix "<<" := ltb (at level 70, no associativity). + + #[global] + Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb. + Proof. + unfold ltb. f_equiv'. + Qed. + + Theorem ltb_base : forall n, (0 << n) = if_zero false true n. + Proof. + intro n; unfold ltb; now rewrite recursion_0. + Qed. + + Theorem ltb_step : + forall m n, (S m << n) = recursion false (fun n' _ => m << n') n. + Proof. + intros m n; unfold ltb at 1. + f_equiv. + rewrite recursion_succ; f_equiv'. + Qed. + + (* Above, we rewrite applications of function. Is it possible to rewrite functions themselves, i.e., rewrite (recursion lt_base lt_step (S n)) to lt_step n (recursion lt_base lt_step n)? *) -Theorem ltb_0 : forall n, (n << 0) = false. -Proof. -cases n. -- rewrite ltb_base; now rewrite if_zero_0. -- intro n; rewrite ltb_step. now rewrite recursion_0. -Qed. - -Theorem ltb_0_succ : forall n, (0 << S n) = true. -Proof. -intro n; rewrite ltb_base; now rewrite if_zero_succ. -Qed. - -Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m). -Proof. -intros n m. -rewrite ltb_step. rewrite recursion_succ; f_equiv'. -Qed. - -Theorem ltb_lt : forall n m, (n << m) = true <-> n < m. -Proof. -double_induct n m. -- cases m. - + rewrite ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. - + intro n. rewrite ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. -- intro n. rewrite ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. -- intros n m. rewrite succ_ltb_mono. now rewrite <- succ_lt_mono. -Qed. - -Theorem ltb_ge : forall n m, (n << m) = false <-> n >= m. -Proof. -intros. rewrite <- not_true_iff_false, ltb_lt. apply nlt_ge. -Qed. - -(*****************************************************) -(** Even *) - -Definition even (x : N.t) := recursion true (fun _ p => negb p) x. - -#[global] -Instance even_wd : Proper (N.eq==>Logic.eq) even. -Proof. -unfold even. f_equiv'. -Qed. - -Theorem even_0 : even 0 = true. -Proof. -unfold even. -now rewrite recursion_0. -Qed. - -Theorem even_succ : forall x, even (S x) = negb (even x). -Proof. -unfold even. -intro x; rewrite recursion_succ; f_equiv'. -Qed. - -(*****************************************************) -(** Division by 2 *) - -Definition half_aux (x : N.t) : N.t * N.t := - recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x. - -Definition half (x : N.t) := snd (half_aux x). - -#[global] -Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux. -Proof. -intros x x' Hx. unfold half_aux. -f_equiv; trivial. -intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *. -rewrite Hu, Hv; auto with *. -Qed. - -#[global] -Instance half_wd : Proper (N.eq==>N.eq) half. -Proof. -unfold half. f_equiv'. -Qed. - -Lemma half_aux_0 : half_aux 0 = (0,0). -Proof. -unfold half_aux. rewrite recursion_0; auto. -Qed. - -Lemma half_aux_succ : forall x, - half_aux (S x) = (S (snd (half_aux x)), fst (half_aux x)). -Proof. -intros. -remember (half_aux x) as h. -destruct h as (f,s); simpl in *. -unfold half_aux in *. -rewrite recursion_succ, <- Heqh; simpl; f_equiv'. -Qed. - -Theorem half_aux_spec : forall n, - n == fst (half_aux n) + snd (half_aux n). -Proof. -apply induction. -- intros x x' Hx. setoid_rewrite Hx; auto with *. -- rewrite half_aux_0; simpl; rewrite add_0_l; auto with *. -- intros. - rewrite half_aux_succ. simpl. - rewrite add_succ_l, add_comm; auto. - now f_equiv. -Qed. - -Theorem half_aux_spec2 : forall n, - fst (half_aux n) == snd (half_aux n) \/ - fst (half_aux n) == S (snd (half_aux n)). -Proof. -apply induction. -- intros x x' Hx. setoid_rewrite Hx; auto with *. -- rewrite half_aux_0; simpl. auto with *. -- intros. - rewrite half_aux_succ; simpl. - destruct H; auto with *. - right; now f_equiv. -Qed. - -Theorem half_0 : half 0 == 0. -Proof. -unfold half. rewrite half_aux_0; simpl; auto with *. -Qed. - -Theorem half_1 : half 1 == 0. -Proof. -unfold half. rewrite one_succ, half_aux_succ, half_aux_0; simpl; auto with *. -Qed. - -Theorem half_double : forall n, - n == 2 * half n \/ n == 1 + 2 * half n. -Proof. -intros. unfold half. -nzsimpl'. -destruct (half_aux_spec2 n) as [H|H]; [left|right]. -- rewrite <- H at 1. apply half_aux_spec. -- rewrite <- add_succ_l. rewrite <- H at 1. apply half_aux_spec. -Qed. - -Theorem half_upper_bound : forall n, 2 * half n <= n. -Proof. -intros. -destruct (half_double n) as [E|E]; rewrite E at 2. -- apply le_refl. -- nzsimpl. - apply le_le_succ_r, le_refl. -Qed. - -Theorem half_lower_bound : forall n, n <= 1 + 2 * half n. -Proof. -intros. -destruct (half_double n) as [E|E]; rewrite E at 1. -- nzsimpl. - apply le_le_succ_r, le_refl. -- apply le_refl. -Qed. - -Theorem half_nz : forall n, 1 < n -> 0 < half n. -Proof. -intros n LT. -assert (LE : 0 <= half n) by apply le_0_l. -le_elim LE; auto. -destruct (half_double n) as [E|E]; - rewrite <- LE, mul_0_r, ?add_0_r in E; rewrite E in LT. -- order'. -- order. -Qed. - -Theorem half_decrease : forall n, 0 < n -> half n < n. -Proof. -intros n LT. -destruct (half_double n) as [E|E]; rewrite E at 2; nzsimpl'. -- rewrite <- add_0_l at 1. - rewrite <- add_lt_mono_r. - assert (LE : 0 <= half n) by apply le_0_l. - le_elim LE; auto. - rewrite <- LE, mul_0_r in E. rewrite E in LT. destruct (nlt_0_r _ LT). -- rewrite <- add_succ_l. - rewrite <- add_0_l at 1. - rewrite <- add_lt_mono_r. - apply lt_0_succ. -Qed. - - -(*****************************************************) -(** Power *) - -Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m. - -#[local] Infix "^^" := pow (at level 30, right associativity). - -#[global] -Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow. -Proof. -unfold pow. f_equiv'. -Qed. - -Lemma pow_0 : forall n, n^^0 == 1. -Proof. -intros. unfold pow. rewrite recursion_0. auto with *. -Qed. - -Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m). -Proof. -intros. unfold pow. rewrite recursion_succ; f_equiv'. -Qed. - - -(*****************************************************) -(** Logarithm for the base 2 *) - -Definition log (x : N.t) : N.t := -strong_rec 0 - (fun g x => - if x << 2 then 0 - else S (g (half x))) - x. - -#[global] -Instance log_prewd : - Proper ((N.eq==>N.eq)==>N.eq==>N.eq) - (fun g x => if x<<2 then 0 else S (g (half x))). -Proof. -intros g g' Hg n n' Hn. -rewrite Hn. -destruct (n' << 2); auto with *. -f_equiv. apply Hg. now f_equiv. -Qed. - -#[global] -Instance log_wd : Proper (N.eq==>N.eq) log. -Proof. -intros x x' Exx'. unfold log. -apply strong_rec_wd; f_equiv'. -Qed. - -Lemma log_good_step : forall n h1 h2, - (forall m, m < n -> h1 m == h2 m) -> - (if n << 2 then 0 else S (h1 (half n))) == - (if n << 2 then 0 else S (h2 (half n))). -Proof. -intros n h1 h2 E. -destruct (n<<2) eqn:H. -- auto with *. -- f_equiv. apply E, half_decrease. - rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. - order'. -Qed. -#[global] -Hint Resolve log_good_step : core. - -Theorem log_init : forall n, n < 2 -> log n == 0. -Proof. -intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. -replace (n << 2) with true; auto with *. -symmetry. now rewrite ltb_lt. -Qed. - -Theorem log_step : forall n, 2 <= n -> log n == S (log (half n)). -Proof. -intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. -replace (n << 2) with false; auto with *. -symmetry. rewrite <- not_true_iff_false, ltb_lt, nlt_ge; auto. -Qed. - -Theorem pow2_log : forall n, 0 < n -> half n < 2^^(log n) <= n. -Proof. -intro n; generalize (le_refl n). set (k:=n) at -2. clearbody k. -revert k. pattern n. apply induction; clear n. -- intros n n' Hn; setoid_rewrite Hn; auto with *. -- intros k Hk1 Hk2. - le_elim Hk1. - + destruct (nlt_0_r _ Hk1). - + rewrite Hk1 in Hk2. destruct (nlt_0_r _ Hk2). - -- intros n IH k Hk1 Hk2. - destruct (lt_ge_cases k 2) as [LT|LE]. - + (* base *) - rewrite log_init, pow_0 by auto. - rewrite <- le_succ_l, <- one_succ in Hk2. - le_elim Hk2. - * rewrite two_succ, <- nle_gt, le_succ_l in LT. destruct LT; auto. - * rewrite <- Hk2. - rewrite half_1; auto using lt_0_1, le_refl. - + (* step *) - rewrite log_step, pow_succ by auto. - rewrite two_succ, le_succ_l in LE. - destruct (IH (half k)) as (IH1,IH2). - * rewrite <- lt_succ_r. apply lt_le_trans with k; auto. - now apply half_decrease. - * apply half_nz; auto. - * set (K:=2^^log (half k)) in *; clearbody K. - split. - -- rewrite <- le_succ_l in IH1. - apply mul_le_mono_l with (p:=2) in IH1. - eapply lt_le_trans; eauto. - nzsimpl'. - rewrite lt_succ_r. - eapply le_trans; [ eapply half_lower_bound | ]. - nzsimpl'; apply le_refl. - -- eapply le_trans; [ | eapply half_upper_bound ]. - apply mul_le_mono_l; auto. -Qed. + Theorem ltb_0 : forall n, (n << 0) = false. + Proof. + cases n. + - rewrite ltb_base; now rewrite if_zero_0. + - intro n; rewrite ltb_step. now rewrite recursion_0. + Qed. + + Theorem ltb_0_succ : forall n, (0 << S n) = true. + Proof. + intro n; rewrite ltb_base; now rewrite if_zero_succ. + Qed. + + Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m). + Proof. + intros n m. + rewrite ltb_step. rewrite recursion_succ; f_equiv'. + Qed. + + Theorem ltb_lt : forall n m, (n << m) = true <-> n < m. + Proof. + double_induct n m. + - cases m. + + rewrite ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. + + intro n. rewrite ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. + - intro n. rewrite ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. + - intros n m. rewrite succ_ltb_mono. now rewrite <- succ_lt_mono. + Qed. + + Theorem ltb_ge : forall n m, (n << m) = false <-> n >= m. + Proof. + intros. rewrite <- not_true_iff_false, ltb_lt. apply nlt_ge. + Qed. + + (*****************************************************) + (** Even *) + + Definition even (x : N.t) := recursion true (fun _ p => negb p) x. + + #[global] + Instance even_wd : Proper (N.eq==>Logic.eq) even. + Proof. + unfold even. f_equiv'. + Qed. + + Theorem even_0 : even 0 = true. + Proof. + unfold even. + now rewrite recursion_0. + Qed. + + Theorem even_succ : forall x, even (S x) = negb (even x). + Proof. + unfold even. + intro x; rewrite recursion_succ; f_equiv'. + Qed. + + (*****************************************************) + (** Division by 2 *) + + Definition half_aux (x : N.t) : N.t * N.t := + recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x. + + Definition half (x : N.t) := snd (half_aux x). + + #[global] + Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux. + Proof. + intros x x' Hx. unfold half_aux. + f_equiv; trivial. + intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *. + rewrite Hu, Hv; auto with *. + Qed. + + #[global] + Instance half_wd : Proper (N.eq==>N.eq) half. + Proof. + unfold half. f_equiv'. + Qed. + + Lemma half_aux_0 : half_aux 0 = (0,0). + Proof. + unfold half_aux. rewrite recursion_0; auto. + Qed. + + Lemma half_aux_succ : forall x, + half_aux (S x) = (S (snd (half_aux x)), fst (half_aux x)). + Proof. + intros. + remember (half_aux x) as h. + destruct h as (f,s); simpl in *. + unfold half_aux in *. + rewrite recursion_succ, <- Heqh; simpl; f_equiv'. + Qed. + + Theorem half_aux_spec : forall n, + n == fst (half_aux n) + snd (half_aux n). + Proof. + apply induction. + - intros x x' Hx. setoid_rewrite Hx; auto with *. + - rewrite half_aux_0; simpl; rewrite add_0_l; auto with *. + - intros. + rewrite half_aux_succ. simpl. + rewrite add_succ_l, add_comm; auto. + now f_equiv. + Qed. + + Theorem half_aux_spec2 : forall n, + fst (half_aux n) == snd (half_aux n) \/ + fst (half_aux n) == S (snd (half_aux n)). + Proof. + apply induction. + - intros x x' Hx. setoid_rewrite Hx; auto with *. + - rewrite half_aux_0; simpl. auto with *. + - intros. + rewrite half_aux_succ; simpl. + destruct H; auto with *. + right; now f_equiv. + Qed. + + Theorem half_0 : half 0 == 0. + Proof. + unfold half. rewrite half_aux_0; simpl; auto with *. + Qed. + + Theorem half_1 : half 1 == 0. + Proof. + unfold half. rewrite one_succ, half_aux_succ, half_aux_0; simpl; auto with *. + Qed. + + Theorem half_double : forall n, + n == 2 * half n \/ n == 1 + 2 * half n. + Proof. + intros. unfold half. + nzsimpl'. + destruct (half_aux_spec2 n) as [H|H]; [left|right]. + - rewrite <- H at 1. apply half_aux_spec. + - rewrite <- add_succ_l. rewrite <- H at 1. apply half_aux_spec. + Qed. + + Theorem half_upper_bound : forall n, 2 * half n <= n. + Proof. + intros. + destruct (half_double n) as [E|E]; rewrite E at 2. + - apply le_refl. + - nzsimpl. + apply le_le_succ_r, le_refl. + Qed. + + Theorem half_lower_bound : forall n, n <= 1 + 2 * half n. + Proof. + intros. + destruct (half_double n) as [E|E]; rewrite E at 1. + - nzsimpl. + apply le_le_succ_r, le_refl. + - apply le_refl. + Qed. + + Theorem half_nz : forall n, 1 < n -> 0 < half n. + Proof. + intros n LT. + assert (LE : 0 <= half n) by apply le_0_l. + le_elim LE; auto. + destruct (half_double n) as [E|E]; + rewrite <- LE, mul_0_r, ?add_0_r in E; rewrite E in LT. + - order'. + - order. + Qed. + + Theorem half_decrease : forall n, 0 < n -> half n < n. + Proof. + intros n LT. + destruct (half_double n) as [E|E]; rewrite E at 2; nzsimpl'. + - rewrite <- add_0_l at 1. + rewrite <- add_lt_mono_r. + assert (LE : 0 <= half n) by apply le_0_l. + le_elim LE; auto. + rewrite <- LE, mul_0_r in E. rewrite E in LT. destruct (nlt_0_r _ LT). + - rewrite <- add_succ_l. + rewrite <- add_0_l at 1. + rewrite <- add_lt_mono_r. + apply lt_0_succ. + Qed. + + + (*****************************************************) + (** Power *) + + Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m. + + #[local] Infix "^^" := pow (at level 30, right associativity). + + #[global] + Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow. + Proof. + unfold pow. f_equiv'. + Qed. + + Lemma pow_0 : forall n, n^^0 == 1. + Proof. + intros. unfold pow. rewrite recursion_0. auto with *. + Qed. + + Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m). + Proof. + intros. unfold pow. rewrite recursion_succ; f_equiv'. + Qed. + + + (*****************************************************) + (** Logarithm for the base 2 *) + + Definition log (x : N.t) : N.t := + strong_rec 0 + (fun g x => + if x << 2 then 0 + else S (g (half x))) + x. + + #[global] + Instance log_prewd : + Proper ((N.eq==>N.eq)==>N.eq==>N.eq) + (fun g x => if x<<2 then 0 else S (g (half x))). + Proof. + intros g g' Hg n n' Hn. + rewrite Hn. + destruct (n' << 2); auto with *. + f_equiv. apply Hg. now f_equiv. + Qed. + + #[global] + Instance log_wd : Proper (N.eq==>N.eq) log. + Proof. + intros x x' Exx'. unfold log. + apply strong_rec_wd; f_equiv'. + Qed. + + Lemma log_good_step : forall n h1 h2, + (forall m, m < n -> h1 m == h2 m) -> + (if n << 2 then 0 else S (h1 (half n))) == + (if n << 2 then 0 else S (h2 (half n))). + Proof. + intros n h1 h2 E. + destruct (n<<2) eqn:H. + - auto with *. + - f_equiv. apply E, half_decrease. + rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. + order'. + Qed. + #[global] + Hint Resolve log_good_step : core. + + Theorem log_init : forall n, n < 2 -> log n == 0. + Proof. + intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. + replace (n << 2) with true; auto with *. + symmetry. now rewrite ltb_lt. + Qed. + + Theorem log_step : forall n, 2 <= n -> log n == S (log (half n)). + Proof. + intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. + replace (n << 2) with false; auto with *. + symmetry. rewrite <- not_true_iff_false, ltb_lt, nlt_ge; auto. + Qed. + + Theorem pow2_log : forall n, 0 < n -> half n < 2^^(log n) <= n. + Proof. + intro n; generalize (le_refl n). set (k:=n) at -2. clearbody k. + revert k. pattern n. apply induction; clear n. + - intros n n' Hn; setoid_rewrite Hn; auto with *. + - intros k Hk1 Hk2. + le_elim Hk1. + + destruct (nlt_0_r _ Hk1). + + rewrite Hk1 in Hk2. destruct (nlt_0_r _ Hk2). + + - intros n IH k Hk1 Hk2. + destruct (lt_ge_cases k 2) as [LT|LE]. + + (* base *) + rewrite log_init, pow_0 by auto. + rewrite <- le_succ_l, <- one_succ in Hk2. + le_elim Hk2. + * rewrite two_succ, <- nle_gt, le_succ_l in LT. destruct LT; auto. + * rewrite <- Hk2. + rewrite half_1; auto using lt_0_1, le_refl. + + (* step *) + rewrite log_step, pow_succ by auto. + rewrite two_succ, le_succ_l in LE. + destruct (IH (half k)) as (IH1,IH2). + * rewrite <- lt_succ_r. apply lt_le_trans with k; auto. + now apply half_decrease. + * apply half_nz; auto. + * set (K:=2^^log (half k)) in *; clearbody K. + split. + -- rewrite <- le_succ_l in IH1. + apply mul_le_mono_l with (p:=2) in IH1. + eapply lt_le_trans; eauto. + nzsimpl'. + rewrite lt_succ_r. + eapply le_trans; [ eapply half_lower_bound | ]. + nzsimpl'; apply le_refl. + -- eapply le_trans; [ | eapply half_upper_bound ]. + apply mul_le_mono_l; auto. + Qed. End NdefOpsProp. diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v index 935a435466..0f60d82569 100644 --- a/theories/Numbers/Natural/Abstract/NDiv.v +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -14,245 +14,245 @@ From Stdlib Require Import NAxioms NSub NZDiv. Module Type NDivProp (Import N : NAxiomsSig')(Import NP : NSubProp N). -(** We benefit from what already exists for NZ *) -Module Import Private_NZDiv := Nop <+ NZDivProp N N NP. + (** We benefit from what already exists for NZ *) + Module Import Private_NZDiv := Nop <+ NZDivProp N N NP. -Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l. + Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l. -(** Let's now state again theorems, but without useless hypothesis. *) + (** Let's now state again theorems, but without useless hypothesis. *) -Lemma mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. -Proof. intros. apply mod_bound_pos; auto'. Qed. + Lemma mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. + Proof. intros. apply mod_bound_pos; auto'. Qed. -(** Another formulation of the main equation *) + (** Another formulation of the main equation *) -Lemma mod_eq : - forall a b, b~=0 -> a mod b == a - b*(a/b). -Proof. -intros. -symmetry. apply add_sub_eq_l. symmetry. -now apply div_mod. -Qed. + Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). + Proof. + intros. + symmetry. apply add_sub_eq_l. symmetry. + now apply div_mod. + Qed. -(** Uniqueness theorems *) + (** Uniqueness theorems *) -Theorem div_mod_unique : - forall b q1 q2 r1 r2, r1 r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. intros b q1 q2 r1 r2 ? ? ?. apply div_mod_unique with b; auto'. Qed. + Theorem div_mod_unique : + forall b q1 q2 r1 r2, r1 r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. + Proof. intros b q1 q2 r1 r2 ? ? ?. apply div_mod_unique with b; auto'. Qed. -Theorem div_unique: - forall a b q r, r a == b*q + r -> q == a/b. -Proof. intros a b q r ? ?; apply div_unique with r; auto'. Qed. + Theorem div_unique: + forall a b q r, r a == b*q + r -> q == a/b. + Proof. intros a b q r ? ?; apply div_unique with r; auto'. Qed. -Theorem mod_unique: - forall a b q r, r a == b*q + r -> r == a mod b. -Proof. intros a b q r ? ?. apply mod_unique with q; auto'. Qed. + Theorem mod_unique: + forall a b q r, r a == b*q + r -> r == a mod b. + Proof. intros a b q r ? ?. apply mod_unique with q; auto'. Qed. -Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b. -Proof. intros. apply div_unique_exact; auto'. Qed. + Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b. + Proof. intros. apply div_unique_exact; auto'. Qed. -(** A division by itself returns 1 *) + (** A division by itself returns 1 *) -Lemma div_same : forall a, a~=0 -> a/a == 1. -Proof. intros. apply div_same; auto'. Qed. + Lemma div_same : forall a, a~=0 -> a/a == 1. + Proof. intros. apply div_same; auto'. Qed. -Lemma mod_same : forall a, a~=0 -> a mod a == 0. -Proof. intros. apply mod_same; auto'. Qed. + Lemma mod_same : forall a, a~=0 -> a mod a == 0. + Proof. intros. apply mod_same; auto'. Qed. -(** A division of a small number by a bigger one yields zero. *) + (** A division of a small number by a bigger one yields zero. *) -Theorem div_small: forall a b, a a/b == 0. -Proof. intros. apply div_small; auto'. Qed. + Theorem div_small: forall a b, a a/b == 0. + Proof. intros. apply div_small; auto'. Qed. -(** Same situation, in term of modulo: *) + (** Same situation, in term of modulo: *) -Theorem mod_small: forall a b, a a mod b == a. -Proof. intros. apply mod_small; auto'. Qed. + Theorem mod_small: forall a b, a a mod b == a. + Proof. intros. apply mod_small; auto'. Qed. -(** * Basic values of divisions and modulo. *) + (** * Basic values of divisions and modulo. *) -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. -Proof. intros. apply div_0_l; auto'. Qed. + Lemma div_0_l: forall a, a~=0 -> 0/a == 0. + Proof. intros. apply div_0_l; auto'. Qed. -Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. -Proof. intros. apply mod_0_l; auto'. Qed. + Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. + Proof. intros. apply mod_0_l; auto'. Qed. -Lemma div_1_r: forall a, a/1 == a. -Proof. intros. apply div_1_r; auto'. Qed. + Lemma div_1_r: forall a, a/1 == a. + Proof. intros. apply div_1_r; auto'. Qed. -Lemma mod_1_r: forall a, a mod 1 == 0. -Proof. intros. apply mod_1_r; auto'. Qed. + Lemma mod_1_r: forall a, a mod 1 == 0. + Proof. intros. apply mod_1_r; auto'. Qed. -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. exact div_1_l. Qed. + Lemma div_1_l: forall a, 1 1/a == 0. + Proof. exact div_1_l. Qed. -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. exact mod_1_l. Qed. + Lemma mod_1_l: forall a, 1 1 mod a == 1. + Proof. exact mod_1_l. Qed. -Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. -Proof. intros. apply div_mul; auto'. Qed. + Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. + Proof. intros. apply div_mul; auto'. Qed. -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. -Proof. intros. apply mod_mul; auto'. Qed. + Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. + Proof. intros. apply mod_mul; auto'. Qed. -(** * Order results about mod and div *) + (** * Order results about mod and div *) -(** A modulo cannot grow beyond its starting point. *) + (** A modulo cannot grow beyond its starting point. *) -Theorem mod_le: forall a b, b~=0 -> a mod b <= a. -Proof. intros. apply mod_le; auto'. Qed. + Theorem mod_le: forall a b, b~=0 -> a mod b <= a. + Proof. intros. apply mod_le; auto'. Qed. -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. exact div_str_pos. Qed. + Lemma div_str_pos : forall a b, 0 0 < a/b. + Proof. exact div_str_pos. Qed. -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a (a/b==0 <-> a (a mod b == a <-> a (a mod b == a <-> a (0 b<=a). -Proof. intros. apply div_str_pos_iff; auto'. Qed. + Lemma div_str_pos_iff : forall a b, b~=0 -> (0 b<=a). + Proof. intros. apply div_str_pos_iff; auto'. Qed. -(** As soon as the divisor is strictly greater than 1, + (** As soon as the divisor is strictly greater than 1, the division is strictly decreasing. *) -Lemma div_lt : forall a b, 0 1 a/b < a. -Proof. exact div_lt. Qed. + Lemma div_lt : forall a b, 0 1 a/b < a. + Proof. exact div_lt. Qed. -(** [le] is compatible with a positive division. *) + (** [le] is compatible with a positive division. *) -Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c. -Proof. intros. apply div_le_mono; auto'. Qed. + Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c. + Proof. intros. apply div_le_mono; auto'. Qed. -Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. -Proof. intros. apply mul_div_le; auto'. Qed. + Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. + Proof. intros. apply mul_div_le; auto'. Qed. -Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)). -Proof. intros; apply mul_succ_div_gt; auto'. Qed. + Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)). + Proof. intros; apply mul_succ_div_gt; auto'. Qed. -(** The previous inequality is exact iff the modulo is zero. *) + (** The previous inequality is exact iff the modulo is zero. *) -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). -Proof. intros. apply div_exact; auto'. Qed. + Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). + Proof. intros. apply div_exact; auto'. Qed. -(** Some additional inequalities about div. *) + (** Some additional inequalities about div. *) -Theorem div_lt_upper_bound: - forall a b q, b~=0 -> a < b*q -> a/b < q. -Proof. intros. apply div_lt_upper_bound; auto'. Qed. + Theorem div_lt_upper_bound: + forall a b q, b~=0 -> a < b*q -> a/b < q. + Proof. intros. apply div_lt_upper_bound; auto'. Qed. -Theorem div_le_upper_bound: - forall a b q, b~=0 -> a <= b*q -> a/b <= q. -Proof. intros; apply div_le_upper_bound; auto'. Qed. + Theorem div_le_upper_bound: + forall a b q, b~=0 -> a <= b*q -> a/b <= q. + Proof. intros; apply div_le_upper_bound; auto'. Qed. -Theorem div_le_lower_bound: - forall a b q, b~=0 -> b*q <= a -> q <= a/b. -Proof. intros; apply div_le_lower_bound; auto'. Qed. + Theorem div_le_lower_bound: + forall a b q, b~=0 -> b*q <= a -> q <= a/b. + Proof. intros; apply div_le_lower_bound; auto'. Qed. -(** A division respects opposite monotonicity for the divisor *) + (** A division respects opposite monotonicity for the divisor *) -Lemma div_le_compat_l: forall p q r, 0 p/r <= p/q. -Proof. intros. apply div_le_compat_l;[auto' | auto]. Qed. + Lemma div_le_compat_l: forall p q r, 0 p/r <= p/q. + Proof. intros. apply div_le_compat_l;[auto' | auto]. Qed. -(** * Relations between usual operations and mod and div *) + (** * Relations between usual operations and mod and div *) -Lemma mod_add : forall a b c, c~=0 -> - (a + b * c) mod c == a mod c. -Proof. intros. apply mod_add; auto'. Qed. + Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. + Proof. intros. apply mod_add; auto'. Qed. -Lemma div_add : forall a b c, c~=0 -> - (a + b * c) / c == a / c + b. -Proof. intros. apply div_add; auto'. Qed. + Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. + Proof. intros. apply div_add; auto'. Qed. -Lemma div_add_l: forall a b c, b~=0 -> - (a * b + c) / b == a + c / b. -Proof. intros. apply div_add_l; auto'. Qed. + Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. + Proof. intros. apply div_add_l; auto'. Qed. -(** Cancellations. *) + (** Cancellations. *) -Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)/(b*c) == a/b. -Proof. intros. apply div_mul_cancel_r; auto'. Qed. + Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. + Proof. intros. apply div_mul_cancel_r; auto'. Qed. -Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)/(c*b) == a/b. -Proof. intros. apply div_mul_cancel_l; auto'. Qed. + Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. + Proof. intros. apply div_mul_cancel_l; auto'. Qed. -Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) mod (b*c) == (a mod b) * c. -Proof. intros. apply mul_mod_distr_r; auto'. Qed. + Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. + Proof. intros. apply mul_mod_distr_r; auto'. Qed. -Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) mod (c*b) == c * (a mod b). -Proof. intros. apply mul_mod_distr_l; auto'. Qed. + Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). + Proof. intros. apply mul_mod_distr_l; auto'. Qed. -(** Operations modulo. *) + (** Operations modulo. *) -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. -Proof. intros. apply mod_mod; auto'. Qed. + Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. + Proof. intros. apply mod_mod; auto'. Qed. -Lemma mul_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. -Proof. intros. apply mul_mod_idemp_l; auto'. Qed. + Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. + Proof. intros. apply mul_mod_idemp_l; auto'. Qed. -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. -Proof. intros. apply mul_mod_idemp_r; auto'. Qed. + Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. + Proof. intros. apply mul_mod_idemp_r; auto'. Qed. -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. intros. apply mul_mod; auto'. Qed. + Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. + Proof. intros. apply mul_mod; auto'. Qed. -Lemma add_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)+b) mod n == (a+b) mod n. -Proof. intros. apply add_mod_idemp_l; auto'. Qed. + Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. + Proof. intros. apply add_mod_idemp_l; auto'. Qed. -Lemma add_mod_idemp_r : forall a b n, n~=0 -> - (a+(b mod n)) mod n == (a+b) mod n. -Proof. intros. apply add_mod_idemp_r; auto'. Qed. + Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. + Proof. intros. apply add_mod_idemp_r; auto'. Qed. -Theorem add_mod: forall a b n, n~=0 -> - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. intros. apply add_mod; auto'. Qed. + Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. + Proof. intros. apply add_mod; auto'. Qed. -Lemma div_div : forall a b c, b~=0 -> c~=0 -> - (a/b)/c == a/(b*c). -Proof. intros. apply div_div; auto'. Qed. + Lemma div_div : forall a b c, b~=0 -> c~=0 -> + (a/b)/c == a/(b*c). + Proof. intros. apply div_div; auto'. Qed. -Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. intros. apply mod_mul_r; auto'. Qed. + Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> + a mod (b*c) == a mod b + b*((a/b) mod c). + Proof. intros. apply mod_mul_r; auto'. Qed. -Lemma add_mul_mod_distr_l : forall a b c d, b~=0 -> 0<=d - (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. - intros a b c d Hb ?. apply add_mul_mod_distr_l. - - apply le_0_l. - - assert (H'b := le_0_l b). order. - - assumption. -Qed. + Lemma add_mul_mod_distr_l : forall a b c d, b~=0 -> 0<=d + (c*a+d) mod (c*b) == c*(a mod b)+d. + Proof. + intros a b c d Hb ?. apply add_mul_mod_distr_l. + - apply le_0_l. + - assert (H'b := le_0_l b). order. + - assumption. + Qed. -Lemma add_mul_mod_distr_r : forall a b c d, b~=0 -> 0<=d - (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. - intros a b c d ? ?. now rewrite !(mul_comm _ c), add_mul_mod_distr_l. -Qed. + Lemma add_mul_mod_distr_r : forall a b c d, b~=0 -> 0<=d + (a*c+d) mod (b*c) == (a mod b)*c+d. + Proof. + intros a b c d ? ?. now rewrite !(mul_comm _ c), add_mul_mod_distr_l. + Qed. -(** A last inequality: *) + (** A last inequality: *) -Theorem div_mul_le: - forall a b c, b~=0 -> c*(a/b) <= (c*a)/b. -Proof. intros. apply div_mul_le; auto'. Qed. + Theorem div_mul_le: + forall a b c, b~=0 -> c*(a/b) <= (c*a)/b. + Proof. intros. apply div_mul_le; auto'. Qed. -(** mod is related to divisibility *) + (** mod is related to divisibility *) -Lemma mod_divides : forall a b, b~=0 -> - (a mod b == 0 <-> exists c, a == b*c). -Proof. intros. apply mod_divides; auto'. Qed. + Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> exists c, a == b*c). + Proof. intros. apply mod_divides; auto'. Qed. End NDivProp. diff --git a/theories/Numbers/Natural/Abstract/NDiv0.v b/theories/Numbers/Natural/Abstract/NDiv0.v index b943c4b16e..c87d1c8323 100644 --- a/theories/Numbers/Natural/Abstract/NDiv0.v +++ b/theories/Numbers/Natural/Abstract/NDiv0.v @@ -11,330 +11,330 @@ From Stdlib Require Import NAxioms NSub NDiv. Module Type NDivPropPrivate (N : NAxiomsSig') (NP : NSubProp N). -Declare Module Private_NDivProp : NDivProp N NP. + Declare Module Private_NDivProp : NDivProp N NP. End NDivPropPrivate. (** Properties of Euclidean Division with a / 0 == 0 and a mod 0 == a *) Module Type NDivProp0 - (Import N : NAxiomsSig') - (Import NP : NSubProp N) - (Import D0 : NZDivSpec0 N N N) - (Import P : NDivPropPrivate N NP). - -Import Private_NDivProp. - -(** Let's now state again theorems, but without useless hypothesis. *) - -Module Div0. - -Lemma div_0_l : forall a, 0/a == 0. -Proof. - intros a. destruct (eq_decidable a 0) as [->|Ha]. - - apply div_0_r. - - now apply div_0_l. -Qed. - -Lemma mod_0_l : forall a, 0 mod a == 0. -Proof. - intros a. destruct (eq_decidable a 0) as [->|Hb]. - - apply mod_0_r. - - now apply mod_0_l. -Qed. - -#[local] Hint Rewrite div_0_l mod_0_l div_0_r mod_0_r : nz. - -Lemma div_mod : forall a b, a == b*(a/b) + (a mod b). -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mod. -Qed. - -Lemma mod_eq : forall a b, a mod b == a - b*(a/b). -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply mod_eq. -Qed. - -Lemma mod_same : forall a, a mod a == 0. -Proof. - intros a. destruct (eq_decidable a 0) as [->|Ha]. - - now nzsimpl. - - now apply mod_same. -Qed. - -Lemma mod_mul : forall a b, (a*b) mod b == 0. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply mod_mul. -Qed. - -Lemma mod_le : forall a b, a mod b <= a. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply mod_le. -Qed. - -Lemma div_le_mono : forall a b c, a<=b -> a/c <= b/c. -Proof. - intros a b c. destruct (eq_decidable c 0) as [->|Hc]. - - now nzsimpl. - - now apply div_le_mono. -Qed. - -Lemma mul_div_le : forall a b, b*(a/b) <= a. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - nzsimpl. apply le_0_l. - - now apply mul_div_le. -Qed. - -Lemma div_exact : forall a b, (a == b*(a/b) <-> a mod b == 0). -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_exact. -Qed. - -Lemma div_lt_upper_bound : forall a b q, a < b*q -> a/b < q. -Proof. - intros a b q. destruct (eq_decidable b 0) as [->|Hb]. - - nzsimpl. now intros ?%nlt_0_r. - - now apply div_lt_upper_bound. -Qed. - -Lemma div_le_upper_bound : forall a b q, a <= b*q -> a/b <= q. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - nzsimpl. intros. apply le_0_l. - - now apply div_le_upper_bound. -Qed. - -Lemma mod_add : forall a b c, (a + b * c) mod c == a mod c. -Proof. - intros a b c. destruct (eq_decidable c 0) as [->|Hc]. - - now nzsimpl. - - now apply mod_add. -Qed. - -Lemma div_mul_cancel_r : forall a b c, c~=0 -> (a*c)/(b*c) == a/b. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mul_cancel_r. -Qed. - -Lemma div_mul_cancel_l : forall a b c, c~=0 -> (c*a)/(c*b) == a/b. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mul_cancel_l. -Qed. - -Lemma mul_mod_distr_r : forall a b c, (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + now nzsimpl. - + now apply mul_mod_distr_r. -Qed. - -Lemma mul_mod_distr_l : forall a b c, (c*a) mod (c*b) == c * (a mod b). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + now nzsimpl. - + now apply mul_mod_distr_l. -Qed. - -Lemma mod_mod : forall a n, (a mod n) mod n == a mod n. -Proof. - intros a n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mod_mod. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mul_mod_idemp_l. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mul_mod_idemp_r. -Qed. - -Lemma mul_mod : forall a b n, (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mul_mod. -Qed. - -Lemma add_mod_idemp_l : forall a b n, ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply add_mod_idemp_l. -Qed. - -Lemma add_mod_idemp_r : forall a b n, (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply add_mod_idemp_r. -Qed. - -Lemma add_mod : forall a b n, (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply add_mod. -Qed. - -Lemma div_div : forall a b c, (a/b)/c == a/(b*c). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + now nzsimpl. - + now apply div_div. -Qed. - -Lemma mod_mul_r : forall a b c, a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + nzsimpl. rewrite add_comm. apply div_mod. - + now apply mod_mul_r. -Qed. - -Lemma add_mul_mod_distr_l : forall a b c d, d (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. - intros a b c d ?. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - apply add_mul_mod_distr_l; intuition auto using le_0_l. -Qed. - -Lemma add_mul_mod_distr_r : forall a b c d, d (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. - intros a b c d ?. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - apply add_mul_mod_distr_r; intuition auto using le_0_l. -Qed. - -Lemma div_mul_le : forall a b c, c*(a/b) <= (c*a)/b. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mul_le. -Qed. - -Lemma mod_divides : forall a b, (a mod b == 0 <-> exists c, a == b*c). -Proof. - intros a b. destruct (eq_decidable b 0) as [Hb|Hb]. - - split. - + intros Hab. exists 0. revert Hab. rewrite Hb. now nzsimpl. - + intros [c Hc]. revert Hc. rewrite Hb. now nzsimpl. - - now apply mod_divides. -Qed. - -End Div0. - -(** Unchanged theorems. *) - -Definition mod_upper_bound := mod_upper_bound. -Definition div_mod_unique := div_mod_unique. -Definition div_unique := div_unique. -Definition mod_unique := mod_unique. -Definition div_unique_exact := div_unique_exact. -Definition div_same := div_same. -Definition div_small := div_small. -Definition mod_small := mod_small. -Definition div_1_r := div_1_r. -Definition mod_1_r := mod_1_r. -Definition div_1_l := div_1_l. -Definition mod_1_l := mod_1_l. -Definition div_mul := div_mul. -Definition div_str_pos := div_str_pos. -Definition div_small_iff := div_small_iff. -Definition mod_small_iff := mod_small_iff. -Definition div_str_pos_iff := div_str_pos_iff. -Definition div_lt := div_lt. -Definition mul_succ_div_gt := mul_succ_div_gt. -Definition div_le_lower_bound := div_le_lower_bound. -Definition div_le_compat_l := div_le_compat_l. -Definition div_add := div_add. -Definition div_add_l := div_add_l. - -(** Deprecation statements. + (Import N : NAxiomsSig') + (Import NP : NSubProp N) + (Import D0 : NZDivSpec0 N N N) + (Import P : NDivPropPrivate N NP). + + Import Private_NDivProp. + + (** Let's now state again theorems, but without useless hypothesis. *) + + Module Div0. + + Lemma div_0_l : forall a, 0/a == 0. + Proof. + intros a. destruct (eq_decidable a 0) as [->|Ha]. + - apply div_0_r. + - now apply div_0_l. + Qed. + + Lemma mod_0_l : forall a, 0 mod a == 0. + Proof. + intros a. destruct (eq_decidable a 0) as [->|Hb]. + - apply mod_0_r. + - now apply mod_0_l. + Qed. + + #[local] Hint Rewrite div_0_l mod_0_l div_0_r mod_0_r : nz. + + Lemma div_mod : forall a b, a == b*(a/b) + (a mod b). + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply div_mod. + Qed. + + Lemma mod_eq : forall a b, a mod b == a - b*(a/b). + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply mod_eq. + Qed. + + Lemma mod_same : forall a, a mod a == 0. + Proof. + intros a. destruct (eq_decidable a 0) as [->|Ha]. + - now nzsimpl. + - now apply mod_same. + Qed. + + Lemma mod_mul : forall a b, (a*b) mod b == 0. + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply mod_mul. + Qed. + + Lemma mod_le : forall a b, a mod b <= a. + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply mod_le. + Qed. + + Lemma div_le_mono : forall a b c, a<=b -> a/c <= b/c. + Proof. + intros a b c. destruct (eq_decidable c 0) as [->|Hc]. + - now nzsimpl. + - now apply div_le_mono. + Qed. + + Lemma mul_div_le : forall a b, b*(a/b) <= a. + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - nzsimpl. apply le_0_l. + - now apply mul_div_le. + Qed. + + Lemma div_exact : forall a b, (a == b*(a/b) <-> a mod b == 0). + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply div_exact. + Qed. + + Lemma div_lt_upper_bound : forall a b q, a < b*q -> a/b < q. + Proof. + intros a b q. destruct (eq_decidable b 0) as [->|Hb]. + - nzsimpl. now intros ?%nlt_0_r. + - now apply div_lt_upper_bound. + Qed. + + Lemma div_le_upper_bound : forall a b q, a <= b*q -> a/b <= q. + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - nzsimpl. intros. apply le_0_l. + - now apply div_le_upper_bound. + Qed. + + Lemma mod_add : forall a b c, (a + b * c) mod c == a mod c. + Proof. + intros a b c. destruct (eq_decidable c 0) as [->|Hc]. + - now nzsimpl. + - now apply mod_add. + Qed. + + Lemma div_mul_cancel_r : forall a b c, c~=0 -> (a*c)/(b*c) == a/b. + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply div_mul_cancel_r. + Qed. + + Lemma div_mul_cancel_l : forall a b c, c~=0 -> (c*a)/(c*b) == a/b. + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply div_mul_cancel_l. + Qed. + + Lemma mul_mod_distr_r : forall a b c, (a*c) mod (b*c) == (a mod b) * c. + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - destruct (eq_decidable c 0) as [->|Hc]. + + now nzsimpl. + + now apply mul_mod_distr_r. + Qed. + + Lemma mul_mod_distr_l : forall a b c, (c*a) mod (c*b) == c * (a mod b). + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - destruct (eq_decidable c 0) as [->|Hc]. + + now nzsimpl. + + now apply mul_mod_distr_l. + Qed. + + Lemma mod_mod : forall a n, (a mod n) mod n == a mod n. + Proof. + intros a n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply mod_mod. + Qed. + + Lemma mul_mod_idemp_l : forall a b n, ((a mod n)*b) mod n == (a*b) mod n. + Proof. + intros a b n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply mul_mod_idemp_l. + Qed. + + Lemma mul_mod_idemp_r : forall a b n, (a*(b mod n)) mod n == (a*b) mod n. + Proof. + intros a b n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply mul_mod_idemp_r. + Qed. + + Lemma mul_mod : forall a b n, (a * b) mod n == ((a mod n) * (b mod n)) mod n. + Proof. + intros a b n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply mul_mod. + Qed. + + Lemma add_mod_idemp_l : forall a b n, ((a mod n)+b) mod n == (a+b) mod n. + Proof. + intros a b n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply add_mod_idemp_l. + Qed. + + Lemma add_mod_idemp_r : forall a b n, (a+(b mod n)) mod n == (a+b) mod n. + Proof. + intros a b n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply add_mod_idemp_r. + Qed. + + Lemma add_mod : forall a b n, (a+b) mod n == (a mod n + b mod n) mod n. + Proof. + intros a b n. destruct (eq_decidable n 0) as [->|Hn]. + - now nzsimpl. + - now apply add_mod. + Qed. + + Lemma div_div : forall a b c, (a/b)/c == a/(b*c). + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - destruct (eq_decidable c 0) as [->|Hc]. + + now nzsimpl. + + now apply div_div. + Qed. + + Lemma mod_mul_r : forall a b c, a mod (b*c) == a mod b + b*((a/b) mod c). + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - destruct (eq_decidable c 0) as [->|Hc]. + + nzsimpl. rewrite add_comm. apply div_mod. + + now apply mod_mul_r. + Qed. + + Lemma add_mul_mod_distr_l : forall a b c d, d (c*a+d) mod (c*b) == c*(a mod b)+d. + Proof. + intros a b c d ?. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - apply add_mul_mod_distr_l; intuition auto using le_0_l. + Qed. + + Lemma add_mul_mod_distr_r : forall a b c d, d (a*c+d) mod (b*c) == (a mod b)*c+d. + Proof. + intros a b c d ?. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - apply add_mul_mod_distr_r; intuition auto using le_0_l. + Qed. + + Lemma div_mul_le : forall a b c, c*(a/b) <= (c*a)/b. + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply div_mul_le. + Qed. + + Lemma mod_divides : forall a b, (a mod b == 0 <-> exists c, a == b*c). + Proof. + intros a b. destruct (eq_decidable b 0) as [Hb|Hb]. + - split. + + intros Hab. exists 0. revert Hab. rewrite Hb. now nzsimpl. + + intros [c Hc]. revert Hc. rewrite Hb. now nzsimpl. + - now apply mod_divides. + Qed. + + End Div0. + + (** Unchanged theorems. *) + + Definition mod_upper_bound := mod_upper_bound. + Definition div_mod_unique := div_mod_unique. + Definition div_unique := div_unique. + Definition mod_unique := mod_unique. + Definition div_unique_exact := div_unique_exact. + Definition div_same := div_same. + Definition div_small := div_small. + Definition mod_small := mod_small. + Definition div_1_r := div_1_r. + Definition mod_1_r := mod_1_r. + Definition div_1_l := div_1_l. + Definition mod_1_l := mod_1_l. + Definition div_mul := div_mul. + Definition div_str_pos := div_str_pos. + Definition div_small_iff := div_small_iff. + Definition mod_small_iff := mod_small_iff. + Definition div_str_pos_iff := div_str_pos_iff. + Definition div_lt := div_lt. + Definition mul_succ_div_gt := mul_succ_div_gt. + Definition div_le_lower_bound := div_le_lower_bound. + Definition div_le_compat_l := div_le_compat_l. + Definition div_add := div_add. + Definition div_add_l := div_add_l. + + (** Deprecation statements. After deprecation phase, remove statements below in favor of Div0 statements. *) -#[deprecated(since="8.17",note="Use Div0.mod_eq instead.")] -Notation mod_eq := mod_eq (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_same instead.")] -Notation mod_same := mod_same (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_0_l instead.")] -Notation div_0_l := div_0_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_0_l instead.")] -Notation mod_0_l := mod_0_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_mul instead.")] -Notation mod_mul := mod_mul (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_le instead.")] -Notation mod_le := mod_le (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_le_mono instead.")] -Notation div_le_mono := div_le_mono (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_div_le instead.")] -Notation mul_div_le := mul_div_le (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_exact instead.")] -Notation div_exact := div_exact (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_lt_upper_bound instead.")] -Notation div_lt_upper_bound := div_lt_upper_bound (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_le_upper_bound instead.")] -Notation div_le_upper_bound := div_le_upper_bound (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_add instead.")] -Notation mod_add := mod_add (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_mul_cancel_r instead.")] -Notation div_mul_cancel_r := div_mul_cancel_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_mul_cancel_l instead.")] -Notation div_mul_cancel_l := div_mul_cancel_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_distr_r instead.")] -Notation mul_mod_distr_r := mul_mod_distr_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_distr_l instead.")] -Notation mul_mod_distr_l := mul_mod_distr_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_mod instead.")] -Notation mod_mod := mod_mod (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_idemp_l instead.")] -Notation mul_mod_idemp_l := mul_mod_idemp_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_idemp_r instead.")] -Notation mul_mod_idemp_r := mul_mod_idemp_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod instead.")] -Notation mul_mod := mul_mod (only parsing). -#[deprecated(since="8.17",note="Use Div0.add_mod_idemp_l instead.")] -Notation add_mod_idemp_l := add_mod_idemp_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.add_mod_idemp_r instead.")] -Notation add_mod_idemp_r := add_mod_idemp_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.add_mod instead.")] -Notation add_mod := add_mod (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_div instead.")] -Notation div_div := div_div (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_mul_r instead.")] -Notation mod_mul_r := mod_mul_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_mul_le instead.")] -Notation div_mul_le := div_mul_le (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_divides instead.")] -Notation mod_divides := mod_divides (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_eq instead.")] + Notation mod_eq := mod_eq (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_same instead.")] + Notation mod_same := mod_same (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_0_l instead.")] + Notation div_0_l := div_0_l (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_0_l instead.")] + Notation mod_0_l := mod_0_l (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_mul instead.")] + Notation mod_mul := mod_mul (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_le instead.")] + Notation mod_le := mod_le (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_le_mono instead.")] + Notation div_le_mono := div_le_mono (only parsing). + #[deprecated(since="8.17",note="Use Div0.mul_div_le instead.")] + Notation mul_div_le := mul_div_le (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_exact instead.")] + Notation div_exact := div_exact (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_lt_upper_bound instead.")] + Notation div_lt_upper_bound := div_lt_upper_bound (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_le_upper_bound instead.")] + Notation div_le_upper_bound := div_le_upper_bound (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_add instead.")] + Notation mod_add := mod_add (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_mul_cancel_r instead.")] + Notation div_mul_cancel_r := div_mul_cancel_r (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_mul_cancel_l instead.")] + Notation div_mul_cancel_l := div_mul_cancel_l (only parsing). + #[deprecated(since="8.17",note="Use Div0.mul_mod_distr_r instead.")] + Notation mul_mod_distr_r := mul_mod_distr_r (only parsing). + #[deprecated(since="8.17",note="Use Div0.mul_mod_distr_l instead.")] + Notation mul_mod_distr_l := mul_mod_distr_l (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_mod instead.")] + Notation mod_mod := mod_mod (only parsing). + #[deprecated(since="8.17",note="Use Div0.mul_mod_idemp_l instead.")] + Notation mul_mod_idemp_l := mul_mod_idemp_l (only parsing). + #[deprecated(since="8.17",note="Use Div0.mul_mod_idemp_r instead.")] + Notation mul_mod_idemp_r := mul_mod_idemp_r (only parsing). + #[deprecated(since="8.17",note="Use Div0.mul_mod instead.")] + Notation mul_mod := mul_mod (only parsing). + #[deprecated(since="8.17",note="Use Div0.add_mod_idemp_l instead.")] + Notation add_mod_idemp_l := add_mod_idemp_l (only parsing). + #[deprecated(since="8.17",note="Use Div0.add_mod_idemp_r instead.")] + Notation add_mod_idemp_r := add_mod_idemp_r (only parsing). + #[deprecated(since="8.17",note="Use Div0.add_mod instead.")] + Notation add_mod := add_mod (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_div instead.")] + Notation div_div := div_div (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_mul_r instead.")] + Notation mod_mul_r := mod_mul_r (only parsing). + #[deprecated(since="8.17",note="Use Div0.div_mul_le instead.")] + Notation div_mul_le := div_mul_le (only parsing). + #[deprecated(since="8.17",note="Use Div0.mod_divides instead.")] + Notation mod_divides := mod_divides (only parsing). End NDivProp0. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v index 0cf293c891..f0e424f4ea 100644 --- a/theories/Numbers/Natural/Abstract/NGcd.v +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -13,248 +13,248 @@ From Stdlib Require Import NAxioms NSub NZGcd. Module Type NGcdProp - (Import A : NAxiomsSig') - (Import B : NSubProp A). - -Module Import Private_NZGcdProp := NZGcdProp A A B. - -(** Properties of divide *) - -#[global] Instance divide_wd : Proper (eq==>eq==>iff) divide := divide_wd. -Definition divide_1_r n := divide_1_r_nonneg n (le_0_l n). -Definition divide_1_l := divide_1_l. -Definition divide_0_r := divide_0_r. -Definition divide_0_l := divide_0_l. -Definition divide_refl := divide_refl. -Definition divide_trans := divide_trans. -#[global] Instance divide_reflexive : Reflexive divide | 5 := divide_refl. -#[global] Instance divide_transitive : Transitive divide | 5 := divide_trans. -Definition divide_antisym n m := divide_antisym_nonneg n m (le_0_l n) (le_0_l m). -Definition mul_divide_mono_l := mul_divide_mono_l. -Definition mul_divide_mono_r := mul_divide_mono_r. -Definition mul_divide_cancel_l := mul_divide_cancel_l. -Definition mul_divide_cancel_r := mul_divide_cancel_r. -Definition divide_add_r := divide_add_r. -Definition divide_mul_l := divide_mul_l. -Definition divide_mul_r := divide_mul_r. -Definition divide_factor_l := divide_factor_l. -Definition divide_factor_r := divide_factor_r. -Definition divide_pos_le := divide_pos_le. - -(** Properties of gcd *) - -Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n). -Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n). -Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n). -Definition gcd_unique n m p := gcd_unique n m p (le_0_l p). -Definition gcd_unique_alt n m p := gcd_unique_alt n m p (le_0_l p). -Definition divide_gcd_iff n m := divide_gcd_iff n m (le_0_l n). -#[global] Instance gcd_wd : Proper (eq==>eq==>eq) gcd := gcd_wd. -Definition gcd_comm := gcd_comm. -Definition gcd_assoc := gcd_assoc. -Definition gcd_eq_0_l := gcd_eq_0_l. -Definition gcd_eq_0_r := gcd_eq_0_r. -Definition gcd_eq_0 := gcd_eq_0. -Definition gcd_mul_diag_l n m := gcd_mul_diag_l n m (le_0_l n). - -#[deprecated(since="8.17",note="Use divide_antisym instead.")] -Notation divide_antisym_nonneg := divide_antisym_nonneg (only parsing). -#[deprecated(since="8.17",note="Use gcd_unique instead.")] -Notation gcd_unique' n m p := gcd_unique (only parsing). -#[deprecated(since="8.17",note="Use gcd_unique_alt instead.")] -Notation gcd_unique_alt' := gcd_unique_alt. -#[deprecated(since="8.17",note="Use divide_gcd_iff instead.")] -Notation divide_gcd_iff' := divide_gcd_iff. - -Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). -Proof. - intros n m p (q,Hq) (r,Hr). - exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr. - now rewrite add_comm, add_sub. -Qed. - -Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). -Proof. - intros n m p H H'. - destruct (le_ge_cases m p) as [LE|LE]. - - apply sub_0_le in LE. rewrite LE. apply divide_0_r. - - apply divide_add_cancel_r with p; trivial. - now rewrite add_comm, sub_add. -Qed. - -Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. -Proof. - intros n m p. apply gcd_unique_alt. - intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. - - apply divide_add_r; trivial. now apply divide_mul_r. - - apply divide_add_cancel_r with (p*n); trivial. - + now apply divide_mul_r. - + now rewrite add_comm. -Qed. - -Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. -Proof. - intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. -Qed. - -Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m. -Proof. - intros n m H. symmetry. - rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r. -Qed. - -(** On natural numbers, we should use a particular form + (Import A : NAxiomsSig') + (Import B : NSubProp A). + + Module Import Private_NZGcdProp := NZGcdProp A A B. + + (** Properties of divide *) + + #[global] Instance divide_wd : Proper (eq==>eq==>iff) divide := divide_wd. + Definition divide_1_r n := divide_1_r_nonneg n (le_0_l n). + Definition divide_1_l := divide_1_l. + Definition divide_0_r := divide_0_r. + Definition divide_0_l := divide_0_l. + Definition divide_refl := divide_refl. + Definition divide_trans := divide_trans. + #[global] Instance divide_reflexive : Reflexive divide | 5 := divide_refl. + #[global] Instance divide_transitive : Transitive divide | 5 := divide_trans. + Definition divide_antisym n m := divide_antisym_nonneg n m (le_0_l n) (le_0_l m). + Definition mul_divide_mono_l := mul_divide_mono_l. + Definition mul_divide_mono_r := mul_divide_mono_r. + Definition mul_divide_cancel_l := mul_divide_cancel_l. + Definition mul_divide_cancel_r := mul_divide_cancel_r. + Definition divide_add_r := divide_add_r. + Definition divide_mul_l := divide_mul_l. + Definition divide_mul_r := divide_mul_r. + Definition divide_factor_l := divide_factor_l. + Definition divide_factor_r := divide_factor_r. + Definition divide_pos_le := divide_pos_le. + + (** Properties of gcd *) + + Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n). + Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n). + Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n). + Definition gcd_unique n m p := gcd_unique n m p (le_0_l p). + Definition gcd_unique_alt n m p := gcd_unique_alt n m p (le_0_l p). + Definition divide_gcd_iff n m := divide_gcd_iff n m (le_0_l n). + #[global] Instance gcd_wd : Proper (eq==>eq==>eq) gcd := gcd_wd. + Definition gcd_comm := gcd_comm. + Definition gcd_assoc := gcd_assoc. + Definition gcd_eq_0_l := gcd_eq_0_l. + Definition gcd_eq_0_r := gcd_eq_0_r. + Definition gcd_eq_0 := gcd_eq_0. + Definition gcd_mul_diag_l n m := gcd_mul_diag_l n m (le_0_l n). + + #[deprecated(since="8.17",note="Use divide_antisym instead.")] + Notation divide_antisym_nonneg := divide_antisym_nonneg (only parsing). + #[deprecated(since="8.17",note="Use gcd_unique instead.")] + Notation gcd_unique' n m p := gcd_unique (only parsing). + #[deprecated(since="8.17",note="Use gcd_unique_alt instead.")] + Notation gcd_unique_alt' := gcd_unique_alt. + #[deprecated(since="8.17",note="Use divide_gcd_iff instead.")] + Notation divide_gcd_iff' := divide_gcd_iff. + + Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). + Proof. + intros n m p (q,Hq) (r,Hr). + exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr. + now rewrite add_comm, add_sub. + Qed. + + Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). + Proof. + intros n m p H H'. + destruct (le_ge_cases m p) as [LE|LE]. + - apply sub_0_le in LE. rewrite LE. apply divide_0_r. + - apply divide_add_cancel_r with p; trivial. + now rewrite add_comm, sub_add. + Qed. + + Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. + Proof. + intros n m p. apply gcd_unique_alt. + intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. + - apply divide_add_r; trivial. now apply divide_mul_r. + - apply divide_add_cancel_r with (p*n); trivial. + + now apply divide_mul_r. + + now rewrite add_comm. + Qed. + + Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. + Proof. + intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. + Qed. + + Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m. + Proof. + intros n m H. symmetry. + rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r. + Qed. + + (** On natural numbers, we should use a particular form for the Bezout identity, since we don't have full subtraction. *) -Definition Bezout n m p := exists a b, a*n == p + b*m. - -#[global] -Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. -Proof. - unfold Bezout. intros x x' Hx y y' Hy z z' Hz. - setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. -Qed. - -Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. -Proof. - intros n m (q & r & H). - apply gcd_unique; trivial using divide_1_l, le_0_1. - intros p Hn Hm. - apply divide_add_cancel_r with (r*m). - - now apply divide_mul_r. - - rewrite add_comm, <- H. now apply divide_mul_r. -Qed. - -(** Bezout on natural numbers commutes *) - -Theorem bezout_comm : forall a b g, - b ~= 0 -> Bezout a b g -> Bezout b a g. -Proof. - intros a b g Hb [p [q Hpq]]. - destruct (eq_decidable a 0) as [Ha|Ha]. - { exists 0, 0. symmetry in Hpq. - rewrite Ha, mul_0_r in Hpq. - apply eq_add_0 in Hpq as [-> _]. - now nzsimpl. } - exists (a*(p+1)*(q+1)-q), (b*(p+1)*(q+1)-p). - enough (E' : (a*(p+1)*(q+1)-q+q)*b == (b*(p+1)*(q+1)-p+p)*a). - { rewrite (mul_add_distr_r _ _ a), (mul_add_distr_r _ _ b), Hpq in E'. - rewrite add_assoc, (add_comm _ g) in E'. - now apply add_cancel_r in E'. } - rewrite !sub_add. - - now rewrite !(mul_comm _ b), !mul_assoc, !(mul_comm _ a), !mul_assoc. - - rewrite <- mul_1_r at 1. apply mul_le_mono; [|apply le_add_l]. - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_r]. - rewrite one_succ. apply le_succ_l. assert (H := le_0_l b). order. - - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_r]. - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_l]. - rewrite one_succ. apply le_succ_l. assert (H := le_0_l a). order. -Qed. - -Lemma gcd_bezout_pos : forall n m, 0 < n -> Bezout n m (gcd n m). -Proof. - enough (H : forall nm, 0 < fst nm -> Bezout (fst nm) (snd nm) (gcd (fst nm) (snd nm))). - { intros n m. apply (H (n, m)). } - intros nm. - induction nm as [[n m] IH] using (measure_induction _ (fun '(n, m) => n + m)). - enough (H : forall n' m', n+m == n'+m' -> 0 Bezout n' m' (gcd n' m')). - { cbn. intros ?. destruct (lt_trichotomy n m) as [Hnm|[Hnm|Hnm]]. - - now apply H. - - exists 1, 0. now rewrite Hnm, mul_1_l, mul_0_l, add_0_r, gcd_diag. - - destruct (eq_0_gt_0_cases m) as [->|?]. - + exists 1, 0. now rewrite gcd_0_r, mul_1_l, mul_0_l, add_0_r. - + apply bezout_comm; [order|]. - rewrite gcd_comm. now apply H; [apply add_comm|]. } - intros n' m' E' [Hn' Hn'm']. - assert (Hlt : n' + (m' - n') < n + m). - { rewrite (add_comm n'), E', sub_add by order. - now apply lt_add_pos_l. } - destruct (IH (n', m'-n') Hlt Hn') as [a [b Hab]]. - cbn in Hab. exists (a+b), b. - rewrite mul_add_distr_r, Hab, mul_sub_distr_l, gcd_sub_diag_r by order. - now rewrite <- add_assoc, sub_add by (apply mul_le_mono_l; order). -Qed. - -(** For strictly positive numbers, we have Bezout in the two directions. *) - -Lemma gcd_bezout_pos_pos : forall n, 0 forall m, 0 - Bezout n m (gcd n m) /\ Bezout m n (gcd n m). -Proof. - intros ????. split; [|rewrite gcd_comm]; now apply gcd_bezout_pos. -Qed. - -(** For arbitrary natural numbers, we could only say that at least + Definition Bezout n m p := exists a b, a*n == p + b*m. + + #[global] + Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. + Proof. + unfold Bezout. intros x x' Hx y y' Hy z z' Hz. + setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. + Qed. + + Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. + Proof. + intros n m (q & r & H). + apply gcd_unique; trivial using divide_1_l, le_0_1. + intros p Hn Hm. + apply divide_add_cancel_r with (r*m). + - now apply divide_mul_r. + - rewrite add_comm, <- H. now apply divide_mul_r. + Qed. + + (** Bezout on natural numbers commutes *) + + Theorem bezout_comm : forall a b g, + b ~= 0 -> Bezout a b g -> Bezout b a g. + Proof. + intros a b g Hb [p [q Hpq]]. + destruct (eq_decidable a 0) as [Ha|Ha]. + { exists 0, 0. symmetry in Hpq. + rewrite Ha, mul_0_r in Hpq. + apply eq_add_0 in Hpq as [-> _]. + now nzsimpl. } + exists (a*(p+1)*(q+1)-q), (b*(p+1)*(q+1)-p). + enough (E' : (a*(p+1)*(q+1)-q+q)*b == (b*(p+1)*(q+1)-p+p)*a). + { rewrite (mul_add_distr_r _ _ a), (mul_add_distr_r _ _ b), Hpq in E'. + rewrite add_assoc, (add_comm _ g) in E'. + now apply add_cancel_r in E'. } + rewrite !sub_add. + - now rewrite !(mul_comm _ b), !mul_assoc, !(mul_comm _ a), !mul_assoc. + - rewrite <- mul_1_r at 1. apply mul_le_mono; [|apply le_add_l]. + rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_r]. + rewrite one_succ. apply le_succ_l. assert (H := le_0_l b). order. + - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_r]. + rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_l]. + rewrite one_succ. apply le_succ_l. assert (H := le_0_l a). order. + Qed. + + Lemma gcd_bezout_pos : forall n m, 0 < n -> Bezout n m (gcd n m). + Proof. + enough (H : forall nm, 0 < fst nm -> Bezout (fst nm) (snd nm) (gcd (fst nm) (snd nm))). + { intros n m. apply (H (n, m)). } + intros nm. + induction nm as [[n m] IH] using (measure_induction _ (fun '(n, m) => n + m)). + enough (H : forall n' m', n+m == n'+m' -> 0 Bezout n' m' (gcd n' m')). + { cbn. intros ?. destruct (lt_trichotomy n m) as [Hnm|[Hnm|Hnm]]. + - now apply H. + - exists 1, 0. now rewrite Hnm, mul_1_l, mul_0_l, add_0_r, gcd_diag. + - destruct (eq_0_gt_0_cases m) as [->|?]. + + exists 1, 0. now rewrite gcd_0_r, mul_1_l, mul_0_l, add_0_r. + + apply bezout_comm; [order|]. + rewrite gcd_comm. now apply H; [apply add_comm|]. } + intros n' m' E' [Hn' Hn'm']. + assert (Hlt : n' + (m' - n') < n + m). + { rewrite (add_comm n'), E', sub_add by order. + now apply lt_add_pos_l. } + destruct (IH (n', m'-n') Hlt Hn') as [a [b Hab]]. + cbn in Hab. exists (a+b), b. + rewrite mul_add_distr_r, Hab, mul_sub_distr_l, gcd_sub_diag_r by order. + now rewrite <- add_assoc, sub_add by (apply mul_le_mono_l; order). + Qed. + + (** For strictly positive numbers, we have Bezout in the two directions. *) + + Lemma gcd_bezout_pos_pos : forall n, 0 forall m, 0 + Bezout n m (gcd n m) /\ Bezout m n (gcd n m). + Proof. + intros ????. split; [|rewrite gcd_comm]; now apply gcd_bezout_pos. + Qed. + + (** For arbitrary natural numbers, we could only say that at least one of the Bezout identities holds. *) -Lemma gcd_bezout : forall n m, - Bezout n m (gcd n m) \/ Bezout m n (gcd n m). -Proof. - intros n m. - destruct (eq_0_gt_0_cases n) as [EQ|LT]. - - right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl. - - left. now apply gcd_bezout_pos. -Qed. - -Lemma gcd_mul_mono_l : - forall n m p, gcd (p * n) (p * m) == p * gcd n m. -Proof. - intros n m p. apply gcd_unique. - - apply mul_divide_mono_l, gcd_divide_l. - - apply mul_divide_mono_l, gcd_divide_r. - - intros q H H'. + Lemma gcd_bezout : forall n m, + Bezout n m (gcd n m) \/ Bezout m n (gcd n m). + Proof. + intros n m. destruct (eq_0_gt_0_cases n) as [EQ|LT]. - + rewrite EQ in *. now rewrite gcd_0_l. - + destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. - apply divide_add_cancel_r with (p*m*b). - * now apply divide_mul_l. - * rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ. - rewrite (mul_comm a), mul_assoc. - now apply divide_mul_l. -Qed. - -Lemma gcd_mul_mono_r : - forall n m p, gcd (n*p) (m*p) == gcd n m * p. -Proof. - intros n m p. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. -Qed. - -Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). -Proof. - intros n m p H G. - destruct (eq_0_gt_0_cases n) as [EQ|LT]. - - rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G. - - destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. - rewrite G in EQ. - apply divide_add_cancel_r with (m*p*b). - + now apply divide_mul_l. - + rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2. - rewrite <- mul_add_distr_r, add_comm, <- EQ. - now apply divide_mul_l, divide_factor_r. -Qed. - -Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> - exists q r, n == q*r /\ (q | m) /\ (r | p). -Proof. - intros n m p Hn H. - assert (G := gcd_nonneg n m). le_elim G. - - destruct (gcd_divide_l n m) as (q,Hq). - exists (gcd n m). exists q. - split. - + now rewrite mul_comm. - + split. - * apply gcd_divide_r. - * destruct (gcd_divide_r n m) as (r,Hr). - rewrite Hr in H. rewrite Hq in H at 1. - rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. - apply gauss with r; trivial. - apply mul_cancel_r with (gcd n m); [order|]. - rewrite mul_1_l. - rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order. - - symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. -Qed. - -(** TODO : relation between gcd and division and modulo *) - -(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) + - right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl. + - left. now apply gcd_bezout_pos. + Qed. + + Lemma gcd_mul_mono_l : + forall n m p, gcd (p * n) (p * m) == p * gcd n m. + Proof. + intros n m p. apply gcd_unique. + - apply mul_divide_mono_l, gcd_divide_l. + - apply mul_divide_mono_l, gcd_divide_r. + - intros q H H'. + destruct (eq_0_gt_0_cases n) as [EQ|LT]. + + rewrite EQ in *. now rewrite gcd_0_l. + + destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. + apply divide_add_cancel_r with (p*m*b). + * now apply divide_mul_l. + * rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ. + rewrite (mul_comm a), mul_assoc. + now apply divide_mul_l. + Qed. + + Lemma gcd_mul_mono_r : + forall n m p, gcd (n*p) (m*p) == gcd n m * p. + Proof. + intros n m p. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. + Qed. + + Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). + Proof. + intros n m p H G. + destruct (eq_0_gt_0_cases n) as [EQ|LT]. + - rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G. + - destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. + rewrite G in EQ. + apply divide_add_cancel_r with (m*p*b). + + now apply divide_mul_l. + + rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2. + rewrite <- mul_add_distr_r, add_comm, <- EQ. + now apply divide_mul_l, divide_factor_r. + Qed. + + Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> + exists q r, n == q*r /\ (q | m) /\ (r | p). + Proof. + intros n m p Hn H. + assert (G := gcd_nonneg n m). le_elim G. + - destruct (gcd_divide_l n m) as (q,Hq). + exists (gcd n m). exists q. + split. + + now rewrite mul_comm. + + split. + * apply gcd_divide_r. + * destruct (gcd_divide_r n m) as (r,Hr). + rewrite Hr in H. rewrite Hq in H at 1. + rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. + apply gauss with r; trivial. + apply mul_cancel_r with (gcd n m); [order|]. + rewrite mul_1_l. + rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order. + - symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. + Qed. + + (** TODO : relation between gcd and division and modulo *) + + (** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) End NGcdProp. diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v index 095ddfd49f..24a6cec961 100644 --- a/theories/Numbers/Natural/Abstract/NIso.v +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -16,88 +16,88 @@ From Stdlib Require Import NBase. Module Homomorphism (N1 N2 : NAxiomsRecSig). -#[local] Notation "n == m" := (N2.eq n m) (at level 70, no associativity). - -Definition homomorphism (f : N1.t -> N2.t) : Prop := - f N1.zero == N2.zero /\ forall n, f (N1.succ n) == N2.succ (f n). - -Definition natural_isomorphism : N1.t -> N2.t := - N1.recursion N2.zero (fun (n : N1.t) (p : N2.t) => N2.succ p). - -#[global] -Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism. -Proof. -unfold natural_isomorphism. -repeat red; intros. f_equiv; trivial. -repeat red; intros. now f_equiv. -Qed. - -Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero. -Proof. -unfold natural_isomorphism; now rewrite N1.recursion_0. -Qed. - -Theorem natural_isomorphism_succ : - forall n : N1.t, natural_isomorphism (N1.succ n) == N2.succ (natural_isomorphism n). -Proof. -unfold natural_isomorphism. -intro n. rewrite N1.recursion_succ; auto with *. -repeat red; intros. now f_equiv. -Qed. - -Theorem hom_nat_iso : homomorphism natural_isomorphism. -Proof. -unfold homomorphism, natural_isomorphism; split; -[exact natural_isomorphism_0 | exact natural_isomorphism_succ]. -Qed. + #[local] Notation "n == m" := (N2.eq n m) (at level 70, no associativity). + + Definition homomorphism (f : N1.t -> N2.t) : Prop := + f N1.zero == N2.zero /\ forall n, f (N1.succ n) == N2.succ (f n). + + Definition natural_isomorphism : N1.t -> N2.t := + N1.recursion N2.zero (fun (n : N1.t) (p : N2.t) => N2.succ p). + + #[global] + Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism. + Proof. + unfold natural_isomorphism. + repeat red; intros. f_equiv; trivial. + repeat red; intros. now f_equiv. + Qed. + + Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero. + Proof. + unfold natural_isomorphism; now rewrite N1.recursion_0. + Qed. + + Theorem natural_isomorphism_succ : + forall n : N1.t, natural_isomorphism (N1.succ n) == N2.succ (natural_isomorphism n). + Proof. + unfold natural_isomorphism. + intro n. rewrite N1.recursion_succ; auto with *. + repeat red; intros. now f_equiv. + Qed. + + Theorem hom_nat_iso : homomorphism natural_isomorphism. + Proof. + unfold homomorphism, natural_isomorphism; split; + [exact natural_isomorphism_0 | exact natural_isomorphism_succ]. + Qed. End Homomorphism. Module Inverse (N1 N2 : NAxiomsRecSig). -Module Import NBasePropMod1 := NBaseProp N1. -(* This makes the tactic induct available. Since it is taken from + Module Import NBasePropMod1 := NBaseProp N1. + (* This makes the tactic induct available. Since it is taken from (NBasePropFunct NAxiomsMod1), it refers to induction on N1. *) -Module Hom12 := Homomorphism N1 N2. -Module Hom21 := Homomorphism N2 N1. + Module Hom12 := Homomorphism N1 N2. + Module Hom21 := Homomorphism N2 N1. -#[local] Notation h12 := Hom12.natural_isomorphism. -#[local] Notation h21 := Hom21.natural_isomorphism. -#[local] Notation "n == m" := (N1.eq n m) (at level 70, no associativity). + #[local] Notation h12 := Hom12.natural_isomorphism. + #[local] Notation h21 := Hom21.natural_isomorphism. + #[local] Notation "n == m" := (N1.eq n m) (at level 70, no associativity). -Lemma inverse_nat_iso : forall n : N1.t, h21 (h12 n) == n. -Proof. -induct n. -- now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0. -- intros n IH. - now rewrite Hom12.natural_isomorphism_succ, Hom21.natural_isomorphism_succ, IH. -Qed. + Lemma inverse_nat_iso : forall n : N1.t, h21 (h12 n) == n. + Proof. + induct n. + - now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0. + - intros n IH. + now rewrite Hom12.natural_isomorphism_succ, Hom21.natural_isomorphism_succ, IH. + Qed. End Inverse. Module Isomorphism (N1 N2 : NAxiomsRecSig). -Module Hom12 := Homomorphism N1 N2. -Module Hom21 := Homomorphism N2 N1. -Module Inverse12 := Inverse N1 N2. -Module Inverse21 := Inverse N2 N1. - -#[local] Notation h12 := Hom12.natural_isomorphism. -#[local] Notation h21 := Hom21.natural_isomorphism. - -Definition isomorphism (f1 : N1.t -> N2.t) (f2 : N2.t -> N1.t) : Prop := - Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\ - forall n, N1.eq (f2 (f1 n)) n /\ - forall n, N2.eq (f1 (f2 n)) n. - -Theorem iso_nat_iso : isomorphism h12 h21. -Proof. -unfold isomorphism. -split. { apply Hom12.hom_nat_iso. } -split. { apply Hom21.hom_nat_iso. } -split. { apply Inverse12.inverse_nat_iso. } -apply Inverse21.inverse_nat_iso. -Qed. + Module Hom12 := Homomorphism N1 N2. + Module Hom21 := Homomorphism N2 N1. + Module Inverse12 := Inverse N1 N2. + Module Inverse21 := Inverse N2 N1. + + #[local] Notation h12 := Hom12.natural_isomorphism. + #[local] Notation h21 := Hom21.natural_isomorphism. + + Definition isomorphism (f1 : N1.t -> N2.t) (f2 : N2.t -> N1.t) : Prop := + Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\ + forall n, N1.eq (f2 (f1 n)) n /\ + forall n, N2.eq (f1 (f2 n)) n. + + Theorem iso_nat_iso : isomorphism h12 h21. + Proof. + unfold isomorphism. + split. { apply Hom12.hom_nat_iso. } + split. { apply Hom21.hom_nat_iso. } + split. { apply Inverse12.inverse_nat_iso. } + apply Inverse21.inverse_nat_iso. + Qed. End Isomorphism. diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v index 3bea75e144..d5845392a2 100644 --- a/theories/Numbers/Natural/Abstract/NLcm.v +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -22,69 +22,69 @@ From Stdlib Require Import NAxioms NSub NDiv NGcd. *) Module Type NLcmProp - (Import A : NAxiomsSig') - (Import B : NSubProp A) - (Import C : NDivProp A B) - (Import D : NGcdProp A B). - -(** Divibility and modulo *) - -Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). -Proof. - intros a b Hb. split. - - intros Hab. exists (a/b). rewrite mul_comm. - rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. - - intros (c,Hc). rewrite Hc. now apply mod_mul. -Qed. - -Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> - (c*a)/b == c*(a/b). -Proof. - intros a b c Hb H. - apply mul_cancel_l with b; trivial. - rewrite mul_assoc, mul_shuffle0. - assert (H':=H). apply mod_divide, div_exact in H'; trivial. - rewrite <- H', (mul_comm a c). - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - now apply divide_mul_r. -Qed. - -(** Gcd of divided elements, for exact divisions *) - -Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) -> - gcd (a/c) (b/c) == (gcd a b)/c. -Proof. - intros a b c Hc Ha Hb. - apply mul_cancel_l with c; try order. - assert (H:=gcd_greatest _ _ _ Ha Hb). - apply mod_divide, div_exact in H; try order. - rewrite <- H. - rewrite <- gcd_mul_mono_l; try order. - f_equiv; symmetry; apply div_exact; try order; - apply mod_divide; trivial; try order. -Qed. - -Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> - gcd (a/g) (b/g) == 1. -Proof. - intros a b g NZ EQ. rewrite gcd_div_factor. - - now rewrite <- EQ, div_same. - - generalize (gcd_nonneg a b); order. - - rewrite EQ; apply gcd_divide_l. - - rewrite EQ; apply gcd_divide_r. -Qed. - -(** The following equality is crucial for Euclid algorithm *) - -Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. -Proof. - intros a b Hb. rewrite (gcd_comm _ b). - rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)). - now rewrite add_comm, mul_comm, <- div_mod. -Qed. - -(** We now define lcm thanks to gcd: + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import C : NDivProp A B) + (Import D : NGcdProp A B). + + (** Divibility and modulo *) + + Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). + Proof. + intros a b Hb. split. + - intros Hab. exists (a/b). rewrite mul_comm. + rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. + - intros (c,Hc). rewrite Hc. now apply mod_mul. + Qed. + + Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> + (c*a)/b == c*(a/b). + Proof. + intros a b c Hb H. + apply mul_cancel_l with b; trivial. + rewrite mul_assoc, mul_shuffle0. + assert (H':=H). apply mod_divide, div_exact in H'; trivial. + rewrite <- H', (mul_comm a c). + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + now apply divide_mul_r. + Qed. + + (** Gcd of divided elements, for exact divisions *) + + Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) -> + gcd (a/c) (b/c) == (gcd a b)/c. + Proof. + intros a b c Hc Ha Hb. + apply mul_cancel_l with c; try order. + assert (H:=gcd_greatest _ _ _ Ha Hb). + apply mod_divide, div_exact in H; try order. + rewrite <- H. + rewrite <- gcd_mul_mono_l; try order. + f_equiv; symmetry; apply div_exact; try order; + apply mod_divide; trivial; try order. + Qed. + + Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> + gcd (a/g) (b/g) == 1. + Proof. + intros a b g NZ EQ. rewrite gcd_div_factor. + - now rewrite <- EQ, div_same. + - generalize (gcd_nonneg a b); order. + - rewrite EQ; apply gcd_divide_l. + - rewrite EQ; apply gcd_divide_r. + Qed. + + (** The following equality is crucial for Euclid algorithm *) + + Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. + Proof. + intros a b Hb. rewrite (gcd_comm _ b). + rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)). + now rewrite add_comm, mul_comm, <- div_mod. + Qed. + + (** We now define lcm thanks to gcd: lcm a b = a * (b / gcd a b) = (a / gcd a b) * b @@ -94,209 +94,209 @@ Qed. equation above. *) -Definition lcm a b := a*(b/gcd a b). - -#[global] -Instance lcm_wd : Proper (eq==>eq==>eq) lcm. -Proof. unfold lcm. solve_proper. Qed. - -Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> - a * (b / gcd a b) == (a*b)/gcd a b. -Proof. - intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. -Qed. - -Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> - (a / gcd a b) * b == (a*b)/gcd a b. -Proof. - intros a b H. rewrite 2 (mul_comm _ b). - rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. -Qed. - -Lemma gcd_div_swap : forall a b, - (a / gcd a b) * b == a * (b / gcd a b). -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. - - now rewrite lcm_equiv1, <-lcm_equiv2. -Qed. - -Lemma divide_lcm_l : forall a b, (a | lcm a b). -Proof. - unfold lcm. intros a b. apply divide_factor_l. -Qed. - -Lemma divide_lcm_r : forall a b, (b | lcm a b). -Proof. - unfold lcm. intros a b. rewrite <- gcd_div_swap. - apply divide_factor_r. -Qed. - -Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). -Proof. - intros a b c Ha Hb (c',Hc). exists c'. - now rewrite <- divide_div_mul_exact, Hc. -Qed. - -Lemma lcm_least : forall a b c, - (a | c) -> (b | c) -> (lcm a b | c). -Proof. - intros a b c Ha Hb. unfold lcm. - destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. - - assert (Ga := gcd_divide_l a b). - assert (Gb := gcd_divide_r a b). - set (g:=gcd a b) in *. - assert (Ha' := divide_div g a c NEQ Ga Ha). - assert (Hb' := divide_div g b c NEQ Gb Hb). - destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. - apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. - destruct Hb' as (b',Hb'). - exists b'. - rewrite mul_shuffle3, <- Hb'. - rewrite (proj2 (div_exact c g NEQ)). - + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - + apply mod_divide; trivial. transitivity a; trivial. -Qed. - -Lemma lcm_comm : forall a b, lcm a b == lcm b a. -Proof. - intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). - now rewrite <- gcd_div_swap. -Qed. - -Lemma lcm_divide_iff : forall n m p, - (lcm n m | p) <-> (n | p) /\ (m | p). -Proof. - intros n m p. split;[split|]. - - transitivity (lcm n m); trivial using divide_lcm_l. - - transitivity (lcm n m); trivial using divide_lcm_r. - - intros (H,H'). now apply lcm_least. -Qed. - -Lemma lcm_unique : forall n m p, - 0<=p -> (n|p) -> (m|p) -> - (forall q, (n|q) -> (m|q) -> (p|q)) -> - lcm n m == p. -Proof. - intros n m p Hp Hn Hm H. - apply divide_antisym; trivial. - - now apply lcm_least. - - apply H. - + apply divide_lcm_l. - + apply divide_lcm_r. -Qed. - -Lemma lcm_unique_alt : forall n m p, 0<=p -> - (forall q, (p|q) <-> (n|q) /\ (m|q)) -> - lcm n m == p. -Proof. - intros n m p Hp H. - apply lcm_unique; trivial. - - apply H, divide_refl. - - apply H, divide_refl. - - intros. apply H. now split. -Qed. - -Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. -Proof. - intros. apply lcm_unique_alt. - - apply le_0_l. - - intros. now rewrite !lcm_divide_iff, and_assoc. -Qed. - -Lemma lcm_0_l : forall n, lcm 0 n == 0. -Proof. - intros. apply lcm_unique; trivial. - - order. - - apply divide_refl. - - apply divide_0_r. -Qed. - -Lemma lcm_0_r : forall n, lcm n 0 == 0. -Proof. - intros. now rewrite lcm_comm, lcm_0_l. -Qed. - -Lemma lcm_1_l : forall n, lcm 1 n == n. -Proof. - intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl. -Qed. - -Lemma lcm_1_r : forall n, lcm n 1 == n. -Proof. - intros. now rewrite lcm_comm, lcm_1_l. -Qed. - -Lemma lcm_diag : forall n, lcm n n == n. -Proof. - intros. apply lcm_unique; trivial using divide_refl, le_0_l. -Qed. - -Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. -Proof. - intros. split. - - intros EQ. - apply eq_mul_0. - apply divide_0_l. rewrite <- EQ. apply lcm_least. - + apply divide_factor_l. - + apply divide_factor_r. - - destruct 1 as [EQ|EQ]; rewrite EQ. - + apply lcm_0_l. - + apply lcm_0_r. -Qed. - -Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m. -Proof. - intros n m H. apply lcm_unique_alt; trivial using le_0_l. - intros q. split. - - split; trivial. now transitivity m. - - now destruct 1. -Qed. - -Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m. -Proof. - intros n m. split. - - now apply divide_lcm_eq_r. - - intros EQ. rewrite <- EQ. apply divide_lcm_l. -Qed. - -Lemma lcm_mul_mono_l : - forall n m p, lcm (p * n) (p * m) == p * lcm n m. -Proof. - intros n m p. - destruct (eq_decidable p 0) as [Hp|Hp]. - - rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl. - - destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]. - + apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. - nzsimpl. rewrite lcm_0_l. now nzsimpl. - + unfold lcm. - rewrite gcd_mul_mono_l. - rewrite mul_assoc. f_equiv. - now rewrite div_mul_cancel_l. -Qed. - -Lemma lcm_mul_mono_r : - forall n m p, lcm (n * p) (m * p) == lcm n m * p. -Proof. - intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. -Qed. - -Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> - (gcd n m == 1 <-> lcm n m == n*m). -Proof. - intros n m Hn Hm. split; intros H. - - unfold lcm. rewrite H. now rewrite div_1_r. - - unfold lcm in *. - apply mul_cancel_l in H; trivial. - assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). - assert (H' := gcd_divide_r n m). - apply mod_divide in H'; trivial. apply div_exact in H'; trivial. - rewrite H in H'. - rewrite <- (mul_1_l m) in H' at 1. - now apply mul_cancel_r in H'. -Qed. + Definition lcm a b := a*(b/gcd a b). + + #[global] + Instance lcm_wd : Proper (eq==>eq==>eq) lcm. + Proof. unfold lcm. solve_proper. Qed. + + Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> + a * (b / gcd a b) == (a*b)/gcd a b. + Proof. + intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. + Qed. + + Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> + (a / gcd a b) * b == (a*b)/gcd a b. + Proof. + intros a b H. rewrite 2 (mul_comm _ b). + rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. + Qed. + + Lemma gcd_div_swap : forall a b, + (a / gcd a b) * b == a * (b / gcd a b). + Proof. + intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. + - now rewrite lcm_equiv1, <-lcm_equiv2. + Qed. + + Lemma divide_lcm_l : forall a b, (a | lcm a b). + Proof. + unfold lcm. intros a b. apply divide_factor_l. + Qed. + + Lemma divide_lcm_r : forall a b, (b | lcm a b). + Proof. + unfold lcm. intros a b. rewrite <- gcd_div_swap. + apply divide_factor_r. + Qed. + + Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). + Proof. + intros a b c Ha Hb (c',Hc). exists c'. + now rewrite <- divide_div_mul_exact, Hc. + Qed. + + Lemma lcm_least : forall a b c, + (a | c) -> (b | c) -> (lcm a b | c). + Proof. + intros a b c Ha Hb. unfold lcm. + destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. + - assert (Ga := gcd_divide_l a b). + assert (Gb := gcd_divide_r a b). + set (g:=gcd a b) in *. + assert (Ha' := divide_div g a c NEQ Ga Ha). + assert (Hb' := divide_div g b c NEQ Gb Hb). + destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. + apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. + destruct Hb' as (b',Hb'). + exists b'. + rewrite mul_shuffle3, <- Hb'. + rewrite (proj2 (div_exact c g NEQ)). + + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + + apply mod_divide; trivial. transitivity a; trivial. + Qed. + + Lemma lcm_comm : forall a b, lcm a b == lcm b a. + Proof. + intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). + now rewrite <- gcd_div_swap. + Qed. + + Lemma lcm_divide_iff : forall n m p, + (lcm n m | p) <-> (n | p) /\ (m | p). + Proof. + intros n m p. split;[split|]. + - transitivity (lcm n m); trivial using divide_lcm_l. + - transitivity (lcm n m); trivial using divide_lcm_r. + - intros (H,H'). now apply lcm_least. + Qed. + + Lemma lcm_unique : forall n m p, + 0<=p -> (n|p) -> (m|p) -> + (forall q, (n|q) -> (m|q) -> (p|q)) -> + lcm n m == p. + Proof. + intros n m p Hp Hn Hm H. + apply divide_antisym; trivial. + - now apply lcm_least. + - apply H. + + apply divide_lcm_l. + + apply divide_lcm_r. + Qed. + + Lemma lcm_unique_alt : forall n m p, 0<=p -> + (forall q, (p|q) <-> (n|q) /\ (m|q)) -> + lcm n m == p. + Proof. + intros n m p Hp H. + apply lcm_unique; trivial. + - apply H, divide_refl. + - apply H, divide_refl. + - intros. apply H. now split. + Qed. + + Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. + Proof. + intros. apply lcm_unique_alt. + - apply le_0_l. + - intros. now rewrite !lcm_divide_iff, and_assoc. + Qed. + + Lemma lcm_0_l : forall n, lcm 0 n == 0. + Proof. + intros. apply lcm_unique; trivial. + - order. + - apply divide_refl. + - apply divide_0_r. + Qed. + + Lemma lcm_0_r : forall n, lcm n 0 == 0. + Proof. + intros. now rewrite lcm_comm, lcm_0_l. + Qed. + + Lemma lcm_1_l : forall n, lcm 1 n == n. + Proof. + intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl. + Qed. + + Lemma lcm_1_r : forall n, lcm n 1 == n. + Proof. + intros. now rewrite lcm_comm, lcm_1_l. + Qed. + + Lemma lcm_diag : forall n, lcm n n == n. + Proof. + intros. apply lcm_unique; trivial using divide_refl, le_0_l. + Qed. + + Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. + Proof. + intros. split. + - intros EQ. + apply eq_mul_0. + apply divide_0_l. rewrite <- EQ. apply lcm_least. + + apply divide_factor_l. + + apply divide_factor_r. + - destruct 1 as [EQ|EQ]; rewrite EQ. + + apply lcm_0_l. + + apply lcm_0_r. + Qed. + + Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m. + Proof. + intros n m H. apply lcm_unique_alt; trivial using le_0_l. + intros q. split. + - split; trivial. now transitivity m. + - now destruct 1. + Qed. + + Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m. + Proof. + intros n m. split. + - now apply divide_lcm_eq_r. + - intros EQ. rewrite <- EQ. apply divide_lcm_l. + Qed. + + Lemma lcm_mul_mono_l : + forall n m p, lcm (p * n) (p * m) == p * lcm n m. + Proof. + intros n m p. + destruct (eq_decidable p 0) as [Hp|Hp]. + - rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl. + - destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]. + + apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. + nzsimpl. rewrite lcm_0_l. now nzsimpl. + + unfold lcm. + rewrite gcd_mul_mono_l. + rewrite mul_assoc. f_equiv. + now rewrite div_mul_cancel_l. + Qed. + + Lemma lcm_mul_mono_r : + forall n m p, lcm (n * p) (m * p) == lcm n m * p. + Proof. + intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. + Qed. + + Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> + (gcd n m == 1 <-> lcm n m == n*m). + Proof. + intros n m Hn Hm. split; intros H. + - unfold lcm. rewrite H. now rewrite div_1_r. + - unfold lcm in *. + apply mul_cancel_l in H; trivial. + assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). + assert (H' := gcd_divide_r n m). + apply mod_divide in H'; trivial. apply div_exact in H'; trivial. + rewrite H in H'. + rewrite <- (mul_1_l m) in H' at 1. + now apply mul_cancel_r in H'. + Qed. End NLcmProp. diff --git a/theories/Numbers/Natural/Abstract/NLcm0.v b/theories/Numbers/Natural/Abstract/NLcm0.v index 8695f31735..060d54776d 100644 --- a/theories/Numbers/Natural/Abstract/NLcm0.v +++ b/theories/Numbers/Natural/Abstract/NLcm0.v @@ -11,134 +11,134 @@ From Stdlib Require Import NAxioms NSub NDiv0 NGcd NLcm. Module Type NLcmPropPrivate - (A : NAxiomsSig') (B : NSubProp A) (C : NDivPropPrivate A B) (D : NGcdProp A B). -Declare Module Private_NLcmProp : NLcmProp A B (C.Private_NDivProp) D. + (A : NAxiomsSig') (B : NSubProp A) (C : NDivPropPrivate A B) (D : NGcdProp A B). + Declare Module Private_NLcmProp : NLcmProp A B (C.Private_NDivProp) D. End NLcmPropPrivate. Module Type NLcmProp0 - (Import A : NAxiomsSig') - (Import B : NSubProp A) - (Import A' : NZDivSpec0 A A A) - (Import D : NGcdProp A B) - (Import C : NDivPropPrivate A B) - (Import C' : NDivProp0 A B A' C) - (Import E : NLcmPropPrivate A B C D). - -Import Private_NLcmProp. -Import Div0. - -Definition lcm a b := a*(b/gcd a b). -#[global] Instance lcm_wd : Proper (eq==>eq==>eq) lcm := lcm_wd. - -(* The types are restated to avoid [Private_NLcmProp.lcm] indirection. *) -Definition gcd_div_gcd : forall a b g, g ~= 0 -> g == gcd a b -> - gcd (a / g) (b / g) == 1 := gcd_div_gcd. -Definition divide_lcm_l : forall a b, (a | lcm a b) := divide_lcm_l. -Definition gcd_div_swap : forall a b, a / gcd a b * b == a * (b / gcd a b) := gcd_div_swap. -Definition divide_lcm_r : forall a b, (b | lcm a b) := divide_lcm_r. -Definition lcm_least : forall a b c, (a | c) -> (b | c) -> (lcm a b | c) := lcm_least. -Definition lcm_comm : forall a b, lcm a b == lcm b a := lcm_comm. -Definition lcm_divide_iff : forall n m p, (lcm n m | p) <-> (n | p) /\ (m | p) := lcm_divide_iff. -Definition lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p := lcm_assoc. -Definition lcm_0_l : forall n, lcm 0 n == 0 := lcm_0_l. -Definition lcm_0_r : forall n, lcm n 0 == 0 := lcm_0_r. -Definition lcm_1_l : forall n, lcm 1 n == n := lcm_1_l. -Definition lcm_1_r : forall n, lcm n 1 == n := lcm_1_r. -Definition lcm_diag : forall n : t, lcm n n == n := lcm_diag. -Definition lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0 := lcm_eq_0. -Definition divide_lcm_eq_r : forall n m, (n | m) -> lcm n m == m := divide_lcm_eq_r. -Definition divide_lcm_iff : forall n m, (n | m) <-> lcm n m == m := divide_lcm_iff. -Definition lcm_mul_mono_l : forall n m p, lcm (p * n) (p * m) == p * lcm n m := lcm_mul_mono_l. -Definition lcm_mul_mono_r : forall n m p, lcm (n * p) (m * p) == lcm n m * p := lcm_mul_mono_r. -Definition gcd_1_lcm_mul : forall n m, n ~= 0 -> m ~= 0 -> - gcd n m == 1 <-> lcm n m == n * m := gcd_1_lcm_mul. -Module Lcm0. - -#[local] Hint Rewrite div_0_l mod_0_l div_0_r mod_0_r gcd_0_l gcd_0_r : nz. - -Lemma mod_divide : forall a b, (a mod b == 0 <-> (b|a)). -Proof. - intros a b. destruct (eq_decidable b 0) as [Hb|Hb]. - - split. - + intros Hab. exists 0. revert Hab. rewrite Hb. now nzsimpl. - + intros [c Hc]. revert Hc. rewrite Hb. now nzsimpl. - - now apply mod_divide. -Qed. - -Lemma divide_div_mul_exact : forall a b c, (b|a) -> (c*a)/b == c*(a/b). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply divide_div_mul_exact. -Qed. - -Lemma gcd_div_factor : forall a b c, (c|a) -> (c|b) -> - gcd (a/c) (b/c) == (gcd a b)/c. -Proof. - intros a b c. destruct (eq_decidable c 0) as [->|Hc]. - - now nzsimpl. - - now apply gcd_div_factor. -Qed. - -Lemma gcd_mod : forall a b, gcd (a mod b) b == gcd b a. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply gcd_mod. -Qed. - -Lemma lcm_equiv1 : forall a b, a * (b / gcd a b) == (a*b)/gcd a b. -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [->|?]. - - now nzsimpl. - - now apply lcm_equiv1. -Qed. - -Lemma lcm_equiv2 : forall a b, (a / gcd a b) * b == (a*b)/gcd a b. -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [->|?]. - - now nzsimpl. - - now apply lcm_equiv2. -Qed. - -Lemma divide_div : forall a b c, (a|b) -> (b|c) -> (b/a|c/a). -Proof. - intros a b c. destruct (eq_decidable a 0) as [->|Ha]. - - now nzsimpl. - - now apply divide_div. -Qed. - -Lemma lcm_unique : forall n m p, - (n|p) -> (m|p) -> (forall q, (n|q) -> (m|q) -> (p|q)) -> lcm n m == p. -Proof. intros n m p. apply lcm_unique, le_0_l. Qed. - -Lemma lcm_unique_alt : forall n m p, - (forall q, (p|q) <-> (n|q) /\ (m|q)) -> lcm n m == p. -Proof. intros n m p. apply lcm_unique_alt, le_0_l. Qed. - -End Lcm0. - -(** Deprecation statements. + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import A' : NZDivSpec0 A A A) + (Import D : NGcdProp A B) + (Import C : NDivPropPrivate A B) + (Import C' : NDivProp0 A B A' C) + (Import E : NLcmPropPrivate A B C D). + + Import Private_NLcmProp. + Import Div0. + + Definition lcm a b := a*(b/gcd a b). + #[global] Instance lcm_wd : Proper (eq==>eq==>eq) lcm := lcm_wd. + + (* The types are restated to avoid [Private_NLcmProp.lcm] indirection. *) + Definition gcd_div_gcd : forall a b g, g ~= 0 -> g == gcd a b -> + gcd (a / g) (b / g) == 1 := gcd_div_gcd. + Definition divide_lcm_l : forall a b, (a | lcm a b) := divide_lcm_l. + Definition gcd_div_swap : forall a b, a / gcd a b * b == a * (b / gcd a b) := gcd_div_swap. + Definition divide_lcm_r : forall a b, (b | lcm a b) := divide_lcm_r. + Definition lcm_least : forall a b c, (a | c) -> (b | c) -> (lcm a b | c) := lcm_least. + Definition lcm_comm : forall a b, lcm a b == lcm b a := lcm_comm. + Definition lcm_divide_iff : forall n m p, (lcm n m | p) <-> (n | p) /\ (m | p) := lcm_divide_iff. + Definition lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p := lcm_assoc. + Definition lcm_0_l : forall n, lcm 0 n == 0 := lcm_0_l. + Definition lcm_0_r : forall n, lcm n 0 == 0 := lcm_0_r. + Definition lcm_1_l : forall n, lcm 1 n == n := lcm_1_l. + Definition lcm_1_r : forall n, lcm n 1 == n := lcm_1_r. + Definition lcm_diag : forall n : t, lcm n n == n := lcm_diag. + Definition lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0 := lcm_eq_0. + Definition divide_lcm_eq_r : forall n m, (n | m) -> lcm n m == m := divide_lcm_eq_r. + Definition divide_lcm_iff : forall n m, (n | m) <-> lcm n m == m := divide_lcm_iff. + Definition lcm_mul_mono_l : forall n m p, lcm (p * n) (p * m) == p * lcm n m := lcm_mul_mono_l. + Definition lcm_mul_mono_r : forall n m p, lcm (n * p) (m * p) == lcm n m * p := lcm_mul_mono_r. + Definition gcd_1_lcm_mul : forall n m, n ~= 0 -> m ~= 0 -> + gcd n m == 1 <-> lcm n m == n * m := gcd_1_lcm_mul. + Module Lcm0. + + #[local] Hint Rewrite div_0_l mod_0_l div_0_r mod_0_r gcd_0_l gcd_0_r : nz. + + Lemma mod_divide : forall a b, (a mod b == 0 <-> (b|a)). + Proof. + intros a b. destruct (eq_decidable b 0) as [Hb|Hb]. + - split. + + intros Hab. exists 0. revert Hab. rewrite Hb. now nzsimpl. + + intros [c Hc]. revert Hc. rewrite Hb. now nzsimpl. + - now apply mod_divide. + Qed. + + Lemma divide_div_mul_exact : forall a b c, (b|a) -> (c*a)/b == c*(a/b). + Proof. + intros a b c. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply divide_div_mul_exact. + Qed. + + Lemma gcd_div_factor : forall a b c, (c|a) -> (c|b) -> + gcd (a/c) (b/c) == (gcd a b)/c. + Proof. + intros a b c. destruct (eq_decidable c 0) as [->|Hc]. + - now nzsimpl. + - now apply gcd_div_factor. + Qed. + + Lemma gcd_mod : forall a b, gcd (a mod b) b == gcd b a. + Proof. + intros a b. destruct (eq_decidable b 0) as [->|Hb]. + - now nzsimpl. + - now apply gcd_mod. + Qed. + + Lemma lcm_equiv1 : forall a b, a * (b / gcd a b) == (a*b)/gcd a b. + Proof. + intros a b. destruct (eq_decidable (gcd a b) 0) as [->|?]. + - now nzsimpl. + - now apply lcm_equiv1. + Qed. + + Lemma lcm_equiv2 : forall a b, (a / gcd a b) * b == (a*b)/gcd a b. + Proof. + intros a b. destruct (eq_decidable (gcd a b) 0) as [->|?]. + - now nzsimpl. + - now apply lcm_equiv2. + Qed. + + Lemma divide_div : forall a b c, (a|b) -> (b|c) -> (b/a|c/a). + Proof. + intros a b c. destruct (eq_decidable a 0) as [->|Ha]. + - now nzsimpl. + - now apply divide_div. + Qed. + + Lemma lcm_unique : forall n m p, + (n|p) -> (m|p) -> (forall q, (n|q) -> (m|q) -> (p|q)) -> lcm n m == p. + Proof. intros n m p. apply lcm_unique, le_0_l. Qed. + + Lemma lcm_unique_alt : forall n m p, + (forall q, (p|q) <-> (n|q) /\ (m|q)) -> lcm n m == p. + Proof. intros n m p. apply lcm_unique_alt, le_0_l. Qed. + + End Lcm0. + + (** Deprecation statements. After deprecation phase, remove statements below in favor of Lcm0 statements. *) -#[deprecated(since="8.17",note="Use Lcm0.mod_divide instead.")] -Notation mod_divide := mod_divide (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.divide_div_mul_exact instead.")] -Notation divide_div_mul_exact := divide_div_mul_exact (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.gcd_div_factor instead.")] -Notation gcd_div_factor := gcd_div_factor (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.gcd_mod instead.")] -Notation gcd_mod := gcd_mod (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.gcd_mod instead.")] -Notation lcm_equiv1 := lcm_equiv1 (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.lcm_equiv2 instead.")] -Notation lcm_equiv2 := lcm_equiv2 (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.divide_div instead.")] -Notation divide_div := divide_div (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.lcm_unique instead.")] -Notation lcm_unique := lcm_unique (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.lcm_unique_alt instead.")] -Notation lcm_unique_alt := lcm_unique_alt (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.mod_divide instead.")] + Notation mod_divide := mod_divide (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.divide_div_mul_exact instead.")] + Notation divide_div_mul_exact := divide_div_mul_exact (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.gcd_div_factor instead.")] + Notation gcd_div_factor := gcd_div_factor (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.gcd_mod instead.")] + Notation gcd_mod := gcd_mod (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.gcd_mod instead.")] + Notation lcm_equiv1 := lcm_equiv1 (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.lcm_equiv2 instead.")] + Notation lcm_equiv2 := lcm_equiv2 (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.divide_div instead.")] + Notation divide_div := divide_div (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.lcm_unique instead.")] + Notation lcm_unique := lcm_unique (only parsing). + #[deprecated(since="8.17",note="Use Lcm0.lcm_unique_alt instead.")] + Notation lcm_unique_alt := lcm_unique_alt (only parsing). End NLcmProp0. diff --git a/theories/Numbers/Natural/Abstract/NLog.v b/theories/Numbers/Natural/Abstract/NLog.v index c49f0d2977..be05a1c51f 100644 --- a/theories/Numbers/Natural/Abstract/NLog.v +++ b/theories/Numbers/Natural/Abstract/NLog.v @@ -13,13 +13,13 @@ From Stdlib Require Import NAxioms NSub NPow NParity NZLog. Module Type NLog2Prop - (A : NAxiomsSig) - (B : NSubProp A) - (C : NParityProp A B) - (D : NPowProp A B C). + (A : NAxiomsSig) + (B : NSubProp A) + (C : NParityProp A B) + (D : NPowProp A B C). - (** For the moment we simply reuse NZ properties *) + (** For the moment we simply reuse NZ properties *) - Include NZLog2Prop A A A B D.Private_NZPow. - Include NZLog2UpProp A A A B D.Private_NZPow. + Include NZLog2Prop A A A B D.Private_NZPow. + Include NZLog2UpProp A A A B D.Private_NZPow. End NLog2Prop. diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v index c236826172..bab1c1460e 100644 --- a/theories/Numbers/Natural/Abstract/NMaxMin.v +++ b/theories/Numbers/Natural/Abstract/NMaxMin.v @@ -13,125 +13,125 @@ From Stdlib Require Import NAxioms NSub GenericMinMax. (** * Properties of minimum and maximum specific to natural numbers *) Module Type NMaxMinProp (Import N : NAxiomsMiniSig'). -Include NSubProp N. + Include NSubProp N. -(** Zero *) + (** Zero *) -Lemma max_0_l : forall n, max 0 n == n. -Proof. - intros. apply max_r. apply le_0_l. -Qed. + Lemma max_0_l : forall n, max 0 n == n. + Proof. + intros. apply max_r. apply le_0_l. + Qed. -Lemma max_0_r : forall n, max n 0 == n. -Proof. - intros. apply max_l. apply le_0_l. -Qed. + Lemma max_0_r : forall n, max n 0 == n. + Proof. + intros. apply max_l. apply le_0_l. + Qed. -Lemma min_0_l : forall n, min 0 n == 0. -Proof. - intros. apply min_l. apply le_0_l. -Qed. + Lemma min_0_l : forall n, min 0 n == 0. + Proof. + intros. apply min_l. apply le_0_l. + Qed. -Lemma min_0_r : forall n, min n 0 == 0. -Proof. - intros. apply min_r. apply le_0_l. -Qed. + Lemma min_0_r : forall n, min n 0 == 0. + Proof. + intros. apply min_r. apply le_0_l. + Qed. -(** The following results are concrete instances of [max_monotone] + (** The following results are concrete instances of [max_monotone] and similar lemmas. *) -(** Succ *) - -Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. -Qed. - -Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. -Qed. - -(** Add *) - -Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. -Qed. - -Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. -Qed. - -Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. -Qed. - -Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. -Qed. - -(** Mul *) - -Lemma mul_max_distr_l n m p : max (p * n) (p * m) == p * max n m. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l. -Qed. - -Lemma mul_max_distr_r n m p : max (n * p) (m * p) == max n m * p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r. -Qed. - -Lemma mul_min_distr_l n m p : min (p * n) (p * m) == p * min n m. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l. -Qed. - -Lemma mul_min_distr_r n m p : min (n * p) (m * p) == min n m * p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r. -Qed. - -(** Sub *) - -Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. -Proof. - destruct (le_ge_cases n m). - - rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l. - - rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l. -Qed. - -Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. -Qed. - -Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. -Proof. - destruct (le_ge_cases n m). - - rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l. - - rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l. -Qed. - -Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. -Proof. - destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. -Qed. + (** Succ *) + + Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. + Qed. + + Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. + Qed. + + (** Add *) + + Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. + Qed. + + Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. + Qed. + + Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. + Qed. + + Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. + Qed. + + (** Mul *) + + Lemma mul_max_distr_l n m p : max (p * n) (p * m) == p * max n m. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l. + Qed. + + Lemma mul_max_distr_r n m p : max (n * p) (m * p) == max n m * p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r. + Qed. + + Lemma mul_min_distr_l n m p : min (p * n) (p * m) == p * min n m. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l. + Qed. + + Lemma mul_min_distr_r n m p : min (n * p) (m * p) == min n m * p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r. + Qed. + + (** Sub *) + + Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. + Proof. + destruct (le_ge_cases n m). + - rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l. + - rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l. + Qed. + + Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. + Qed. + + Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. + Proof. + destruct (le_ge_cases n m). + - rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l. + - rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l. + Qed. + + Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. + Proof. + destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. + Qed. End NMaxMinProp. diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v index 0626a2ee63..d4f490d3b4 100644 --- a/theories/Numbers/Natural/Abstract/NMulOrder.v +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -13,87 +13,87 @@ From Stdlib Require Export NAddOrder. Module NMulOrderProp (Import N : NAxiomsMiniSig'). -Include NAddOrderProp N. + Include NAddOrderProp N. -(** Theorems that are either not valid on Z or have different proofs + (** Theorems that are either not valid on Z or have different proofs on N and Z *) -Theorem square_lt_mono : forall n m, n < m <-> n * n < m * m. -Proof. -intros n m; split; intro; -[apply square_lt_mono_nonneg | apply square_lt_simpl_nonneg]; -try assumption; apply le_0_l. -Qed. - -Theorem square_le_mono : forall n m, n <= m <-> n * n <= m * m. -Proof. -intros n m; split; intro; -[apply square_le_mono_nonneg | apply square_le_simpl_nonneg]; -try assumption; apply le_0_l. -Qed. - -Theorem mul_le_mono_l : forall n m p, n <= m -> p * n <= p * m. -Proof. - intros; apply mul_le_mono_nonneg_l. - - apply le_0_l. - - assumption. -Qed. - -Theorem mul_le_mono_r : forall n m p, n <= m -> n * p <= m * p. -Proof. - intros; apply mul_le_mono_nonneg_r. - - apply le_0_l. - - assumption. -Qed. - -Theorem le_mul_l : forall n m, m ~= 0 -> n <= m * n. -Proof. - intros n m D%neq_0_le_1; rewrite <-(mul_1_l n) at 1. - apply mul_le_mono_r; exact D. -Qed. - -Theorem le_mul_r : forall n m, m ~= 0 -> n <= n * m. -Proof. - intros n m; rewrite mul_comm; exact (le_mul_l _ _). -Qed. - -Theorem mul_lt_mono : forall n m p q, n < m -> p < q -> n * p < m * q. -Proof. -intros; apply mul_lt_mono_nonneg; try assumption; apply le_0_l. -Qed. - -Theorem mul_le_mono : forall n m p q, n <= m -> p <= q -> n * p <= m * q. -Proof. -intros; apply mul_le_mono_nonneg; try assumption; apply le_0_l. -Qed. - -Theorem lt_0_mul' : forall n m, n * m > 0 <-> n > 0 /\ m > 0. -Proof. -intros n m; split; [intro H | intros [H1 H2]]. -- apply lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. - + now split. - + false_hyp H1 nlt_0_r. -- now apply mul_pos_pos. -Qed. - -Notation mul_pos := lt_0_mul' (only parsing). - -Theorem eq_mul_1 : forall n m, n * m == 1 <-> n == 1 /\ m == 1. -Proof. -intros n m. -split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l]. -intro H; destruct (lt_trichotomy n 1) as [H1 | [H1 | H1]]. -- apply lt_1_r in H1. rewrite H1, mul_0_l in H. order'. -- rewrite H1, mul_1_l in H; now split. -- destruct (eq_0_gt_0_cases m) as [H2 | H2]. - + rewrite H2, mul_0_r in H. order'. - + apply (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1. - assert (H3 : 1 < n * m) by now apply (lt_1_l m). - rewrite H in H3; false_hyp H3 lt_irrefl. -Qed. - -(** Alternative name : *) - -Definition mul_eq_1 := eq_mul_1. + Theorem square_lt_mono : forall n m, n < m <-> n * n < m * m. + Proof. + intros n m; split; intro; + [apply square_lt_mono_nonneg | apply square_lt_simpl_nonneg]; + try assumption; apply le_0_l. + Qed. + + Theorem square_le_mono : forall n m, n <= m <-> n * n <= m * m. + Proof. + intros n m; split; intro; + [apply square_le_mono_nonneg | apply square_le_simpl_nonneg]; + try assumption; apply le_0_l. + Qed. + + Theorem mul_le_mono_l : forall n m p, n <= m -> p * n <= p * m. + Proof. + intros; apply mul_le_mono_nonneg_l. + - apply le_0_l. + - assumption. + Qed. + + Theorem mul_le_mono_r : forall n m p, n <= m -> n * p <= m * p. + Proof. + intros; apply mul_le_mono_nonneg_r. + - apply le_0_l. + - assumption. + Qed. + + Theorem le_mul_l : forall n m, m ~= 0 -> n <= m * n. + Proof. + intros n m D%neq_0_le_1; rewrite <-(mul_1_l n) at 1. + apply mul_le_mono_r; exact D. + Qed. + + Theorem le_mul_r : forall n m, m ~= 0 -> n <= n * m. + Proof. + intros n m; rewrite mul_comm; exact (le_mul_l _ _). + Qed. + + Theorem mul_lt_mono : forall n m p q, n < m -> p < q -> n * p < m * q. + Proof. + intros; apply mul_lt_mono_nonneg; try assumption; apply le_0_l. + Qed. + + Theorem mul_le_mono : forall n m p q, n <= m -> p <= q -> n * p <= m * q. + Proof. + intros; apply mul_le_mono_nonneg; try assumption; apply le_0_l. + Qed. + + Theorem lt_0_mul' : forall n m, n * m > 0 <-> n > 0 /\ m > 0. + Proof. + intros n m; split; [intro H | intros [H1 H2]]. + - apply lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. + + now split. + + false_hyp H1 nlt_0_r. + - now apply mul_pos_pos. + Qed. + + Notation mul_pos := lt_0_mul' (only parsing). + + Theorem eq_mul_1 : forall n m, n * m == 1 <-> n == 1 /\ m == 1. + Proof. + intros n m. + split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l]. + intro H; destruct (lt_trichotomy n 1) as [H1 | [H1 | H1]]. + - apply lt_1_r in H1. rewrite H1, mul_0_l in H. order'. + - rewrite H1, mul_1_l in H; now split. + - destruct (eq_0_gt_0_cases m) as [H2 | H2]. + + rewrite H2, mul_0_r in H. order'. + + apply (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1. + assert (H3 : 1 < n * m) by now apply (lt_1_l m). + rewrite H in H3; false_hyp H3 lt_irrefl. + Qed. + + (** Alternative name : *) + + Definition mul_eq_1 := eq_mul_1. End NMulOrderProp. diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 4554c4b116..68eaf49658 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -13,282 +13,282 @@ From Stdlib Require Export NAdd. Module NOrderProp (Import N : NAxiomsMiniSig'). -Include NAddProp N. - -(* Theorems that are true for natural numbers but not for integers *) - -Theorem lt_wf_0 : well_founded lt. -Proof. -setoid_replace lt with (fun n m => 0 <= n < m). -- apply lt_wf. -- intros x y; split. - + intro H; split; [apply le_0_l | assumption]. - + now intros [_ H]. -Defined. - -(* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *) - -Theorem nlt_0_r : forall n, ~ n < 0. -Proof. -intro n; apply le_ngt. apply le_0_l. -Qed. - -Theorem nle_succ_0 : forall n, ~ (S n <= 0). -Proof. -intros n H; apply le_succ_l in H; false_hyp H nlt_0_r. -Qed. - -Theorem le_0_r : forall n, n <= 0 <-> n == 0. -Proof. -intros n; split; intro H. -- le_elim H; [false_hyp H nlt_0_r | assumption]. -- now apply eq_le_incl. -Qed. - -Theorem lt_0_succ : forall n, 0 < S n. -Proof. -intro n; induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. -Qed. - -Theorem le_1_succ : forall n, 1 <= S n. -Proof. -intros n; rewrite one_succ; apply ->succ_le_mono; exact (le_0_l _). -Qed. - -Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. -Proof. -intro n; cases n. -- split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. -- intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. -Qed. - -Theorem neq_0_le_1 : forall n, n ~= 0 <-> 1 <= n. -Proof. -intros n; split. -- intros <-%succ_pred; exact (le_1_succ _). -- intros H E; rewrite E, one_succ in H; apply (nle_succ_0 0); exact H. -Qed. - -Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. -Proof. -intro n; cases n. -- now left. -- intro; right; apply lt_0_succ. -Qed. - -Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. -Proof. -setoid_rewrite one_succ. -intro n; induct n. { now left. } -intro n; cases n. { intros; right; now left. } -intros n IH. destruct IH as [H | [H | H]]. -- false_hyp H neq_succ_0. -- right; right. rewrite H. apply lt_succ_diag_r. -- right; right. now apply lt_lt_succ_r. -Qed. - -Theorem lt_1_r : forall n, n < 1 <-> n == 0. -Proof. -setoid_rewrite one_succ. -intro n; cases n. -- split; intro; [reflexivity | apply lt_succ_diag_r]. -- intros n. rewrite <- succ_lt_mono. - split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. -Qed. - -Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. -Proof. -setoid_rewrite one_succ. -intro n; cases n. -- split; intro; [now left | apply le_succ_diag_r]. -- intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. - split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. -Qed. - -Theorem lt_lt_0 : forall n m, n < m -> 0 < m. -Proof. -intros n m; induct n. -- trivial. -- intros n IH H. apply IH; now apply lt_succ_l. -Qed. - -Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. -Proof. -intros n m p H H0. apply lt_1_l with m; auto. -apply le_lt_trans with n; auto. now apply le_0_l. -Qed. - -(** Elimination principlies for < and <= for relations *) - -Section RelElim. - -Variable R : relation N.t. -Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. - -Theorem le_ind_rel : - (forall m, R 0 m) -> - (forall n m, n <= m -> R n m -> R (S n) (S m)) -> - forall n m, n <= m -> R n m. -Proof. -intros Base Step n; induct n. -{ intros; apply Base. } -intros n IH m H. elim H using le_ind. -- solve_proper. -- apply Step; [| apply IH]; now apply eq_le_incl. -- intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto. -Qed. - -Theorem lt_ind_rel : - (forall m, R 0 (S m)) -> - (forall n m, n < m -> R n m -> R (S n) (S m)) -> - forall n m, n < m -> R n m. -Proof. -intros Base Step n; induct n. -- intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. - rewrite H; apply Base. -- intros n IH m H. elim H using lt_ind. - + solve_proper. - + apply Step; [| apply IH]; now apply lt_succ_diag_r. - + intros k H1 H2. apply lt_succ_l in H1. auto. -Qed. - -End RelElim. - -(** Predecessor and order *) - -Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n. -Proof. -intros n H; apply succ_pred; intro H1; rewrite H1 in H. -false_hyp H lt_irrefl. -Qed. - -Theorem le_pred_l : forall n, P n <= n. -Proof. -intro n; cases n. -- rewrite pred_0; now apply eq_le_incl. -- intros; rewrite pred_succ; apply le_succ_diag_r. -Qed. - -Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. -Proof. -intro n; cases n. -- intro H; exfalso; now apply H. -- intros; rewrite pred_succ; apply lt_succ_diag_r. -Qed. - -Theorem le_le_pred : forall n m, n <= m -> P n <= m. -Proof. - intros n m H; apply le_trans with n. - - apply le_pred_l. - - assumption. -Qed. - -Theorem lt_lt_pred : forall n m, n < m -> P n < m. -Proof. - intros n m H; apply le_lt_trans with n. - - apply le_pred_l. - - assumption. -Qed. - -Theorem lt_le_pred : forall n m, n < m -> n <= P m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m; cases m. -- intro H; false_hyp H nlt_0_r. -- intros m IH. rewrite pred_succ; now apply lt_succ_r. -Qed. - -Theorem lt_pred_le : forall n m, P n < m -> n <= m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m; cases n. -- rewrite pred_0; intro H; now apply lt_le_incl. -- intros n IH. rewrite pred_succ in IH. now apply le_succ_l. -Qed. - -Theorem lt_pred_lt : forall n m, n < P m -> n < m. -Proof. -intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l]. -Qed. - -Theorem le_pred_le : forall n m, n <= P m -> n <= m. -Proof. -intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l]. -Qed. - -Theorem pred_le_mono : forall n m, n <= m -> P n <= P m. - (* Converse is false for n == 1, m == 0 *) -Proof. -intros n m H; elim H using le_ind_rel. -- solve_proper. -- intro; rewrite pred_0; apply le_0_l. -- intros p q H1 _; now do 2 rewrite pred_succ. -Qed. - -Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m). -Proof. -intros n m H1; split; intro H2. -- assert (m ~= 0). { apply neq_0_lt_0. now apply lt_lt_0 with n. } - now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ; - [apply succ_lt_mono | | |]. -- assert (m ~= 0). - { apply neq_0_lt_0. apply lt_lt_0 with (P n). - apply lt_le_trans with (P m). + Include NAddProp N. + + (* Theorems that are true for natural numbers but not for integers *) + + Theorem lt_wf_0 : well_founded lt. + Proof. + setoid_replace lt with (fun n m => 0 <= n < m). + - apply lt_wf. + - intros x y; split. + + intro H; split; [apply le_0_l | assumption]. + + now intros [_ H]. + Defined. + + (* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *) + + Theorem nlt_0_r : forall n, ~ n < 0. + Proof. + intro n; apply le_ngt. apply le_0_l. + Qed. + + Theorem nle_succ_0 : forall n, ~ (S n <= 0). + Proof. + intros n H; apply le_succ_l in H; false_hyp H nlt_0_r. + Qed. + + Theorem le_0_r : forall n, n <= 0 <-> n == 0. + Proof. + intros n; split; intro H. + - le_elim H; [false_hyp H nlt_0_r | assumption]. + - now apply eq_le_incl. + Qed. + + Theorem lt_0_succ : forall n, 0 < S n. + Proof. + intro n; induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. + Qed. + + Theorem le_1_succ : forall n, 1 <= S n. + Proof. + intros n; rewrite one_succ; apply ->succ_le_mono; exact (le_0_l _). + Qed. + + Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. + Proof. + intro n; cases n. + - split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. + - intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. + Qed. + + Theorem neq_0_le_1 : forall n, n ~= 0 <-> 1 <= n. + Proof. + intros n; split. + - intros <-%succ_pred; exact (le_1_succ _). + - intros H E; rewrite E, one_succ in H; apply (nle_succ_0 0); exact H. + Qed. + + Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. + Proof. + intro n; cases n. + - now left. + - intro; right; apply lt_0_succ. + Qed. + + Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. + Proof. + setoid_rewrite one_succ. + intro n; induct n. { now left. } + intro n; cases n. { intros; right; now left. } + intros n IH. destruct IH as [H | [H | H]]. + - false_hyp H neq_succ_0. + - right; right. rewrite H. apply lt_succ_diag_r. + - right; right. now apply lt_lt_succ_r. + Qed. + + Theorem lt_1_r : forall n, n < 1 <-> n == 0. + Proof. + setoid_rewrite one_succ. + intro n; cases n. + - split; intro; [reflexivity | apply lt_succ_diag_r]. + - intros n. rewrite <- succ_lt_mono. + split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. + Qed. + + Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. + Proof. + setoid_rewrite one_succ. + intro n; cases n. + - split; intro; [now left | apply le_succ_diag_r]. + - intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. + split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. + Qed. + + Theorem lt_lt_0 : forall n m, n < m -> 0 < m. + Proof. + intros n m; induct n. + - trivial. + - intros n IH H. apply IH; now apply lt_succ_l. + Qed. + + Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. + Proof. + intros n m p H H0. apply lt_1_l with m; auto. + apply le_lt_trans with n; auto. now apply le_0_l. + Qed. + + (** Elimination principlies for < and <= for relations *) + + Section RelElim. + + Variable R : relation N.t. + Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. + + Theorem le_ind_rel : + (forall m, R 0 m) -> + (forall n m, n <= m -> R n m -> R (S n) (S m)) -> + forall n m, n <= m -> R n m. + Proof. + intros Base Step n; induct n. + { intros; apply Base. } + intros n IH m H. elim H using le_ind. + - solve_proper. + - apply Step; [| apply IH]; now apply eq_le_incl. + - intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto. + Qed. + + Theorem lt_ind_rel : + (forall m, R 0 (S m)) -> + (forall n m, n < m -> R n m -> R (S n) (S m)) -> + forall n m, n < m -> R n m. + Proof. + intros Base Step n; induct n. + - intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. + rewrite H; apply Base. + - intros n IH m H. elim H using lt_ind. + + solve_proper. + + apply Step; [| apply IH]; now apply lt_succ_diag_r. + + intros k H1 H2. apply lt_succ_l in H1. auto. + Qed. + + End RelElim. + + (** Predecessor and order *) + + Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n. + Proof. + intros n H; apply succ_pred; intro H1; rewrite H1 in H. + false_hyp H lt_irrefl. + Qed. + + Theorem le_pred_l : forall n, P n <= n. + Proof. + intro n; cases n. + - rewrite pred_0; now apply eq_le_incl. + - intros; rewrite pred_succ; apply le_succ_diag_r. + Qed. + + Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. + Proof. + intro n; cases n. + - intro H; exfalso; now apply H. + - intros; rewrite pred_succ; apply lt_succ_diag_r. + Qed. + + Theorem le_le_pred : forall n m, n <= m -> P n <= m. + Proof. + intros n m H; apply le_trans with n. + - apply le_pred_l. - assumption. + Qed. + + Theorem lt_lt_pred : forall n m, n < m -> P n < m. + Proof. + intros n m H; apply le_lt_trans with n. - apply le_pred_l. - } - apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2. -Qed. - -Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. -Proof. -intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ. -Qed. - -Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m H. apply lt_le_pred. now apply le_succ_l. -Qed. - -Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m H. apply lt_succ_r. now apply lt_pred_le. -Qed. - -Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m. -Proof. -intros n m; cases n. -- rewrite pred_0. split; intro H; apply le_0_l. -- intro n. rewrite pred_succ. apply succ_le_mono. -Qed. - -Lemma measure_induction : forall (X : Type) (f : X -> t) (A : X -> Type), - (forall x, (forall y, f y < f x -> A y) -> A x) -> - forall x, A x. -Proof. - intros X f A IH x. apply (measure_right_induction X f A 0); [|apply le_0_l]. - intros y _ IH'. apply IH. intros. apply IH'. now split; [apply le_0_l|]. -Defined. - -(* This is kept private in order to drop the [Proper] condition in + - assumption. + Qed. + + Theorem lt_le_pred : forall n m, n < m -> n <= P m. + (* Converse is false for n == m == 0 *) + Proof. + intros n m; cases m. + - intro H; false_hyp H nlt_0_r. + - intros m IH. rewrite pred_succ; now apply lt_succ_r. + Qed. + + Theorem lt_pred_le : forall n m, P n < m -> n <= m. + (* Converse is false for n == m == 0 *) + Proof. + intros n m; cases n. + - rewrite pred_0; intro H; now apply lt_le_incl. + - intros n IH. rewrite pred_succ in IH. now apply le_succ_l. + Qed. + + Theorem lt_pred_lt : forall n m, n < P m -> n < m. + Proof. + intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l]. + Qed. + + Theorem le_pred_le : forall n m, n <= P m -> n <= m. + Proof. + intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l]. + Qed. + + Theorem pred_le_mono : forall n m, n <= m -> P n <= P m. + (* Converse is false for n == 1, m == 0 *) + Proof. + intros n m H; elim H using le_ind_rel. + - solve_proper. + - intro; rewrite pred_0; apply le_0_l. + - intros p q H1 _; now do 2 rewrite pred_succ. + Qed. + + Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m). + Proof. + intros n m H1; split; intro H2. + - assert (m ~= 0). { apply neq_0_lt_0. now apply lt_lt_0 with n. } + now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ; + [apply succ_lt_mono | | |]. + - assert (m ~= 0). + { apply neq_0_lt_0. apply lt_lt_0 with (P n). + apply lt_le_trans with (P m). + - assumption. + - apply le_pred_l. + } + apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2. + Qed. + + Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. + Proof. + intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ. + Qed. + + Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m. + (* Converse is false for n == m == 0 *) + Proof. + intros n m H. apply lt_le_pred. now apply le_succ_l. + Qed. + + Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m. + (* Converse is false for n == m == 0 *) + Proof. + intros n m H. apply lt_succ_r. now apply lt_pred_le. + Qed. + + Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m. + Proof. + intros n m; cases n. + - rewrite pred_0. split; intro H; apply le_0_l. + - intro n. rewrite pred_succ. apply succ_le_mono. + Qed. + + Lemma measure_induction : forall (X : Type) (f : X -> t) (A : X -> Type), + (forall x, (forall y, f y < f x -> A y) -> A x) -> + forall x, A x. + Proof. + intros X f A IH x. apply (measure_right_induction X f A 0); [|apply le_0_l]. + intros y _ IH'. apply IH. intros. apply IH'. now split; [apply le_0_l|]. + Defined. + + (* This is kept private in order to drop the [Proper] condition in implementations. *) -(* begin hide *) -Theorem Private_strong_induction_le {A : t -> Prop} : - Proper (eq ==> iff) A -> - A 0 -> (forall n, ((forall m, m <= n -> A m) -> A (S n))) -> (forall n, A n). -Proof. - intros H H0 sIH n. - enough (forall k, k <= n -> A k) as key. { - apply key; exact (le_refl _). - } - induct n. - - intros k ->%le_0_r; exact H0. - - intros n I k [Hk%lt_succ_r%I | ->]%lt_eq_cases. - + exact Hk. - + apply sIH; exact I. -Qed. -(* end hide *) + (* begin hide *) + Theorem Private_strong_induction_le {A : t -> Prop} : + Proper (eq ==> iff) A -> + A 0 -> (forall n, ((forall m, m <= n -> A m) -> A (S n))) -> (forall n, A n). + Proof. + intros H H0 sIH n. + enough (forall k, k <= n -> A k) as key. { + apply key; exact (le_refl _). + } + induct n. + - intros k ->%le_0_r; exact H0. + - intros n I k [Hk%lt_succ_r%I | ->]%lt_eq_cases. + + exact Hk. + + apply sIH; exact I. + Qed. + (* end hide *) End NOrderProp. diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v index 14800a285e..a8952b338e 100644 --- a/theories/Numbers/Natural/Abstract/NParity.v +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -14,53 +14,53 @@ From Stdlib Require Import Bool NSub NZParity. Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). -Include NZParityProp N N NP. + Include NZParityProp N N NP. -Lemma odd_pred n : n~=0 -> odd (P n) = even n. -Proof. - intros. rewrite <- (succ_pred n) at 2 by trivial. - symmetry. apply even_succ. -Qed. + Lemma odd_pred n : n~=0 -> odd (P n) = even n. + Proof. + intros. rewrite <- (succ_pred n) at 2 by trivial. + symmetry. apply even_succ. + Qed. -Lemma even_pred n : n~=0 -> even (P n) = odd n. -Proof. - intros. rewrite <- (succ_pred n) at 2 by trivial. - symmetry. apply odd_succ. -Qed. + Lemma even_pred n : n~=0 -> even (P n) = odd n. + Proof. + intros. rewrite <- (succ_pred n) at 2 by trivial. + symmetry. apply odd_succ. + Qed. -Lemma even_sub n m : m<=n -> even (n-m) = Bool.eqb (even n) (even m). -Proof. - intros. - case_eq (even n); case_eq (even m); - rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; - intros (m',Hm) (n',Hn). - - exists (n'-m'). now rewrite mul_sub_distr_l, Hn, Hm. - - exists (n'-m'-1). - rewrite !mul_sub_distr_l, Hn, Hm, sub_add_distr, mul_1_r. - rewrite two_succ at 5. rewrite <- (add_1_l 1). rewrite sub_add_distr. - symmetry. apply sub_add. - apply le_add_le_sub_l. - rewrite add_1_l, <- two_succ, <- (mul_1_r 2) at 1. - rewrite <- mul_sub_distr_l. rewrite <- mul_le_mono_pos_l by order'. - rewrite one_succ, le_succ_l. rewrite <- lt_add_lt_sub_l, add_0_r. - destruct (le_gt_cases n' m') as [LE|GT]; trivial. - generalize (double_below _ _ LE). order. - - exists (n'-m'). rewrite mul_sub_distr_l, Hn, Hm. - apply add_sub_swap. - apply mul_le_mono_pos_l; try order'. - destruct (le_gt_cases m' n') as [LE|GT]; trivial. - generalize (double_above _ _ GT). order. - - exists (n'-m'). rewrite Hm,Hn, mul_sub_distr_l. - rewrite sub_add_distr. rewrite add_sub_swap. - + apply add_sub. - + apply succ_le_mono. - rewrite add_1_r in Hm,Hn. order. -Qed. + Lemma even_sub n m : m<=n -> even (n-m) = Bool.eqb (even n) (even m). + Proof. + intros. + case_eq (even n); case_eq (even m); + rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; + intros (m',Hm) (n',Hn). + - exists (n'-m'). now rewrite mul_sub_distr_l, Hn, Hm. + - exists (n'-m'-1). + rewrite !mul_sub_distr_l, Hn, Hm, sub_add_distr, mul_1_r. + rewrite two_succ at 5. rewrite <- (add_1_l 1). rewrite sub_add_distr. + symmetry. apply sub_add. + apply le_add_le_sub_l. + rewrite add_1_l, <- two_succ, <- (mul_1_r 2) at 1. + rewrite <- mul_sub_distr_l. rewrite <- mul_le_mono_pos_l by order'. + rewrite one_succ, le_succ_l. rewrite <- lt_add_lt_sub_l, add_0_r. + destruct (le_gt_cases n' m') as [LE|GT]; trivial. + generalize (double_below _ _ LE). order. + - exists (n'-m'). rewrite mul_sub_distr_l, Hn, Hm. + apply add_sub_swap. + apply mul_le_mono_pos_l; try order'. + destruct (le_gt_cases m' n') as [LE|GT]; trivial. + generalize (double_above _ _ GT). order. + - exists (n'-m'). rewrite Hm,Hn, mul_sub_distr_l. + rewrite sub_add_distr. rewrite add_sub_swap. + + apply add_sub. + + apply succ_le_mono. + rewrite add_1_r in Hm,Hn. order. + Qed. -Lemma odd_sub n m : m<=n -> odd (n-m) = xorb (odd n) (odd m). -Proof. - intros. rewrite <- !negb_even. rewrite even_sub by trivial. - now destruct (even n), (even m). -Qed. + Lemma odd_sub n m : m<=n -> odd (n-m) = xorb (odd n) (odd m). + Proof. + intros. rewrite <- !negb_even. rewrite even_sub by trivial. + now destruct (even n), (even m). + Qed. End NParityProp. diff --git a/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v index ec4eb3cf04..044e265dbc 100644 --- a/theories/Numbers/Natural/Abstract/NPow.v +++ b/theories/Numbers/Natural/Abstract/NPow.v @@ -15,156 +15,156 @@ From Stdlib Require Import Bool NAxioms NSub NParity NZPow. (** Derived properties of power, specialized on natural numbers *) Module Type NPowProp - (Import A : NAxiomsSig') - (Import B : NSubProp A) - (Import C : NParityProp A B). + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import C : NParityProp A B). - Module Import Private_NZPow := Nop <+ NZPowProp A A B. + Module Import Private_NZPow := Nop <+ NZPowProp A A B. -Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l. -Ltac wrap l := intros; apply l; auto'. + Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l. + Ltac wrap l := intros; apply l; auto'. -Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b. -Proof. wrap pow_succ_r. Qed. + Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b. + Proof. wrap pow_succ_r. Qed. -(** Power and basic constants *) + (** Power and basic constants *) -Lemma pow_0_l : forall a, a~=0 -> 0^a == 0. -Proof. wrap pow_0_l. Qed. + Lemma pow_0_l : forall a, a~=0 -> 0^a == 0. + Proof. wrap pow_0_l. Qed. -Definition pow_1_r : forall a, a^1 == a - := pow_1_r. + Definition pow_1_r : forall a, a^1 == a + := pow_1_r. -Lemma pow_1_l : forall a, 1^a == 1. -Proof. wrap pow_1_l. Qed. + Lemma pow_1_l : forall a, 1^a == 1. + Proof. wrap pow_1_l. Qed. -Definition pow_2_r : forall a, a^2 == a*a - := pow_2_r. + Definition pow_2_r : forall a, a^2 == a*a + := pow_2_r. -(** Power and addition, multiplication *) + (** Power and addition, multiplication *) -Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c. -Proof. wrap pow_add_r. Qed. + Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c. + Proof. wrap pow_add_r. Qed. -Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c. -Proof. wrap pow_mul_l. Qed. + Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c. + Proof. wrap pow_mul_l. Qed. -Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c. -Proof. wrap pow_mul_r. Qed. + Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c. + Proof. wrap pow_mul_r. Qed. -(** Power and nullity *) + (** Power and nullity *) -Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. -Proof. intros a b ? ?. apply (pow_eq_0 a b); trivial. auto'. Qed. + Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. + Proof. intros a b ? ?. apply (pow_eq_0 a b); trivial. auto'. Qed. -Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0. -Proof. wrap pow_nonzero. Qed. + Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0. + Proof. wrap pow_nonzero. Qed. -Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0. -Proof. - intros a b. split. - - rewrite pow_eq_0_iff. intros [H |[H H']]. - + generalize (le_0_l b); order. - + split; order. - - intros (Hb,Ha). rewrite Ha. now apply pow_0_l'. -Qed. + Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0. + Proof. + intros a b. split. + - rewrite pow_eq_0_iff. intros [H |[H H']]. + + generalize (le_0_l b); order. + + split; order. + - intros (Hb,Ha). rewrite Ha. now apply pow_0_l'. + Qed. -(** Monotonicity *) + (** Monotonicity *) -Lemma pow_lt_mono_l : forall a b c, c~=0 -> a a^c < b^c. -Proof. wrap pow_lt_mono_l. Qed. + Lemma pow_lt_mono_l : forall a b c, c~=0 -> a a^c < b^c. + Proof. wrap pow_lt_mono_l. Qed. -Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c. -Proof. wrap pow_le_mono_l. Qed. + Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c. + Proof. wrap pow_le_mono_l. Qed. -Lemma pow_gt_1 : forall a b, 1 b~=0 -> 1 b~=0 -> 1 b a^b < a^c. -Proof. wrap pow_lt_mono_r. Qed. + Lemma pow_lt_mono_r : forall a b c, 1 b a^b < a^c. + Proof. wrap pow_lt_mono_r. Qed. -(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) + (** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) -Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c. -Proof. wrap pow_le_mono_r. Qed. + Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c. + Proof. wrap pow_le_mono_r. Qed. -Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d -> - a^b <= c^d. -Proof. wrap pow_le_mono. Qed. + Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d -> + a^b <= c^d. + Proof. wrap pow_le_mono. Qed. -Definition pow_lt_mono : forall a b c d, 0 0 - a^b < c^d - := pow_lt_mono. + Definition pow_lt_mono : forall a b c d, 0 0 + a^b < c^d + := pow_lt_mono. -(** Injectivity *) + (** Injectivity *) -Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b. -Proof. intros; eapply pow_inj_l; eauto; auto'. Qed. + Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b. + Proof. intros; eapply pow_inj_l; eauto; auto'. Qed. -Lemma pow_inj_r : forall a b c, 1 a^b == a^c -> b == c. -Proof. intros; eapply pow_inj_r; eauto; auto'. Qed. + Lemma pow_inj_r : forall a b c, 1 a^b == a^c -> b == c. + Proof. intros; eapply pow_inj_r; eauto; auto'. Qed. -(** Monotonicity results, both ways *) + (** Monotonicity results, both ways *) -Lemma pow_lt_mono_l_iff : forall a b c, c~=0 -> - (a a^c < b^c). -Proof. wrap pow_lt_mono_l_iff. Qed. + Lemma pow_lt_mono_l_iff : forall a b c, c~=0 -> + (a a^c < b^c). + Proof. wrap pow_lt_mono_l_iff. Qed. -Lemma pow_le_mono_l_iff : forall a b c, c~=0 -> - (a<=b <-> a^c <= b^c). -Proof. wrap pow_le_mono_l_iff. Qed. + Lemma pow_le_mono_l_iff : forall a b c, c~=0 -> + (a<=b <-> a^c <= b^c). + Proof. wrap pow_le_mono_l_iff. Qed. -Lemma pow_lt_mono_r_iff : forall a b c, 1 - (b a^b < a^c). -Proof. wrap pow_lt_mono_r_iff. Qed. + Lemma pow_lt_mono_r_iff : forall a b c, 1 + (b a^b < a^c). + Proof. wrap pow_lt_mono_r_iff. Qed. -Lemma pow_le_mono_r_iff : forall a b c, 1 - (b<=c <-> a^b <= a^c). -Proof. wrap pow_le_mono_r_iff. Qed. + Lemma pow_le_mono_r_iff : forall a b c, 1 + (b<=c <-> a^b <= a^c). + Proof. wrap pow_le_mono_r_iff. Qed. -Lemma pow_lower_bound : forall a b, a~= 0 -> 1 <= a ^ b. -Proof. - intros a b; rewrite <-(pow_0_r a); intros H. - exact (pow_le_mono_r _ _ _ H (le_0_l _)). -Qed. + Lemma pow_lower_bound : forall a b, a~= 0 -> 1 <= a ^ b. + Proof. + intros a b; rewrite <-(pow_0_r a); intros H. + exact (pow_le_mono_r _ _ _ H (le_0_l _)). + Qed. -(** For any a>1, the a^x function is above the identity function *) + (** For any a>1, the a^x function is above the identity function *) -Lemma pow_gt_lin_r : forall a b, 1 b < a^b. -Proof. wrap pow_gt_lin_r. Qed. + Lemma pow_gt_lin_r : forall a b, 1 b < a^b. + Proof. wrap pow_gt_lin_r. Qed. -(** Someday, we should say something about the full Newton formula. + (** Someday, we should say something about the full Newton formula. In the meantime, we can at least provide some inequalities about (a+b)^c. *) -Lemma pow_add_lower : forall a b c, c~=0 -> - a^c + b^c <= (a+b)^c. -Proof. wrap pow_add_lower. Qed. + Lemma pow_add_lower : forall a b c, c~=0 -> + a^c + b^c <= (a+b)^c. + Proof. wrap pow_add_lower. Qed. -(** This upper bound can also be seen as a convexity proof for x^c : + (** This upper bound can also be seen as a convexity proof for x^c : image of (a+b)/2 is below the middle of the images of a and b *) -Lemma pow_add_upper : forall a b c, c~=0 -> - (a+b)^c <= 2^(pred c) * (a^c + b^c). -Proof. wrap pow_add_upper. Qed. - -(** Power and parity *) - -Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a. -Proof. - intros a b Hb. rewrite neq_0_lt_0 in Hb. - apply lt_ind with (4:=Hb). - - solve_proper. - - now nzsimpl. - - clear b Hb. intros b Hb IH. - rewrite pow_succ_r', even_mul, IH. now destruct (even a). -Qed. - -Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a. -Proof. - intros. now rewrite <- !negb_even, even_pow. -Qed. + Lemma pow_add_upper : forall a b c, c~=0 -> + (a+b)^c <= 2^(pred c) * (a^c + b^c). + Proof. wrap pow_add_upper. Qed. + + (** Power and parity *) + + Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a. + Proof. + intros a b Hb. rewrite neq_0_lt_0 in Hb. + apply lt_ind with (4:=Hb). + - solve_proper. + - now nzsimpl. + - clear b Hb. intros b Hb IH. + rewrite pow_succ_r', even_mul, IH. now destruct (even a). + Qed. + + Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a. + Proof. + intros. now rewrite <- !negb_even, even_pow. + Qed. End NPowProp. diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v index b8a1730a7f..87c76ecd54 100644 --- a/theories/Numbers/Natural/Abstract/NProperties.v +++ b/theories/Numbers/Natural/Abstract/NProperties.v @@ -32,9 +32,9 @@ Module Type NExtraProp (N:NAxiomsSig)(P:NBasicProp N) := NExtraPreProp N P <+ NDivProp N P <+ NLcmProp N P <+ NBitsProp N P. Module Type NExtraProp0 (N:NAxiomsSig)(P:NBasicProp N)(D0:NZDivSpec0 N N N)(E:NExtraPreProp N P). - Module Private_NDivProp := Nop <+ NDivProp N P. - Include NDivProp0 N P D0. - Module Private_NLcmProp := Nop <+ NLcmProp N P Private_NDivProp E. - Include NLcmProp0 N P D0 E. - Include NBitsProp N P E E Private_NDivProp E. + Module Private_NDivProp := Nop <+ NDivProp N P. + Include NDivProp0 N P D0. + Module Private_NLcmProp := Nop <+ NLcmProp N P Private_NDivProp E. + Include NLcmProp0 N P D0 E. + Include NBitsProp N P E E Private_NDivProp E. End NExtraProp0. diff --git a/theories/Numbers/Natural/Abstract/NSqrt.v b/theories/Numbers/Natural/Abstract/NSqrt.v index d1005ba06b..3a5a3e71ca 100644 --- a/theories/Numbers/Natural/Abstract/NSqrt.v +++ b/theories/Numbers/Natural/Abstract/NSqrt.v @@ -14,64 +14,64 @@ From Stdlib Require Import NAxioms NSub NZSqrt. Module NSqrtProp (Import A : NAxiomsSig')(Import B : NSubProp A). - Module Import Private_NZSqrt := Nop <+ NZSqrtProp A A B. + Module Import Private_NZSqrt := Nop <+ NZSqrtProp A A B. - Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l. - Ltac wrap l := intros; apply l; auto'. + Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l. + Ltac wrap l := intros; apply l; auto'. - (** We redefine NZSqrt's results, without the non-negative hyps *) + (** We redefine NZSqrt's results, without the non-negative hyps *) -Lemma sqrt_spec' : forall a, √a*√a <= a < S (√a) * S (√a). -Proof. wrap sqrt_spec. Qed. + Lemma sqrt_spec' : forall a, √a*√a <= a < S (√a) * S (√a). + Proof. wrap sqrt_spec. Qed. -Definition sqrt_unique : forall a b, b*b<=a<(S b)*(S b) -> √a == b - := sqrt_unique. + Definition sqrt_unique : forall a b, b*b<=a<(S b)*(S b) -> √a == b + := sqrt_unique. -Lemma sqrt_square : forall a, √(a*a) == a. -Proof. wrap sqrt_square. Qed. + Lemma sqrt_square : forall a, √(a*a) == a. + Proof. wrap sqrt_square. Qed. -Definition sqrt_le_mono : forall a b, a<=b -> √a <= √b - := sqrt_le_mono. + Definition sqrt_le_mono : forall a b, a<=b -> √a <= √b + := sqrt_le_mono. -Definition sqrt_lt_cancel : forall a b, √a < √b -> a < b - := sqrt_lt_cancel. + Definition sqrt_lt_cancel : forall a b, √a < √b -> a < b + := sqrt_lt_cancel. -Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= √a. -Proof. wrap sqrt_le_square. Qed. + Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= √a. + Proof. wrap sqrt_le_square. Qed. -Lemma sqrt_lt_square : forall a b, a √a < b. -Proof. wrap sqrt_lt_square. Qed. + Lemma sqrt_lt_square : forall a b, a √a < b. + Proof. wrap sqrt_lt_square. Qed. -Definition sqrt_0 := sqrt_0. -Definition sqrt_1 := sqrt_1. -Definition sqrt_2 := sqrt_2. + Definition sqrt_0 := sqrt_0. + Definition sqrt_1 := sqrt_1. + Definition sqrt_2 := sqrt_2. -Definition sqrt_lt_lin : forall a, 1 √a √a A) -> N.t -> A) (n : N.t) : A := - recursion (fun _ => a) (fun _ => f) (S n) n. + Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A := + recursion (fun _ => a) (fun _ => f) (S n) n. -(** For convenience, we use in proofs an intermediate definition + (** For convenience, we use in proofs an intermediate definition between [recursion] and [strong_rec]. *) -Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A := - recursion (fun _ => a) (fun _ => f). - -Lemma strong_rec_alt : forall a f n, - strong_rec a f n = strong_rec0 a f (S n) n. -Proof. -reflexivity. -Qed. - -Instance strong_rec0_wd : - Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq) - strong_rec0. -Proof. -unfold strong_rec0; f_equiv'. -Qed. - -Instance strong_rec_wd : - Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec. -Proof. -intros a a' Eaa' f f' Eff' n n' Enn'. -rewrite !strong_rec_alt; f_equiv'. -Qed. - -Section FixPoint. - -Variable f : (N.t -> A) -> N.t -> A. -Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f. - -Lemma strong_rec0_0 : forall a m, - (strong_rec0 a f 0 m) = a. -Proof. -intros. unfold strong_rec0. rewrite recursion_0; auto. -Qed. - -Lemma strong_rec0_succ : forall a n m, - Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m). -Proof. -intros. unfold strong_rec0. -f_equiv. -rewrite recursion_succ; f_equiv'. -Qed. - -Lemma strong_rec_0 : forall a, - Aeq (strong_rec a f 0) (f (fun _ => a) 0). -Proof. -intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'. -rewrite strong_rec0_0. reflexivity. -Qed. - -(* We need an assumption saying that for every n, the step function (f h n) + Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A := + recursion (fun _ => a) (fun _ => f). + + Lemma strong_rec_alt : forall a f n, + strong_rec a f n = strong_rec0 a f (S n) n. + Proof. + reflexivity. + Qed. + + Instance strong_rec0_wd : + Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq) + strong_rec0. + Proof. + unfold strong_rec0; f_equiv'. + Qed. + + Instance strong_rec_wd : + Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec. + Proof. + intros a a' Eaa' f f' Eff' n n' Enn'. + rewrite !strong_rec_alt; f_equiv'. + Qed. + + Section FixPoint. + + Variable f : (N.t -> A) -> N.t -> A. + Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f. + + Lemma strong_rec0_0 : forall a m, + (strong_rec0 a f 0 m) = a. + Proof. + intros. unfold strong_rec0. rewrite recursion_0; auto. + Qed. + + Lemma strong_rec0_succ : forall a n m, + Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m). + Proof. + intros. unfold strong_rec0. + f_equiv. + rewrite recursion_succ; f_equiv'. + Qed. + + Lemma strong_rec_0 : forall a, + Aeq (strong_rec a f 0) (f (fun _ => a) 0). + Proof. + intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'. + rewrite strong_rec0_0. reflexivity. + Qed. + + (* We need an assumption saying that for every n, the step function (f h n) calls h only on the segment [0 ... n - 1]. This means that if h1 and h2 coincide on values < n, then (f h1 n) coincides with (f h2 n) *) -Hypothesis step_good : - forall (n : N.t) (h1 h2 : N.t -> A), - (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n). - -Lemma strong_rec0_more_steps : forall a k n m, m < n -> - Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m). -Proof. - intros a k n. pattern n. - apply induction; clear n. - - - intros n n' Hn; setoid_rewrite Hn; auto with *. - - - intros m Hm. destruct (nlt_0_r _ Hm). - - - intros n IH m Hm. - rewrite lt_succ_r in Hm. - rewrite add_succ_l. - rewrite 2 strong_rec0_succ. - apply step_good. - intros m' Hm'. - apply IH. - apply lt_le_trans with m; auto. -Qed. - -Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t), - Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n). -Proof. -intros. -rewrite strong_rec0_succ. -apply step_good. -intros m Hm. -symmetry. -setoid_replace n with (S m + (n - S m)). -- apply strong_rec0_more_steps. - apply lt_succ_diag_r. -- rewrite add_comm. - symmetry. - apply sub_add. - rewrite le_succ_l; auto. -Qed. - -Theorem strong_rec_fixpoint : forall (a : A) (n : N.t), - Aeq (strong_rec a f n) (f (strong_rec a f) n). -Proof. -intros. -transitivity (f (fun n => strong_rec0 a f (S n) n) n). -- rewrite strong_rec_alt. - apply strong_rec0_fixpoint. -- f_equiv. - intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *. -Qed. - -(** NB: without the [step_good] hypothesis, we have proved that + Hypothesis step_good : + forall (n : N.t) (h1 h2 : N.t -> A), + (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n). + + Lemma strong_rec0_more_steps : forall a k n m, m < n -> + Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m). + Proof. + intros a k n. pattern n. + apply induction; clear n. + + - intros n n' Hn; setoid_rewrite Hn; auto with *. + + - intros m Hm. destruct (nlt_0_r _ Hm). + + - intros n IH m Hm. + rewrite lt_succ_r in Hm. + rewrite add_succ_l. + rewrite 2 strong_rec0_succ. + apply step_good. + intros m' Hm'. + apply IH. + apply lt_le_trans with m; auto. + Qed. + + Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t), + Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n). + Proof. + intros. + rewrite strong_rec0_succ. + apply step_good. + intros m Hm. + symmetry. + setoid_replace n with (S m + (n - S m)). + - apply strong_rec0_more_steps. + apply lt_succ_diag_r. + - rewrite add_comm. + symmetry. + apply sub_add. + rewrite le_succ_l; auto. + Qed. + + Theorem strong_rec_fixpoint : forall (a : A) (n : N.t), + Aeq (strong_rec a f n) (f (strong_rec a f) n). + Proof. + intros. + transitivity (f (fun n => strong_rec0 a f (S n) n) n). + - rewrite strong_rec_alt. + apply strong_rec0_fixpoint. + - f_equiv. + intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *. + Qed. + + (** NB: without the [step_good] hypothesis, we have proved that [strong_rec a f 0] is [f (fun _ => a) 0]. Now we can prove that the first argument of [f] is arbitrary in this case... *) -Theorem strong_rec_0_any : forall (a : A)(any : N.t->A), - Aeq (strong_rec a f 0) (f any 0). -Proof. -intros. -rewrite strong_rec_fixpoint. -apply step_good. -intros m Hm. destruct (nlt_0_r _ Hm). -Qed. - -(** ... and that first argument of [strong_rec] is always arbitrary. *) - -Lemma strong_rec_any_fst_arg : forall a a' n, - Aeq (strong_rec a f n) (strong_rec a' f n). -Proof. -intros a a' n. -generalize (le_refl n). -set (k:=n) at -2. clearbody k. revert k. pattern n. -apply induction; clear n. -- (* compat *) - intros n n' Hn. setoid_rewrite Hn; auto with *. -- (* 0 *) - intros k Hk. rewrite le_0_r in Hk. - rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any. -- (* S *) - intros n IH k Hk. - rewrite 2 strong_rec_fixpoint. - apply step_good. - intros m Hm. - apply IH. - rewrite succ_le_mono. - apply le_trans with k; auto. - rewrite le_succ_l; auto. -Qed. - -End FixPoint. -End StrongRecursion. - -Arguments strong_rec [A] a f n. + Theorem strong_rec_0_any : forall (a : A)(any : N.t->A), + Aeq (strong_rec a f 0) (f any 0). + Proof. + intros. + rewrite strong_rec_fixpoint. + apply step_good. + intros m Hm. destruct (nlt_0_r _ Hm). + Qed. + + (** ... and that first argument of [strong_rec] is always arbitrary. *) + + Lemma strong_rec_any_fst_arg : forall a a' n, + Aeq (strong_rec a f n) (strong_rec a' f n). + Proof. + intros a a' n. + generalize (le_refl n). + set (k:=n) at -2. clearbody k. revert k. pattern n. + apply induction; clear n. + - (* compat *) + intros n n' Hn. setoid_rewrite Hn; auto with *. + - (* 0 *) + intros k Hk. rewrite le_0_r in Hk. + rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any. + - (* S *) + intros n IH k Hk. + rewrite 2 strong_rec_fixpoint. + apply step_good. + intros m Hm. + apply IH. + rewrite succ_le_mono. + apply le_trans with k; auto. + rewrite le_succ_l; auto. + Qed. + + End FixPoint. + End StrongRecursion. + + Arguments strong_rec [A] a f n. End NStrongRecProp. diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index 39aac707a6..3d881af2dc 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -13,342 +13,342 @@ From Stdlib Require Export NMulOrder. Module Type NSubProp (Import N : NAxiomsMiniSig'). -Include NMulOrderProp N. - -Theorem sub_0_l : forall n, 0 - n == 0. -Proof. -intro n; induct n. -- apply sub_0_r. -- intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. -Qed. - -Theorem sub_succ : forall n m, S n - S m == n - m. -Proof. -intros n m; induct m. -- rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. -- intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. -Qed. - -Theorem sub_diag : forall n, n - n == 0. -Proof. - intro n; induct n. - - apply sub_0_r. - - intros n IH; rewrite sub_succ; now rewrite IH. -Qed. - -Theorem sub_gt : forall n m, n > m -> n - m ~= 0. -Proof. -intros n m H; elim H using lt_ind_rel; clear n m H. -- solve_proper. -- intro; rewrite sub_0_r; apply neq_succ_0. -- intros; now rewrite sub_succ. -Qed. - -Theorem add_sub_assoc : forall n m p, p <= m -> n + (m - p) == (n + m) - p. -Proof. -intros n m p; induct p. -- intro; now do 2 rewrite sub_0_r. -- intros p IH H. do 2 rewrite sub_succ_r. - rewrite <- IH by (apply lt_le_incl; now apply le_succ_l). - rewrite add_pred_r by (apply sub_gt; now apply le_succ_l). - reflexivity. -Qed. - -Theorem sub_succ_l : forall n m, n <= m -> S m - n == S (m - n). -Proof. -intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)). -symmetry; now apply add_sub_assoc. -Qed. - -Theorem add_sub : forall n m, (n + m) - m == n. -Proof. -intros n m. rewrite <- add_sub_assoc by (apply le_refl). -rewrite sub_diag; now rewrite add_0_r. -Qed. - -Definition add_simpl_r := add_sub. - -Theorem add_simpl_l : forall n m, (n + m) - n == m. -Proof. -intros n m. rewrite add_comm. apply add_sub. -Qed. - -Theorem add_add_simpl_l_l n m p : (n + m) - (n + p) == m - p. -Proof. -induct n. - now rewrite 2!add_0_l. -intros n Ih. -rewrite 2!add_succ_l. now rewrite sub_succ. -Qed. - -Theorem sub_add : forall n m, n <= m -> (m - n) + n == m. -Proof. -intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption. -rewrite add_comm. apply add_sub. -Qed. - -Theorem add_sub_eq_l : forall n m p, m + p == n -> n - m == p. -Proof. -intros n m p H. symmetry. -assert (H1 : m + p - m == n - m) by now rewrite H. -rewrite add_comm in H1. now rewrite add_sub in H1. -Qed. - -Theorem add_sub_eq_r : forall n m p, m + p == n -> n - p == m. -Proof. -intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l. -Qed. - -(* This could be proved by adding m to both sides. Then the proof would + Include NMulOrderProp N. + + Theorem sub_0_l : forall n, 0 - n == 0. + Proof. + intro n; induct n. + - apply sub_0_r. + - intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. + Qed. + + Theorem sub_succ : forall n m, S n - S m == n - m. + Proof. + intros n m; induct m. + - rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. + - intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. + Qed. + + Theorem sub_diag : forall n, n - n == 0. + Proof. + intro n; induct n. + - apply sub_0_r. + - intros n IH; rewrite sub_succ; now rewrite IH. + Qed. + + Theorem sub_gt : forall n m, n > m -> n - m ~= 0. + Proof. + intros n m H; elim H using lt_ind_rel; clear n m H. + - solve_proper. + - intro; rewrite sub_0_r; apply neq_succ_0. + - intros; now rewrite sub_succ. + Qed. + + Theorem add_sub_assoc : forall n m p, p <= m -> n + (m - p) == (n + m) - p. + Proof. + intros n m p; induct p. + - intro; now do 2 rewrite sub_0_r. + - intros p IH H. do 2 rewrite sub_succ_r. + rewrite <- IH by (apply lt_le_incl; now apply le_succ_l). + rewrite add_pred_r by (apply sub_gt; now apply le_succ_l). + reflexivity. + Qed. + + Theorem sub_succ_l : forall n m, n <= m -> S m - n == S (m - n). + Proof. + intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)). + symmetry; now apply add_sub_assoc. + Qed. + + Theorem add_sub : forall n m, (n + m) - m == n. + Proof. + intros n m. rewrite <- add_sub_assoc by (apply le_refl). + rewrite sub_diag; now rewrite add_0_r. + Qed. + + Definition add_simpl_r := add_sub. + + Theorem add_simpl_l : forall n m, (n + m) - n == m. + Proof. + intros n m. rewrite add_comm. apply add_sub. + Qed. + + Theorem add_add_simpl_l_l n m p : (n + m) - (n + p) == m - p. + Proof. + induct n. + now rewrite 2!add_0_l. + intros n Ih. + rewrite 2!add_succ_l. now rewrite sub_succ. + Qed. + + Theorem sub_add : forall n m, n <= m -> (m - n) + n == m. + Proof. + intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption. + rewrite add_comm. apply add_sub. + Qed. + + Theorem add_sub_eq_l : forall n m p, m + p == n -> n - m == p. + Proof. + intros n m p H. symmetry. + assert (H1 : m + p - m == n - m) by now rewrite H. + rewrite add_comm in H1. now rewrite add_sub in H1. + Qed. + + Theorem add_sub_eq_r : forall n m p, m + p == n -> n - p == m. + Proof. + intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l. + Qed. + + (* This could be proved by adding m to both sides. Then the proof would use add_sub_assoc and sub_0_le, which is proven below. *) -Theorem add_sub_eq_nz : forall n m p, p ~= 0 -> n - m == p -> m + p == n. -Proof. -intros n m p H; double_induct n m. -- intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H. -- intro n; rewrite sub_0_r; now rewrite add_0_l. -- intros n m IH H1. rewrite sub_succ in H1. apply IH in H1. - rewrite add_succ_l; now rewrite H1. -Qed. - -Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. -Proof. -intros n m p; induct p. -- rewrite add_0_r; now rewrite sub_0_r. -- intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. -Qed. - -Theorem add_sub_swap : forall n m p, p <= n -> n + m - p == n - p + m. -Proof. -intros n m p H. -rewrite (add_comm n m). -rewrite <- add_sub_assoc by assumption. -now rewrite (add_comm m (n - p)). -Qed. - -(** Sub and order *) - -Theorem le_sub_l : forall n m, n - m <= n. -Proof. -intros n m; induct m. -- rewrite sub_0_r; now apply eq_le_incl. -- intros m IH. rewrite sub_succ_r. - apply le_trans with (n - m); [apply le_pred_l | assumption]. -Qed. - -Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. -Proof. -intros n m; double_induct n m. -- intro m; split; intro; [apply le_0_l | apply sub_0_l]. -- intro m; rewrite sub_0_r; split; intro H; - [false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. -- intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ. -Qed. - -Theorem sub_pred_l : forall n m, P n - m == P (n - m). -Proof. -intros n m; destruct (zero_or_succ n) as [-> | [k ->]]. -- rewrite pred_0, sub_0_l, pred_0; reflexivity. -- rewrite pred_succ; destruct (lt_ge_cases k m) as [H | H]. - + pose proof H as H'. apply lt_le_incl in H' as ->%sub_0_le. - apply le_succ_l, sub_0_le in H as ->; rewrite pred_0; reflexivity. - + rewrite sub_succ_l, pred_succ by (exact H); reflexivity. -Qed. - -Theorem sub_pred_r : forall n m, m ~= 0 -> m <= n -> n - P m == S (n - m). -Proof. -intros n m H H'; destruct (zero_or_succ m) as [[]%H | [k Hk]]; rewrite Hk in *. -rewrite pred_succ, sub_succ_r, succ_pred; [reflexivity |]. -apply sub_gt, le_succ_l; exact H'. -Qed. - -Theorem sub_add_le : forall n m, n <= n - m + m. -Proof. -intros n m. -destruct (le_ge_cases n m) as [LE|GE]. -- rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. - now rewrite <- sub_0_le. -- rewrite sub_add by assumption. apply le_refl. -Qed. - -Theorem le_sub_le_add_r : forall n m p, - n - p <= m <-> n <= m + p. -Proof. -intros n m p. -split; intros LE. -- rewrite (add_le_mono_r _ _ p) in LE. - apply le_trans with (n-p+p); auto using sub_add_le. -- destruct (le_ge_cases n p) as [LE'|GE]. - + rewrite <- sub_0_le in LE'. rewrite LE'. apply le_0_l. - + rewrite (add_le_mono_r _ _ p). now rewrite sub_add. -Qed. - -Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. -Proof. -intros n m p. rewrite add_comm; apply le_sub_le_add_r. -Qed. - -Theorem lt_sub_lt_add_r : forall n m p, - n - p < m -> n < m + p. -Proof. -intros n m p LT. -rewrite (add_lt_mono_r _ _ p) in LT. -apply le_lt_trans with (n-p+p); auto using sub_add_le. -Qed. - -(** Unfortunately, we do not have [n < m + p -> n - p < m]. + Theorem add_sub_eq_nz : forall n m p, p ~= 0 -> n - m == p -> m + p == n. + Proof. + intros n m p H; double_induct n m. + - intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H. + - intro n; rewrite sub_0_r; now rewrite add_0_l. + - intros n m IH H1. rewrite sub_succ in H1. apply IH in H1. + rewrite add_succ_l; now rewrite H1. + Qed. + + Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. + Proof. + intros n m p; induct p. + - rewrite add_0_r; now rewrite sub_0_r. + - intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. + Qed. + + Theorem add_sub_swap : forall n m p, p <= n -> n + m - p == n - p + m. + Proof. + intros n m p H. + rewrite (add_comm n m). + rewrite <- add_sub_assoc by assumption. + now rewrite (add_comm m (n - p)). + Qed. + + (** Sub and order *) + + Theorem le_sub_l : forall n m, n - m <= n. + Proof. + intros n m; induct m. + - rewrite sub_0_r; now apply eq_le_incl. + - intros m IH. rewrite sub_succ_r. + apply le_trans with (n - m); [apply le_pred_l | assumption]. + Qed. + + Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. + Proof. + intros n m; double_induct n m. + - intro m; split; intro; [apply le_0_l | apply sub_0_l]. + - intro m; rewrite sub_0_r; split; intro H; + [false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. + - intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ. + Qed. + + Theorem sub_pred_l : forall n m, P n - m == P (n - m). + Proof. + intros n m; destruct (zero_or_succ n) as [-> | [k ->]]. + - rewrite pred_0, sub_0_l, pred_0; reflexivity. + - rewrite pred_succ; destruct (lt_ge_cases k m) as [H | H]. + + pose proof H as H'. apply lt_le_incl in H' as ->%sub_0_le. + apply le_succ_l, sub_0_le in H as ->; rewrite pred_0; reflexivity. + + rewrite sub_succ_l, pred_succ by (exact H); reflexivity. + Qed. + + Theorem sub_pred_r : forall n m, m ~= 0 -> m <= n -> n - P m == S (n - m). + Proof. + intros n m H H'; destruct (zero_or_succ m) as [[]%H | [k Hk]]; rewrite Hk in *. + rewrite pred_succ, sub_succ_r, succ_pred; [reflexivity |]. + apply sub_gt, le_succ_l; exact H'. + Qed. + + Theorem sub_add_le : forall n m, n <= n - m + m. + Proof. + intros n m. + destruct (le_ge_cases n m) as [LE|GE]. + - rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. + now rewrite <- sub_0_le. + - rewrite sub_add by assumption. apply le_refl. + Qed. + + Theorem le_sub_le_add_r : forall n m p, + n - p <= m <-> n <= m + p. + Proof. + intros n m p. + split; intros LE. + - rewrite (add_le_mono_r _ _ p) in LE. + apply le_trans with (n-p+p); auto using sub_add_le. + - destruct (le_ge_cases n p) as [LE'|GE]. + + rewrite <- sub_0_le in LE'. rewrite LE'. apply le_0_l. + + rewrite (add_le_mono_r _ _ p). now rewrite sub_add. + Qed. + + Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. + Proof. + intros n m p. rewrite add_comm; apply le_sub_le_add_r. + Qed. + + Theorem lt_sub_lt_add_r : forall n m p, + n - p < m -> n < m + p. + Proof. + intros n m p LT. + rewrite (add_lt_mono_r _ _ p) in LT. + apply le_lt_trans with (n-p+p); auto using sub_add_le. + Qed. + + (** Unfortunately, we do not have [n < m + p -> n - p < m]. For instance [1<0+2] but not [1-2<0]. *) -Theorem lt_sub_lt_add_l : forall n m p, n - m < p -> n < m + p. -Proof. -intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. -Qed. - -Theorem le_add_le_sub_r : forall n m p, n + p <= m -> n <= m - p. -Proof. -intros n m p LE. -apply (add_le_mono_r _ _ p). -rewrite sub_add. -- assumption. -- apply le_trans with (n+p); trivial. - rewrite <- (add_0_l p) at 1. rewrite <- add_le_mono_r. apply le_0_l. -Qed. - -(** Unfortunately, we do not have [n <= m - p -> n + p <= m]. + Theorem lt_sub_lt_add_l : forall n m p, n - m < p -> n < m + p. + Proof. + intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. + Qed. + + Theorem le_add_le_sub_r : forall n m p, n + p <= m -> n <= m - p. + Proof. + intros n m p LE. + apply (add_le_mono_r _ _ p). + rewrite sub_add. + - assumption. + - apply le_trans with (n+p); trivial. + rewrite <- (add_0_l p) at 1. rewrite <- add_le_mono_r. apply le_0_l. + Qed. + + (** Unfortunately, we do not have [n <= m - p -> n + p <= m]. For instance [0<=1-2] but not [2+0<=1]. *) -Theorem le_add_le_sub_l : forall n m p, n + p <= m -> p <= m - n. -Proof. -intros n m p. rewrite add_comm; apply le_add_le_sub_r. -Qed. - -Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. -Proof. -intros n m p. -destruct (le_ge_cases p m) as [LE|GE]. -- rewrite <- (sub_add p m) at 1 by assumption. - now rewrite <- add_lt_mono_r. -- assert (GE' := GE). rewrite <- sub_0_le in GE'; rewrite GE'. - split; intros LT. - + elim (lt_irrefl m). apply le_lt_trans with (n+p); trivial. - rewrite <- (add_0_l m). apply add_le_mono. - * apply le_0_l. - * assumption. - + now elim (nlt_0_r n). -Qed. - -Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. -Proof. -intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. -Qed. - -Theorem sub_lt : forall n m, m <= n -> 0 < m -> n - m < n. -Proof. -intros n m LE LT. -assert (LE' := le_sub_l n m). rewrite lt_eq_cases in LE'. -destruct LE' as [LT'|EQ]. -- assumption. -- apply add_sub_eq_nz in EQ; [|order]. - rewrite (add_lt_mono_r _ _ n), add_0_l in LT. order. -Qed. - -Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p. -Proof. - intros n m p. rewrite le_sub_le_add_r. - transitivity m. - - assumption. - - apply sub_add_le. -Qed. - -Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n. -Proof. - intros n m p. rewrite le_sub_le_add_r. - transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. -Qed. - -Theorem sub_sub_distr : - forall n m p, p <= m -> m <= n -> n - (m - p) == (n - m) + p. -Proof. - intros n m p; revert n m; induct p. - - intros n m _ _; rewrite add_0_r, sub_0_r; reflexivity. - - intros p IH n m H1 H2; rewrite add_succ_r. - destruct (zero_or_succ m) as [Hm | [k Hk]]. - + contradict H1; rewrite Hm; exact (nle_succ_0 _). - + rewrite Hk in *; clear m Hk; rewrite sub_succ; apply <-succ_le_mono in H1. - assert (n - k ~= 0) as ne by (apply sub_gt, le_succ_l; exact H2). - rewrite sub_succ_r, add_pred_l by (exact ne). - rewrite succ_pred by (intros [[]%ne _]%eq_add_0). - apply IH with (1 := H1), le_trans with (2 := H2). - exact (le_succ_diag_r _). -Qed. - -(** Sub and mul *) - -Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. -Proof. -intros n m; cases m. -- now rewrite pred_0, mul_0_r, sub_0_l. -- intro m; rewrite pred_succ, mul_succ_r, <- add_sub_assoc. - + now rewrite sub_diag, add_0_r. - + now apply eq_le_incl. -Qed. - -Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. -Proof. -intros n m p; induct n. -- now rewrite sub_0_l, mul_0_l, sub_0_l. -- intros n IH. destruct (le_gt_cases m n) as [H | H]. - + rewrite sub_succ_l by assumption. do 2 rewrite mul_succ_l. - rewrite (add_comm ((n - m) * p) p), (add_comm (n * p) p). - rewrite <- (add_sub_assoc p (n * p) (m * p)) by now apply mul_le_mono_r. - now apply add_cancel_l. - + assert (H1 : S n <= m) by now apply le_succ_l. - setoid_replace (S n - m) with 0 by now apply sub_0_le. - setoid_replace ((S n * p) - m * p) with 0 by (apply sub_0_le; now apply mul_le_mono_r). - apply mul_0_l. -Qed. - -Theorem mul_sub_distr_l : forall n m p, p * (n - m) == p * n - p * m. -Proof. -intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m). -apply mul_sub_distr_r. -Qed. - -(** Alternative definitions of [<=] and [<] based on [+] *) - -Definition le_alt n m := exists p, p + n == m. -Definition lt_alt n m := exists p, S p + n == m. - -Lemma le_equiv : forall n m, le_alt n m <-> n <= m. -Proof. -intros n m; split. -- intros (p,H). rewrite <- H, add_comm. apply le_add_r. -- intro H. exists (m-n). now apply sub_add. -Qed. - -Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. -Proof. -intros n m; split. -- intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. -- intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. - apply sub_add. now rewrite le_succ_l. -Qed. - -#[global] -Instance le_alt_wd : Proper (eq==>eq==>iff) le_alt. -Proof. - intros x x' Hx y y' Hy; unfold le_alt. - setoid_rewrite Hx. setoid_rewrite Hy. auto with *. -Qed. - -#[global] -Instance lt_alt_wd : Proper (eq==>eq==>iff) lt_alt. -Proof. - intros x x' Hx y y' Hy; unfold lt_alt. - setoid_rewrite Hx. setoid_rewrite Hy. auto with *. -Qed. - -(** With these alternative definition, the dichotomy: + Theorem le_add_le_sub_l : forall n m p, n + p <= m -> p <= m - n. + Proof. + intros n m p. rewrite add_comm; apply le_add_le_sub_r. + Qed. + + Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. + Proof. + intros n m p. + destruct (le_ge_cases p m) as [LE|GE]. + - rewrite <- (sub_add p m) at 1 by assumption. + now rewrite <- add_lt_mono_r. + - assert (GE' := GE). rewrite <- sub_0_le in GE'; rewrite GE'. + split; intros LT. + + elim (lt_irrefl m). apply le_lt_trans with (n+p); trivial. + rewrite <- (add_0_l m). apply add_le_mono. + * apply le_0_l. + * assumption. + + now elim (nlt_0_r n). + Qed. + + Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. + Proof. + intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. + Qed. + + Theorem sub_lt : forall n m, m <= n -> 0 < m -> n - m < n. + Proof. + intros n m LE LT. + assert (LE' := le_sub_l n m). rewrite lt_eq_cases in LE'. + destruct LE' as [LT'|EQ]. + - assumption. + - apply add_sub_eq_nz in EQ; [|order]. + rewrite (add_lt_mono_r _ _ n), add_0_l in LT. order. + Qed. + + Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p. + Proof. + intros n m p. rewrite le_sub_le_add_r. + transitivity m. + - assumption. + - apply sub_add_le. + Qed. + + Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n. + Proof. + intros n m p. rewrite le_sub_le_add_r. + transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. + Qed. + + Theorem sub_sub_distr : + forall n m p, p <= m -> m <= n -> n - (m - p) == (n - m) + p. + Proof. + intros n m p; revert n m; induct p. + - intros n m _ _; rewrite add_0_r, sub_0_r; reflexivity. + - intros p IH n m H1 H2; rewrite add_succ_r. + destruct (zero_or_succ m) as [Hm | [k Hk]]. + + contradict H1; rewrite Hm; exact (nle_succ_0 _). + + rewrite Hk in *; clear m Hk; rewrite sub_succ; apply <-succ_le_mono in H1. + assert (n - k ~= 0) as ne by (apply sub_gt, le_succ_l; exact H2). + rewrite sub_succ_r, add_pred_l by (exact ne). + rewrite succ_pred by (intros [[]%ne _]%eq_add_0). + apply IH with (1 := H1), le_trans with (2 := H2). + exact (le_succ_diag_r _). + Qed. + + (** Sub and mul *) + + Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. + Proof. + intros n m; cases m. + - now rewrite pred_0, mul_0_r, sub_0_l. + - intro m; rewrite pred_succ, mul_succ_r, <- add_sub_assoc. + + now rewrite sub_diag, add_0_r. + + now apply eq_le_incl. + Qed. + + Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. + Proof. + intros n m p; induct n. + - now rewrite sub_0_l, mul_0_l, sub_0_l. + - intros n IH. destruct (le_gt_cases m n) as [H | H]. + + rewrite sub_succ_l by assumption. do 2 rewrite mul_succ_l. + rewrite (add_comm ((n - m) * p) p), (add_comm (n * p) p). + rewrite <- (add_sub_assoc p (n * p) (m * p)) by now apply mul_le_mono_r. + now apply add_cancel_l. + + assert (H1 : S n <= m) by now apply le_succ_l. + setoid_replace (S n - m) with 0 by now apply sub_0_le. + setoid_replace ((S n * p) - m * p) with 0 by (apply sub_0_le; now apply mul_le_mono_r). + apply mul_0_l. + Qed. + + Theorem mul_sub_distr_l : forall n m p, p * (n - m) == p * n - p * m. + Proof. + intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m). + apply mul_sub_distr_r. + Qed. + + (** Alternative definitions of [<=] and [<] based on [+] *) + + Definition le_alt n m := exists p, p + n == m. + Definition lt_alt n m := exists p, S p + n == m. + + Lemma le_equiv : forall n m, le_alt n m <-> n <= m. + Proof. + intros n m; split. + - intros (p,H). rewrite <- H, add_comm. apply le_add_r. + - intro H. exists (m-n). now apply sub_add. + Qed. + + Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. + Proof. + intros n m; split. + - intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. + - intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. + apply sub_add. now rewrite le_succ_l. + Qed. + + #[global] + Instance le_alt_wd : Proper (eq==>eq==>iff) le_alt. + Proof. + intros x x' Hx y y' Hy; unfold le_alt. + setoid_rewrite Hx. setoid_rewrite Hy. auto with *. + Qed. + + #[global] + Instance lt_alt_wd : Proper (eq==>eq==>iff) lt_alt. + Proof. + intros x x' Hx y y' Hy; unfold lt_alt. + setoid_rewrite Hx. setoid_rewrite Hy. auto with *. + Qed. + + (** With these alternative definition, the dichotomy: [forall n m, n <= m \/ m <= n] @@ -360,21 +360,21 @@ We will need this in the proof of induction principle for integers constructed as pairs of natural numbers. This formula can be proved from know properties of [<=]. However, it can also be done directly. *) -Theorem le_alt_dichotomy : forall n m, le_alt n m \/ le_alt m n. -Proof. -intros n m; induct n. -- left; exists m; apply add_0_r. -- intros n IH. - destruct IH as [[p H] | [p H]]. - + destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. - * rewrite add_0_l in H. right; exists (S 0); rewrite H, add_succ_l; - now rewrite add_0_l. - * left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. - + right; exists (S p). rewrite add_succ_l; now rewrite H. -Qed. - -Theorem add_dichotomy : - forall n m, (exists p, p + n == m) \/ (exists p, p + m == n). -Proof. exact le_alt_dichotomy. Qed. + Theorem le_alt_dichotomy : forall n m, le_alt n m \/ le_alt m n. + Proof. + intros n m; induct n. + - left; exists m; apply add_0_r. + - intros n IH. + destruct IH as [[p H] | [p H]]. + + destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. + * rewrite add_0_l in H. right; exists (S 0); rewrite H, add_succ_l; + now rewrite add_0_l. + * left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. + + right; exists (S p). rewrite add_succ_l; now rewrite H. + Qed. + + Theorem add_dichotomy : + forall n m, (exists p, p + n == m) \/ (exists p, p + m == n). + Proof. exact le_alt_dichotomy. Qed. End NSubProp. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index aec12610e9..9945d2009a 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -30,1910 +30,1910 @@ From Stdlib Require Export BinPosDef. are placed in a module [Pos] for qualification purpose. *) Module Pos - <: UsualOrderedTypeFull - <: UsualDecidableTypeFull - <: TotalOrder. + <: UsualOrderedTypeFull + <: UsualDecidableTypeFull + <: TotalOrder. -(** * Definitions of operations, now in a separate file *) + (** * Definitions of operations, now in a separate file *) -Include BinPosDef.Pos. + Include BinPosDef.Pos. -(** In functor applications that follow, we only inline t and eq *) + (** In functor applications that follow, we only inline t and eq *) -Set Inline Level 30. + Set Inline Level 30. -(** * Logical Predicates *) + (** * Logical Predicates *) -Definition eq := @Logic.eq positive. -Definition eq_equiv := @eq_equivalence positive. -Include BackportEq. + Definition eq := @Logic.eq positive. + Definition eq_equiv := @eq_equivalence positive. + Include BackportEq. -Definition lt x y := (x ?= y) = Lt. -Definition gt x y := (x ?= y) = Gt. -Definition le x y := (x ?= y) <> Gt. -Definition ge x y := (x ?= y) <> Lt. + Definition lt x y := (x ?= y) = Lt. + Definition gt x y := (x ?= y) = Gt. + Definition le x y := (x ?= y) <> Gt. + Definition ge x y := (x ?= y) <> Lt. -Infix "<=" := le : positive_scope. -Infix "<" := lt : positive_scope. -Infix ">=" := ge : positive_scope. -Infix ">" := gt : positive_scope. + Infix "<=" := le : positive_scope. + Infix "<" := lt : positive_scope. + Infix ">=" := ge : positive_scope. + Infix ">" := gt : positive_scope. -Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope. -Notation "x < y < z" := (x < y /\ y < z) : positive_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. - -(**********************************************************************) -(** * Properties of operations over positive numbers *) - -(** ** Decidability of equality on binary positive numbers *) - -Lemma eq_dec : forall x y:positive, {x = y} + {x <> y}. -Proof. - decide equality. -Defined. - -(**********************************************************************) -(** * Properties of successor on binary positive numbers *) - -(** ** Specification of [xI] in term of [succ] and [xO] *) - -Lemma xI_succ_xO p : p~1 = succ p~0. -Proof. - reflexivity. -Qed. - -Lemma succ_discr p : p <> succ p. -Proof. - now destruct p. -Qed. - -(** ** Successor and double *) - -Lemma pred_double_spec p : pred_double p = pred (p~0). -Proof. - reflexivity. -Qed. - -Lemma succ_pred_double p : succ (pred_double p) = p~0. -Proof. - induction p; simpl; now f_equal. -Qed. - -Lemma pred_double_succ p : pred_double (succ p) = p~1. -Proof. - induction p; simpl; now f_equal. -Qed. - -Lemma double_succ p : (succ p)~0 = succ (succ p~0). -Proof. - now destruct p. -Qed. - -Lemma pred_double_xO_discr p : pred_double p <> p~0. -Proof. - now destruct p. -Qed. - -(** ** Successor and predecessor *) - -Lemma succ_not_1 p : succ p <> 1. -Proof. - now destruct p. -Qed. - -Lemma pred_succ p : pred (succ p) = p. -Proof. - destruct p; simpl; trivial. apply pred_double_succ. -Qed. - -Lemma succ_pred_or p : p = 1 \/ succ (pred p) = p. -Proof. - destruct p; simpl; auto. - right; apply succ_pred_double. -Qed. - -Lemma succ_pred p : p <> 1 -> succ (pred p) = p. -Proof. - destruct p; intros H; simpl; trivial. - - apply succ_pred_double. - - now destruct H. -Qed. - -(** ** Injectivity of successor *) - -Lemma succ_inj p q : succ p = succ q -> p = q. -Proof. - revert q. - induction p as [p|p|]; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. - - elim (succ_not_1 p); auto. - - elim (succ_not_1 q); auto. -Qed. - -(** ** Predecessor to [N] *) - -Lemma pred_N_succ p : pred_N (succ p) = Npos p. -Proof. - destruct p; simpl; trivial. f_equal. apply pred_double_succ. -Qed. - - -(**********************************************************************) -(** * Properties of addition on binary positive numbers *) - -(** ** Specification of [succ] in term of [add] *) - -Lemma add_1_r p : p + 1 = succ p. -Proof. - now destruct p. -Qed. - -Lemma add_1_l p : 1 + p = succ p. -Proof. - now destruct p. -Qed. - -(** ** Specification of [add_carry] *) - -Theorem add_carry_spec p q : add_carry p q = succ (p + q). -Proof. - revert q. induction p; intro q; destruct q; simpl; now f_equal. -Qed. - -(** ** Commutativity *) - -Theorem add_comm p q : p + q = q + p. -Proof. - revert q. induction p; intro q; destruct q; simpl; f_equal; trivial. - rewrite 2 add_carry_spec; now f_equal. -Qed. - -(** ** Permutation of [add] and [succ] *) - -Theorem add_succ_r p q : p + succ q = succ (p + q). -Proof. - revert q. - induction p; intro q; destruct q; simpl; f_equal; - auto using add_1_r; rewrite add_carry_spec; auto. -Qed. - -Theorem add_succ_l p q : succ p + q = succ (p + q). -Proof. - rewrite add_comm, (add_comm p). apply add_succ_r. -Qed. - -(** ** No neutral elements for addition *) -Lemma add_no_neutral p q : q + p <> p. -Proof. - revert q. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; - destr_eq H; apply (IHp q H). -Qed. - -(** ** Simplification *) - -Lemma add_carry_add p q r s : - add_carry p r = add_carry q s -> p + r = q + s. -Proof. - intros H; apply succ_inj; now rewrite <- 2 add_carry_spec. -Qed. - -Lemma add_reg_r p q r : p + r = q + r -> p = q. -Proof. - revert p q. induction r. - - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; - auto using add_carry_add; contradict H; - rewrite add_carry_spec, <- add_succ_r; auto using add_no_neutral. - - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; - contradict H; auto using add_no_neutral. - - intros p q H. apply succ_inj. now rewrite <- 2 add_1_r. -Qed. - -Lemma add_reg_l p q r : p + q = p + r -> q = r. -Proof. - rewrite 2 (add_comm p). now apply add_reg_r. -Qed. - -Lemma add_cancel_r p q r : p + r = q + r <-> p = q. -Proof. - split. - - apply add_reg_r. - - congruence. -Qed. + Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope. + Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope. + Notation "x < y < z" := (x < y /\ y < z) : positive_scope. + Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. -Lemma add_cancel_l p q r : r + p = r + q <-> p = q. -Proof. - split. - - apply add_reg_l. - - congruence. -Qed. - -Lemma add_carry_reg_r p q r : - add_carry p r = add_carry q r -> p = q. -Proof. - intros H. apply (add_reg_r _ _ r); now apply add_carry_add. -Qed. - -Lemma add_carry_reg_l p q r : - add_carry p q = add_carry p r -> q = r. -Proof. - intros H; apply (add_reg_r _ _ p); - rewrite (add_comm r), (add_comm q); now apply add_carry_add. -Qed. - -(** ** Addition is associative *) - -Theorem add_assoc p q r : p + (q + r) = p + q + r. -Proof. - revert q r. induction p. - - intros [q|q| ] [r|r| ]; simpl; f_equal; trivial; - rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r; - f_equal; trivial. - - intros [q|q| ] [r|r| ]; simpl; f_equal; trivial; - rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r; - f_equal; trivial. - - intros q r; rewrite 2 add_1_l, add_succ_l; auto. -Qed. - -(** ** Commutation of addition and double *) - -Lemma add_xO p q : (p + q)~0 = p~0 + q~0. -Proof. - now destruct p, q. -Qed. + (**********************************************************************) + (** * Properties of operations over positive numbers *) -Lemma add_xI_pred_double p q : - (p + q)~0 = p~1 + pred_double q. -Proof. - change (p~1) with (p~0 + 1). - now rewrite <- add_assoc, add_1_l, succ_pred_double. -Qed. - -Lemma add_xO_pred_double p q : - pred_double (p + q) = p~0 + pred_double q. -Proof. - revert q. induction p as [p IHp| p IHp| ]; intro q; destruct q; simpl; - rewrite ?add_carry_spec, ?pred_double_succ, ?add_xI_pred_double; - try reflexivity. - - rewrite IHp; auto. - - rewrite <- succ_pred_double, <- add_1_l. reflexivity. -Qed. - -(** ** Miscellaneous *) + (** ** Decidability of equality on binary positive numbers *) -Lemma add_diag p : p + p = p~0. -Proof. - induction p as [p IHp| p IHp| ]; simpl; - now rewrite ?add_carry_spec, ?IHp. -Qed. + Lemma eq_dec : forall x y:positive, {x = y} + {x <> y}. + Proof. + decide equality. + Defined. -(**********************************************************************) -(** * Peano induction and recursion on binary positive positive numbers *) - -(** The Peano-like recursor function for [positive] (due to Daniel Schepler) *) - -Fixpoint peano_rect (P:positive->Type) (a:P 1) - (f: forall p:positive, P p -> P (succ p)) (p:positive) : P p := -let f2 := peano_rect (fun p:positive => P (p~0)) (f _ a) - (fun (p:positive) (x:P (p~0)) => f _ (f _ x)) -in -match p with - | q~1 => f _ (f2 q) - | q~0 => f2 q - | 1 => a -end. - -Theorem peano_rect_succ (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (succ p)) (p:positive) : - peano_rect P a f (succ p) = f _ (peano_rect P a f p). -Proof. - revert P a f. induction p as [p IHp|p IHp|]; trivial. - intros. simpl. now rewrite IHp. -Qed. + (**********************************************************************) + (** * Properties of successor on binary positive numbers *) -Theorem peano_rect_base (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (succ p)) : - peano_rect P a f 1 = a. -Proof. - trivial. -Qed. + (** ** Specification of [xI] in term of [succ] and [xO] *) -Definition peano_rec (P:positive->Set) := peano_rect P. + Lemma xI_succ_xO p : p~1 = succ p~0. + Proof. + reflexivity. + Qed. -(** Peano induction *) + Lemma succ_discr p : p <> succ p. + Proof. + now destruct p. + Qed. -Definition peano_ind (P:positive->Prop) := peano_rect P. + (** ** Successor and double *) -(** Peano case analysis *) + Lemma pred_double_spec p : pred_double p = pred (p~0). + Proof. + reflexivity. + Qed. -Theorem peano_case : - forall P:positive -> Prop, - P 1 -> (forall n:positive, P (succ n)) -> forall p:positive, P p. -Proof. - intros; apply peano_ind; auto. -Qed. + Lemma succ_pred_double p : succ (pred_double p) = p~0. + Proof. + induction p; simpl; now f_equal. + Qed. -(** Earlier, the Peano-like recursor was built and proved in a way due to - Conor McBride, see "The view from the left" *) + Lemma pred_double_succ p : pred_double (succ p) = p~1. + Proof. + induction p; simpl; now f_equal. + Qed. -Inductive PeanoView : positive -> Type := -| PeanoOne : PeanoView 1 -| PeanoSucc : forall p, PeanoView p -> PeanoView (succ p). + Lemma double_succ p : (succ p)~0 = succ (succ p~0). + Proof. + now destruct p. + Qed. -Fixpoint peanoView_xO p (q:PeanoView p) : PeanoView (p~0) := - match q in PeanoView x return PeanoView (x~0) with - | PeanoOne => PeanoSucc _ PeanoOne - | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xO _ q)) - end. + Lemma pred_double_xO_discr p : pred_double p <> p~0. + Proof. + now destruct p. + Qed. -Fixpoint peanoView_xI p (q:PeanoView p) : PeanoView (p~1) := - match q in PeanoView x return PeanoView (x~1) with - | PeanoOne => PeanoSucc _ (PeanoSucc _ PeanoOne) - | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xI _ q)) - end. + (** ** Successor and predecessor *) -Fixpoint peanoView p : PeanoView p := - match p return PeanoView p with - | 1 => PeanoOne - | p~0 => peanoView_xO p (peanoView p) - | p~1 => peanoView_xI p (peanoView p) + Lemma succ_not_1 p : succ p <> 1. + Proof. + now destruct p. + Qed. + + Lemma pred_succ p : pred (succ p) = p. + Proof. + destruct p; simpl; trivial. apply pred_double_succ. + Qed. + + Lemma succ_pred_or p : p = 1 \/ succ (pred p) = p. + Proof. + destruct p; simpl; auto. + right; apply succ_pred_double. + Qed. + + Lemma succ_pred p : p <> 1 -> succ (pred p) = p. + Proof. + destruct p; intros H; simpl; trivial. + - apply succ_pred_double. + - now destruct H. + Qed. + + (** ** Injectivity of successor *) + + Lemma succ_inj p q : succ p = succ q -> p = q. + Proof. + revert q. + induction p as [p|p|]; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. + - elim (succ_not_1 p); auto. + - elim (succ_not_1 q); auto. + Qed. + + (** ** Predecessor to [N] *) + + Lemma pred_N_succ p : pred_N (succ p) = Npos p. + Proof. + destruct p; simpl; trivial. f_equal. apply pred_double_succ. + Qed. + + + (**********************************************************************) + (** * Properties of addition on binary positive numbers *) + + (** ** Specification of [succ] in term of [add] *) + + Lemma add_1_r p : p + 1 = succ p. + Proof. + now destruct p. + Qed. + + Lemma add_1_l p : 1 + p = succ p. + Proof. + now destruct p. + Qed. + + (** ** Specification of [add_carry] *) + + Theorem add_carry_spec p q : add_carry p q = succ (p + q). + Proof. + revert q. induction p; intro q; destruct q; simpl; now f_equal. + Qed. + + (** ** Commutativity *) + + Theorem add_comm p q : p + q = q + p. + Proof. + revert q. induction p; intro q; destruct q; simpl; f_equal; trivial. + rewrite 2 add_carry_spec; now f_equal. + Qed. + + (** ** Permutation of [add] and [succ] *) + + Theorem add_succ_r p q : p + succ q = succ (p + q). + Proof. + revert q. + induction p; intro q; destruct q; simpl; f_equal; + auto using add_1_r; rewrite add_carry_spec; auto. + Qed. + + Theorem add_succ_l p q : succ p + q = succ (p + q). + Proof. + rewrite add_comm, (add_comm p). apply add_succ_r. + Qed. + + (** ** No neutral elements for addition *) + Lemma add_no_neutral p q : q + p <> p. + Proof. + revert q. + induction p as [p IHp|p IHp| ]; intros [q|q| ] H; + destr_eq H; apply (IHp q H). + Qed. + + (** ** Simplification *) + + Lemma add_carry_add p q r s : + add_carry p r = add_carry q s -> p + r = q + s. + Proof. + intros H; apply succ_inj; now rewrite <- 2 add_carry_spec. + Qed. + + Lemma add_reg_r p q r : p + r = q + r -> p = q. + Proof. + revert p q. induction r. + - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; + auto using add_carry_add; contradict H; + rewrite add_carry_spec, <- add_succ_r; auto using add_no_neutral. + - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; + contradict H; auto using add_no_neutral. + - intros p q H. apply succ_inj. now rewrite <- 2 add_1_r. + Qed. + + Lemma add_reg_l p q r : p + q = p + r -> q = r. + Proof. + rewrite 2 (add_comm p). now apply add_reg_r. + Qed. + + Lemma add_cancel_r p q r : p + r = q + r <-> p = q. + Proof. + split. + - apply add_reg_r. + - congruence. + Qed. + + Lemma add_cancel_l p q r : r + p = r + q <-> p = q. + Proof. + split. + - apply add_reg_l. + - congruence. + Qed. + + Lemma add_carry_reg_r p q r : + add_carry p r = add_carry q r -> p = q. + Proof. + intros H. apply (add_reg_r _ _ r); now apply add_carry_add. + Qed. + + Lemma add_carry_reg_l p q r : + add_carry p q = add_carry p r -> q = r. + Proof. + intros H; apply (add_reg_r _ _ p); + rewrite (add_comm r), (add_comm q); now apply add_carry_add. + Qed. + + (** ** Addition is associative *) + + Theorem add_assoc p q r : p + (q + r) = p + q + r. + Proof. + revert q r. induction p. + - intros [q|q| ] [r|r| ]; simpl; f_equal; trivial; + rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r; + f_equal; trivial. + - intros [q|q| ] [r|r| ]; simpl; f_equal; trivial; + rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r; + f_equal; trivial. + - intros q r; rewrite 2 add_1_l, add_succ_l; auto. + Qed. + + (** ** Commutation of addition and double *) + + Lemma add_xO p q : (p + q)~0 = p~0 + q~0. + Proof. + now destruct p, q. + Qed. + + Lemma add_xI_pred_double p q : + (p + q)~0 = p~1 + pred_double q. + Proof. + change (p~1) with (p~0 + 1). + now rewrite <- add_assoc, add_1_l, succ_pred_double. + Qed. + + Lemma add_xO_pred_double p q : + pred_double (p + q) = p~0 + pred_double q. + Proof. + revert q. induction p as [p IHp| p IHp| ]; intro q; destruct q; simpl; + rewrite ?add_carry_spec, ?pred_double_succ, ?add_xI_pred_double; + try reflexivity. + - rewrite IHp; auto. + - rewrite <- succ_pred_double, <- add_1_l. reflexivity. + Qed. + + (** ** Miscellaneous *) + + Lemma add_diag p : p + p = p~0. + Proof. + induction p as [p IHp| p IHp| ]; simpl; + now rewrite ?add_carry_spec, ?IHp. + Qed. + + (**********************************************************************) + (** * Peano induction and recursion on binary positive positive numbers *) + + (** The Peano-like recursor function for [positive] (due to Daniel Schepler) *) + + Fixpoint peano_rect (P:positive->Type) (a:P 1) + (f: forall p:positive, P p -> P (succ p)) (p:positive) : P p := + let f2 := peano_rect (fun p:positive => P (p~0)) (f _ a) + (fun (p:positive) (x:P (p~0)) => f _ (f _ x)) + in + match p with + | q~1 => f _ (f2 q) + | q~0 => f2 q + | 1 => a end. -Definition PeanoView_iter (P:positive->Type) - (a:P 1) (f:forall p, P p -> P (succ p)) := - (fix iter p (q:PeanoView p) : P p := - match q in PeanoView p return P p with - | PeanoOne => a - | PeanoSucc _ q => f _ (iter _ q) - end). - -Theorem eq_dep_eq_positive : - forall (P:positive->Type) (p:positive) (x y:P p), - eq_dep positive P p x p y -> x = y. -Proof. - apply eq_dep_eq_dec. - decide equality. -Qed. - -Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. -Proof. - intros p q q'. - induction q as [ | p q IHq ]. - - apply eq_dep_eq_positive. - cut (1=1). - + pattern 1 at 1 2 5, q'. destruct q' as [|p ?]. - * trivial. - * destruct p; intros; discriminate. - + trivial. - - apply eq_dep_eq_positive. - cut (succ p=succ p). - + pattern (succ p) at 1 2 5, q'. destruct q' as [|? q']. - * intro. destruct p; discriminate. - * intro H. apply succ_inj in H. - generalize q'. rewrite H. intro q'0. - rewrite (IHq q'0). - trivial. - + trivial. -Qed. - -Lemma peano_equiv (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) p : - PeanoView_iter P a f p (peanoView p) = peano_rect P a f p. -Proof. - revert P a f. induction p as [|p IHp] using peano_rect. - - trivial. - - intros; simpl. rewrite peano_rect_succ. - rewrite (PeanoViewUnique _ (peanoView (succ p)) (PeanoSucc _ (peanoView p))). - simpl; now f_equal. -Qed. - -(**********************************************************************) -(** * Properties of multiplication on binary positive numbers *) - -(** ** One is neutral for multiplication *) - -Lemma mul_1_l p : 1 * p = p. -Proof. - reflexivity. -Qed. - -Lemma mul_1_r p : p * 1 = p. -Proof. - induction p; simpl; now f_equal. -Qed. - -(** ** Right reduction properties for multiplication *) - -Lemma mul_xO_r p q : p * q~0 = (p * q)~0. -Proof. - induction p; simpl; f_equal; f_equal; trivial. -Qed. - -Lemma mul_xI_r p q : p * q~1 = p + (p * q)~0. -Proof. - induction p as [p IHp|p IHp| ]; simpl; f_equal; trivial. - now rewrite IHp, 2 add_assoc, (add_comm p). -Qed. - -(** ** Commutativity of multiplication *) - -Theorem mul_comm p q : p * q = q * p. -Proof. - induction q as [q IHq|q IHq| ]; simpl; rewrite <- ? IHq; - auto using mul_xI_r, mul_xO_r, mul_1_r. -Qed. - -(** ** Distributivity of multiplication over addition *) - -Theorem mul_add_distr_l p q r : - p * (q + r) = p * q + p * r. -Proof. - induction p as [p IHp|p IHp| ]; simpl. - - rewrite IHp. set (m:=(p*q)~0). set (n:=(p*r)~0). - change ((p*q+p*r)~0) with (m+n). - rewrite 2 add_assoc; f_equal. - rewrite <- 2 add_assoc; f_equal. - apply add_comm. - - f_equal; auto. - - reflexivity. -Qed. - -Theorem mul_add_distr_r p q r : - (p + q) * r = p * r + q * r. -Proof. - rewrite 3 (mul_comm _ r); apply mul_add_distr_l. -Qed. - -(** ** Associativity of multiplication *) - -Theorem mul_assoc p q r : p * (q * r) = p * q * r. -Proof. - induction p as [p IHp| p IHp | ]; simpl; rewrite ?IHp; trivial. - now rewrite mul_add_distr_r. -Qed. - -(** ** Successor and multiplication *) - -Lemma mul_succ_l p q : (succ p) * q = q + p * q. -Proof. - induction p as [p IHp | p IHp | ]; simpl; trivial. - - now rewrite IHp, add_assoc, add_diag, <-add_xO. - - symmetry; apply add_diag. -Qed. - -Lemma mul_succ_r p q : p * (succ q) = p + p * q. -Proof. - rewrite mul_comm, mul_succ_l. f_equal. apply mul_comm. -Qed. - -(** ** Parity properties of multiplication *) - -Lemma mul_xI_mul_xO_discr p q r : p~1 * r <> q~0 * r. -Proof. - induction r; try discriminate. - rewrite 2 mul_xO_r; intro H; destr_eq H; auto. -Qed. - -Lemma mul_xO_discr p q : p~0 * q <> q. -Proof. - induction q; try discriminate. - rewrite mul_xO_r; injection; auto. -Qed. - -(** ** Simplification properties of multiplication *) - -Theorem mul_reg_r p q r : p * r = q * r -> p = q. -Proof. - revert q r. - induction p as [p IHp| p IHp| ]; intros [q|q| ] r H; - reflexivity || apply f_equal || exfalso. - - apply IHp with (r~0). simpl in *. - rewrite 2 mul_xO_r. apply add_reg_l with (1:=H). - - contradict H. apply mul_xI_mul_xO_discr. - - contradict H. simpl. rewrite add_comm. apply add_no_neutral. - - symmetry in H. contradict H. apply mul_xI_mul_xO_discr. - - apply IHp with (r~0). simpl. now rewrite 2 mul_xO_r. - - contradict H. apply mul_xO_discr. - - symmetry in H. contradict H. simpl. rewrite add_comm. - apply add_no_neutral. - - symmetry in H. contradict H. apply mul_xO_discr. -Qed. - -Theorem mul_reg_l p q r : r * p = r * q -> p = q. -Proof. - rewrite 2 (mul_comm r). apply mul_reg_r. -Qed. - -Lemma mul_cancel_r p q r : p * r = q * r <-> p = q. -Proof. - split. - - apply mul_reg_r. - - congruence. -Qed. - -Lemma mul_cancel_l p q r : r * p = r * q <-> p = q. -Proof. - split. - - apply mul_reg_l. - - congruence. -Qed. - -(** ** Inversion of multiplication *) - -Lemma mul_eq_1_l p q : p * q = 1 -> p = 1. -Proof. - now destruct p, q. -Qed. - -Lemma mul_eq_1_r p q : p * q = 1 -> q = 1. -Proof. - now destruct p, q. -Qed. - -Notation mul_eq_1 := mul_eq_1_l. - -(** ** Square *) - -Lemma square_xO p : p~0 * p~0 = (p*p)~0~0. -Proof. - simpl. now rewrite mul_comm. -Qed. - -Lemma square_xI p : p~1 * p~1 = (p*p+p)~0~1. -Proof. - simpl. rewrite mul_comm. simpl. f_equal. - rewrite add_assoc, add_diag. simpl. now rewrite add_comm. -Qed. - -(** ** Properties of [iter] *) - -Lemma iter_swap_gen A B (f:A->B)(g:A->A)(h:B->B) : - (forall a, f (g a) = h (f a)) -> forall p a, - f (iter g a p) = iter h (f a) p. -Proof. - intros H p; induction p as [p IHp|p IHp|]; simpl; intros; now rewrite ?H, ?IHp. -Qed. - -Theorem iter_swap : - forall p (A:Type) (f:A -> A) (x:A), - iter f (f x) p = f (iter f x p). -Proof. - intros. symmetry. now apply iter_swap_gen. -Qed. - -Theorem iter_succ : - forall p (A:Type) (f:A -> A) (x:A), - iter f x (succ p) = f (iter f x p). -Proof. - intro p; induction p as [p IHp|p IHp|]; intros; simpl; trivial. - now rewrite !IHp, iter_swap. -Qed. - -Theorem iter_succ_r : - forall p (A:Type) (f:A -> A) (x:A), - iter f x (succ p) = iter f (f x) p. -Proof. - intros; now rewrite iter_succ, iter_swap. -Qed. - -Theorem iter_add : - forall p q (A:Type) (f:A -> A) (x:A), - iter f x (p+q) = iter f (iter f x q) p. -Proof. - intro p; induction p as [|p IHp] using peano_ind; intros. - - now rewrite add_1_l, iter_succ. - - now rewrite add_succ_l, !iter_succ, IHp. -Qed. + Theorem peano_rect_succ (P:positive->Type) (a:P 1) + (f:forall p, P p -> P (succ p)) (p:positive) : + peano_rect P a f (succ p) = f _ (peano_rect P a f p). + Proof. + revert P a f. induction p as [p IHp|p IHp|]; trivial. + intros. simpl. now rewrite IHp. + Qed. -Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop) : - P 1 (f a) -> - (forall p a', P p a' -> P (succ p) (f a')) -> - forall p, P p (iter f a p). -Proof. - intros ? ? p; induction p as [|p IHp] using peano_ind; trivial. - rewrite iter_succ; auto. -Qed. + Theorem peano_rect_base (P:positive->Type) (a:P 1) + (f:forall p, P p -> P (succ p)) : + peano_rect P a f 1 = a. + Proof. + trivial. + Qed. -Theorem iter_invariant : - forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop), - (forall x:A, Inv x -> Inv (f x)) -> - forall x:A, Inv x -> Inv (iter f x p). -Proof. - intros; apply iter_ind; auto. -Qed. + Definition peano_rec (P:positive->Set) := peano_rect P. -(** ** Properties of power *) + (** Peano induction *) -Lemma pow_1_r p : p^1 = p. -Proof. - unfold pow. simpl. now rewrite mul_comm. -Qed. + Definition peano_ind (P:positive->Prop) := peano_rect P. -Lemma pow_succ_r p q : p^(succ q) = p * p^q. -Proof. - unfold pow. now rewrite iter_succ. -Qed. + (** Peano case analysis *) -(** ** Properties of square *) + Theorem peano_case : + forall P:positive -> Prop, + P 1 -> (forall n:positive, P (succ n)) -> forall p:positive, P p. + Proof. + intros; apply peano_ind; auto. + Qed. -Lemma square_spec p : square p = p * p. -Proof. - induction p as [p IHp|p IHp|]. - - rewrite square_xI. simpl. now rewrite IHp. - - rewrite square_xO. simpl. now rewrite IHp. - - trivial. -Qed. + (** Earlier, the Peano-like recursor was built and proved in a way due to + Conor McBride, see "The view from the left" *) -(** ** Properties of [sub_mask] *) + Inductive PeanoView : positive -> Type := + | PeanoOne : PeanoView 1 + | PeanoSucc : forall p, PeanoView p -> PeanoView (succ p). + + Fixpoint peanoView_xO p (q:PeanoView p) : PeanoView (p~0) := + match q in PeanoView x return PeanoView (x~0) with + | PeanoOne => PeanoSucc _ PeanoOne + | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xO _ q)) + end. + + Fixpoint peanoView_xI p (q:PeanoView p) : PeanoView (p~1) := + match q in PeanoView x return PeanoView (x~1) with + | PeanoOne => PeanoSucc _ (PeanoSucc _ PeanoOne) + | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xI _ q)) + end. + + Fixpoint peanoView p : PeanoView p := + match p return PeanoView p with + | 1 => PeanoOne + | p~0 => peanoView_xO p (peanoView p) + | p~1 => peanoView_xI p (peanoView p) + end. + + Definition PeanoView_iter (P:positive->Type) + (a:P 1) (f:forall p, P p -> P (succ p)) := + (fix iter p (q:PeanoView p) : P p := + match q in PeanoView p return P p with + | PeanoOne => a + | PeanoSucc _ q => f _ (iter _ q) + end). + + Theorem eq_dep_eq_positive : + forall (P:positive->Type) (p:positive) (x y:P p), + eq_dep positive P p x p y -> x = y. + Proof. + apply eq_dep_eq_dec. + decide equality. + Qed. + + Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. + Proof. + intros p q q'. + induction q as [ | p q IHq ]. + - apply eq_dep_eq_positive. + cut (1=1). + + pattern 1 at 1 2 5, q'. destruct q' as [|p ?]. + * trivial. + * destruct p; intros; discriminate. + + trivial. + - apply eq_dep_eq_positive. + cut (succ p=succ p). + + pattern (succ p) at 1 2 5, q'. destruct q' as [|? q']. + * intro. destruct p; discriminate. + * intro H. apply succ_inj in H. + generalize q'. rewrite H. intro q'0. + rewrite (IHq q'0). + trivial. + + trivial. + Qed. + + Lemma peano_equiv (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) p : + PeanoView_iter P a f p (peanoView p) = peano_rect P a f p. + Proof. + revert P a f. induction p as [|p IHp] using peano_rect. + - trivial. + - intros; simpl. rewrite peano_rect_succ. + rewrite (PeanoViewUnique _ (peanoView (succ p)) (PeanoSucc _ (peanoView p))). + simpl; now f_equal. + Qed. + + (**********************************************************************) + (** * Properties of multiplication on binary positive numbers *) + + (** ** One is neutral for multiplication *) + + Lemma mul_1_l p : 1 * p = p. + Proof. + reflexivity. + Qed. + + Lemma mul_1_r p : p * 1 = p. + Proof. + induction p; simpl; now f_equal. + Qed. + + (** ** Right reduction properties for multiplication *) + + Lemma mul_xO_r p q : p * q~0 = (p * q)~0. + Proof. + induction p; simpl; f_equal; f_equal; trivial. + Qed. + + Lemma mul_xI_r p q : p * q~1 = p + (p * q)~0. + Proof. + induction p as [p IHp|p IHp| ]; simpl; f_equal; trivial. + now rewrite IHp, 2 add_assoc, (add_comm p). + Qed. + + (** ** Commutativity of multiplication *) + + Theorem mul_comm p q : p * q = q * p. + Proof. + induction q as [q IHq|q IHq| ]; simpl; rewrite <- ? IHq; + auto using mul_xI_r, mul_xO_r, mul_1_r. + Qed. + + (** ** Distributivity of multiplication over addition *) + + Theorem mul_add_distr_l p q r : + p * (q + r) = p * q + p * r. + Proof. + induction p as [p IHp|p IHp| ]; simpl. + - rewrite IHp. set (m:=(p*q)~0). set (n:=(p*r)~0). + change ((p*q+p*r)~0) with (m+n). + rewrite 2 add_assoc; f_equal. + rewrite <- 2 add_assoc; f_equal. + apply add_comm. + - f_equal; auto. + - reflexivity. + Qed. + + Theorem mul_add_distr_r p q r : + (p + q) * r = p * r + q * r. + Proof. + rewrite 3 (mul_comm _ r); apply mul_add_distr_l. + Qed. + + (** ** Associativity of multiplication *) + + Theorem mul_assoc p q r : p * (q * r) = p * q * r. + Proof. + induction p as [p IHp| p IHp | ]; simpl; rewrite ?IHp; trivial. + now rewrite mul_add_distr_r. + Qed. + + (** ** Successor and multiplication *) + + Lemma mul_succ_l p q : (succ p) * q = q + p * q. + Proof. + induction p as [p IHp | p IHp | ]; simpl; trivial. + - now rewrite IHp, add_assoc, add_diag, <-add_xO. + - symmetry; apply add_diag. + Qed. + + Lemma mul_succ_r p q : p * (succ q) = p + p * q. + Proof. + rewrite mul_comm, mul_succ_l. f_equal. apply mul_comm. + Qed. + + (** ** Parity properties of multiplication *) + + Lemma mul_xI_mul_xO_discr p q r : p~1 * r <> q~0 * r. + Proof. + induction r; try discriminate. + rewrite 2 mul_xO_r; intro H; destr_eq H; auto. + Qed. + + Lemma mul_xO_discr p q : p~0 * q <> q. + Proof. + induction q; try discriminate. + rewrite mul_xO_r; injection; auto. + Qed. + + (** ** Simplification properties of multiplication *) + + Theorem mul_reg_r p q r : p * r = q * r -> p = q. + Proof. + revert q r. + induction p as [p IHp| p IHp| ]; intros [q|q| ] r H; + reflexivity || apply f_equal || exfalso. + - apply IHp with (r~0). simpl in *. + rewrite 2 mul_xO_r. apply add_reg_l with (1:=H). + - contradict H. apply mul_xI_mul_xO_discr. + - contradict H. simpl. rewrite add_comm. apply add_no_neutral. + - symmetry in H. contradict H. apply mul_xI_mul_xO_discr. + - apply IHp with (r~0). simpl. now rewrite 2 mul_xO_r. + - contradict H. apply mul_xO_discr. + - symmetry in H. contradict H. simpl. rewrite add_comm. + apply add_no_neutral. + - symmetry in H. contradict H. apply mul_xO_discr. + Qed. + + Theorem mul_reg_l p q r : r * p = r * q -> p = q. + Proof. + rewrite 2 (mul_comm r). apply mul_reg_r. + Qed. + + Lemma mul_cancel_r p q r : p * r = q * r <-> p = q. + Proof. + split. + - apply mul_reg_r. + - congruence. + Qed. + + Lemma mul_cancel_l p q r : r * p = r * q <-> p = q. + Proof. + split. + - apply mul_reg_l. + - congruence. + Qed. + + (** ** Inversion of multiplication *) + + Lemma mul_eq_1_l p q : p * q = 1 -> p = 1. + Proof. + now destruct p, q. + Qed. + + Lemma mul_eq_1_r p q : p * q = 1 -> q = 1. + Proof. + now destruct p, q. + Qed. + + Notation mul_eq_1 := mul_eq_1_l. + + (** ** Square *) + + Lemma square_xO p : p~0 * p~0 = (p*p)~0~0. + Proof. + simpl. now rewrite mul_comm. + Qed. + + Lemma square_xI p : p~1 * p~1 = (p*p+p)~0~1. + Proof. + simpl. rewrite mul_comm. simpl. f_equal. + rewrite add_assoc, add_diag. simpl. now rewrite add_comm. + Qed. + + (** ** Properties of [iter] *) + + Lemma iter_swap_gen A B (f:A->B)(g:A->A)(h:B->B) : + (forall a, f (g a) = h (f a)) -> forall p a, + f (iter g a p) = iter h (f a) p. + Proof. + intros H p; induction p as [p IHp|p IHp|]; simpl; intros; now rewrite ?H, ?IHp. + Qed. + + Theorem iter_swap : + forall p (A:Type) (f:A -> A) (x:A), + iter f (f x) p = f (iter f x p). + Proof. + intros. symmetry. now apply iter_swap_gen. + Qed. + + Theorem iter_succ : + forall p (A:Type) (f:A -> A) (x:A), + iter f x (succ p) = f (iter f x p). + Proof. + intro p; induction p as [p IHp|p IHp|]; intros; simpl; trivial. + now rewrite !IHp, iter_swap. + Qed. + + Theorem iter_succ_r : + forall p (A:Type) (f:A -> A) (x:A), + iter f x (succ p) = iter f (f x) p. + Proof. + intros; now rewrite iter_succ, iter_swap. + Qed. + + Theorem iter_add : + forall p q (A:Type) (f:A -> A) (x:A), + iter f x (p+q) = iter f (iter f x q) p. + Proof. + intro p; induction p as [|p IHp] using peano_ind; intros. + - now rewrite add_1_l, iter_succ. + - now rewrite add_succ_l, !iter_succ, IHp. + Qed. + + Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop) : + P 1 (f a) -> + (forall p a', P p a' -> P (succ p) (f a')) -> + forall p, P p (iter f a p). + Proof. + intros ? ? p; induction p as [|p IHp] using peano_ind; trivial. + rewrite iter_succ; auto. + Qed. + + Theorem iter_invariant : + forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop), + (forall x:A, Inv x -> Inv (f x)) -> + forall x:A, Inv x -> Inv (iter f x p). + Proof. + intros; apply iter_ind; auto. + Qed. + + (** ** Properties of power *) + + Lemma pow_1_r p : p^1 = p. + Proof. + unfold pow. simpl. now rewrite mul_comm. + Qed. + + Lemma pow_succ_r p q : p^(succ q) = p * p^q. + Proof. + unfold pow. now rewrite iter_succ. + Qed. + + (** ** Properties of square *) + + Lemma square_spec p : square p = p * p. + Proof. + induction p as [p IHp|p IHp|]. + - rewrite square_xI. simpl. now rewrite IHp. + - rewrite square_xO. simpl. now rewrite IHp. + - trivial. + Qed. + + (** ** Properties of [sub_mask] *) + + Lemma sub_mask_succ_r p q : + sub_mask p (succ q) = sub_mask_carry p q. + Proof. + revert q. induction p as [p ?|p ?|]; intro q; destruct q; + simpl; f_equal; trivial; now destruct p. + Qed. + + Theorem sub_mask_carry_spec p q : + sub_mask_carry p q = pred_mask (sub_mask p q). + Proof. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; + try reflexivity; rewrite ?IHp; + destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto. + Qed. + + Inductive SubMaskSpec (p q : positive) : mask -> Prop := + | SubIsNul : p = q -> SubMaskSpec p q IsNul + | SubIsPos : forall r, q + r = p -> SubMaskSpec p q (IsPos r) + | SubIsNeg : forall r, p + r = q -> SubMaskSpec p q IsNeg. + + Theorem sub_mask_spec p q : SubMaskSpec p q (sub_mask p q). + Proof. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; + simpl; try constructor; trivial. + - (* p~1 q~1 *) + destruct (IHp q) as [|r|r]; subst; try now constructor. + now apply SubIsNeg with r~0. + - (* p~1 q~0 *) + destruct (IHp q) as [|r|r]; subst; try now constructor. + apply SubIsNeg with (pred_double r). symmetry. apply add_xI_pred_double. + - (* p~0 q~1 *) + rewrite sub_mask_carry_spec. + destruct (IHp q) as [|r|r]; subst; try constructor. + + now apply SubIsNeg with 1. + + destruct r; simpl; try constructor; simpl. + * now rewrite add_carry_spec, <- add_succ_r. + * now rewrite add_carry_spec, <- add_succ_r, succ_pred_double. + * now rewrite add_1_r. + + now apply SubIsNeg with r~1. + - (* p~0 q~0 *) + destruct (IHp q) as [|r|r]; subst; try now constructor. + now apply SubIsNeg with r~0. + - (* p~0 1 *) + now rewrite add_1_l, succ_pred_double. + - (* 1 q~1 *) + now apply SubIsNeg with q~0. + - (* 1 q~0 *) + apply SubIsNeg with (pred_double q). now rewrite add_1_l, succ_pred_double. + Qed. + + Theorem sub_mask_nul_iff p q : sub_mask p q = IsNul <-> p = q. + Proof. + split. + - now case sub_mask_spec. + - intros <-. induction p as [p IHp|p IHp|]; simpl; now rewrite ?IHp. + Qed. + + Theorem sub_mask_diag p : sub_mask p p = IsNul. + Proof. + now apply sub_mask_nul_iff. + Qed. + + Lemma sub_mask_add p q r : sub_mask p q = IsPos r -> q + r = p. + Proof. + case sub_mask_spec; congruence. + Qed. + + Lemma sub_mask_add_diag_l p q : sub_mask (p+q) p = IsPos q. + Proof. + case sub_mask_spec. + - intros H. rewrite add_comm in H. elim (add_no_neutral _ _ H). + - intros r H. apply add_cancel_l in H. now f_equal. + - intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H). + Qed. + + Lemma sub_mask_pos_iff p q r : sub_mask p q = IsPos r <-> q + r = p. + Proof. + split. + - apply sub_mask_add. + - intros <-; apply sub_mask_add_diag_l. + Qed. + + Lemma sub_mask_add_diag_r p q : sub_mask p (p+q) = IsNeg. + Proof. + case sub_mask_spec; trivial. + - intros H. symmetry in H; rewrite add_comm in H. elim (add_no_neutral _ _ H). + - intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H). + Qed. + + Lemma sub_mask_neg_iff p q : sub_mask p q = IsNeg <-> exists r, p + r = q. + Proof. + split. + - case sub_mask_spec; try discriminate. intros r Hr _; now exists r. + - intros (r,<-). apply sub_mask_add_diag_r. + Qed. + + (*********************************************************************) + (** * Properties of boolean comparisons *) + + Theorem eqb_eq p q : (p =? q) = true <-> p=q. + Proof. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q; + simpl; rewrite ?IHp; split; congruence. + Qed. + + Theorem ltb_lt p q : (p p < q. + Proof. + unfold ltb, lt. destruct compare; easy'. + Qed. + + Theorem leb_le p q : (p <=? q) = true <-> p <= q. + Proof. + unfold leb, le. destruct compare; easy'. + Qed. + + (** More about [eqb] *) + + Include BoolEqualityFacts. + + (**********************************************************************) + (** * Properties of comparison on binary positive numbers *) + + (** First, we express [compare_cont] in term of [compare] *) + + Definition switch_Eq c c' := + match c' with + | Eq => c + | Lt => Lt + | Gt => Gt + end. + + Lemma compare_cont_spec p q c : + compare_cont c p q = switch_Eq c (p ?= q). + Proof. + unfold compare. + revert q c. + induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; trivial. + - intros c. + rewrite 2 IHp. now destruct (compare_cont Eq p q). + - intros c. + rewrite 2 IHp. now destruct (compare_cont Eq p q). + Qed. + + (** From this general result, we now describe particular cases + of [compare_cont p q c = c'] : + - When [c=Eq], this is directly [compare] + - When [c<>Eq], we'll show first that [c'<>Eq] + - That leaves only 4 lemmas for [c] and [c'] being [Lt] or [Gt] +*) -Lemma sub_mask_succ_r p q : - sub_mask p (succ q) = sub_mask_carry p q. -Proof. - revert q. induction p as [p ?|p ?|]; intro q; destruct q; - simpl; f_equal; trivial; now destruct p. -Qed. + Theorem compare_cont_Eq p q c : + compare_cont c p q = Eq -> c = Eq. + Proof. + rewrite compare_cont_spec. now destruct (p ?= q). + Qed. + + Lemma compare_cont_Lt_Gt p q : + compare_cont Lt p q = Gt <-> p > q. + Proof. + rewrite compare_cont_spec. unfold gt. destruct (p ?= q); now split. + Qed. + + Lemma compare_cont_Lt_Lt p q : + compare_cont Lt p q = Lt <-> p <= q. + Proof. + rewrite compare_cont_spec. unfold le. destruct (p ?= q); easy'. + Qed. + + Lemma compare_cont_Gt_Lt p q : + compare_cont Gt p q = Lt <-> p < q. + Proof. + rewrite compare_cont_spec. unfold lt. destruct (p ?= q); now split. + Qed. + + Lemma compare_cont_Gt_Gt p q : + compare_cont Gt p q = Gt <-> p >= q. + Proof. + rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. + Qed. + + Lemma compare_cont_Lt_not_Lt p q : + compare_cont Lt p q <> Lt <-> p > q. + Proof. + rewrite compare_cont_Lt_Lt. + unfold gt, le, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. + Qed. + + Lemma compare_cont_Lt_not_Gt p q : + compare_cont Lt p q <> Gt <-> p <= q. + Proof. + apply not_iff_compat, compare_cont_Lt_Gt. + Qed. + + Lemma compare_cont_Gt_not_Lt p q : + compare_cont Gt p q <> Lt <-> p >= q. + Proof. + apply not_iff_compat, compare_cont_Gt_Lt. + Qed. + + Lemma compare_cont_Gt_not_Gt p q : + compare_cont Gt p q <> Gt <-> p < q. + Proof. + rewrite compare_cont_Gt_Gt. + unfold ge, lt, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. + Qed. + + (** We can express recursive equations for [compare] *) + + Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q). + Proof. reflexivity. Qed. + + Lemma compare_xI_xI p q : (p~1 ?= q~1) = (p ?= q). + Proof. reflexivity. Qed. + + Lemma compare_xI_xO p q : + (p~1 ?= q~0) = switch_Eq Gt (p ?= q). + Proof. exact (compare_cont_spec p q Gt). Qed. + + Lemma compare_xO_xI p q : + (p~0 ?= q~1) = switch_Eq Lt (p ?= q). + Proof. exact (compare_cont_spec p q Lt). Qed. + + #[global] Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. + + Ltac simpl_compare := autorewrite with compare. + Ltac simpl_compare_in H := autorewrite with compare in H. + + (** Relation between [compare] and [sub_mask] *) + + Definition mask2cmp (p:mask) : comparison := + match p with + | IsNul => Eq + | IsPos _ => Gt + | IsNeg => Lt + end. + + Lemma compare_sub_mask p q : (p ?= q) = mask2cmp (sub_mask p q). + Proof. + revert q. + induction p as [p IHp| p IHp| ]; intros [q|q| ]; simpl; trivial; + specialize (IHp q); rewrite ?sub_mask_carry_spec; + destruct (sub_mask p q) as [|r|]; simpl in *; + try clear r; try destruct r; simpl; trivial; + simpl_compare; now rewrite IHp. + Qed. + + (** Alternative characterisation of strict order in term of addition *) + + Lemma lt_iff_add p q : p < q <-> exists r, p + r = q. + Proof. + unfold "<". rewrite <- sub_mask_neg_iff, compare_sub_mask. + destruct sub_mask; now split. + Qed. + + Lemma gt_iff_add p q : p > q <-> exists r, q + r = p. + Proof. + unfold ">". rewrite compare_sub_mask. + split. + - case_eq (sub_mask p q); try discriminate; intros r Hr _. + exists r. now apply sub_mask_pos_iff. + - intros (r,Hr). apply sub_mask_pos_iff in Hr. now rewrite Hr. + Qed. + + (** Basic facts about [compare_cont] *) + + Theorem compare_cont_refl p c : + compare_cont c p p = c. + Proof. + now induction p. + Qed. + + Lemma compare_cont_antisym p q c : + CompOpp (compare_cont c p q) = compare_cont (CompOpp c) q p. + Proof. + revert q c. + induction p as [p IHp|p IHp| ]; intros [q|q| ] c; simpl; + trivial; apply IHp. + Qed. + + (** Basic facts about [compare] *) + + Lemma compare_eq_iff p q : (p ?= q) = Eq <-> p = q. + Proof. + rewrite compare_sub_mask, <- sub_mask_nul_iff. + destruct sub_mask; now split. + Qed. + + Lemma compare_antisym p q : (q ?= p) = CompOpp (p ?= q). + Proof. + unfold compare. now rewrite compare_cont_antisym. + Qed. + + Lemma compare_lt_iff p q : (p ?= q) = Lt <-> p < q. + Proof. reflexivity. Qed. + + Lemma compare_le_iff p q : (p ?= q) <> Gt <-> p <= q. + Proof. reflexivity. Qed. + + (** More properties about [compare] and boolean comparisons, + including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) -Theorem sub_mask_carry_spec p q : - sub_mask_carry p q = pred_mask (sub_mask p q). -Proof. - revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; - try reflexivity; rewrite ?IHp; - destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto. -Qed. + Include BoolOrderFacts. -Inductive SubMaskSpec (p q : positive) : mask -> Prop := - | SubIsNul : p = q -> SubMaskSpec p q IsNul - | SubIsPos : forall r, q + r = p -> SubMaskSpec p q (IsPos r) - | SubIsNeg : forall r, p + r = q -> SubMaskSpec p q IsNeg. + Definition le_lteq := lt_eq_cases. -Theorem sub_mask_spec p q : SubMaskSpec p q (sub_mask p q). -Proof. - revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; - simpl; try constructor; trivial. - - (* p~1 q~1 *) - destruct (IHp q) as [|r|r]; subst; try now constructor. - now apply SubIsNeg with r~0. - - (* p~1 q~0 *) - destruct (IHp q) as [|r|r]; subst; try now constructor. - apply SubIsNeg with (pred_double r). symmetry. apply add_xI_pred_double. - - (* p~0 q~1 *) - rewrite sub_mask_carry_spec. - destruct (IHp q) as [|r|r]; subst; try constructor. - + now apply SubIsNeg with 1. - + destruct r; simpl; try constructor; simpl. - * now rewrite add_carry_spec, <- add_succ_r. - * now rewrite add_carry_spec, <- add_succ_r, succ_pred_double. - * now rewrite add_1_r. - + now apply SubIsNeg with r~1. - - (* p~0 q~0 *) - destruct (IHp q) as [|r|r]; subst; try now constructor. - now apply SubIsNeg with r~0. - - (* p~0 1 *) - now rewrite add_1_l, succ_pred_double. - - (* 1 q~1 *) - now apply SubIsNeg with q~0. - - (* 1 q~0 *) - apply SubIsNeg with (pred_double q). now rewrite add_1_l, succ_pred_double. -Qed. + (** ** Facts about [gt] and [ge] *) -Theorem sub_mask_nul_iff p q : sub_mask p q = IsNul <-> p = q. -Proof. - split. - - now case sub_mask_spec. - - intros <-. induction p as [p IHp|p IHp|]; simpl; now rewrite ?IHp. -Qed. + (** The predicates [lt] and [le] are now favored in the statements + of theorems, the use of [gt] and [ge] is hence not recommended. + We provide here the bare minimal results to related them with + [lt] and [le]. *) -Theorem sub_mask_diag p : sub_mask p p = IsNul. -Proof. - now apply sub_mask_nul_iff. -Qed. - -Lemma sub_mask_add p q r : sub_mask p q = IsPos r -> q + r = p. -Proof. - case sub_mask_spec; congruence. -Qed. - -Lemma sub_mask_add_diag_l p q : sub_mask (p+q) p = IsPos q. -Proof. - case sub_mask_spec. - - intros H. rewrite add_comm in H. elim (add_no_neutral _ _ H). - - intros r H. apply add_cancel_l in H. now f_equal. - - intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H). -Qed. - -Lemma sub_mask_pos_iff p q r : sub_mask p q = IsPos r <-> q + r = p. -Proof. - split. - - apply sub_mask_add. - - intros <-; apply sub_mask_add_diag_l. -Qed. - -Lemma sub_mask_add_diag_r p q : sub_mask p (p+q) = IsNeg. -Proof. - case sub_mask_spec; trivial. - - intros H. symmetry in H; rewrite add_comm in H. elim (add_no_neutral _ _ H). - - intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H). -Qed. - -Lemma sub_mask_neg_iff p q : sub_mask p q = IsNeg <-> exists r, p + r = q. -Proof. - split. - - case sub_mask_spec; try discriminate. intros r Hr _; now exists r. - - intros (r,<-). apply sub_mask_add_diag_r. -Qed. - -(*********************************************************************) -(** * Properties of boolean comparisons *) - -Theorem eqb_eq p q : (p =? q) = true <-> p=q. -Proof. - revert q. induction p as [p IHp|p IHp|]; intro q; destruct q; - simpl; rewrite ?IHp; split; congruence. -Qed. - -Theorem ltb_lt p q : (p p < q. -Proof. - unfold ltb, lt. destruct compare; easy'. -Qed. - -Theorem leb_le p q : (p <=? q) = true <-> p <= q. -Proof. - unfold leb, le. destruct compare; easy'. -Qed. - -(** More about [eqb] *) - -Include BoolEqualityFacts. - -(**********************************************************************) -(** * Properties of comparison on binary positive numbers *) - -(** First, we express [compare_cont] in term of [compare] *) - -Definition switch_Eq c c' := - match c' with - | Eq => c - | Lt => Lt - | Gt => Gt - end. - -Lemma compare_cont_spec p q c : - compare_cont c p q = switch_Eq c (p ?= q). -Proof. - unfold compare. - revert q c. - induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; trivial. - - intros c. - rewrite 2 IHp. now destruct (compare_cont Eq p q). - - intros c. - rewrite 2 IHp. now destruct (compare_cont Eq p q). -Qed. - -(** From this general result, we now describe particular cases - of [compare_cont p q c = c'] : - - When [c=Eq], this is directly [compare] - - When [c<>Eq], we'll show first that [c'<>Eq] - - That leaves only 4 lemmas for [c] and [c'] being [Lt] or [Gt] -*) - -Theorem compare_cont_Eq p q c : - compare_cont c p q = Eq -> c = Eq. -Proof. - rewrite compare_cont_spec. now destruct (p ?= q). -Qed. - -Lemma compare_cont_Lt_Gt p q : - compare_cont Lt p q = Gt <-> p > q. -Proof. - rewrite compare_cont_spec. unfold gt. destruct (p ?= q); now split. -Qed. - -Lemma compare_cont_Lt_Lt p q : - compare_cont Lt p q = Lt <-> p <= q. -Proof. - rewrite compare_cont_spec. unfold le. destruct (p ?= q); easy'. -Qed. - -Lemma compare_cont_Gt_Lt p q : - compare_cont Gt p q = Lt <-> p < q. -Proof. - rewrite compare_cont_spec. unfold lt. destruct (p ?= q); now split. -Qed. - -Lemma compare_cont_Gt_Gt p q : - compare_cont Gt p q = Gt <-> p >= q. -Proof. - rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. -Qed. - -Lemma compare_cont_Lt_not_Lt p q : - compare_cont Lt p q <> Lt <-> p > q. -Proof. - rewrite compare_cont_Lt_Lt. - unfold gt, le, compare. - now destruct compare_cont; split; try apply comparison_eq_stable. -Qed. - -Lemma compare_cont_Lt_not_Gt p q : - compare_cont Lt p q <> Gt <-> p <= q. -Proof. - apply not_iff_compat, compare_cont_Lt_Gt. -Qed. - -Lemma compare_cont_Gt_not_Lt p q : - compare_cont Gt p q <> Lt <-> p >= q. -Proof. - apply not_iff_compat, compare_cont_Gt_Lt. -Qed. - -Lemma compare_cont_Gt_not_Gt p q : - compare_cont Gt p q <> Gt <-> p < q. -Proof. - rewrite compare_cont_Gt_Gt. - unfold ge, lt, compare. - now destruct compare_cont; split; try apply comparison_eq_stable. -Qed. - -(** We can express recursive equations for [compare] *) - -Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q). -Proof. reflexivity. Qed. - -Lemma compare_xI_xI p q : (p~1 ?= q~1) = (p ?= q). -Proof. reflexivity. Qed. - -Lemma compare_xI_xO p q : - (p~1 ?= q~0) = switch_Eq Gt (p ?= q). -Proof. exact (compare_cont_spec p q Gt). Qed. - -Lemma compare_xO_xI p q : - (p~0 ?= q~1) = switch_Eq Lt (p ?= q). -Proof. exact (compare_cont_spec p q Lt). Qed. - -#[global] Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. - -Ltac simpl_compare := autorewrite with compare. -Ltac simpl_compare_in H := autorewrite with compare in H. - -(** Relation between [compare] and [sub_mask] *) - -Definition mask2cmp (p:mask) : comparison := - match p with - | IsNul => Eq - | IsPos _ => Gt - | IsNeg => Lt - end. - -Lemma compare_sub_mask p q : (p ?= q) = mask2cmp (sub_mask p q). -Proof. - revert q. - induction p as [p IHp| p IHp| ]; intros [q|q| ]; simpl; trivial; - specialize (IHp q); rewrite ?sub_mask_carry_spec; - destruct (sub_mask p q) as [|r|]; simpl in *; - try clear r; try destruct r; simpl; trivial; - simpl_compare; now rewrite IHp. -Qed. - -(** Alternative characterisation of strict order in term of addition *) - -Lemma lt_iff_add p q : p < q <-> exists r, p + r = q. -Proof. - unfold "<". rewrite <- sub_mask_neg_iff, compare_sub_mask. - destruct sub_mask; now split. -Qed. - -Lemma gt_iff_add p q : p > q <-> exists r, q + r = p. -Proof. - unfold ">". rewrite compare_sub_mask. - split. - - case_eq (sub_mask p q); try discriminate; intros r Hr _. - exists r. now apply sub_mask_pos_iff. - - intros (r,Hr). apply sub_mask_pos_iff in Hr. now rewrite Hr. -Qed. - -(** Basic facts about [compare_cont] *) - -Theorem compare_cont_refl p c : - compare_cont c p p = c. -Proof. - now induction p. -Qed. - -Lemma compare_cont_antisym p q c : - CompOpp (compare_cont c p q) = compare_cont (CompOpp c) q p. -Proof. - revert q c. - induction p as [p IHp|p IHp| ]; intros [q|q| ] c; simpl; - trivial; apply IHp. -Qed. - -(** Basic facts about [compare] *) - -Lemma compare_eq_iff p q : (p ?= q) = Eq <-> p = q. -Proof. - rewrite compare_sub_mask, <- sub_mask_nul_iff. - destruct sub_mask; now split. -Qed. - -Lemma compare_antisym p q : (q ?= p) = CompOpp (p ?= q). -Proof. - unfold compare. now rewrite compare_cont_antisym. -Qed. - -Lemma compare_lt_iff p q : (p ?= q) = Lt <-> p < q. -Proof. reflexivity. Qed. - -Lemma compare_le_iff p q : (p ?= q) <> Gt <-> p <= q. -Proof. reflexivity. Qed. - -(** More properties about [compare] and boolean comparisons, - including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) - -Include BoolOrderFacts. - -Definition le_lteq := lt_eq_cases. - -(** ** Facts about [gt] and [ge] *) - -(** The predicates [lt] and [le] are now favored in the statements - of theorems, the use of [gt] and [ge] is hence not recommended. - We provide here the bare minimal results to related them with - [lt] and [le]. *) - -Lemma gt_lt_iff p q : p > q <-> q < p. -Proof. - unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma gt_lt p q : p > q -> q < p. -Proof. - apply gt_lt_iff. -Qed. - -Lemma lt_gt p q : p < q -> q > p. -Proof. - apply gt_lt_iff. -Qed. - -Lemma ge_le_iff p q : p >= q <-> q <= p. -Proof. - unfold le, ge. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma ge_le p q : p >= q -> q <= p. -Proof. - apply ge_le_iff. -Qed. - -Lemma le_ge p q : p <= q -> q >= p. -Proof. - apply ge_le_iff. -Qed. - -(** ** Comparison and the successor *) - -Lemma compare_succ_r p q : - switch_Eq Gt (p ?= succ q) = switch_Eq Lt (p ?= q). -Proof. - revert q. - induction p as [p IH|p IH| ]; intros [q|q| ]; simpl; - simpl_compare; rewrite ?IH; trivial; - (now destruct compare) || (now destruct p). -Qed. - -Lemma compare_succ_l p q : - switch_Eq Lt (succ p ?= q) = switch_Eq Gt (p ?= q). -Proof. - rewrite 2 (compare_antisym q). generalize (compare_succ_r q p). - now do 2 destruct compare. -Qed. - -Theorem lt_succ_r p q : p < succ q <-> p <= q. -Proof. - unfold lt, le. generalize (compare_succ_r p q). - do 2 destruct compare; try discriminate; now split. -Qed. - -Lemma lt_succ_diag_r p : p < succ p. -Proof. - rewrite lt_iff_add. exists 1. apply add_1_r. -Qed. - -Lemma compare_succ_succ p q : (succ p ?= succ q) = (p ?= q). -Proof. - revert q. - induction p as [p|p|]; intro q; destruct q as [q|q|]; - simpl; simpl_compare; trivial; - apply compare_succ_l || apply compare_succ_r || - (now destruct p) || (now destruct q). -Qed. - -(** ** 1 is the least positive number *) - -Lemma le_1_l p : 1 <= p. -Proof. - now destruct p. -Qed. - -Lemma nlt_1_r p : ~ p < 1. -Proof. - now destruct p. -Qed. - -Lemma lt_1_succ p : 1 < succ p. -Proof. - apply lt_succ_r, le_1_l. -Qed. - -(** ** Properties of the order *) - -Lemma le_nlt p q : p <= q <-> ~ q < p. -Proof. - now rewrite <- ge_le_iff. -Qed. - -Lemma lt_nle p q : p < q <-> ~ q <= p. -Proof. - intros. unfold lt, le. rewrite compare_antisym. - destruct compare; split; auto; easy'. -Qed. - -Lemma lt_le_incl p q : p p<=q. -Proof. - intros. apply le_lteq. now left. -Qed. - -Lemma lt_lt_succ n m : n < m -> n < succ m. -Proof. - intros. now apply lt_succ_r, lt_le_incl. -Qed. - -Lemma succ_lt_mono n m : n < m <-> succ n < succ m. -Proof. - unfold lt. now rewrite compare_succ_succ. -Qed. - -Lemma succ_le_mono n m : n <= m <-> succ n <= succ m. -Proof. - unfold le. now rewrite compare_succ_succ. -Qed. - -Lemma lt_trans n m p : n < m -> m < p -> n < p. -Proof. - rewrite 3 lt_iff_add. intros (r,Hr) (s,Hs). - exists (r+s). now rewrite add_assoc, Hr, Hs. -Qed. - -Theorem lt_ind : forall (A : positive -> Prop) (n : positive), - A (succ n) -> - (forall m : positive, n < m -> A m -> A (succ m)) -> - forall m : positive, n < m -> A m. -Proof. - intros A n AB AS m. induction m using peano_ind; intros H. - - elim (nlt_1_r _ H). - - apply lt_succ_r, le_lteq in H. destruct H as [H|H]; subst; auto. -Qed. - -#[global] -Instance lt_strorder : StrictOrder lt. -Proof. - split. - - exact lt_irrefl. - - exact lt_trans. -Qed. - -#[global] -Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) lt. -Proof. repeat red. intros. subst; auto. Qed. - -Lemma lt_total p q : p < q \/ p = q \/ q < p. -Proof. - case (compare_spec p q); intuition. -Qed. - -Lemma le_refl p : p <= p. -Proof. - intros. unfold le. now rewrite compare_refl. -Qed. - -Lemma le_lt_trans n m p : n <= m -> m < p -> n < p. -Proof. - intros H H'. apply le_lteq in H. destruct H. - - now apply lt_trans with m. - - now subst. -Qed. - -Lemma lt_le_trans n m p : n < m -> m <= p -> n < p. -Proof. - intros H H'. apply le_lteq in H'. destruct H'. - - now apply lt_trans with m. - - now subst. -Qed. - -Lemma le_trans n m p : n <= m -> m <= p -> n <= p. -Proof. - intros H H'. - apply le_lteq in H. destruct H. - - apply le_lteq; left. now apply lt_le_trans with m. - - now subst. -Qed. - -Lemma le_succ_l n m : succ n <= m <-> n < m. -Proof. - rewrite <- lt_succ_r. symmetry. apply succ_lt_mono. -Qed. - -Lemma le_antisym p q : p <= q -> q <= p -> p = q. -Proof. - rewrite le_lteq; destruct 1; auto. - rewrite le_lteq; destruct 1; auto. - elim (lt_irrefl p). now transitivity q. -Qed. - -#[global] -Instance le_preorder : PreOrder le. -Proof. - split. - - exact le_refl. - - exact le_trans. -Qed. - -#[global] -Instance le_partorder : PartialOrder Logic.eq le. -Proof. - intros x y. change (x=y <-> x <= y <= x). - split. - - intros; now subst. - - destruct 1; now apply le_antisym. -Qed. - -(** ** Comparison and addition *) - -Lemma add_compare_mono_l p q r : (p+q ?= p+r) = (q ?= r). -Proof. - revert q r. induction p using peano_ind; intros q r. - - rewrite 2 add_1_l. apply compare_succ_succ. - - now rewrite 2 add_succ_l, compare_succ_succ. -Qed. - -Lemma add_compare_mono_r p q r : (q+p ?= r+p) = (q ?= r). -Proof. - rewrite 2 (add_comm _ p). apply add_compare_mono_l. -Qed. - -(** ** Order and addition *) - -Lemma lt_add_diag_r p q : p < p + q. -Proof. - rewrite lt_iff_add. now exists q. -Qed. - -Lemma add_lt_mono_l p q r : q p+q < p+r. -Proof. - unfold lt. rewrite add_compare_mono_l. apply iff_refl. -Qed. - -Lemma add_lt_mono_r p q r : q q+p < r+p. -Proof. - unfold lt. rewrite add_compare_mono_r. apply iff_refl. -Qed. - -Lemma add_lt_mono p q r s : p r p+r p+q<=p+r. -Proof. - unfold le. rewrite add_compare_mono_l. apply iff_refl. -Qed. - -Lemma add_le_mono_r p q r : q<=r <-> q+p<=r+p. -Proof. - unfold le. rewrite add_compare_mono_r. apply iff_refl. -Qed. - -Lemma add_le_mono p q r s : p<=q -> r<=s -> p+r <= q+s. -Proof. - intros. apply le_trans with (p+s). - - now apply add_le_mono_l. - - now apply add_le_mono_r. -Qed. - -(** ** Comparison and multiplication *) - -Lemma mul_compare_mono_l p q r : (p*q ?= p*r) = (q ?= r). -Proof. - revert q r. induction p as [p IHp|p IHp|]; simpl; trivial. - intros q r. specialize (IHp q r). - destruct (compare_spec q r). - - subst. apply compare_refl. - - now apply add_lt_mono. - - now apply lt_gt, add_lt_mono, gt_lt. -Qed. - -Lemma mul_compare_mono_r p q r : (q*p ?= r*p) = (q ?= r). -Proof. - rewrite 2 (mul_comm _ p). apply mul_compare_mono_l. -Qed. - -(** ** Order and multiplication *) - -Lemma mul_lt_mono_l p q r : q p*q < p*r. -Proof. - unfold lt. rewrite mul_compare_mono_l. apply iff_refl. -Qed. - -Lemma mul_lt_mono_r p q r : q q*p < r*p. -Proof. - unfold lt. rewrite mul_compare_mono_r. apply iff_refl. -Qed. - -Lemma mul_lt_mono p q r s : p r p*r < q*s. -Proof. - intros. apply lt_trans with (p*s). - - now apply mul_lt_mono_l. - - now apply mul_lt_mono_r. -Qed. - -Lemma mul_le_mono_l p q r : q<=r <-> p*q<=p*r. -Proof. - unfold le. rewrite mul_compare_mono_l. apply iff_refl. -Qed. - -Lemma mul_le_mono_r p q r : q<=r <-> q*p<=r*p. -Proof. - unfold le. rewrite mul_compare_mono_r. apply iff_refl. -Qed. - -Lemma mul_le_mono p q r s : p<=q -> r<=s -> p*r <= q*s. -Proof. - intros. apply le_trans with (p*s). - - now apply mul_le_mono_l. - - now apply mul_le_mono_r. -Qed. - -Lemma lt_add_r p q : p < p+q. -Proof. - induction q as [|q] using peano_ind. - - rewrite add_1_r. apply lt_succ_diag_r. - - apply lt_trans with (p+q); auto. - apply add_lt_mono_l, lt_succ_diag_r. -Qed. - -Lemma lt_not_add_l p q : ~ p+q < p. -Proof. - intro H. elim (lt_irrefl p). - apply lt_trans with (p+q); auto using lt_add_r. -Qed. - -Lemma pow_gt_1 n p : 1 1 exists r, sub_mask p q = IsPos r /\ q + r = p. -Proof. - rewrite lt_iff_add. intros (r,Hr). exists r. split; trivial. - now apply sub_mask_pos_iff. -Qed. - -Lemma sub_mask_pos p q : - q < p -> exists r, sub_mask p q = IsPos r. -Proof. - intros H. destruct (sub_mask_pos' p q H) as (r & Hr & _). now exists r. -Qed. - -Theorem sub_add p q : q < p -> (p-q)+q = p. -Proof. - intros H. destruct (sub_mask_pos p q H) as (r,U). - unfold sub. rewrite U. rewrite add_comm. now apply sub_mask_add. -Qed. - -Lemma add_sub p q : (p+q)-q = p. -Proof. - intros. apply add_reg_r with q. - rewrite sub_add; trivial. - rewrite add_comm. apply lt_add_r. -Qed. - -Lemma mul_sub_distr_l p q r : r p*(q-r) = p*q-p*r. -Proof. - intros H. - apply add_reg_r with (p*r). - rewrite <- mul_add_distr_l. - rewrite sub_add; trivial. - symmetry. apply sub_add; trivial. - now apply mul_lt_mono_l. -Qed. - -Lemma mul_sub_distr_r p q r : q

(p-q)*r = p*r-q*r. -Proof. - intros H. rewrite 3 (mul_comm _ r). now apply mul_sub_distr_l. -Qed. - -Lemma sub_lt_mono_l p q r: q

p r-p < r-q. -Proof. - intros Hqp Hpr. - apply (add_lt_mono_r p). - rewrite sub_add by trivial. - apply le_lt_trans with ((r-q)+q). - - rewrite sub_add by (now apply lt_trans with p). - apply le_refl. - - now apply add_lt_mono_l. -Qed. - -Lemma sub_compare_mono_l p q r : - q

r

(p-q ?= p-r) = (r ?= q). -Proof. - intros Hqp Hrp. - case (compare_spec r q); intros H. - - subst. apply compare_refl. - - apply sub_lt_mono_l; trivial. - - apply lt_gt, sub_lt_mono_l; trivial. -Qed. - -Lemma sub_compare_mono_r p q r : - p p (q-p ?= r-p) = (q ?= r). -Proof. - intros. rewrite <- (add_compare_mono_r p), 2 sub_add; trivial. -Qed. - -Lemma sub_lt_mono_r p q r : q

r q-r < p-r. -Proof. - intros. unfold lt. rewrite sub_compare_mono_r; trivial. - now apply lt_trans with q. -Qed. - -Lemma sub_decr n m : m n-m < n. -Proof. - intros. - apply add_lt_mono_r with m. - rewrite sub_add; trivial. - apply lt_add_r. -Qed. - -Lemma add_sub_assoc p q r : r p+(q-r) = p+q-r. -Proof. - intros. - apply add_reg_r with r. - rewrite <- add_assoc, !sub_add; trivial. - rewrite add_comm. apply lt_trans with q; trivial using lt_add_r. -Qed. - -Lemma sub_add_distr p q r : q+r < p -> p-(q+r) = p-q-r. -Proof. - intros. - assert (q < p) - by (apply lt_trans with (q+r); trivial using lt_add_r). - rewrite (add_comm q r) in *. - apply add_reg_r with (r+q). - rewrite sub_add by trivial. - rewrite add_assoc, !sub_add; trivial. - apply (add_lt_mono_r q). rewrite sub_add; trivial. -Qed. - -Lemma sub_sub_distr p q r : r q-r < p -> p-(q-r) = p+r-q. -Proof. - intros. - apply add_reg_r with ((q-r)+r). - rewrite add_assoc, !sub_add; trivial. - rewrite <- (sub_add q r); trivial. - now apply add_lt_mono_r. -Qed. - -(** Recursive equations for [sub] *) - -Lemma sub_xO_xO n m : m n~0 - m~0 = (n-m)~0. -Proof. - intros H. unfold sub. simpl. - now destruct (sub_mask_pos n m H) as (p, ->). -Qed. - -Lemma sub_xI_xI n m : m n~1 - m~1 = (n-m)~0. -Proof. - intros H. unfold sub. simpl. - now destruct (sub_mask_pos n m H) as (p, ->). -Qed. - -Lemma sub_xI_xO n m : m n~1 - m~0 = (n-m)~1. -Proof. - intros H. unfold sub. simpl. - now destruct (sub_mask_pos n m) as (p, ->). -Qed. - -Lemma sub_xO_xI n m : n~0 - m~1 = pred_double (n-m). -Proof. - unfold sub. simpl. rewrite sub_mask_carry_spec. - now destruct (sub_mask n m) as [|[r|r|]|]. -Qed. - -(** Properties of subtraction with underflow *) - -Lemma sub_mask_neg_iff' p q : sub_mask p q = IsNeg <-> p < q. -Proof. - rewrite lt_iff_add. apply sub_mask_neg_iff. -Qed. - -Lemma sub_mask_neg p q : p sub_mask p q = IsNeg. -Proof. - apply sub_mask_neg_iff'. -Qed. - -Lemma sub_le p q : p<=q -> p-q = 1. -Proof. - unfold le, sub. rewrite compare_sub_mask. - destruct sub_mask; easy'. -Qed. - -Lemma sub_lt p q : p p-q = 1. -Proof. - intros. now apply sub_le, lt_le_incl. -Qed. - -Lemma sub_diag p : p-p = 1. -Proof. - unfold sub. now rewrite sub_mask_diag. -Qed. - -(** ** Results concerning [size] and [size_nat] *) - -Lemma size_nat_monotone p q : p (size_nat p <= size_nat q)%nat. -Proof. - assert (le0 : forall n, (0<=n)%nat) by (intro n; induction n; auto). - assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). - revert q. - induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; - simpl; intros H; auto; easy || apply leS; - red in H; simpl_compare_in H. - - apply IHp. red. now destruct (p?=q). - - destruct (compare_spec p q); subst; now auto. -Qed. - -Lemma size_gt p : p < 2^(size p). -Proof. - induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. - apply le_succ_l in IHp. now apply le_succ_l. -Qed. - -Lemma size_le p : 2^(size p) <= p~0. -Proof. - induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. - apply mul_le_mono_l. - apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp. -Qed. - -(** ** Properties of [min] and [max] *) - -(** First, the specification *) - -Lemma max_l : forall x y, y<=x -> max x y = x. -Proof. - intros x y H. unfold max. case compare_spec; auto. - intros H'. apply le_nlt in H. now elim H. -Qed. - -Lemma max_r : forall x y, x<=y -> max x y = y. -Proof. - unfold le, max. intros x y. destruct compare; easy'. -Qed. - -Lemma min_l : forall x y, x<=y -> min x y = x. -Proof. - unfold le, min. intros x y. destruct compare; easy'. -Qed. - -Lemma min_r : forall x y, y<=x -> min x y = y. -Proof. - intros x y H. unfold min. case compare_spec; auto. - intros H'. apply le_nlt in H. now elim H'. -Qed. - -(** We hence obtain all the generic properties of [min] and [max]. *) - -Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -Ltac order := Private_Tac.order. - -(** Minimum, maximum and constant one *) - -Lemma max_1_l n : max 1 n = n. -Proof. - unfold max. case compare_spec; auto. - intros H. apply lt_nle in H. elim H. apply le_1_l. -Qed. - -Lemma max_1_r n : max n 1 = n. -Proof. rewrite max_comm. apply max_1_l. Qed. - -Lemma min_1_l n : min 1 n = 1. -Proof. - unfold min. case compare_spec; auto. - intros H. apply lt_nle in H. elim H. apply le_1_l. -Qed. - -Lemma min_1_r n : min n 1 = 1. -Proof. rewrite min_comm. apply min_1_l. Qed. - -(** Minimum, maximum and operations (consequences of monotonicity) *) - -Lemma succ_max_distr n m : succ (max n m) = max (succ n) (succ m). -Proof. - symmetry. apply max_monotone. - intros x x'. apply succ_le_mono. -Qed. - -Lemma succ_min_distr n m : succ (min n m) = min (succ n) (succ m). -Proof. - symmetry. apply min_monotone. - intros x x'. apply succ_le_mono. -Qed. - -Lemma add_max_distr_l n m p : max (p + n) (p + m) = p + max n m. -Proof. - apply max_monotone. intros x x'. apply add_le_mono_l. -Qed. - -Lemma add_max_distr_r n m p : max (n + p) (m + p) = max n m + p. -Proof. - rewrite 3 (add_comm _ p). apply add_max_distr_l. -Qed. - -Lemma add_min_distr_l n m p : min (p + n) (p + m) = p + min n m. -Proof. - apply min_monotone. intros x x'. apply add_le_mono_l. -Qed. - -Lemma add_min_distr_r n m p : min (n + p) (m + p) = min n m + p. -Proof. - rewrite 3 (add_comm _ p). apply add_min_distr_l. -Qed. - -Lemma mul_max_distr_l n m p : max (p * n) (p * m) = p * max n m. -Proof. - apply max_monotone. intros x x'. apply mul_le_mono_l. -Qed. - -Lemma mul_max_distr_r n m p : max (n * p) (m * p) = max n m * p. -Proof. - rewrite 3 (mul_comm _ p). apply mul_max_distr_l. -Qed. - -Lemma mul_min_distr_l n m p : min (p * n) (p * m) = p * min n m. -Proof. - apply min_monotone. intros x x'. apply mul_le_mono_l. -Qed. - -Lemma mul_min_distr_r n m p : min (n * p) (m * p) = min n m * p. -Proof. - rewrite 3 (mul_comm _ p). apply mul_min_distr_l. -Qed. - - -(** ** Results concerning [iter_op] *) - -Lemma iter_op_succ : forall A (op:A->A->A), - (forall x y z, op x (op y z) = op (op x y) z) -> - forall p a, - iter_op op (succ p) a = op a (iter_op op p a). -Proof. - intros A op H p; induction p as [p IHp|p IHp|]; simpl; intros; trivial. - rewrite H. apply IHp. -Qed. - -Lemma iter_op_correct {A} op x p z - (op_zero_r : op x z = x) - (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) - : @Pos.iter_op A op p x = Pos.iter (op x) z p. -Proof. - induction p using peano_ind; cbn; - rewrite ?iter_op_succ, ?iter_succ, ?IHp; auto. -Qed. - -(** ** Results about [of_nat] and [of_succ_nat] *) - -Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n). -Proof. - induction n as [|n IHn]. - - trivial. - - simpl. f_equal. now rewrite IHn. -Qed. - -Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n. -Proof. - destruct n. - - trivial. - - simpl pred. rewrite pred_succ. apply of_nat_succ. -Qed. - -Lemma succ_of_nat (n:nat) : n<>O -> succ (of_nat n) = of_succ_nat n. -Proof. - rewrite of_nat_succ. destruct n; trivial. now destruct 1. -Qed. - -(** ** Correctness proofs for the square root function *) - -Inductive SqrtSpec : positive*mask -> positive -> Prop := - | SqrtExact s x : x=s*s -> SqrtSpec (s,IsNul) x - | SqrtApprox s r x : x=s*s+r -> r <= s~0 -> SqrtSpec (s,IsPos r) x. - -Lemma sqrtrem_step_spec f g p x : - (f=xO \/ f=xI) -> (g=xO \/ g=xI) -> - SqrtSpec p x -> SqrtSpec (sqrtrem_step f g p) (g (f x)). -Proof. - intros Hf Hg [ s _ -> | s r _ -> Hr ]. - - (* exact *) - unfold sqrtrem_step. - destruct Hf,Hg; subst; simpl; constructor; now rewrite ?square_xO. - - (* approx *) - assert (Hfg : forall p q, g (f (p+q)) = p~0~0 + g (f q)) - by (intros; destruct Hf, Hg; now subst). - unfold sqrtrem_step, leb. - case compare_spec; [intros EQ | intros LT | intros GT]. - + (* - EQ *) - rewrite <- EQ, sub_mask_diag. constructor. - destruct Hg; subst g; destr_eq EQ. - destruct Hf; subst f; destr_eq EQ. - subst. now rewrite square_xI. - + (* - LT *) - destruct (sub_mask_pos' _ _ LT) as (y & -> & H). constructor. - * rewrite Hfg, <- H. now rewrite square_xI, add_assoc. - * clear Hfg. - rewrite <- lt_succ_r in Hr. change (r < s~1) in Hr. - rewrite <- lt_succ_r, (add_lt_mono_l (s~0~1)), H. simpl. - rewrite add_carry_spec, add_diag. simpl. - destruct Hf,Hg; subst; red; simpl_compare; now rewrite Hr. - + (* - GT *) - constructor. - * now rewrite Hfg, square_xO. - * apply lt_succ_r, GT. -Qed. - -Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. -Proof. -revert p. fix sqrtrem_spec 1. - intro p; destruct p as [p|p|]; try destruct p; try (constructor; easy); - apply sqrtrem_step_spec; auto. -Qed. - -Lemma sqrt_spec p : - let s := sqrt p in s*s <= p < (succ s)*(succ s). -Proof. - simpl. - assert (H:=sqrtrem_spec p). - unfold sqrt in *. destruct sqrtrem as (s,rm); simpl. - inversion_clear H; subst. - - (* exact *) - split. - + reflexivity. - + apply mul_lt_mono; apply lt_succ_diag_r. - - (* approx *) - split. - + apply lt_le_incl, lt_add_r. - + rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l. - rewrite add_assoc, (add_comm _ _). apply add_lt_mono_r. - now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r. -Qed. - -(** ** Correctness proofs for the gcd function *) - -Lemma divide_add_cancel_l p q r : (p | r) -> (p | q + r) -> (p | q). -Proof. - intros (s,Hs) (t,Ht). - exists (t-s). - rewrite mul_sub_distr_r. - - rewrite <- Hs, <- Ht. - symmetry. apply add_sub. - - apply mul_lt_mono_r with p. - rewrite <- Hs, <- Ht, add_comm. - apply lt_add_r. -Qed. - -Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q). -Proof. - intros (s,Hs) (t,Ht). - destruct p. - - destruct s as [s|s|]; try easy. simpl in Hs. destr_eq Hs. now exists s. - - rewrite mul_xO_r in Ht; discriminate. - - exists q; now rewrite mul_1_r. -Qed. - -Lemma divide_xO_xO p q : (p~0|q~0) <-> (p|q). -Proof. - split; intros (r,H); simpl in *. - - rewrite mul_xO_r in H. destr_eq H. now exists r. - - exists r; simpl. rewrite mul_xO_r. f_equal; auto. -Qed. - -Lemma divide_mul_l p q r : (p|q) -> (p|q*r). -Proof. - intros (s,H). exists (s*r). - rewrite <- mul_assoc, (mul_comm r p), mul_assoc. now f_equal. -Qed. - -Lemma divide_mul_r p q r : (p|r) -> (p|q*r). -Proof. - rewrite mul_comm. apply divide_mul_l. -Qed. - -(** The first component of ggcd is gcd *) - -Lemma ggcdn_gcdn : forall n a b, - fst (ggcdn n a b) = gcdn n a b. -Proof. - intro n; induction n as [|n IHn]. - - simpl; auto. - - intros a b; destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; - rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto. -Qed. - -Lemma ggcd_gcd : forall a b, fst (ggcd a b) = gcd a b. -Proof. - unfold ggcd, gcd. intros. apply ggcdn_gcdn. -Qed. - -(** The other components of ggcd are indeed the correct factors. *) - -Ltac destr_pggcdn IHn := - match goal with |- context [ ggcdn _ ?x ?y ] => - generalize (IHn x y); destruct ggcdn as (?g,(?u,?v)); simpl - end. - -Lemma ggcdn_correct_divisors : forall n a b, - let '(g,(aa,bb)) := ggcdn n a b in - a = g*aa /\ b = g*bb. -Proof. - intro n; induction n as [|n IHn]. - - simpl; auto. - - intros a b; destruct a, b; - simpl; auto; try case compare_spec; try destr_pggcdn IHn. - + (* Eq *) - intros ->. now rewrite mul_comm. - + (* Lt *) - intros (H',H) LT; split; auto. - rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. - simpl. f_equal. symmetry. - rewrite add_comm. now apply sub_add. - + (* Gt *) - intros (H',H) LT; split; auto. - rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. - simpl. f_equal. symmetry. - rewrite add_comm. now apply sub_add. - + (* Then... *) - intros (H,H'); split; auto. rewrite mul_xO_r, H'; auto. - + intros (H,H'); split; auto. rewrite mul_xO_r, H; auto. - + intros (H,H'); split; subst; auto. -Qed. - -Lemma ggcd_correct_divisors : forall a b, - let '(g,(aa,bb)) := ggcd a b in - a=g*aa /\ b=g*bb. -Proof. - unfold ggcd. intros. apply ggcdn_correct_divisors. -Qed. - -(** We can use this fact to prove a part of the gcd correctness *) - -Lemma gcd_divide_l : forall a b, (gcd a b | a). -Proof. - intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. - now rewrite mul_comm. -Qed. - -Lemma gcd_divide_r : forall a b, (gcd a b | b). -Proof. - intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. - now rewrite mul_comm. -Qed. - -(** We now prove directly that gcd is the greatest amongst common divisors *) - -Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat -> - forall p, (p|a) -> (p|b) -> (p|gcdn n a b). -Proof. - intro n; induction n as [|n IHn]; intros a b. - - destruct a, b; simpl; inversion 1. - - destruct a as [a|a|], b as [b|b|]; simpl; try case compare_spec; simpl; auto. - + (* Lt *) - intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * apply le_S_n in LE. eapply Nat.le_trans; [|eapply LE]. - rewrite Nat.add_comm, <- plus_n_Sm, <- plus_Sn_m. - apply Nat.add_le_mono; trivial. - apply size_nat_monotone, sub_decr, LT. - * apply divide_xO_xI with a; trivial. - apply (divide_add_cancel_l p _ a~1); trivial. - now rewrite <- sub_xI_xI, sub_add. - + (* Gt *) - intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * apply le_S_n in LE. eapply Nat.le_trans; [|eapply LE]. - apply Nat.add_le_mono; trivial. - apply size_nat_monotone, sub_decr, LT. - * apply divide_xO_xI with b; trivial. - apply (divide_add_cancel_l p _ b~1); trivial. - now rewrite <- sub_xI_xI, sub_add. - + (* a~1 b~0 *) - intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * apply le_S_n in LE. simpl. now rewrite plus_n_Sm. - * apply divide_xO_xI with a; trivial. - + (* a~0 b~1 *) - intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * simpl. now apply le_S_n. - * apply divide_xO_xI with b; trivial. - + (* a~0 b~0 *) - intros LE p Hp1 Hp2. - destruct p as [p|p|]. - * { change (gcdn n a b)~0 with (2*(gcdn n a b)). - apply divide_mul_r. - apply IHn; clear IHn. - - apply le_S_n in LE. rewrite <- plus_n_Sm in LE. now apply Nat.lt_le_incl. - - apply divide_xO_xI with p; trivial. now exists 1. - - apply divide_xO_xI with p; trivial. now exists 1. - } - * { apply divide_xO_xO. - apply IHn; clear IHn. - - apply le_S_n in LE. rewrite <- plus_n_Sm in LE. now apply Nat.lt_le_incl. - - now apply divide_xO_xO. - - now apply divide_xO_xO. - } - * exists (gcdn n a b)~0. now rewrite mul_1_r. -Qed. - -Lemma gcd_greatest : forall a b p, (p|a) -> (p|b) -> (p|gcd a b). -Proof. - intros. apply gcdn_greatest; auto. -Qed. - -(** As a consequence, the rests after division by gcd are relatively prime *) - -Lemma ggcd_greatest : forall a b, - let (aa,bb) := snd (ggcd a b) in - forall p, (p|aa) -> (p|bb) -> p=1. -Proof. - intros a b **. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). - rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl. - intros H (EQa,EQb) p Hp1 Hp2; subst. - assert (H' : (g*p | g)). { - apply H. - - destruct Hp1 as (r,Hr). exists r. - now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. - - destruct Hp2 as (r,Hr). exists r. - now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. - } - destruct H' as (q,H'). - rewrite (mul_comm g p), mul_assoc in H'. - apply mul_eq_1 with q; rewrite mul_comm. - now apply mul_reg_r with g. -Qed. + Lemma gt_lt_iff p q : p > q <-> q < p. + Proof. + unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. + Qed. + + Lemma gt_lt p q : p > q -> q < p. + Proof. + apply gt_lt_iff. + Qed. + + Lemma lt_gt p q : p < q -> q > p. + Proof. + apply gt_lt_iff. + Qed. + + Lemma ge_le_iff p q : p >= q <-> q <= p. + Proof. + unfold le, ge. now rewrite compare_antisym, CompOpp_iff. + Qed. + + Lemma ge_le p q : p >= q -> q <= p. + Proof. + apply ge_le_iff. + Qed. + + Lemma le_ge p q : p <= q -> q >= p. + Proof. + apply ge_le_iff. + Qed. + + (** ** Comparison and the successor *) + + Lemma compare_succ_r p q : + switch_Eq Gt (p ?= succ q) = switch_Eq Lt (p ?= q). + Proof. + revert q. + induction p as [p IH|p IH| ]; intros [q|q| ]; simpl; + simpl_compare; rewrite ?IH; trivial; + (now destruct compare) || (now destruct p). + Qed. + + Lemma compare_succ_l p q : + switch_Eq Lt (succ p ?= q) = switch_Eq Gt (p ?= q). + Proof. + rewrite 2 (compare_antisym q). generalize (compare_succ_r q p). + now do 2 destruct compare. + Qed. + + Theorem lt_succ_r p q : p < succ q <-> p <= q. + Proof. + unfold lt, le. generalize (compare_succ_r p q). + do 2 destruct compare; try discriminate; now split. + Qed. + + Lemma lt_succ_diag_r p : p < succ p. + Proof. + rewrite lt_iff_add. exists 1. apply add_1_r. + Qed. + + Lemma compare_succ_succ p q : (succ p ?= succ q) = (p ?= q). + Proof. + revert q. + induction p as [p|p|]; intro q; destruct q as [q|q|]; + simpl; simpl_compare; trivial; + apply compare_succ_l || apply compare_succ_r || + (now destruct p) || (now destruct q). + Qed. + + (** ** 1 is the least positive number *) + + Lemma le_1_l p : 1 <= p. + Proof. + now destruct p. + Qed. + + Lemma nlt_1_r p : ~ p < 1. + Proof. + now destruct p. + Qed. + + Lemma lt_1_succ p : 1 < succ p. + Proof. + apply lt_succ_r, le_1_l. + Qed. + + (** ** Properties of the order *) + + Lemma le_nlt p q : p <= q <-> ~ q < p. + Proof. + now rewrite <- ge_le_iff. + Qed. + + Lemma lt_nle p q : p < q <-> ~ q <= p. + Proof. + intros. unfold lt, le. rewrite compare_antisym. + destruct compare; split; auto; easy'. + Qed. + + Lemma lt_le_incl p q : p p<=q. + Proof. + intros. apply le_lteq. now left. + Qed. + + Lemma lt_lt_succ n m : n < m -> n < succ m. + Proof. + intros. now apply lt_succ_r, lt_le_incl. + Qed. + + Lemma succ_lt_mono n m : n < m <-> succ n < succ m. + Proof. + unfold lt. now rewrite compare_succ_succ. + Qed. + + Lemma succ_le_mono n m : n <= m <-> succ n <= succ m. + Proof. + unfold le. now rewrite compare_succ_succ. + Qed. + + Lemma lt_trans n m p : n < m -> m < p -> n < p. + Proof. + rewrite 3 lt_iff_add. intros (r,Hr) (s,Hs). + exists (r+s). now rewrite add_assoc, Hr, Hs. + Qed. + + Theorem lt_ind : forall (A : positive -> Prop) (n : positive), + A (succ n) -> + (forall m : positive, n < m -> A m -> A (succ m)) -> + forall m : positive, n < m -> A m. + Proof. + intros A n AB AS m. induction m using peano_ind; intros H. + - elim (nlt_1_r _ H). + - apply lt_succ_r, le_lteq in H. destruct H as [H|H]; subst; auto. + Qed. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - exact lt_irrefl. + - exact lt_trans. + Qed. + + #[global] + Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) lt. + Proof. repeat red. intros. subst; auto. Qed. + + Lemma lt_total p q : p < q \/ p = q \/ q < p. + Proof. + case (compare_spec p q); intuition. + Qed. + + Lemma le_refl p : p <= p. + Proof. + intros. unfold le. now rewrite compare_refl. + Qed. + + Lemma le_lt_trans n m p : n <= m -> m < p -> n < p. + Proof. + intros H H'. apply le_lteq in H. destruct H. + - now apply lt_trans with m. + - now subst. + Qed. + + Lemma lt_le_trans n m p : n < m -> m <= p -> n < p. + Proof. + intros H H'. apply le_lteq in H'. destruct H'. + - now apply lt_trans with m. + - now subst. + Qed. + + Lemma le_trans n m p : n <= m -> m <= p -> n <= p. + Proof. + intros H H'. + apply le_lteq in H. destruct H. + - apply le_lteq; left. now apply lt_le_trans with m. + - now subst. + Qed. + + Lemma le_succ_l n m : succ n <= m <-> n < m. + Proof. + rewrite <- lt_succ_r. symmetry. apply succ_lt_mono. + Qed. + + Lemma le_antisym p q : p <= q -> q <= p -> p = q. + Proof. + rewrite le_lteq; destruct 1; auto. + rewrite le_lteq; destruct 1; auto. + elim (lt_irrefl p). now transitivity q. + Qed. + + #[global] + Instance le_preorder : PreOrder le. + Proof. + split. + - exact le_refl. + - exact le_trans. + Qed. + + #[global] + Instance le_partorder : PartialOrder Logic.eq le. + Proof. + intros x y. change (x=y <-> x <= y <= x). + split. + - intros; now subst. + - destruct 1; now apply le_antisym. + Qed. + + (** ** Comparison and addition *) + + Lemma add_compare_mono_l p q r : (p+q ?= p+r) = (q ?= r). + Proof. + revert q r. induction p using peano_ind; intros q r. + - rewrite 2 add_1_l. apply compare_succ_succ. + - now rewrite 2 add_succ_l, compare_succ_succ. + Qed. + + Lemma add_compare_mono_r p q r : (q+p ?= r+p) = (q ?= r). + Proof. + rewrite 2 (add_comm _ p). apply add_compare_mono_l. + Qed. + + (** ** Order and addition *) + + Lemma lt_add_diag_r p q : p < p + q. + Proof. + rewrite lt_iff_add. now exists q. + Qed. + + Lemma add_lt_mono_l p q r : q p+q < p+r. + Proof. + unfold lt. rewrite add_compare_mono_l. apply iff_refl. + Qed. + + Lemma add_lt_mono_r p q r : q q+p < r+p. + Proof. + unfold lt. rewrite add_compare_mono_r. apply iff_refl. + Qed. + + Lemma add_lt_mono p q r s : p r p+r p+q<=p+r. + Proof. + unfold le. rewrite add_compare_mono_l. apply iff_refl. + Qed. + + Lemma add_le_mono_r p q r : q<=r <-> q+p<=r+p. + Proof. + unfold le. rewrite add_compare_mono_r. apply iff_refl. + Qed. + + Lemma add_le_mono p q r s : p<=q -> r<=s -> p+r <= q+s. + Proof. + intros. apply le_trans with (p+s). + - now apply add_le_mono_l. + - now apply add_le_mono_r. + Qed. + + (** ** Comparison and multiplication *) + + Lemma mul_compare_mono_l p q r : (p*q ?= p*r) = (q ?= r). + Proof. + revert q r. induction p as [p IHp|p IHp|]; simpl; trivial. + intros q r. specialize (IHp q r). + destruct (compare_spec q r). + - subst. apply compare_refl. + - now apply add_lt_mono. + - now apply lt_gt, add_lt_mono, gt_lt. + Qed. + + Lemma mul_compare_mono_r p q r : (q*p ?= r*p) = (q ?= r). + Proof. + rewrite 2 (mul_comm _ p). apply mul_compare_mono_l. + Qed. + + (** ** Order and multiplication *) + + Lemma mul_lt_mono_l p q r : q p*q < p*r. + Proof. + unfold lt. rewrite mul_compare_mono_l. apply iff_refl. + Qed. + + Lemma mul_lt_mono_r p q r : q q*p < r*p. + Proof. + unfold lt. rewrite mul_compare_mono_r. apply iff_refl. + Qed. + + Lemma mul_lt_mono p q r s : p r p*r < q*s. + Proof. + intros. apply lt_trans with (p*s). + - now apply mul_lt_mono_l. + - now apply mul_lt_mono_r. + Qed. + + Lemma mul_le_mono_l p q r : q<=r <-> p*q<=p*r. + Proof. + unfold le. rewrite mul_compare_mono_l. apply iff_refl. + Qed. + + Lemma mul_le_mono_r p q r : q<=r <-> q*p<=r*p. + Proof. + unfold le. rewrite mul_compare_mono_r. apply iff_refl. + Qed. + + Lemma mul_le_mono p q r s : p<=q -> r<=s -> p*r <= q*s. + Proof. + intros. apply le_trans with (p*s). + - now apply mul_le_mono_l. + - now apply mul_le_mono_r. + Qed. + + Lemma lt_add_r p q : p < p+q. + Proof. + induction q as [|q] using peano_ind. + - rewrite add_1_r. apply lt_succ_diag_r. + - apply lt_trans with (p+q); auto. + apply add_lt_mono_l, lt_succ_diag_r. + Qed. + + Lemma lt_not_add_l p q : ~ p+q < p. + Proof. + intro H. elim (lt_irrefl p). + apply lt_trans with (p+q); auto using lt_add_r. + Qed. + + Lemma pow_gt_1 n p : 1 1 exists r, sub_mask p q = IsPos r /\ q + r = p. + Proof. + rewrite lt_iff_add. intros (r,Hr). exists r. split; trivial. + now apply sub_mask_pos_iff. + Qed. + + Lemma sub_mask_pos p q : + q < p -> exists r, sub_mask p q = IsPos r. + Proof. + intros H. destruct (sub_mask_pos' p q H) as (r & Hr & _). now exists r. + Qed. + + Theorem sub_add p q : q < p -> (p-q)+q = p. + Proof. + intros H. destruct (sub_mask_pos p q H) as (r,U). + unfold sub. rewrite U. rewrite add_comm. now apply sub_mask_add. + Qed. + + Lemma add_sub p q : (p+q)-q = p. + Proof. + intros. apply add_reg_r with q. + rewrite sub_add; trivial. + rewrite add_comm. apply lt_add_r. + Qed. + + Lemma mul_sub_distr_l p q r : r p*(q-r) = p*q-p*r. + Proof. + intros H. + apply add_reg_r with (p*r). + rewrite <- mul_add_distr_l. + rewrite sub_add; trivial. + symmetry. apply sub_add; trivial. + now apply mul_lt_mono_l. + Qed. + + Lemma mul_sub_distr_r p q r : q

(p-q)*r = p*r-q*r. + Proof. + intros H. rewrite 3 (mul_comm _ r). now apply mul_sub_distr_l. + Qed. + + Lemma sub_lt_mono_l p q r: q

p r-p < r-q. + Proof. + intros Hqp Hpr. + apply (add_lt_mono_r p). + rewrite sub_add by trivial. + apply le_lt_trans with ((r-q)+q). + - rewrite sub_add by (now apply lt_trans with p). + apply le_refl. + - now apply add_lt_mono_l. + Qed. + + Lemma sub_compare_mono_l p q r : + q

r

(p-q ?= p-r) = (r ?= q). + Proof. + intros Hqp Hrp. + case (compare_spec r q); intros H. + - subst. apply compare_refl. + - apply sub_lt_mono_l; trivial. + - apply lt_gt, sub_lt_mono_l; trivial. + Qed. + + Lemma sub_compare_mono_r p q r : + p p (q-p ?= r-p) = (q ?= r). + Proof. + intros. rewrite <- (add_compare_mono_r p), 2 sub_add; trivial. + Qed. + + Lemma sub_lt_mono_r p q r : q

r q-r < p-r. + Proof. + intros. unfold lt. rewrite sub_compare_mono_r; trivial. + now apply lt_trans with q. + Qed. + + Lemma sub_decr n m : m n-m < n. + Proof. + intros. + apply add_lt_mono_r with m. + rewrite sub_add; trivial. + apply lt_add_r. + Qed. + + Lemma add_sub_assoc p q r : r p+(q-r) = p+q-r. + Proof. + intros. + apply add_reg_r with r. + rewrite <- add_assoc, !sub_add; trivial. + rewrite add_comm. apply lt_trans with q; trivial using lt_add_r. + Qed. + + Lemma sub_add_distr p q r : q+r < p -> p-(q+r) = p-q-r. + Proof. + intros. + assert (q < p) + by (apply lt_trans with (q+r); trivial using lt_add_r). + rewrite (add_comm q r) in *. + apply add_reg_r with (r+q). + rewrite sub_add by trivial. + rewrite add_assoc, !sub_add; trivial. + apply (add_lt_mono_r q). rewrite sub_add; trivial. + Qed. + + Lemma sub_sub_distr p q r : r q-r < p -> p-(q-r) = p+r-q. + Proof. + intros. + apply add_reg_r with ((q-r)+r). + rewrite add_assoc, !sub_add; trivial. + rewrite <- (sub_add q r); trivial. + now apply add_lt_mono_r. + Qed. + + (** Recursive equations for [sub] *) + + Lemma sub_xO_xO n m : m n~0 - m~0 = (n-m)~0. + Proof. + intros H. unfold sub. simpl. + now destruct (sub_mask_pos n m H) as (p, ->). + Qed. + + Lemma sub_xI_xI n m : m n~1 - m~1 = (n-m)~0. + Proof. + intros H. unfold sub. simpl. + now destruct (sub_mask_pos n m H) as (p, ->). + Qed. + + Lemma sub_xI_xO n m : m n~1 - m~0 = (n-m)~1. + Proof. + intros H. unfold sub. simpl. + now destruct (sub_mask_pos n m) as (p, ->). + Qed. + + Lemma sub_xO_xI n m : n~0 - m~1 = pred_double (n-m). + Proof. + unfold sub. simpl. rewrite sub_mask_carry_spec. + now destruct (sub_mask n m) as [|[r|r|]|]. + Qed. + + (** Properties of subtraction with underflow *) + + Lemma sub_mask_neg_iff' p q : sub_mask p q = IsNeg <-> p < q. + Proof. + rewrite lt_iff_add. apply sub_mask_neg_iff. + Qed. + + Lemma sub_mask_neg p q : p sub_mask p q = IsNeg. + Proof. + apply sub_mask_neg_iff'. + Qed. + + Lemma sub_le p q : p<=q -> p-q = 1. + Proof. + unfold le, sub. rewrite compare_sub_mask. + destruct sub_mask; easy'. + Qed. + + Lemma sub_lt p q : p p-q = 1. + Proof. + intros. now apply sub_le, lt_le_incl. + Qed. + + Lemma sub_diag p : p-p = 1. + Proof. + unfold sub. now rewrite sub_mask_diag. + Qed. + + (** ** Results concerning [size] and [size_nat] *) + + Lemma size_nat_monotone p q : p (size_nat p <= size_nat q)%nat. + Proof. + assert (le0 : forall n, (0<=n)%nat) by (intro n; induction n; auto). + assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). + revert q. + induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; + simpl; intros H; auto; easy || apply leS; + red in H; simpl_compare_in H. + - apply IHp. red. now destruct (p?=q). + - destruct (compare_spec p q); subst; now auto. + Qed. + + Lemma size_gt p : p < 2^(size p). + Proof. + induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. + apply le_succ_l in IHp. now apply le_succ_l. + Qed. + + Lemma size_le p : 2^(size p) <= p~0. + Proof. + induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. + apply mul_le_mono_l. + apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp. + Qed. + + (** ** Properties of [min] and [max] *) + + (** First, the specification *) + + Lemma max_l : forall x y, y<=x -> max x y = x. + Proof. + intros x y H. unfold max. case compare_spec; auto. + intros H'. apply le_nlt in H. now elim H. + Qed. + + Lemma max_r : forall x y, x<=y -> max x y = y. + Proof. + unfold le, max. intros x y. destruct compare; easy'. + Qed. + + Lemma min_l : forall x y, x<=y -> min x y = x. + Proof. + unfold le, min. intros x y. destruct compare; easy'. + Qed. + + Lemma min_r : forall x y, y<=x -> min x y = y. + Proof. + intros x y H. unfold min. case compare_spec; auto. + intros H'. apply le_nlt in H. now elim H'. + Qed. + + (** We hence obtain all the generic properties of [min] and [max]. *) + + Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + + Ltac order := Private_Tac.order. + + (** Minimum, maximum and constant one *) + + Lemma max_1_l n : max 1 n = n. + Proof. + unfold max. case compare_spec; auto. + intros H. apply lt_nle in H. elim H. apply le_1_l. + Qed. + + Lemma max_1_r n : max n 1 = n. + Proof. rewrite max_comm. apply max_1_l. Qed. + + Lemma min_1_l n : min 1 n = 1. + Proof. + unfold min. case compare_spec; auto. + intros H. apply lt_nle in H. elim H. apply le_1_l. + Qed. + + Lemma min_1_r n : min n 1 = 1. + Proof. rewrite min_comm. apply min_1_l. Qed. + + (** Minimum, maximum and operations (consequences of monotonicity) *) + + Lemma succ_max_distr n m : succ (max n m) = max (succ n) (succ m). + Proof. + symmetry. apply max_monotone. + intros x x'. apply succ_le_mono. + Qed. + + Lemma succ_min_distr n m : succ (min n m) = min (succ n) (succ m). + Proof. + symmetry. apply min_monotone. + intros x x'. apply succ_le_mono. + Qed. + + Lemma add_max_distr_l n m p : max (p + n) (p + m) = p + max n m. + Proof. + apply max_monotone. intros x x'. apply add_le_mono_l. + Qed. + + Lemma add_max_distr_r n m p : max (n + p) (m + p) = max n m + p. + Proof. + rewrite 3 (add_comm _ p). apply add_max_distr_l. + Qed. + + Lemma add_min_distr_l n m p : min (p + n) (p + m) = p + min n m. + Proof. + apply min_monotone. intros x x'. apply add_le_mono_l. + Qed. + + Lemma add_min_distr_r n m p : min (n + p) (m + p) = min n m + p. + Proof. + rewrite 3 (add_comm _ p). apply add_min_distr_l. + Qed. + + Lemma mul_max_distr_l n m p : max (p * n) (p * m) = p * max n m. + Proof. + apply max_monotone. intros x x'. apply mul_le_mono_l. + Qed. + + Lemma mul_max_distr_r n m p : max (n * p) (m * p) = max n m * p. + Proof. + rewrite 3 (mul_comm _ p). apply mul_max_distr_l. + Qed. + + Lemma mul_min_distr_l n m p : min (p * n) (p * m) = p * min n m. + Proof. + apply min_monotone. intros x x'. apply mul_le_mono_l. + Qed. + + Lemma mul_min_distr_r n m p : min (n * p) (m * p) = min n m * p. + Proof. + rewrite 3 (mul_comm _ p). apply mul_min_distr_l. + Qed. + + + (** ** Results concerning [iter_op] *) + + Lemma iter_op_succ : forall A (op:A->A->A), + (forall x y z, op x (op y z) = op (op x y) z) -> + forall p a, + iter_op op (succ p) a = op a (iter_op op p a). + Proof. + intros A op H p; induction p as [p IHp|p IHp|]; simpl; intros; trivial. + rewrite H. apply IHp. + Qed. + + Lemma iter_op_correct {A} op x p z + (op_zero_r : op x z = x) + (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) + : @Pos.iter_op A op p x = Pos.iter (op x) z p. + Proof. + induction p using peano_ind; cbn; + rewrite ?iter_op_succ, ?iter_succ, ?IHp; auto. + Qed. + + (** ** Results about [of_nat] and [of_succ_nat] *) + + Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n). + Proof. + induction n as [|n IHn]. + - trivial. + - simpl. f_equal. now rewrite IHn. + Qed. + + Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n. + Proof. + destruct n. + - trivial. + - simpl pred. rewrite pred_succ. apply of_nat_succ. + Qed. + + Lemma succ_of_nat (n:nat) : n<>O -> succ (of_nat n) = of_succ_nat n. + Proof. + rewrite of_nat_succ. destruct n; trivial. now destruct 1. + Qed. + + (** ** Correctness proofs for the square root function *) + + Inductive SqrtSpec : positive*mask -> positive -> Prop := + | SqrtExact s x : x=s*s -> SqrtSpec (s,IsNul) x + | SqrtApprox s r x : x=s*s+r -> r <= s~0 -> SqrtSpec (s,IsPos r) x. + + Lemma sqrtrem_step_spec f g p x : + (f=xO \/ f=xI) -> (g=xO \/ g=xI) -> + SqrtSpec p x -> SqrtSpec (sqrtrem_step f g p) (g (f x)). + Proof. + intros Hf Hg [ s _ -> | s r _ -> Hr ]. + - (* exact *) + unfold sqrtrem_step. + destruct Hf,Hg; subst; simpl; constructor; now rewrite ?square_xO. + - (* approx *) + assert (Hfg : forall p q, g (f (p+q)) = p~0~0 + g (f q)) + by (intros; destruct Hf, Hg; now subst). + unfold sqrtrem_step, leb. + case compare_spec; [intros EQ | intros LT | intros GT]. + + (* - EQ *) + rewrite <- EQ, sub_mask_diag. constructor. + destruct Hg; subst g; destr_eq EQ. + destruct Hf; subst f; destr_eq EQ. + subst. now rewrite square_xI. + + (* - LT *) + destruct (sub_mask_pos' _ _ LT) as (y & -> & H). constructor. + * rewrite Hfg, <- H. now rewrite square_xI, add_assoc. + * clear Hfg. + rewrite <- lt_succ_r in Hr. change (r < s~1) in Hr. + rewrite <- lt_succ_r, (add_lt_mono_l (s~0~1)), H. simpl. + rewrite add_carry_spec, add_diag. simpl. + destruct Hf,Hg; subst; red; simpl_compare; now rewrite Hr. + + (* - GT *) + constructor. + * now rewrite Hfg, square_xO. + * apply lt_succ_r, GT. + Qed. + + Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. + Proof. + revert p. fix sqrtrem_spec 1. + intro p; destruct p as [p|p|]; try destruct p; try (constructor; easy); + apply sqrtrem_step_spec; auto. + Qed. + + Lemma sqrt_spec p : + let s := sqrt p in s*s <= p < (succ s)*(succ s). + Proof. + simpl. + assert (H:=sqrtrem_spec p). + unfold sqrt in *. destruct sqrtrem as (s,rm); simpl. + inversion_clear H; subst. + - (* exact *) + split. + + reflexivity. + + apply mul_lt_mono; apply lt_succ_diag_r. + - (* approx *) + split. + + apply lt_le_incl, lt_add_r. + + rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l. + rewrite add_assoc, (add_comm _ _). apply add_lt_mono_r. + now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r. + Qed. + + (** ** Correctness proofs for the gcd function *) + + Lemma divide_add_cancel_l p q r : (p | r) -> (p | q + r) -> (p | q). + Proof. + intros (s,Hs) (t,Ht). + exists (t-s). + rewrite mul_sub_distr_r. + - rewrite <- Hs, <- Ht. + symmetry. apply add_sub. + - apply mul_lt_mono_r with p. + rewrite <- Hs, <- Ht, add_comm. + apply lt_add_r. + Qed. + + Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q). + Proof. + intros (s,Hs) (t,Ht). + destruct p. + - destruct s as [s|s|]; try easy. simpl in Hs. destr_eq Hs. now exists s. + - rewrite mul_xO_r in Ht; discriminate. + - exists q; now rewrite mul_1_r. + Qed. + + Lemma divide_xO_xO p q : (p~0|q~0) <-> (p|q). + Proof. + split; intros (r,H); simpl in *. + - rewrite mul_xO_r in H. destr_eq H. now exists r. + - exists r; simpl. rewrite mul_xO_r. f_equal; auto. + Qed. + + Lemma divide_mul_l p q r : (p|q) -> (p|q*r). + Proof. + intros (s,H). exists (s*r). + rewrite <- mul_assoc, (mul_comm r p), mul_assoc. now f_equal. + Qed. + + Lemma divide_mul_r p q r : (p|r) -> (p|q*r). + Proof. + rewrite mul_comm. apply divide_mul_l. + Qed. + + (** The first component of ggcd is gcd *) + + Lemma ggcdn_gcdn : forall n a b, + fst (ggcdn n a b) = gcdn n a b. + Proof. + intro n; induction n as [|n IHn]. + - simpl; auto. + - intros a b; destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; + rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto. + Qed. + + Lemma ggcd_gcd : forall a b, fst (ggcd a b) = gcd a b. + Proof. + unfold ggcd, gcd. intros. apply ggcdn_gcdn. + Qed. + + (** The other components of ggcd are indeed the correct factors. *) + + Ltac destr_pggcdn IHn := + match goal with |- context [ ggcdn _ ?x ?y ] => + generalize (IHn x y); destruct ggcdn as (?g,(?u,?v)); simpl + end. + + Lemma ggcdn_correct_divisors : forall n a b, + let '(g,(aa,bb)) := ggcdn n a b in + a = g*aa /\ b = g*bb. + Proof. + intro n; induction n as [|n IHn]. + - simpl; auto. + - intros a b; destruct a, b; + simpl; auto; try case compare_spec; try destr_pggcdn IHn. + + (* Eq *) + intros ->. now rewrite mul_comm. + + (* Lt *) + intros (H',H) LT; split; auto. + rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. + simpl. f_equal. symmetry. + rewrite add_comm. now apply sub_add. + + (* Gt *) + intros (H',H) LT; split; auto. + rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. + simpl. f_equal. symmetry. + rewrite add_comm. now apply sub_add. + + (* Then... *) + intros (H,H'); split; auto. rewrite mul_xO_r, H'; auto. + + intros (H,H'); split; auto. rewrite mul_xO_r, H; auto. + + intros (H,H'); split; subst; auto. + Qed. + + Lemma ggcd_correct_divisors : forall a b, + let '(g,(aa,bb)) := ggcd a b in + a=g*aa /\ b=g*bb. + Proof. + unfold ggcd. intros. apply ggcdn_correct_divisors. + Qed. + + (** We can use this fact to prove a part of the gcd correctness *) + + Lemma gcd_divide_l : forall a b, (gcd a b | a). + Proof. + intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). + destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. + now rewrite mul_comm. + Qed. + + Lemma gcd_divide_r : forall a b, (gcd a b | b). + Proof. + intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). + destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. + now rewrite mul_comm. + Qed. + + (** We now prove directly that gcd is the greatest amongst common divisors *) + + Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat -> + forall p, (p|a) -> (p|b) -> (p|gcdn n a b). + Proof. + intro n; induction n as [|n IHn]; intros a b. + - destruct a, b; simpl; inversion 1. + - destruct a as [a|a|], b as [b|b|]; simpl; try case compare_spec; simpl; auto. + + (* Lt *) + intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. + * apply le_S_n in LE. eapply Nat.le_trans; [|eapply LE]. + rewrite Nat.add_comm, <- plus_n_Sm, <- plus_Sn_m. + apply Nat.add_le_mono; trivial. + apply size_nat_monotone, sub_decr, LT. + * apply divide_xO_xI with a; trivial. + apply (divide_add_cancel_l p _ a~1); trivial. + now rewrite <- sub_xI_xI, sub_add. + + (* Gt *) + intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. + * apply le_S_n in LE. eapply Nat.le_trans; [|eapply LE]. + apply Nat.add_le_mono; trivial. + apply size_nat_monotone, sub_decr, LT. + * apply divide_xO_xI with b; trivial. + apply (divide_add_cancel_l p _ b~1); trivial. + now rewrite <- sub_xI_xI, sub_add. + + (* a~1 b~0 *) + intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. + * apply le_S_n in LE. simpl. now rewrite plus_n_Sm. + * apply divide_xO_xI with a; trivial. + + (* a~0 b~1 *) + intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. + * simpl. now apply le_S_n. + * apply divide_xO_xI with b; trivial. + + (* a~0 b~0 *) + intros LE p Hp1 Hp2. + destruct p as [p|p|]. + * { change (gcdn n a b)~0 with (2*(gcdn n a b)). + apply divide_mul_r. + apply IHn; clear IHn. + - apply le_S_n in LE. rewrite <- plus_n_Sm in LE. now apply Nat.lt_le_incl. + - apply divide_xO_xI with p; trivial. now exists 1. + - apply divide_xO_xI with p; trivial. now exists 1. + } + * { apply divide_xO_xO. + apply IHn; clear IHn. + - apply le_S_n in LE. rewrite <- plus_n_Sm in LE. now apply Nat.lt_le_incl. + - now apply divide_xO_xO. + - now apply divide_xO_xO. + } + * exists (gcdn n a b)~0. now rewrite mul_1_r. + Qed. + + Lemma gcd_greatest : forall a b p, (p|a) -> (p|b) -> (p|gcd a b). + Proof. + intros. apply gcdn_greatest; auto. + Qed. + + (** As a consequence, the rests after division by gcd are relatively prime *) + + Lemma ggcd_greatest : forall a b, + let (aa,bb) := snd (ggcd a b) in + forall p, (p|aa) -> (p|bb) -> p=1. + Proof. + intros a b **. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). + rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl. + intros H (EQa,EQb) p Hp1 Hp2; subst. + assert (H' : (g*p | g)). { + apply H. + - destruct Hp1 as (r,Hr). exists r. + now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. + - destruct Hp2 as (r,Hr). exists r. + now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. + } + destruct H' as (q,H'). + rewrite (mul_comm g p), mul_assoc in H'. + apply mul_eq_1 with q; rewrite mul_comm. + now apply mul_reg_r with g. + Qed. End Pos. @@ -2150,17 +2150,17 @@ Lemma Pminus_mask_Gt p q : Pos.sub_mask p q = IsPos h /\ q + h = p /\ (h = 1 \/ Pos.sub_mask_carry p q = IsPos (Pos.pred h)). Proof. - intros H. apply Pos.gt_lt in H. - destruct (Pos.sub_mask_pos p q H) as (r & U). - exists r. repeat split; trivial. - - now apply Pos.sub_mask_pos_iff. - - destruct (Pos.eq_dec r 1) as [EQ|NE]; [now left|right]. - rewrite Pos.sub_mask_carry_spec, U. destruct r; trivial. now elim NE. + intros H. apply Pos.gt_lt in H. + destruct (Pos.sub_mask_pos p q H) as (r & U). + exists r. repeat split; trivial. + - now apply Pos.sub_mask_pos_iff. + - destruct (Pos.eq_dec r 1) as [EQ|NE]; [now left|right]. + rewrite Pos.sub_mask_carry_spec, U. destruct r; trivial. now elim NE. Qed. Lemma Pplus_minus : forall p q, p > q -> q+(p-q) = p. Proof. - intros. rewrite Pos.add_comm. now apply Pos.sub_add, Pos.gt_lt. + intros. rewrite Pos.add_comm. now apply Pos.sub_add, Pos.gt_lt. Qed. (** Discontinued results of little interest and little/zero use diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 9a4ad9a4c2..691cbbe0a5 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -24,359 +24,359 @@ From Stdlib Require Export BinNums BinNums.PosDef. Module Pos. -Include BinNums.PosDef.Pos. + Include BinNums.PosDef.Pos. -Definition t := positive. + Definition t := positive. -(** * Operations over positive numbers *) + (** * Operations over positive numbers *) -Infix "+" := add : positive_scope. + Infix "+" := add : positive_scope. -(** ** Predecessor *) + (** ** Predecessor *) -Definition pred x := - match x with - | p~1 => p~0 - | p~0 => pred_double p - | 1 => 1 - end. + Definition pred x := + match x with + | p~1 => p~0 + | p~0 => pred_double p + | 1 => 1 + end. -(** ** Predecessor with mask *) + (** ** Predecessor with mask *) -Definition pred_mask (p : mask) : mask := - match p with - | IsPos 1 => IsNul - | IsPos q => IsPos (pred q) - | IsNul => IsNeg - | IsNeg => IsNeg - end. + Definition pred_mask (p : mask) : mask := + match p with + | IsPos 1 => IsNul + | IsPos q => IsPos (pred q) + | IsNul => IsNeg + | IsNeg => IsNeg + end. -Infix "-" := sub : positive_scope. + Infix "-" := sub : positive_scope. -Infix "*" := mul : positive_scope. + Infix "*" := mul : positive_scope. -(** ** Power *) + (** ** Power *) -Definition pow (x:positive) := iter (mul x) 1. + Definition pow (x:positive) := iter (mul x) 1. -Infix "^" := pow : positive_scope. + Infix "^" := pow : positive_scope. -(** ** Square *) + (** ** Square *) -Fixpoint square p := - match p with - | p~1 => (square p + p)~0~1 - | p~0 => (square p)~0~0 - | 1 => 1 - end. + Fixpoint square p := + match p with + | p~1 => (square p + p)~0~1 + | p~0 => (square p)~0~0 + | 1 => 1 + end. -(** ** Number of digits in a positive number *) + (** ** Number of digits in a positive number *) -Fixpoint size_nat p : nat := - match p with - | 1 => S O - | p~1 => S (size_nat p) - | p~0 => S (size_nat p) - end. + Fixpoint size_nat p : nat := + match p with + | 1 => S O + | p~1 => S (size_nat p) + | p~0 => S (size_nat p) + end. -(** Same, with positive output *) + (** Same, with positive output *) -Fixpoint size p := - match p with - | 1 => 1 - | p~1 => succ (size p) - | p~0 => succ (size p) - end. + Fixpoint size p := + match p with + | 1 => 1 + | p~1 => succ (size p) + | p~0 => succ (size p) + end. -Infix "?=" := compare (at level 70, no associativity) : positive_scope. + Infix "?=" := compare (at level 70, no associativity) : positive_scope. -Definition min p p' := - match p ?= p' with - | Lt | Eq => p - | Gt => p' - end. + Definition min p p' := + match p ?= p' with + | Lt | Eq => p + | Gt => p' + end. -Definition max p p' := - match p ?= p' with - | Lt | Eq => p' - | Gt => p - end. + Definition max p p' := + match p ?= p' with + | Lt | Eq => p' + | Gt => p + end. -(** ** Boolean equality and comparisons *) + (** ** Boolean equality and comparisons *) -Definition ltb x y := - match x ?= y with Lt => true | _ => false end. + Definition ltb x y := + match x ?= y with Lt => true | _ => false end. -Infix "=?" := eqb (at level 70, no associativity) : positive_scope. -Infix "<=?" := leb (at level 70, no associativity) : positive_scope. -Infix " 1 - | S n => - match a,b with - | 1, _ => 1 - | _, 1 => 1 - | a~0, b~0 => (gcdn n a b)~0 - | _ , b~0 => gcdn n a b - | a~0, _ => gcdn n a b - | a'~1, b'~1 => - match a' ?= b' with - | Eq => a - | Lt => gcdn n (b'-a') a - | Gt => gcdn n (a'-b') b - end - end - end. - -(** We'll show later that we need at most (log2(a.b)) loops *) - -Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b. - -(** Generalized Gcd, also computing the division of a and b by the gcd *) -Set Printing Universes. -Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) := - match n with - | O => (1,(a,b)) - | S n => - match a,b with - | 1, _ => (1,(1,b)) - | _, 1 => (1,(a,1)) - | a~0, b~0 => - let (g,p) := ggcdn n a b in - (g~0,p) - | _, b~0 => - let '(g,(aa,bb)) := ggcdn n a b in - (g,(aa, bb~0)) - | a~0, _ => - let '(g,(aa,bb)) := ggcdn n a b in - (g,(aa~0, bb)) - | a'~1, b'~1 => - match a' ?= b' with - | Eq => (a,(1,1)) - | Lt => - let '(g,(ba,aa)) := ggcdn n (b'-a') a in - (g,(aa, aa + ba~0)) - | Gt => - let '(g,(ab,bb)) := ggcdn n (a'-b') b in - (g,(bb + ab~0, bb)) - end - end - end. - -Definition ggcd (a b: positive) := ggcdn (size_nat a + size_nat b)%nat a b. - -(** Shifts. NB: right shift of 1 stays at 1. *) - -Definition shiftl_nat (p:positive) := nat_rect _ p (fun _ => xO). -Definition shiftr_nat (p:positive) := nat_rect _ p (fun _ => div2). - -Definition shiftl (p:positive)(n:N) := - match n with - | N0 => p - | Npos n => iter xO p n - end. - -Definition shiftr (p:positive)(n:N) := - match n with - | N0 => p - | Npos n => iter div2 p n - end. - -(** Checking whether a particular bit is set or not *) - -Fixpoint testbit_nat (p:positive) : nat -> bool := - match p with - | 1 => fun n => match n with - | O => true - | S _ => false - end - | p~0 => fun n => match n with - | O => false - | S n' => testbit_nat p n' - end - | p~1 => fun n => match n with + Fixpoint gcdn (n : nat) (a b : positive) : positive := + match n with + | O => 1 + | S n => + match a,b with + | 1, _ => 1 + | _, 1 => 1 + | a~0, b~0 => (gcdn n a b)~0 + | _ , b~0 => gcdn n a b + | a~0, _ => gcdn n a b + | a'~1, b'~1 => + match a' ?= b' with + | Eq => a + | Lt => gcdn n (b'-a') a + | Gt => gcdn n (a'-b') b + end + end + end. + + (** We'll show later that we need at most (log2(a.b)) loops *) + + Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b. + + (** Generalized Gcd, also computing the division of a and b by the gcd *) + Set Printing Universes. + Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) := + match n with + | O => (1,(a,b)) + | S n => + match a,b with + | 1, _ => (1,(1,b)) + | _, 1 => (1,(a,1)) + | a~0, b~0 => + let (g,p) := ggcdn n a b in + (g~0,p) + | _, b~0 => + let '(g,(aa,bb)) := ggcdn n a b in + (g,(aa, bb~0)) + | a~0, _ => + let '(g,(aa,bb)) := ggcdn n a b in + (g,(aa~0, bb)) + | a'~1, b'~1 => + match a' ?= b' with + | Eq => (a,(1,1)) + | Lt => + let '(g,(ba,aa)) := ggcdn n (b'-a') a in + (g,(aa, aa + ba~0)) + | Gt => + let '(g,(ab,bb)) := ggcdn n (a'-b') b in + (g,(bb + ab~0, bb)) + end + end + end. + + Definition ggcd (a b: positive) := ggcdn (size_nat a + size_nat b)%nat a b. + + (** Shifts. NB: right shift of 1 stays at 1. *) + + Definition shiftl_nat (p:positive) := nat_rect _ p (fun _ => xO). + Definition shiftr_nat (p:positive) := nat_rect _ p (fun _ => div2). + + Definition shiftl (p:positive)(n:N) := + match n with + | N0 => p + | Npos n => iter xO p n + end. + + Definition shiftr (p:positive)(n:N) := + match n with + | N0 => p + | Npos n => iter div2 p n + end. + + (** Checking whether a particular bit is set or not *) + + Fixpoint testbit_nat (p:positive) : nat -> bool := + match p with + | 1 => fun n => match n with | O => true - | S n' => testbit_nat p n' + | S _ => false end - end. - -(** Same, but with index in N *) - -Fixpoint testbit (p:positive)(n:N) := - match p, n with - | p~0, N0 => false - | _, N0 => true - | 1, _ => false - | p~0, Npos n => testbit p (pred_N n) - | p~1, Npos n => testbit p (pred_N n) - end. - -(** ** From Peano natural numbers to binary positive numbers *) - -(** A version preserving positive numbers, and sending 0 to 1. *) - -Fixpoint of_nat (n:nat) : positive := - match n with - | O => 1 - | S O => 1 - | S x => succ (of_nat x) - end. - -(** ** Conversion with a decimal representation for printing/parsing *) - -#[local] Notation ten := 1~0~1~0. - -Fixpoint of_uint_acc (d:Decimal.uint)(acc:positive) := - match d with - | Decimal.Nil => acc - | Decimal.D0 l => of_uint_acc l (mul ten acc) - | Decimal.D1 l => of_uint_acc l (add 1 (mul ten acc)) - | Decimal.D2 l => of_uint_acc l (add 1~0 (mul ten acc)) - | Decimal.D3 l => of_uint_acc l (add 1~1 (mul ten acc)) - | Decimal.D4 l => of_uint_acc l (add 1~0~0 (mul ten acc)) - | Decimal.D5 l => of_uint_acc l (add 1~0~1 (mul ten acc)) - | Decimal.D6 l => of_uint_acc l (add 1~1~0 (mul ten acc)) - | Decimal.D7 l => of_uint_acc l (add 1~1~1 (mul ten acc)) - | Decimal.D8 l => of_uint_acc l (add 1~0~0~0 (mul ten acc)) - | Decimal.D9 l => of_uint_acc l (add 1~0~0~1 (mul ten acc)) - end. - -Fixpoint of_uint (d:Decimal.uint) : N := - match d with - | Decimal.Nil => N0 - | Decimal.D0 l => of_uint l - | Decimal.D1 l => Npos (of_uint_acc l 1) - | Decimal.D2 l => Npos (of_uint_acc l 1~0) - | Decimal.D3 l => Npos (of_uint_acc l 1~1) - | Decimal.D4 l => Npos (of_uint_acc l 1~0~0) - | Decimal.D5 l => Npos (of_uint_acc l 1~0~1) - | Decimal.D6 l => Npos (of_uint_acc l 1~1~0) - | Decimal.D7 l => Npos (of_uint_acc l 1~1~1) - | Decimal.D8 l => Npos (of_uint_acc l 1~0~0~0) - | Decimal.D9 l => Npos (of_uint_acc l 1~0~0~1) - end. - -#[local] Notation sixteen := 1~0~0~0~0. - -Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:positive) := - match d with - | Hexadecimal.Nil => acc - | Hexadecimal.D0 l => of_hex_uint_acc l (mul sixteen acc) - | Hexadecimal.D1 l => of_hex_uint_acc l (add 1 (mul sixteen acc)) - | Hexadecimal.D2 l => of_hex_uint_acc l (add 1~0 (mul sixteen acc)) - | Hexadecimal.D3 l => of_hex_uint_acc l (add 1~1 (mul sixteen acc)) - | Hexadecimal.D4 l => of_hex_uint_acc l (add 1~0~0 (mul sixteen acc)) - | Hexadecimal.D5 l => of_hex_uint_acc l (add 1~0~1 (mul sixteen acc)) - | Hexadecimal.D6 l => of_hex_uint_acc l (add 1~1~0 (mul sixteen acc)) - | Hexadecimal.D7 l => of_hex_uint_acc l (add 1~1~1 (mul sixteen acc)) - | Hexadecimal.D8 l => of_hex_uint_acc l (add 1~0~0~0 (mul sixteen acc)) - | Hexadecimal.D9 l => of_hex_uint_acc l (add 1~0~0~1 (mul sixteen acc)) - | Hexadecimal.Da l => of_hex_uint_acc l (add 1~0~1~0 (mul sixteen acc)) - | Hexadecimal.Db l => of_hex_uint_acc l (add 1~0~1~1 (mul sixteen acc)) - | Hexadecimal.Dc l => of_hex_uint_acc l (add 1~1~0~0 (mul sixteen acc)) - | Hexadecimal.Dd l => of_hex_uint_acc l (add 1~1~0~1 (mul sixteen acc)) - | Hexadecimal.De l => of_hex_uint_acc l (add 1~1~1~0 (mul sixteen acc)) - | Hexadecimal.Df l => of_hex_uint_acc l (add 1~1~1~1 (mul sixteen acc)) - end. - -Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := - match d with - | Hexadecimal.Nil => N0 - | Hexadecimal.D0 l => of_hex_uint l - | Hexadecimal.D1 l => Npos (of_hex_uint_acc l 1) - | Hexadecimal.D2 l => Npos (of_hex_uint_acc l 1~0) - | Hexadecimal.D3 l => Npos (of_hex_uint_acc l 1~1) - | Hexadecimal.D4 l => Npos (of_hex_uint_acc l 1~0~0) - | Hexadecimal.D5 l => Npos (of_hex_uint_acc l 1~0~1) - | Hexadecimal.D6 l => Npos (of_hex_uint_acc l 1~1~0) - | Hexadecimal.D7 l => Npos (of_hex_uint_acc l 1~1~1) - | Hexadecimal.D8 l => Npos (of_hex_uint_acc l 1~0~0~0) - | Hexadecimal.D9 l => Npos (of_hex_uint_acc l 1~0~0~1) - | Hexadecimal.Da l => Npos (of_hex_uint_acc l 1~0~1~0) - | Hexadecimal.Db l => Npos (of_hex_uint_acc l 1~0~1~1) - | Hexadecimal.Dc l => Npos (of_hex_uint_acc l 1~1~0~0) - | Hexadecimal.Dd l => Npos (of_hex_uint_acc l 1~1~0~1) - | Hexadecimal.De l => Npos (of_hex_uint_acc l 1~1~1~0) - | Hexadecimal.Df l => Npos (of_hex_uint_acc l 1~1~1~1) - end. - -Definition of_num_uint (d:Number.uint) : N := - match d with - | Number.UIntDecimal d => of_uint d - | Number.UIntHexadecimal d => of_hex_uint d - end. - -Definition of_int (d:Decimal.int) : option positive := - match d with - | Decimal.Pos d => - match of_uint d with - | N0 => None - | Npos p => Some p - end - | Decimal.Neg _ => None - end. - -Definition of_hex_int (d:Hexadecimal.int) : option positive := - match d with - | Hexadecimal.Pos d => - match of_hex_uint d with - | N0 => None - | Npos p => Some p - end - | Hexadecimal.Neg _ => None - end. - -Definition of_num_int (d:Number.int) : option positive := - match d with - | Number.IntDecimal d => of_int d - | Number.IntHexadecimal d => of_hex_int d - end. - -Fixpoint to_little_uint p := - match p with - | 1 => Decimal.D1 Decimal.Nil - | p~1 => Decimal.Little.succ_double (to_little_uint p) - | p~0 => Decimal.Little.double (to_little_uint p) - end. - -Definition to_uint p := Decimal.rev (to_little_uint p). - -Fixpoint to_little_hex_uint p := - match p with - | 1 => Hexadecimal.D1 Hexadecimal.Nil - | p~1 => Hexadecimal.Little.succ_double (to_little_hex_uint p) - | p~0 => Hexadecimal.Little.double (to_little_hex_uint p) - end. - -Definition to_hex_uint p := Hexadecimal.rev (to_little_hex_uint p). - -Definition to_num_uint p := Number.UIntDecimal (to_uint p). - -Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). - -Definition to_int n := Decimal.Pos (to_uint n). - -Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). - -Definition to_num_int n := Number.IntDecimal (to_int n). - -Definition to_num_hex_int n := Number.IntHexadecimal (to_hex_int n). - -Number Notation positive of_num_int to_num_hex_uint : hex_positive_scope. -Number Notation positive of_num_int to_num_uint : positive_scope. + | p~0 => fun n => match n with + | O => false + | S n' => testbit_nat p n' + end + | p~1 => fun n => match n with + | O => true + | S n' => testbit_nat p n' + end + end. + + (** Same, but with index in N *) + + Fixpoint testbit (p:positive)(n:N) := + match p, n with + | p~0, N0 => false + | _, N0 => true + | 1, _ => false + | p~0, Npos n => testbit p (pred_N n) + | p~1, Npos n => testbit p (pred_N n) + end. + + (** ** From Peano natural numbers to binary positive numbers *) + + (** A version preserving positive numbers, and sending 0 to 1. *) + + Fixpoint of_nat (n:nat) : positive := + match n with + | O => 1 + | S O => 1 + | S x => succ (of_nat x) + end. + + (** ** Conversion with a decimal representation for printing/parsing *) + + #[local] Notation ten := 1~0~1~0. + + Fixpoint of_uint_acc (d:Decimal.uint)(acc:positive) := + match d with + | Decimal.Nil => acc + | Decimal.D0 l => of_uint_acc l (mul ten acc) + | Decimal.D1 l => of_uint_acc l (add 1 (mul ten acc)) + | Decimal.D2 l => of_uint_acc l (add 1~0 (mul ten acc)) + | Decimal.D3 l => of_uint_acc l (add 1~1 (mul ten acc)) + | Decimal.D4 l => of_uint_acc l (add 1~0~0 (mul ten acc)) + | Decimal.D5 l => of_uint_acc l (add 1~0~1 (mul ten acc)) + | Decimal.D6 l => of_uint_acc l (add 1~1~0 (mul ten acc)) + | Decimal.D7 l => of_uint_acc l (add 1~1~1 (mul ten acc)) + | Decimal.D8 l => of_uint_acc l (add 1~0~0~0 (mul ten acc)) + | Decimal.D9 l => of_uint_acc l (add 1~0~0~1 (mul ten acc)) + end. + + Fixpoint of_uint (d:Decimal.uint) : N := + match d with + | Decimal.Nil => N0 + | Decimal.D0 l => of_uint l + | Decimal.D1 l => Npos (of_uint_acc l 1) + | Decimal.D2 l => Npos (of_uint_acc l 1~0) + | Decimal.D3 l => Npos (of_uint_acc l 1~1) + | Decimal.D4 l => Npos (of_uint_acc l 1~0~0) + | Decimal.D5 l => Npos (of_uint_acc l 1~0~1) + | Decimal.D6 l => Npos (of_uint_acc l 1~1~0) + | Decimal.D7 l => Npos (of_uint_acc l 1~1~1) + | Decimal.D8 l => Npos (of_uint_acc l 1~0~0~0) + | Decimal.D9 l => Npos (of_uint_acc l 1~0~0~1) + end. + + #[local] Notation sixteen := 1~0~0~0~0. + + Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:positive) := + match d with + | Hexadecimal.Nil => acc + | Hexadecimal.D0 l => of_hex_uint_acc l (mul sixteen acc) + | Hexadecimal.D1 l => of_hex_uint_acc l (add 1 (mul sixteen acc)) + | Hexadecimal.D2 l => of_hex_uint_acc l (add 1~0 (mul sixteen acc)) + | Hexadecimal.D3 l => of_hex_uint_acc l (add 1~1 (mul sixteen acc)) + | Hexadecimal.D4 l => of_hex_uint_acc l (add 1~0~0 (mul sixteen acc)) + | Hexadecimal.D5 l => of_hex_uint_acc l (add 1~0~1 (mul sixteen acc)) + | Hexadecimal.D6 l => of_hex_uint_acc l (add 1~1~0 (mul sixteen acc)) + | Hexadecimal.D7 l => of_hex_uint_acc l (add 1~1~1 (mul sixteen acc)) + | Hexadecimal.D8 l => of_hex_uint_acc l (add 1~0~0~0 (mul sixteen acc)) + | Hexadecimal.D9 l => of_hex_uint_acc l (add 1~0~0~1 (mul sixteen acc)) + | Hexadecimal.Da l => of_hex_uint_acc l (add 1~0~1~0 (mul sixteen acc)) + | Hexadecimal.Db l => of_hex_uint_acc l (add 1~0~1~1 (mul sixteen acc)) + | Hexadecimal.Dc l => of_hex_uint_acc l (add 1~1~0~0 (mul sixteen acc)) + | Hexadecimal.Dd l => of_hex_uint_acc l (add 1~1~0~1 (mul sixteen acc)) + | Hexadecimal.De l => of_hex_uint_acc l (add 1~1~1~0 (mul sixteen acc)) + | Hexadecimal.Df l => of_hex_uint_acc l (add 1~1~1~1 (mul sixteen acc)) + end. + + Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := + match d with + | Hexadecimal.Nil => N0 + | Hexadecimal.D0 l => of_hex_uint l + | Hexadecimal.D1 l => Npos (of_hex_uint_acc l 1) + | Hexadecimal.D2 l => Npos (of_hex_uint_acc l 1~0) + | Hexadecimal.D3 l => Npos (of_hex_uint_acc l 1~1) + | Hexadecimal.D4 l => Npos (of_hex_uint_acc l 1~0~0) + | Hexadecimal.D5 l => Npos (of_hex_uint_acc l 1~0~1) + | Hexadecimal.D6 l => Npos (of_hex_uint_acc l 1~1~0) + | Hexadecimal.D7 l => Npos (of_hex_uint_acc l 1~1~1) + | Hexadecimal.D8 l => Npos (of_hex_uint_acc l 1~0~0~0) + | Hexadecimal.D9 l => Npos (of_hex_uint_acc l 1~0~0~1) + | Hexadecimal.Da l => Npos (of_hex_uint_acc l 1~0~1~0) + | Hexadecimal.Db l => Npos (of_hex_uint_acc l 1~0~1~1) + | Hexadecimal.Dc l => Npos (of_hex_uint_acc l 1~1~0~0) + | Hexadecimal.Dd l => Npos (of_hex_uint_acc l 1~1~0~1) + | Hexadecimal.De l => Npos (of_hex_uint_acc l 1~1~1~0) + | Hexadecimal.Df l => Npos (of_hex_uint_acc l 1~1~1~1) + end. + + Definition of_num_uint (d:Number.uint) : N := + match d with + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d + end. + + Definition of_int (d:Decimal.int) : option positive := + match d with + | Decimal.Pos d => + match of_uint d with + | N0 => None + | Npos p => Some p + end + | Decimal.Neg _ => None + end. + + Definition of_hex_int (d:Hexadecimal.int) : option positive := + match d with + | Hexadecimal.Pos d => + match of_hex_uint d with + | N0 => None + | Npos p => Some p + end + | Hexadecimal.Neg _ => None + end. + + Definition of_num_int (d:Number.int) : option positive := + match d with + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d + end. + + Fixpoint to_little_uint p := + match p with + | 1 => Decimal.D1 Decimal.Nil + | p~1 => Decimal.Little.succ_double (to_little_uint p) + | p~0 => Decimal.Little.double (to_little_uint p) + end. + + Definition to_uint p := Decimal.rev (to_little_uint p). + + Fixpoint to_little_hex_uint p := + match p with + | 1 => Hexadecimal.D1 Hexadecimal.Nil + | p~1 => Hexadecimal.Little.succ_double (to_little_hex_uint p) + | p~0 => Hexadecimal.Little.double (to_little_hex_uint p) + end. + + Definition to_hex_uint p := Hexadecimal.rev (to_little_hex_uint p). + + Definition to_num_uint p := Number.UIntDecimal (to_uint p). + + Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). + + Definition to_int n := Decimal.Pos (to_uint n). + + Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). + + Definition to_num_int n := Number.IntDecimal (to_int n). + + Definition to_num_hex_int n := Number.IntHexadecimal (to_hex_int n). + + Number Notation positive of_num_int to_num_hex_uint : hex_positive_scope. + Number Notation positive of_num_int to_num_uint : positive_scope. End Pos. diff --git a/theories/PArith/Pnat.v b/theories/PArith/Pnat.v index 64fcfe91e2..ce36c45a89 100644 --- a/theories/PArith/Pnat.v +++ b/theories/PArith/Pnat.v @@ -20,324 +20,324 @@ From Stdlib Require Import BinPos PeanoNat. #[local] Open Scope nat_scope. Module Pos2Nat. - Import Pos. - -(** [Pos.to_nat] is a morphism for successor, addition, multiplication *) - -Lemma inj_succ p : to_nat (succ p) = S (to_nat p). -Proof. - unfold to_nat. rewrite iter_op_succ. - - trivial. - - apply Nat.add_assoc. -Qed. - -Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q. -Proof. - revert q. induction p as [|p IHp] using peano_ind; intros q. - - now rewrite add_1_l, inj_succ. - - now rewrite add_succ_l, !inj_succ, IHp. -Qed. - -Theorem inj_mul p q : to_nat (p * q) = to_nat p * to_nat q. -Proof. - revert q. induction p as [|p IHp] using peano_ind; simpl; intros; trivial. - now rewrite mul_succ_l, inj_add, IHp, inj_succ. -Qed. - -(** Mapping of xH, xO and xI through [Pos.to_nat] *) - -Lemma inj_1 : to_nat 1 = 1. -Proof. - reflexivity. -Qed. - -Lemma inj_xO p : to_nat (xO p) = 2 * to_nat p. -Proof. - exact (inj_mul 2 p). -Qed. - -Lemma inj_xI p : to_nat (xI p) = S (2 * to_nat p). -Proof. - now rewrite xI_succ_xO, inj_succ, inj_xO. -Qed. - -(** [Pos.to_nat] maps to the strictly positive subset of [nat] *) - -Lemma is_succ p : exists n, to_nat p = S n. -Proof. - induction p as [|p IHp] using peano_ind. - - now exists 0. - - destruct IHp as (n,Hn). exists (S n). now rewrite inj_succ, Hn. -Qed. - -(** [Pos.to_nat] is strictly positive *) - -Lemma is_pos p : 0 < to_nat p. -Proof. - destruct (is_succ p) as (n,->). apply Nat.lt_0_succ. -Qed. - -(** [Pos.to_nat] is a bijection between [positive] and + Import Pos. + + (** [Pos.to_nat] is a morphism for successor, addition, multiplication *) + + Lemma inj_succ p : to_nat (succ p) = S (to_nat p). + Proof. + unfold to_nat. rewrite iter_op_succ. + - trivial. + - apply Nat.add_assoc. + Qed. + + Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q. + Proof. + revert q. induction p as [|p IHp] using peano_ind; intros q. + - now rewrite add_1_l, inj_succ. + - now rewrite add_succ_l, !inj_succ, IHp. + Qed. + + Theorem inj_mul p q : to_nat (p * q) = to_nat p * to_nat q. + Proof. + revert q. induction p as [|p IHp] using peano_ind; simpl; intros; trivial. + now rewrite mul_succ_l, inj_add, IHp, inj_succ. + Qed. + + (** Mapping of xH, xO and xI through [Pos.to_nat] *) + + Lemma inj_1 : to_nat 1 = 1. + Proof. + reflexivity. + Qed. + + Lemma inj_xO p : to_nat (xO p) = 2 * to_nat p. + Proof. + exact (inj_mul 2 p). + Qed. + + Lemma inj_xI p : to_nat (xI p) = S (2 * to_nat p). + Proof. + now rewrite xI_succ_xO, inj_succ, inj_xO. + Qed. + + (** [Pos.to_nat] maps to the strictly positive subset of [nat] *) + + Lemma is_succ p : exists n, to_nat p = S n. + Proof. + induction p as [|p IHp] using peano_ind. + - now exists 0. + - destruct IHp as (n,Hn). exists (S n). now rewrite inj_succ, Hn. + Qed. + + (** [Pos.to_nat] is strictly positive *) + + Lemma is_pos p : 0 < to_nat p. + Proof. + destruct (is_succ p) as (n,->). apply Nat.lt_0_succ. + Qed. + + (** [Pos.to_nat] is a bijection between [positive] and non-zero [nat], with [Pos.of_nat] as reciprocal. See [Nat2Pos.id] below for the dual equation. *) -Theorem id p : of_nat (to_nat p) = p. -Proof. - induction p as [|p IHp] using peano_ind. - - trivial. - - rewrite inj_succ. rewrite <- IHp at 2. - now destruct (is_succ p) as (n,->). -Qed. - -(** [Pos.to_nat] is hence injective *) - -Lemma inj p q : to_nat p = to_nat q -> p = q. -Proof. - intros H. now rewrite <- (id p), <- (id q), H. -Qed. - -Lemma inj_iff p q : to_nat p = to_nat q <-> p = q. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. - -(** [Pos.to_nat] is a morphism for comparison *) - -Lemma inj_compare p q : (p ?= q)%positive = (to_nat p ?= to_nat q). -Proof. - revert q. induction p as [ |p IH] using peano_ind; intros q. - - destruct (succ_pred_or q) as [Hq|Hq]; [now subst|]. - rewrite <- Hq, lt_1_succ, inj_succ, inj_1, Nat.compare_succ. - symmetry. apply Nat.compare_lt_iff, is_pos. - - destruct (succ_pred_or q) as [Hq|Hq]; [subst|]. - + rewrite compare_antisym, lt_1_succ, inj_succ. simpl. - symmetry. apply Nat.compare_gt_iff, is_pos. - + now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH. -Qed. - -(** [Pos.to_nat] is a morphism for [lt], [le], etc *) - -Lemma inj_lt p q : (p < q)%positive <-> to_nat p < to_nat q. -Proof. - unfold lt. now rewrite inj_compare, Nat.compare_lt_iff. -Qed. - -Lemma inj_le p q : (p <= q)%positive <-> to_nat p <= to_nat q. -Proof. - unfold le. now rewrite inj_compare, Nat.compare_le_iff. -Qed. - -Lemma inj_gt p q : (p > q)%positive <-> to_nat p > to_nat q. -Proof. - unfold gt. now rewrite inj_compare, Nat.compare_gt_iff. -Qed. - -Lemma inj_ge p q : (p >= q)%positive <-> to_nat p >= to_nat q. -Proof. - unfold ge. now rewrite inj_compare, Nat.compare_ge_iff. -Qed. - -(** [Pos.to_nat] is a morphism for subtraction *) - -Theorem inj_sub p q : (q < p)%positive -> - to_nat (p - q) = to_nat p - to_nat q. -Proof. - intro H. apply Nat.add_cancel_r with (to_nat q). - rewrite Nat.sub_add. - - now rewrite <- inj_add, sub_add. - - now apply Nat.lt_le_incl, inj_lt. -Qed. - -Theorem inj_sub_max p q : - to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q). -Proof. - destruct (ltb_spec q p) as [H|H]. - - (* q < p *) - rewrite <- inj_sub by trivial. - now destruct (is_succ (p - q)) as (m,->). - - (* p <= q *) - rewrite sub_le by trivial. - apply inj_le, Nat.sub_0_le in H. now rewrite H. -Qed. - -Theorem inj_pred p : (1 < p)%positive -> - to_nat (pred p) = Nat.pred (to_nat p). -Proof. - intros. now rewrite <- Pos.sub_1_r, inj_sub, Nat.sub_1_r. -Qed. - -Theorem inj_pred_max p : - to_nat (pred p) = Nat.max 1 (Peano.pred (to_nat p)). -Proof. - rewrite <- Pos.sub_1_r, <- Nat.sub_1_r. apply inj_sub_max. -Qed. - -(** [Pos.to_nat] and other operations *) - -Lemma inj_min p q : - to_nat (min p q) = Nat.min (to_nat p) (to_nat q). -Proof. - unfold min. rewrite inj_compare. - case Nat.compare_spec; intros H; symmetry. - - apply Nat.min_l. now rewrite H. - - now apply Nat.min_l, Nat.lt_le_incl. - - now apply Nat.min_r, Nat.lt_le_incl. -Qed. - -Lemma inj_max p q : - to_nat (max p q) = Nat.max (to_nat p) (to_nat q). -Proof. - unfold max. rewrite inj_compare. - case Nat.compare_spec; intros H; symmetry. - - apply Nat.max_r. now rewrite H. - - now apply Nat.max_r, Nat.lt_le_incl. - - now apply Nat.max_l, Nat.lt_le_incl. -Qed. - -Theorem inj_iter p {A} (f:A->A) (x:A) : - Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p). -Proof. - induction p as [|p IHp] using peano_ind. - - trivial. - - intros. rewrite inj_succ, iter_succ. - simpl. f_equal. apply IHp. -Qed. - -Theorem inj_pow p q : to_nat (p ^ q) = to_nat p ^ to_nat q. -Proof. - induction q as [|q IHq] using peano_ind. - - now rewrite Pos.pow_1_r, inj_1, Nat.pow_1_r. - - unfold Pos.pow. rewrite inj_succ, iter_succ, inj_mul. fold (Pos.pow p q). - now rewrite IHq. -Qed. + Theorem id p : of_nat (to_nat p) = p. + Proof. + induction p as [|p IHp] using peano_ind. + - trivial. + - rewrite inj_succ. rewrite <- IHp at 2. + now destruct (is_succ p) as (n,->). + Qed. + + (** [Pos.to_nat] is hence injective *) + + Lemma inj p q : to_nat p = to_nat q -> p = q. + Proof. + intros H. now rewrite <- (id p), <- (id q), H. + Qed. + + Lemma inj_iff p q : to_nat p = to_nat q <-> p = q. + Proof. + split. + - apply inj. + - intros; now subst. + Qed. + + (** [Pos.to_nat] is a morphism for comparison *) + + Lemma inj_compare p q : (p ?= q)%positive = (to_nat p ?= to_nat q). + Proof. + revert q. induction p as [ |p IH] using peano_ind; intros q. + - destruct (succ_pred_or q) as [Hq|Hq]; [now subst|]. + rewrite <- Hq, lt_1_succ, inj_succ, inj_1, Nat.compare_succ. + symmetry. apply Nat.compare_lt_iff, is_pos. + - destruct (succ_pred_or q) as [Hq|Hq]; [subst|]. + + rewrite compare_antisym, lt_1_succ, inj_succ. simpl. + symmetry. apply Nat.compare_gt_iff, is_pos. + + now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH. + Qed. + + (** [Pos.to_nat] is a morphism for [lt], [le], etc *) + + Lemma inj_lt p q : (p < q)%positive <-> to_nat p < to_nat q. + Proof. + unfold lt. now rewrite inj_compare, Nat.compare_lt_iff. + Qed. + + Lemma inj_le p q : (p <= q)%positive <-> to_nat p <= to_nat q. + Proof. + unfold le. now rewrite inj_compare, Nat.compare_le_iff. + Qed. + + Lemma inj_gt p q : (p > q)%positive <-> to_nat p > to_nat q. + Proof. + unfold gt. now rewrite inj_compare, Nat.compare_gt_iff. + Qed. + + Lemma inj_ge p q : (p >= q)%positive <-> to_nat p >= to_nat q. + Proof. + unfold ge. now rewrite inj_compare, Nat.compare_ge_iff. + Qed. + + (** [Pos.to_nat] is a morphism for subtraction *) + + Theorem inj_sub p q : (q < p)%positive -> + to_nat (p - q) = to_nat p - to_nat q. + Proof. + intro H. apply Nat.add_cancel_r with (to_nat q). + rewrite Nat.sub_add. + - now rewrite <- inj_add, sub_add. + - now apply Nat.lt_le_incl, inj_lt. + Qed. + + Theorem inj_sub_max p q : + to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q). + Proof. + destruct (ltb_spec q p) as [H|H]. + - (* q < p *) + rewrite <- inj_sub by trivial. + now destruct (is_succ (p - q)) as (m,->). + - (* p <= q *) + rewrite sub_le by trivial. + apply inj_le, Nat.sub_0_le in H. now rewrite H. + Qed. + + Theorem inj_pred p : (1 < p)%positive -> + to_nat (pred p) = Nat.pred (to_nat p). + Proof. + intros. now rewrite <- Pos.sub_1_r, inj_sub, Nat.sub_1_r. + Qed. + + Theorem inj_pred_max p : + to_nat (pred p) = Nat.max 1 (Peano.pred (to_nat p)). + Proof. + rewrite <- Pos.sub_1_r, <- Nat.sub_1_r. apply inj_sub_max. + Qed. + + (** [Pos.to_nat] and other operations *) + + Lemma inj_min p q : + to_nat (min p q) = Nat.min (to_nat p) (to_nat q). + Proof. + unfold min. rewrite inj_compare. + case Nat.compare_spec; intros H; symmetry. + - apply Nat.min_l. now rewrite H. + - now apply Nat.min_l, Nat.lt_le_incl. + - now apply Nat.min_r, Nat.lt_le_incl. + Qed. + + Lemma inj_max p q : + to_nat (max p q) = Nat.max (to_nat p) (to_nat q). + Proof. + unfold max. rewrite inj_compare. + case Nat.compare_spec; intros H; symmetry. + - apply Nat.max_r. now rewrite H. + - now apply Nat.max_r, Nat.lt_le_incl. + - now apply Nat.max_l, Nat.lt_le_incl. + Qed. + + Theorem inj_iter p {A} (f:A->A) (x:A) : + Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p). + Proof. + induction p as [|p IHp] using peano_ind. + - trivial. + - intros. rewrite inj_succ, iter_succ. + simpl. f_equal. apply IHp. + Qed. + + Theorem inj_pow p q : to_nat (p ^ q) = to_nat p ^ to_nat q. + Proof. + induction q as [|q IHq] using peano_ind. + - now rewrite Pos.pow_1_r, inj_1, Nat.pow_1_r. + - unfold Pos.pow. rewrite inj_succ, iter_succ, inj_mul. fold (Pos.pow p q). + now rewrite IHq. + Qed. End Pos2Nat. Module Nat2Pos. -(** [Pos.of_nat] is a bijection between non-zero [nat] and + (** [Pos.of_nat] is a bijection between non-zero [nat] and [positive], with [Pos.to_nat] as reciprocal. See [Pos2Nat.id] above for the dual equation. *) -Theorem id (n:nat) : n<>0 -> Pos.to_nat (Pos.of_nat n) = n. -Proof. - induction n as [|n H]; trivial. - - now destruct 1. - - intros _. simpl Pos.of_nat. destruct n. - + trivial. - + rewrite Pos2Nat.inj_succ. f_equal. now apply H. -Qed. - -Theorem id_max (n:nat) : Pos.to_nat (Pos.of_nat n) = max 1 n. -Proof. - destruct n. - - trivial. - - now rewrite id. -Qed. - -(** [Pos.of_nat] is hence injective for non-zero numbers *) - -Lemma inj (n m : nat) : n<>0 -> m<>0 -> Pos.of_nat n = Pos.of_nat m -> n = m. -Proof. - intros Hn Hm H. now rewrite <- (id n), <- (id m), H. -Qed. - -Lemma inj_iff (n m : nat) : n<>0 -> m<>0 -> - (Pos.of_nat n = Pos.of_nat m <-> n = m). -Proof. - split. - - now apply inj. - - intros; now subst. -Qed. - -(** Usual operations are morphisms with respect to [Pos.of_nat] + Theorem id (n:nat) : n<>0 -> Pos.to_nat (Pos.of_nat n) = n. + Proof. + induction n as [|n H]; trivial. + - now destruct 1. + - intros _. simpl Pos.of_nat. destruct n. + + trivial. + + rewrite Pos2Nat.inj_succ. f_equal. now apply H. + Qed. + + Theorem id_max (n:nat) : Pos.to_nat (Pos.of_nat n) = max 1 n. + Proof. + destruct n. + - trivial. + - now rewrite id. + Qed. + + (** [Pos.of_nat] is hence injective for non-zero numbers *) + + Lemma inj (n m : nat) : n<>0 -> m<>0 -> Pos.of_nat n = Pos.of_nat m -> n = m. + Proof. + intros Hn Hm H. now rewrite <- (id n), <- (id m), H. + Qed. + + Lemma inj_iff (n m : nat) : n<>0 -> m<>0 -> + (Pos.of_nat n = Pos.of_nat m <-> n = m). + Proof. + split. + - now apply inj. + - intros; now subst. + Qed. + + (** Usual operations are morphisms with respect to [Pos.of_nat] for non-zero numbers. *) -Lemma inj_0 : Pos.of_nat 0 = 1%positive. -Proof. reflexivity. Qed. - -Lemma inj_succ (n:nat) : n<>0 -> Pos.of_nat (S n) = Pos.succ (Pos.of_nat n). -Proof. -intro H. apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id. -Qed. - -Lemma inj_pred (n:nat) : Pos.of_nat (pred n) = Pos.pred (Pos.of_nat n). -Proof. - destruct n as [|[|n]]; trivial. simpl. now rewrite Pos.pred_succ. -Qed. - -Lemma inj_add (n m : nat) : n<>0 -> m<>0 -> - Pos.of_nat (n+m) = (Pos.of_nat n + Pos.of_nat m)%positive. -Proof. -intros Hn Hm. apply Pos2Nat.inj. -rewrite Pos2Nat.inj_add, !id; trivial. -intros H. destruct n. -- now destruct Hn. -- now simpl in H. -Qed. - -Lemma inj_mul (n m : nat) : n<>0 -> m<>0 -> - Pos.of_nat (n*m) = (Pos.of_nat n * Pos.of_nat m)%positive. -Proof. -intros Hn Hm. apply Pos2Nat.inj. -rewrite Pos2Nat.inj_mul, !id; trivial. -intros H. apply Nat.mul_eq_0 in H. destruct H. -- now elim Hn. -- now elim Hm. -Qed. - -Lemma inj_compare (n m : nat) : n<>0 -> m<>0 -> - (n ?= m) = (Pos.of_nat n ?= Pos.of_nat m)%positive. -Proof. -intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial. -Qed. - -Lemma inj_sub (n m : nat) : m<>0 -> - Pos.of_nat (n-m) = (Pos.of_nat n - Pos.of_nat m)%positive. -Proof. - intros Hm. - apply Pos2Nat.inj. - rewrite Pos2Nat.inj_sub_max. - rewrite (id m) by trivial. rewrite !id_max. - destruct n, m; trivial. -Qed. - -Lemma inj_min (n m : nat) : - Pos.of_nat (min n m) = Pos.min (Pos.of_nat n) (Pos.of_nat m). -Proof. - destruct n as [|n]. { simpl. symmetry. apply Pos.min_l, Pos.le_1_l. } - destruct m as [|m]. { simpl. symmetry. apply Pos.min_r, Pos.le_1_l. } - unfold Pos.min. rewrite <- inj_compare by easy. - case Nat.compare_spec; intros H; f_equal; - apply Nat.min_l || apply Nat.min_r. - - rewrite H; auto. - - now apply Nat.lt_le_incl. - - now apply Nat.lt_le_incl. -Qed. - -Lemma inj_max (n m : nat) : - Pos.of_nat (max n m) = Pos.max (Pos.of_nat n) (Pos.of_nat m). -Proof. - destruct n as [|n]. { simpl. symmetry. apply Pos.max_r, Pos.le_1_l. } - destruct m as [|m]. { simpl. symmetry. apply Pos.max_l, Pos.le_1_l. } - unfold Pos.max. rewrite <- inj_compare by easy. - case Nat.compare_spec; intros H; f_equal; - apply Nat.max_l || apply Nat.max_r. - - rewrite H; auto. - - now apply Nat.lt_le_incl. - - now apply Nat.lt_le_incl. -Qed. - -Theorem inj_pow (n m : nat) : m <> 0 -> - Pos.of_nat (n^m) = (Pos.of_nat n ^ Pos.of_nat m)%positive. -Proof. - intros Hm. apply Pos2Nat.inj. rewrite Pos2Nat.inj_pow. - destruct n. - - now rewrite Nat.pow_0_l, inj_0, Pos2Nat.inj_1, Nat.pow_1_l. - - now rewrite !id; [..|apply Nat.pow_nonzero]. -Qed. + Lemma inj_0 : Pos.of_nat 0 = 1%positive. + Proof. reflexivity. Qed. + + Lemma inj_succ (n:nat) : n<>0 -> Pos.of_nat (S n) = Pos.succ (Pos.of_nat n). + Proof. + intro H. apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id. + Qed. + + Lemma inj_pred (n:nat) : Pos.of_nat (pred n) = Pos.pred (Pos.of_nat n). + Proof. + destruct n as [|[|n]]; trivial. simpl. now rewrite Pos.pred_succ. + Qed. + + Lemma inj_add (n m : nat) : n<>0 -> m<>0 -> + Pos.of_nat (n+m) = (Pos.of_nat n + Pos.of_nat m)%positive. + Proof. + intros Hn Hm. apply Pos2Nat.inj. + rewrite Pos2Nat.inj_add, !id; trivial. + intros H. destruct n. + - now destruct Hn. + - now simpl in H. + Qed. + + Lemma inj_mul (n m : nat) : n<>0 -> m<>0 -> + Pos.of_nat (n*m) = (Pos.of_nat n * Pos.of_nat m)%positive. + Proof. + intros Hn Hm. apply Pos2Nat.inj. + rewrite Pos2Nat.inj_mul, !id; trivial. + intros H. apply Nat.mul_eq_0 in H. destruct H. + - now elim Hn. + - now elim Hm. + Qed. + + Lemma inj_compare (n m : nat) : n<>0 -> m<>0 -> + (n ?= m) = (Pos.of_nat n ?= Pos.of_nat m)%positive. + Proof. + intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial. + Qed. + + Lemma inj_sub (n m : nat) : m<>0 -> + Pos.of_nat (n-m) = (Pos.of_nat n - Pos.of_nat m)%positive. + Proof. + intros Hm. + apply Pos2Nat.inj. + rewrite Pos2Nat.inj_sub_max. + rewrite (id m) by trivial. rewrite !id_max. + destruct n, m; trivial. + Qed. + + Lemma inj_min (n m : nat) : + Pos.of_nat (min n m) = Pos.min (Pos.of_nat n) (Pos.of_nat m). + Proof. + destruct n as [|n]. { simpl. symmetry. apply Pos.min_l, Pos.le_1_l. } + destruct m as [|m]. { simpl. symmetry. apply Pos.min_r, Pos.le_1_l. } + unfold Pos.min. rewrite <- inj_compare by easy. + case Nat.compare_spec; intros H; f_equal; + apply Nat.min_l || apply Nat.min_r. + - rewrite H; auto. + - now apply Nat.lt_le_incl. + - now apply Nat.lt_le_incl. + Qed. + + Lemma inj_max (n m : nat) : + Pos.of_nat (max n m) = Pos.max (Pos.of_nat n) (Pos.of_nat m). + Proof. + destruct n as [|n]. { simpl. symmetry. apply Pos.max_r, Pos.le_1_l. } + destruct m as [|m]. { simpl. symmetry. apply Pos.max_l, Pos.le_1_l. } + unfold Pos.max. rewrite <- inj_compare by easy. + case Nat.compare_spec; intros H; f_equal; + apply Nat.max_l || apply Nat.max_r. + - rewrite H; auto. + - now apply Nat.lt_le_incl. + - now apply Nat.lt_le_incl. + Qed. + + Theorem inj_pow (n m : nat) : m <> 0 -> + Pos.of_nat (n^m) = (Pos.of_nat n ^ Pos.of_nat m)%positive. + Proof. + intros Hm. apply Pos2Nat.inj. rewrite Pos2Nat.inj_pow. + destruct n. + - now rewrite Nat.pow_0_l, inj_0, Pos2Nat.inj_1, Nat.pow_1_l. + - now rewrite !id; [..|apply Nat.pow_nonzero]. + Qed. End Nat2Pos. @@ -347,75 +347,75 @@ End Nat2Pos. Module Pos2SuccNat. -(** Composition of [Pos.to_nat] and [Pos.of_succ_nat] is successor + (** Composition of [Pos.to_nat] and [Pos.of_succ_nat] is successor on [positive] *) -Theorem id_succ p : Pos.of_succ_nat (Pos.to_nat p) = Pos.succ p. -Proof. -rewrite Pos.of_nat_succ, <- Pos2Nat.inj_succ. apply Pos2Nat.id. -Qed. + Theorem id_succ p : Pos.of_succ_nat (Pos.to_nat p) = Pos.succ p. + Proof. + rewrite Pos.of_nat_succ, <- Pos2Nat.inj_succ. apply Pos2Nat.id. + Qed. -(** Composition of [Pos.to_nat], [Pos.of_succ_nat] and [Pos.pred] + (** Composition of [Pos.to_nat], [Pos.of_succ_nat] and [Pos.pred] is identity on [positive] *) -Theorem pred_id p : Pos.pred (Pos.of_succ_nat (Pos.to_nat p)) = p. -Proof. -now rewrite id_succ, Pos.pred_succ. -Qed. + Theorem pred_id p : Pos.pred (Pos.of_succ_nat (Pos.to_nat p)) = p. + Proof. + now rewrite id_succ, Pos.pred_succ. + Qed. End Pos2SuccNat. Module SuccNat2Pos. -(** Composition of [Pos.of_succ_nat] and [Pos.to_nat] is successor on [nat] *) + (** Composition of [Pos.of_succ_nat] and [Pos.to_nat] is successor on [nat] *) -Theorem id_succ (n:nat) : Pos.to_nat (Pos.of_succ_nat n) = S n. -Proof. -rewrite Pos.of_nat_succ. now apply Nat2Pos.id. -Qed. + Theorem id_succ (n:nat) : Pos.to_nat (Pos.of_succ_nat n) = S n. + Proof. + rewrite Pos.of_nat_succ. now apply Nat2Pos.id. + Qed. -Theorem pred_id (n:nat) : pred (Pos.to_nat (Pos.of_succ_nat n)) = n. -Proof. -now rewrite id_succ. -Qed. + Theorem pred_id (n:nat) : pred (Pos.to_nat (Pos.of_succ_nat n)) = n. + Proof. + now rewrite id_succ. + Qed. -(** [Pos.of_succ_nat] is hence injective *) + (** [Pos.of_succ_nat] is hence injective *) -Lemma inj (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m -> n = m. -Proof. - intro H. apply (f_equal Pos.to_nat) in H. rewrite !id_succ in H. - now injection H. -Qed. + Lemma inj (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m -> n = m. + Proof. + intro H. apply (f_equal Pos.to_nat) in H. rewrite !id_succ in H. + now injection H. + Qed. -Lemma inj_iff (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m <-> n = m. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. + Lemma inj_iff (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m <-> n = m. + Proof. + split. + - apply inj. + - intros; now subst. + Qed. -(** Another formulation *) + (** Another formulation *) -Theorem inv n p : Pos.to_nat p = S n -> Pos.of_succ_nat n = p. -Proof. - intros H. apply Pos2Nat.inj. now rewrite id_succ. -Qed. + Theorem inv n p : Pos.to_nat p = S n -> Pos.of_succ_nat n = p. + Proof. + intros H. apply Pos2Nat.inj. now rewrite id_succ. + Qed. -(** Successor and comparison are morphisms with respect to + (** Successor and comparison are morphisms with respect to [Pos.of_succ_nat] *) -Lemma inj_succ n : Pos.of_succ_nat (S n) = Pos.succ (Pos.of_succ_nat n). -Proof. -apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ. -Qed. + Lemma inj_succ n : Pos.of_succ_nat (S n) = Pos.succ (Pos.of_succ_nat n). + Proof. + apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ. + Qed. -Lemma inj_compare n m : - (n ?= m) = (Pos.of_succ_nat n ?= Pos.of_succ_nat m)%positive. -Proof. -rewrite Pos2Nat.inj_compare, !id_succ; trivial. -Qed. + Lemma inj_compare n m : + (n ?= m) = (Pos.of_succ_nat n ?= Pos.of_succ_nat m)%positive. + Proof. + rewrite Pos2Nat.inj_compare, !id_succ; trivial. + Qed. -(** Other operations, for instance [Pos.add] and [plus] aren't + (** Other operations, for instance [Pos.add] and [plus] aren't directly related this way (we would need to compensate for the successor hidden in [Pos.of_succ_nat] *) @@ -489,52 +489,52 @@ Qed. Section ObsoletePmultNat. -Lemma Pmult_nat_mult : forall p n, - Pmult_nat p n = Pos.to_nat p * n. -Proof. - intro p; induction p as [p IHp|p IHp|]; intros n; unfold Pos.to_nat; simpl. - - f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc. - f_equal. simpl. now rewrite Nat.add_0_r. - - rewrite 2 IHp. rewrite <- Nat.mul_assoc. - f_equal. simpl. now rewrite Nat.add_0_r. - - simpl. now rewrite Nat.add_0_r. -Qed. - -Lemma Pmult_nat_succ_morphism : - forall p n, Pmult_nat (Pos.succ p) n = n + Pmult_nat p n. -Proof. - intros. now rewrite !Pmult_nat_mult, Pos2Nat.inj_succ. -Qed. - -Theorem Pmult_nat_l_plus_morphism : - forall p q n, Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n. -Proof. - intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply Nat.mul_add_distr_r. -Qed. - -Theorem Pmult_nat_plus_carry_morphism : - forall p q n, Pmult_nat (Pos.add_carry p q) n = n + Pmult_nat (p + q) n. -Proof. - intros. now rewrite Pos.add_carry_spec, Pmult_nat_succ_morphism. -Qed. - -Lemma Pmult_nat_r_plus_morphism : - forall p n, Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n. -Proof. - intros. rewrite !Pmult_nat_mult. apply Nat.mul_add_distr_l. -Qed. - -Lemma ZL6 : forall p, Pmult_nat p 2 = Pos.to_nat p + Pos.to_nat p. -Proof. - intros. rewrite Pmult_nat_mult, Nat.mul_comm. simpl. now rewrite Nat.add_0_r. -Qed. - -Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n. -Proof. - intros p n. rewrite Pmult_nat_mult. - apply Nat.le_trans with (1*n). - - now rewrite Nat.mul_1_l. - - apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos. -Qed. + Lemma Pmult_nat_mult : forall p n, + Pmult_nat p n = Pos.to_nat p * n. + Proof. + intro p; induction p as [p IHp|p IHp|]; intros n; unfold Pos.to_nat; simpl. + - f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc. + f_equal. simpl. now rewrite Nat.add_0_r. + - rewrite 2 IHp. rewrite <- Nat.mul_assoc. + f_equal. simpl. now rewrite Nat.add_0_r. + - simpl. now rewrite Nat.add_0_r. + Qed. + + Lemma Pmult_nat_succ_morphism : + forall p n, Pmult_nat (Pos.succ p) n = n + Pmult_nat p n. + Proof. + intros. now rewrite !Pmult_nat_mult, Pos2Nat.inj_succ. + Qed. + + Theorem Pmult_nat_l_plus_morphism : + forall p q n, Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n. + Proof. + intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply Nat.mul_add_distr_r. + Qed. + + Theorem Pmult_nat_plus_carry_morphism : + forall p q n, Pmult_nat (Pos.add_carry p q) n = n + Pmult_nat (p + q) n. + Proof. + intros. now rewrite Pos.add_carry_spec, Pmult_nat_succ_morphism. + Qed. + + Lemma Pmult_nat_r_plus_morphism : + forall p n, Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n. + Proof. + intros. rewrite !Pmult_nat_mult. apply Nat.mul_add_distr_l. + Qed. + + Lemma ZL6 : forall p, Pmult_nat p 2 = Pos.to_nat p + Pos.to_nat p. + Proof. + intros. rewrite Pmult_nat_mult, Nat.mul_comm. simpl. now rewrite Nat.add_0_r. + Qed. + + Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n. + Proof. + intros p n. rewrite Pmult_nat_mult. + apply Nat.le_trans with (1*n). + - now rewrite Nat.mul_1_l. + - apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos. + Qed. End ObsoletePmultNat. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 3d40a3d502..6d8bccd5c1 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -92,7 +92,7 @@ Qed. Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. Proof. - unfold Qeq; simpl; rewrite !Z.mul_1_r; reflexivity. + unfold Qeq; simpl; rewrite !Z.mul_1_r; reflexivity. Qed. (** Another approach : using Qcompare for defining order relations. *) @@ -102,27 +102,27 @@ Notation "p ?= q" := (Qcompare p q) : Q_scope. Lemma Qeq_alt p q : (p == q) <-> (p ?= q) = Eq. Proof. -symmetry. apply Z.compare_eq_iff. + symmetry. apply Z.compare_eq_iff. Qed. Lemma Qlt_alt p q : (p ((p?=q) = Lt). Proof. -reflexivity. + reflexivity. Qed. Lemma Qgt_alt p q : (p>q) <-> ((p?=q) = Gt). Proof. -symmetry. apply Z.gt_lt_iff. + symmetry. apply Z.gt_lt_iff. Qed. Lemma Qle_alt p q : (p<=q) <-> ((p?=q) <> Gt). Proof. -reflexivity. + reflexivity. Qed. Lemma Qge_alt p q : (p>=q) <-> ((p?=q) <> Lt). Proof. -symmetry. apply Z.ge_le_iff. + symmetry. apply Z.ge_le_iff. Qed. #[global] @@ -132,31 +132,31 @@ Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x). Proof. - symmetry. apply Z.compare_antisym. + symmetry. apply Z.compare_antisym. Qed. Lemma Qcompare_spec x y : CompareSpec (x==y) (x y == x. Proof. - auto with qarith. + auto with qarith. Qed. Theorem Qeq_trans x y z : x == y -> y == z -> x == z. Proof. -unfold Qeq; intros XY YZ. -apply Z.mul_reg_r with (QDen y); [auto with qarith|]. -now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0. + unfold Qeq; intros XY YZ. + apply Z.mul_reg_r with (QDen y); [auto with qarith|]. + now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0. Qed. #[global] @@ -174,7 +174,7 @@ Proof. split; red; eauto with qarith. Qed. Theorem Qeq_dec x y : {x==y} + {~ x==y}. Proof. - apply Z.eq_dec. + apply Z.eq_dec. Defined. Definition Qeq_bool x y := @@ -211,12 +211,12 @@ Qed. Theorem Qnot_eq_sym x y : ~x == y -> ~y == x. Proof. - auto with qarith. + auto with qarith. Qed. Lemma Qeq_bool_comm x y: Qeq_bool x y = Qeq_bool y x. Proof. - apply eq_true_iff_eq. rewrite !Qeq_bool_iff. now symmetry. + apply eq_true_iff_eq. rewrite !Qeq_bool_iff. now symmetry. Qed. Lemma Qeq_bool_refl x: Qeq_bool x x = true. @@ -458,7 +458,7 @@ Number Notation Q of_number to_number (via IQ Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b). Proof. -unfold Qeq. simpl. ring. + unfold Qeq. simpl. ring. Qed. (** * Setoid compatibility results *) @@ -566,15 +566,15 @@ Qed. #[global] Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool. Proof. - intros p q H r s H'; apply eq_true_iff_eq. - rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith. + intros p q H r s H'; apply eq_true_iff_eq. + rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith. Qed. #[global] Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool. Proof. - intros p q H r s H'; apply eq_true_iff_eq. - rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith. + intros p q H r s H'; apply eq_true_iff_eq. + rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith. Qed. @@ -634,19 +634,19 @@ Qed. Lemma Qplus_inj_r (x y z: Q): x + z == y + z <-> x == y. Proof. - split; intro E. - - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y). - rewrite <- (Qplus_opp_r z); auto. - do 2 rewrite Qplus_assoc. - rewrite E. reflexivity. - - rewrite E. reflexivity. + split; intro E. + - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y). + rewrite <- (Qplus_opp_r z); auto. + do 2 rewrite Qplus_assoc. + rewrite E. reflexivity. + - rewrite E. reflexivity. Qed. Lemma Qplus_inj_l (x y z: Q): z + x == z + y <-> x == y. Proof. - rewrite (Qplus_comm z x), (Qplus_comm z y). - apply Qplus_inj_r. + rewrite (Qplus_comm z x), (Qplus_comm z y). + apply Qplus_inj_r. Qed. @@ -727,7 +727,7 @@ Qed. Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y. Proof. - unfold Qplus, inject_Z. simpl. f_equal. ring. + unfold Qplus, inject_Z. simpl. f_equal. ring. Qed. Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y. @@ -741,7 +741,7 @@ Proof. reflexivity. Qed. Lemma Qinv_involutive : forall q, (/ / q) == q. Proof. -intros [[|n|n] d]; red; simpl; reflexivity. + intros [[|n|n] d]; red; simpl; reflexivity. Qed. Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1. @@ -803,19 +803,19 @@ Qed. Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y). Proof. - intro z_ne_0. - split; intro E. - - rewrite <- (Qmult_1_r x), <- (Qmult_1_r y). - rewrite <- (Qmult_inv_r z); auto. - do 2 rewrite Qmult_assoc. - rewrite E. reflexivity. - - rewrite E. reflexivity. + intro z_ne_0. + split; intro E. + - rewrite <- (Qmult_1_r x), <- (Qmult_1_r y). + rewrite <- (Qmult_inv_r z); auto. + do 2 rewrite Qmult_assoc. + rewrite E. reflexivity. + - rewrite E. reflexivity. Qed. Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y). Proof. - rewrite (Qmult_comm z x), (Qmult_comm z y). - apply Qmult_inj_r. + rewrite (Qmult_comm z x), (Qmult_comm z y). + apply Qmult_inj_r. Qed. (** * Reduction and construction of Q *) @@ -965,12 +965,12 @@ Proof. apply Z.lt_neq. Qed. Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). Proof. - unfold Qle. simpl. now rewrite !Z.mul_1_r. + unfold Qle. simpl. now rewrite !Z.mul_1_r. Qed. Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y). Proof. - unfold Qlt. simpl. now rewrite !Z.mul_1_r. + unfold Qlt. simpl. now rewrite !Z.mul_1_r. Qed. @@ -978,8 +978,8 @@ Qed. Lemma Qle_lteq x y : x<=y <-> x p <= q /\ ~ (p == q). @@ -1167,32 +1167,32 @@ Qed. Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y. Proof. - split; intros. - - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). - do 2 rewrite Qplus_assoc. - apply Qplus_le_compat; auto with *. - - apply Qplus_le_compat; auto with *. + split; intros. + - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). + do 2 rewrite Qplus_assoc. + apply Qplus_le_compat; auto with *. + - apply Qplus_le_compat; auto with *. Qed. Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y. Proof. - rewrite (Qplus_comm z x), (Qplus_comm z y). - apply Qplus_le_l. + rewrite (Qplus_comm z x), (Qplus_comm z y). + apply Qplus_le_l. Qed. Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y. Proof. - split; intros. - - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). - do 2 rewrite Qplus_assoc. - apply Qplus_lt_le_compat; auto with *. - - apply Qplus_lt_le_compat; auto with *. + split; intros. + - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). + do 2 rewrite Qplus_assoc. + apply Qplus_lt_le_compat; auto with *. + - apply Qplus_lt_le_compat; auto with *. Qed. Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y. Proof. - rewrite (Qplus_comm z x), (Qplus_comm z y). - apply Qplus_lt_l. + rewrite (Qplus_comm z x), (Qplus_comm z y). + apply Qplus_lt_l. Qed. Lemma Qplus_lt_compat : forall x y z t : Q, @@ -1233,15 +1233,15 @@ Qed. Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y). Proof. - split; intro. - - now apply Qmult_lt_0_le_reg_r with z. - - apply Qmult_le_compat_r; auto with qarith. + split; intro. + - now apply Qmult_lt_0_le_reg_r with z. + - apply Qmult_le_compat_r; auto with qarith. Qed. Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y). Proof. - rewrite (Qmult_comm z x), (Qmult_comm z y). - apply Qmult_le_r. + rewrite (Qmult_comm z x), (Qmult_comm z y). + apply Qmult_le_r. Qed. Lemma Qmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. @@ -1258,31 +1258,31 @@ Qed. Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y). Proof. - Open Scope Z_scope. - intros (a1,a2) (b1,b2) (c1,c2). - unfold Qle, Qlt; simpl. - simpl_mult. - rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - rewrite Z.mul_1_r. - intro LT. rewrite <- Z.mul_lt_mono_pos_r. - - reflexivity. - - now apply Z.mul_pos_pos. - Close Scope Z_scope. + Open Scope Z_scope. + intros (a1,a2) (b1,b2) (c1,c2). + unfold Qle, Qlt; simpl. + simpl_mult. + rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). + rewrite Z.mul_1_r. + intro LT. rewrite <- Z.mul_lt_mono_pos_r. + - reflexivity. + - now apply Z.mul_pos_pos. + Close Scope Z_scope. Qed. Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y). Proof. - rewrite (Qmult_comm z x), (Qmult_comm z y). - apply Qmult_lt_r. + rewrite (Qmult_comm z x), (Qmult_comm z y). + apply Qmult_lt_r. Qed. Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b. Proof. -intros a b Ha Hb. -unfold Qle in *. -simpl in *. -rewrite Z.mul_1_r in *. -auto using Z.mul_nonneg_nonneg. + intros a b Ha Hb. + unfold Qle in *. + simpl in *. + rewrite Z.mul_1_r in *. + auto using Z.mul_nonneg_nonneg. Qed. Lemma Qmult_lt_0_compat : forall a b : Q, 0 < a -> 0 < b -> 0 < a * b. @@ -1362,98 +1362,98 @@ Qed. Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a. Proof. -intros [[|n|n] d] Ha; assumption. + intros [[|n|n] d] Ha; assumption. Qed. Lemma Qle_shift_div_l : forall a b c, 0 < c -> a*c <= b -> a <= b/c. Proof. -intros a b c Hc H. -apply Qmult_lt_0_le_reg_r with (c). -- assumption. -- setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm. - rewrite Qmult_div_r; try assumption. - auto with *. + intros a b c Hc H. + apply Qmult_lt_0_le_reg_r with (c). + - assumption. + - setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm. + rewrite Qmult_div_r; try assumption. + auto with *. Qed. Lemma Qle_shift_inv_l : forall a c, 0 < c -> a*c <= 1 -> a <= /c. Proof. -intros a c Hc H. -setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). -change (a <= 1/c). -apply Qle_shift_div_l; assumption. + intros a c Hc H. + setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). + change (a <= 1/c). + apply Qle_shift_div_l; assumption. Qed. Lemma Qle_shift_div_r : forall a b c, 0 < b -> a <= c*b -> a/b <= c. Proof. -intros a b c Hc H. -apply Qmult_lt_0_le_reg_r with b. -- assumption. -- setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm. - rewrite Qmult_div_r; try assumption. - auto with *. + intros a b c Hc H. + apply Qmult_lt_0_le_reg_r with b. + - assumption. + - setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm. + rewrite Qmult_div_r; try assumption. + auto with *. Qed. Lemma Qle_shift_inv_r : forall b c, 0 < b -> 1 <= c*b -> /b <= c. Proof. -intros b c Hc H. -setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). -change (1/b <= c). -apply Qle_shift_div_r; assumption. + intros b c Hc H. + setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). + change (1/b <= c). + apply Qle_shift_div_r; assumption. Qed. Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a. Proof. -intros [[|n|n] d] Ha; assumption. + intros [[|n|n] d] Ha; assumption. Qed. Lemma Qlt_shift_div_l : forall a b c, 0 < c -> a*c < b -> a < b/c. Proof. -intros a b c Hc H. -apply Qnot_le_lt. -intros H0. -apply (Qlt_not_le _ _ H). -apply Qmult_lt_0_le_reg_r with (/c). -- apply Qinv_lt_0_compat. - assumption. -- setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with * ). - assumption. + intros a b c Hc H. + apply Qnot_le_lt. + intros H0. + apply (Qlt_not_le _ _ H). + apply Qmult_lt_0_le_reg_r with (/c). + - apply Qinv_lt_0_compat. + assumption. + - setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with * ). + assumption. Qed. Lemma Qlt_shift_inv_l : forall a c, 0 < c -> a*c < 1 -> a < /c. Proof. -intros a c Hc H. -setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). -change (a < 1/c). -apply Qlt_shift_div_l; assumption. + intros a c Hc H. + setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). + change (a < 1/c). + apply Qlt_shift_div_l; assumption. Qed. Lemma Qlt_shift_div_r : forall a b c, 0 < b -> a < c*b -> a/b < c. Proof. -intros a b c Hc H. -apply Qnot_le_lt. -intros H0. -apply (Qlt_not_le _ _ H). -apply Qmult_lt_0_le_reg_r with (/b). -- apply Qinv_lt_0_compat. - assumption. -- setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with * ). - assumption. + intros a b c Hc H. + apply Qnot_le_lt. + intros H0. + apply (Qlt_not_le _ _ H). + apply Qmult_lt_0_le_reg_r with (/b). + - apply Qinv_lt_0_compat. + assumption. + - setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with * ). + assumption. Qed. Lemma Qlt_shift_inv_r : forall b c, 0 < b -> 1 < c*b -> /b < c. Proof. -intros b c Hc H. -setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). -change (1/b < c). -apply Qlt_shift_div_r; assumption. + intros b c Hc H. + setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). + change (1/b < c). + apply Qlt_shift_div_r; assumption. Qed. Lemma Qinv_lt_contravar : forall a b : Q, @@ -1487,12 +1487,12 @@ Definition Qpower_positive : Q -> positive -> Q := #[global] Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive. Proof. -intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy. -unfold Qpower_positive. -induction y as [y IHy|y IHy|]; simpl; -try rewrite IHy; -try rewrite Hx; -reflexivity. + intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy. + unfold Qpower_positive. + induction y as [y IHy|y IHy|]; simpl; + try rewrite IHy; + try rewrite Hx; + reflexivity. Qed. Definition Qpower (q:Q) (z:Z) := @@ -1509,6 +1509,6 @@ Register Qpower as rat.Q.Qpower. #[global] Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower. Proof. -intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy. -destruct y; simpl; rewrite ?Hx; auto with *. + intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy. + destruct y; simpl; rewrite ?Hx; auto with *. Qed. diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v index 1b361259df..ff5d7139af 100644 --- a/theories/QArith/QOrderedType.v +++ b/theories/QArith/QOrderedType.v @@ -15,14 +15,14 @@ From Stdlib Require Import QArith_base Equalities Orders OrdersTac. (** * DecidableType structure for rational numbers *) Module Q_as_DT <: DecidableTypeFull. - Definition t := Q. - Definition eq := Qeq. - Definition eq_equiv := Q_Setoid. - Definition eqb := Qeq_bool. - Definition eqb_eq := Qeq_bool_iff. + Definition t := Q. + Definition eq := Qeq. + Definition eq_equiv := Q_Setoid. + Definition eqb := Qeq_bool. + Definition eqb_eq := Qeq_bool_iff. - Include BackportEq. (** eq_refl, eq_sym, eq_trans *) - Include HasEqBool2Dec. (** eq_dec *) + Include BackportEq. (** eq_refl, eq_sym, eq_trans *) + Include HasEqBool2Dec. (** eq_dec *) End Q_as_DT. @@ -34,21 +34,21 @@ End Q_as_DT. (** * OrderedType structure for rational numbers *) Module Q_as_OT <: OrderedTypeFull. - Include Q_as_DT. - Definition lt := Qlt. - Definition le := Qle. - Definition compare := Qcompare. + Include Q_as_DT. + Definition lt := Qlt. + Definition le := Qle. + Definition compare := Qcompare. -#[global] - Instance lt_strorder : StrictOrder Qlt. - Proof. split; [ exact Qlt_irrefl | exact Qlt_trans ]. Qed. + #[global] + Instance lt_strorder : StrictOrder Qlt. + Proof. split; [ exact Qlt_irrefl | exact Qlt_trans ]. Qed. -#[global] - Instance lt_compat : Proper (Qeq==>Qeq==>iff) Qlt. - Proof. auto with *. Qed. + #[global] + Instance lt_compat : Proper (Qeq==>Qeq==>iff) Qlt. + Proof. auto with *. Qed. - Definition le_lteq := Qle_lteq. - Definition compare_spec := Qcompare_spec. + Definition le_lteq := Qle_lteq. + Definition compare_spec := Qcompare_spec. End Q_as_OT. diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v index a6a15cc557..1a1a0d1dbd 100644 --- a/theories/QArith/Qabs.v +++ b/theories/QArith/Qabs.v @@ -18,89 +18,91 @@ Definition Qabs (x:Q) := let (n,d):=x in (Z.abs n#d). Lemma Qabs_case : forall (x:Q) (P : Q -> Type), (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P (Qabs x). Proof. -intros x P H1 H2. -destruct x as [[|xn|xn] xd]; -[apply H1|apply H1|apply H2]; -abstract (compute; discriminate). + intros x P H1 H2. + destruct x as [[|xn|xn] xd]; + [apply H1|apply H1|apply H2]; + abstract (compute; discriminate). Defined. Add Morphism Qabs with signature Qeq ==> Qeq as Qabs_wd. -intros [xn xd] [yn yd] H. -simpl. -unfold Qeq in *. -simpl in *. -change (Zpos yd)%Z with (Z.abs (Zpos yd)). -change (Zpos xd)%Z with (Z.abs (Zpos xd)). -repeat rewrite <- Z.abs_mul. -congruence. +Proof. + intros [xn xd] [yn yd] H. + simpl. + unfold Qeq in *. + simpl in *. + change (Zpos yd)%Z with (Z.abs (Zpos yd)). + change (Zpos xd)%Z with (Z.abs (Zpos xd)). + repeat rewrite <- Z.abs_mul. + congruence. Qed. Lemma Qabs_pos : forall x, 0 <= x -> Qabs x == x. Proof. -intros x H. -apply Qabs_case. -- reflexivity. -- intros H0. - setoid_replace x with 0. - + reflexivity. - + apply Qle_antisym; assumption. + intros x H. + apply Qabs_case. + - reflexivity. + - intros H0. + setoid_replace x with 0. + + reflexivity. + + apply Qle_antisym; assumption. Qed. Lemma Qabs_neg : forall x, x <= 0 -> Qabs x == - x. Proof. -intros x H. -apply Qabs_case. -- intros H0. - setoid_replace x with 0. - + reflexivity. - + apply Qle_antisym; assumption. -- reflexivity. + intros x H. + apply Qabs_case. + - intros H0. + setoid_replace x with 0. + + reflexivity. + + apply Qle_antisym; assumption. + - reflexivity. Qed. Lemma Qabs_nonneg : forall x, 0 <= (Qabs x). -intros x. -apply Qabs_case. -- auto. -- apply (Qopp_le_compat x 0). +Proof. + intros x. + apply Qabs_case. + - auto. + - apply (Qopp_le_compat x 0). Qed. Lemma Zabs_Qabs : forall n d, (Z.abs n#d)==Qabs (n#d). Proof. -intros [|n|n]; reflexivity. + intros [|n|n]; reflexivity. Qed. Lemma Qabs_opp : forall x, Qabs (-x) == Qabs x. Proof. -intros x. -do 2 apply Qabs_case; try (intros; ring); -(intros H0 H1; -setoid_replace x with 0;[reflexivity|]; -apply Qle_antisym);try assumption; -rewrite Qle_minus_iff in *; -ring_simplify; -ring_simplify in H1; -assumption. + intros x. + do 2 apply Qabs_case; try (intros; ring); + (intros H0 H1; + setoid_replace x with 0;[reflexivity|]; + apply Qle_antisym);try assumption; + rewrite Qle_minus_iff in *; + ring_simplify; + ring_simplify in H1; + assumption. Qed. Lemma Qabs_triangle : forall x y, Qabs (x+y) <= Qabs x + Qabs y. Proof. -intros [xn xd] [yn yd]. -unfold Qplus. -unfold Qle. -simpl. -apply Z.mul_le_mono_nonneg_r; auto using Pos2Z.is_nonneg. -change (Zpos yd)%Z with (Z.abs (Zpos yd)). -change (Zpos xd)%Z with (Z.abs (Zpos xd)). -repeat rewrite <- Z.abs_mul. -apply Z.abs_triangle. + intros [xn xd] [yn yd]. + unfold Qplus. + unfold Qle. + simpl. + apply Z.mul_le_mono_nonneg_r; auto using Pos2Z.is_nonneg. + change (Zpos yd)%Z with (Z.abs (Zpos yd)). + change (Zpos xd)%Z with (Z.abs (Zpos xd)). + repeat rewrite <- Z.abs_mul. + apply Z.abs_triangle. Qed. Lemma Qabs_Qmult : forall a b, Qabs (a*b) == (Qabs a)*(Qabs b). Proof. -intros [an ad] [bn bd]. -simpl. -rewrite Z.abs_mul. -reflexivity. + intros [an ad] [bn bd]. + simpl. + rewrite Z.abs_mul. + reflexivity. Qed. Lemma Qabs_Qinv : forall q, Qabs (/ q) == / (Qabs q). @@ -112,89 +114,89 @@ Qed. Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x). Proof. - unfold Qminus, Qopp. simpl. - rewrite Pos.mul_comm, <- Z.abs_opp. - do 2 f_equal. ring. + unfold Qminus, Qopp. simpl. + rewrite Pos.mul_comm, <- Z.abs_opp. + do 2 f_equal. ring. Qed. Lemma Qle_Qabs : forall a, a <= Qabs a. Proof. -intros a. -apply Qabs_case; auto with *. -intros H. -apply Qle_trans with 0; try assumption. -change 0 with (-0). -apply Qopp_le_compat. -assumption. + intros a. + apply Qabs_case; auto with *. + intros H. + apply Qle_trans with 0; try assumption. + change 0 with (-0). + apply Qopp_le_compat. + assumption. Qed. Lemma Qabs_triangle_reverse : forall x y, Qabs x - Qabs y <= Qabs (x - y). Proof. -intros x y. -rewrite Qle_minus_iff. -setoid_replace (Qabs (x - y) + - (Qabs x - Qabs y)) with ((Qabs (x - y) + Qabs y) + - Qabs x) by ring. -rewrite <- Qle_minus_iff. -setoid_replace (Qabs x) with (Qabs (x-y+y)). -- apply Qabs_triangle. -- apply Qabs_wd. - ring. + intros x y. + rewrite Qle_minus_iff. + setoid_replace (Qabs (x - y) + - (Qabs x - Qabs y)) with ((Qabs (x - y) + Qabs y) + - Qabs x) by ring. + rewrite <- Qle_minus_iff. + setoid_replace (Qabs x) with (Qabs (x-y+y)). + - apply Qabs_triangle. + - apply Qabs_wd. + ring. Qed. Lemma Qabs_Qle_condition x y: Qabs x <= y <-> -y <= x <= y. Proof. - split. - - split. - + rewrite <- (Qopp_opp x). - apply Qopp_le_compat. - apply Qle_trans with (Qabs (-x)). - * apply Qle_Qabs. - * now rewrite Qabs_opp. - + apply Qle_trans with (Qabs x); auto using Qle_Qabs. - - intros (H,H'). - apply Qabs_case; trivial. - intros. rewrite <- (Qopp_opp y). now apply Qopp_le_compat. + split. + - split. + + rewrite <- (Qopp_opp x). + apply Qopp_le_compat. + apply Qle_trans with (Qabs (-x)). + * apply Qle_Qabs. + * now rewrite Qabs_opp. + + apply Qle_trans with (Qabs x); auto using Qle_Qabs. + - intros (H,H'). + apply Qabs_case; trivial. + intros. rewrite <- (Qopp_opp y). now apply Qopp_le_compat. Qed. Lemma Qabs_Qlt_condition: forall x y : Q, Qabs x < y <-> -y < x < y. Proof. - split. - - split. - + rewrite <- (Qopp_opp x). - apply Qopp_lt_compat. - apply Qle_lt_trans with (Qabs (-x)). - * apply Qle_Qabs. - * now rewrite Qabs_opp. - + apply Qle_lt_trans with (Qabs x); auto using Qle_Qabs. - - intros (H,H'). - apply Qabs_case; trivial. - intros. rewrite <- (Qopp_opp y). now apply Qopp_lt_compat. + split. + - split. + + rewrite <- (Qopp_opp x). + apply Qopp_lt_compat. + apply Qle_lt_trans with (Qabs (-x)). + * apply Qle_Qabs. + * now rewrite Qabs_opp. + + apply Qle_lt_trans with (Qabs x); auto using Qle_Qabs. + - intros (H,H'). + apply Qabs_case; trivial. + intros. rewrite <- (Qopp_opp y). now apply Qopp_lt_compat. Qed. Lemma Qabs_diff_Qle_condition x y r: Qabs (x - y) <= r <-> x - r <= y <= x + r. Proof. - intros. unfold Qminus. - rewrite Qabs_Qle_condition. - rewrite <- (Qplus_le_l (-r) (x+-y) (y+r)). - rewrite <- (Qplus_le_l (x+-y) r (y-r)). - setoid_replace (-r + (y + r)) with y by ring. - setoid_replace (r + (y - r)) with y by ring. - setoid_replace (x + - y + (y + r)) with (x + r) by ring. - setoid_replace (x + - y + (y - r)) with (x - r) by ring. - intuition. + intros. unfold Qminus. + rewrite Qabs_Qle_condition. + rewrite <- (Qplus_le_l (-r) (x+-y) (y+r)). + rewrite <- (Qplus_le_l (x+-y) r (y-r)). + setoid_replace (-r + (y + r)) with y by ring. + setoid_replace (r + (y - r)) with y by ring. + setoid_replace (x + - y + (y + r)) with (x + r) by ring. + setoid_replace (x + - y + (y - r)) with (x - r) by ring. + intuition. Qed. Lemma Qabs_diff_Qlt_condition x y r: Qabs (x - y) < r <-> x - r < y < x + r. Proof. - intros. unfold Qminus. - rewrite Qabs_Qlt_condition. - rewrite <- (Qplus_lt_l (-r) (x+-y) (y+r)). - rewrite <- (Qplus_lt_l (x+-y) r (y-r)). - setoid_replace (-r + (y + r)) with y by ring. - setoid_replace (r + (y - r)) with y by ring. - setoid_replace (x + - y + (y + r)) with (x + r) by ring. - setoid_replace (x + - y + (y - r)) with (x - r) by ring. - intuition. + intros. unfold Qminus. + rewrite Qabs_Qlt_condition. + rewrite <- (Qplus_lt_l (-r) (x+-y) (y+r)). + rewrite <- (Qplus_lt_l (x+-y) r (y-r)). + setoid_replace (-r + (y + r)) with y by ring. + setoid_replace (r + (y - r)) with y by ring. + setoid_replace (x + - y + (y + r)) with (x + r) by ring. + setoid_replace (x + - y + (y - r)) with (x - r) by ring. + intuition. Qed. Lemma Qabs_ge: forall r s : Q, r <= s -> r <= Qabs s. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 19e7dc89b8..54a3077e8c 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -86,9 +86,9 @@ Arguments Q2Qc q%_Q. Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'. Proof. - split; intro H. - - now injection H as [= H%Qred_eq_iff]. - - apply Qc_is_canon. simpl. now rewrite H. + split; intro H. + - now injection H as [= H%Qred_eq_iff]. + - apply Qc_is_canon. simpl. now rewrite H. Qed. Notation " 0 " := (Q2Qc 0) : Qc_scope. @@ -539,7 +539,7 @@ Add Field Qcfield : Qcft. Example test_field : (forall x y : Qc, y<>0 -> (x/y)*y = x)%Qc. Proof. -intros. -field. -auto. + intros. + field. + auto. Qed. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index 0d86296216..59d4b90dc3 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -42,9 +42,9 @@ Qed. Lemma Qpower_theory : power_theory 1 Qmult Qeq Z.of_N Qpower. Proof. -constructor. -intros r [|n]; -reflexivity. + constructor. + intros r [|n]; + reflexivity. Qed. Ltac isQcst t := @@ -83,73 +83,83 @@ Add Field Qfield : Qsft Section Examples. -Section Ex1. -Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). - intros. - ring. -Defined. -End Ex1. - -Section Ex2. -Let ex2 : forall x y : Q, x+y == y+x. - intros. - ring. -Defined. -End Ex2. - -Section Ex3. -Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z). - intros. - ring. -Defined. -End Ex3. - -Section Ex4. -Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2). - ring. -Defined. -End Ex4. - -Section Ex5. -Let ex5 : 1+1 == 2#1. - ring. -Defined. -End Ex5. - -Section Ex6. -Let ex6 : (1#1)+(1#1) == 2#1. - ring. -Defined. -End Ex6. - -Section Ex7. -Let ex7 : forall x : Q, x-x== 0. - intro. - ring. -Defined. -End Ex7. - -Section Ex8. -Let ex8 : forall x : Q, x^1 == x. - intro. - ring. -Defined. -End Ex8. - -Section Ex9. -Let ex9 : forall x : Q, x^0 == 1. - intro. - ring. -Defined. -End Ex9. - -Section Ex10. -Let ex10 : forall x y : Q, ~(y==0) -> (x/y)*y == x. - intros. - field. - auto. -Defined. -End Ex10. + Section Ex1. + Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). + Proof. + intros. + ring. + Defined. + End Ex1. + + Section Ex2. + Let ex2 : forall x y : Q, x+y == y+x. + Proof. + intros. + ring. + Defined. + End Ex2. + + Section Ex3. + Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z). + Proof. + intros. + ring. + Defined. + End Ex3. + + Section Ex4. + Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2). + Proof. + ring. + Defined. + End Ex4. + + Section Ex5. + Let ex5 : 1+1 == 2#1. + Proof. + ring. + Defined. + End Ex5. + + Section Ex6. + Let ex6 : (1#1)+(1#1) == 2#1. + Proof. + ring. + Defined. + End Ex6. + + Section Ex7. + Let ex7 : forall x : Q, x-x== 0. + Proof. + intro. + ring. + Defined. + End Ex7. + + Section Ex8. + Let ex8 : forall x : Q, x^1 == x. + Proof. + intro. + ring. + Defined. + End Ex8. + + Section Ex9. + Let ex9 : forall x : Q, x^0 == 1. + Proof. + intro. + ring. + Defined. + End Ex9. + + Section Ex10. + Let ex10 : forall x y : Q, ~(y==0) -> (x/y)*y == x. + Proof. + intros. + field. + auto. + Defined. + End Ex10. End Examples. diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v index 44a1a38760..853c2db896 100644 --- a/theories/QArith/Qminmax.v +++ b/theories/QArith/Qminmax.v @@ -20,50 +20,50 @@ Definition Qmax := gmax Qcompare. Definition Qmin := gmin Qcompare. Module QHasMinMax <: HasMinMax Q_as_OT. - Module QMM := GenericMinMax Q_as_OT. - Definition max := Qmax. - Definition min := Qmin. - Definition max_l := QMM.max_l. - Definition max_r := QMM.max_r. - Definition min_l := QMM.min_l. - Definition min_r := QMM.min_r. + Module QMM := GenericMinMax Q_as_OT. + Definition max := Qmax. + Definition min := Qmin. + Definition max_l := QMM.max_l. + Definition max_r := QMM.max_r. + Definition min_l := QMM.min_l. + Definition min_r := QMM.min_r. End QHasMinMax. Module Q. -(** We obtain hence all the generic properties of max and min. *) + (** We obtain hence all the generic properties of max and min. *) -Include MinMaxProperties Q_as_OT QHasMinMax. + Include MinMaxProperties Q_as_OT QHasMinMax. -(** * Properties specific to the [Q] domain *) + (** * Properties specific to the [Q] domain *) -(** Compatibilities (consequences of monotonicity) *) + (** Compatibilities (consequences of monotonicity) *) -Lemma plus_max_distr_l : forall n m p, Qmax (p + n) (p + m) == p + Qmax n m. -Proof. - intros. apply max_monotone. - - intros x x' Hx; rewrite Hx; auto with qarith. - - intros x x' Hx. apply Qplus_le_compat; q_order. -Qed. + Lemma plus_max_distr_l : forall n m p, Qmax (p + n) (p + m) == p + Qmax n m. + Proof. + intros. apply max_monotone. + - intros x x' Hx; rewrite Hx; auto with qarith. + - intros x x' Hx. apply Qplus_le_compat; q_order. + Qed. -Lemma plus_max_distr_r : forall n m p, Qmax (n + p) (m + p) == Qmax n m + p. -Proof. - intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p). - apply plus_max_distr_l. -Qed. + Lemma plus_max_distr_r : forall n m p, Qmax (n + p) (m + p) == Qmax n m + p. + Proof. + intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p). + apply plus_max_distr_l. + Qed. -Lemma plus_min_distr_l : forall n m p, Qmin (p + n) (p + m) == p + Qmin n m. -Proof. - intros. apply min_monotone. - - intros x x' Hx; rewrite Hx; auto with qarith. - - intros x x' Hx. apply Qplus_le_compat; q_order. -Qed. + Lemma plus_min_distr_l : forall n m p, Qmin (p + n) (p + m) == p + Qmin n m. + Proof. + intros. apply min_monotone. + - intros x x' Hx; rewrite Hx; auto with qarith. + - intros x x' Hx. apply Qplus_le_compat; q_order. + Qed. -Lemma plus_min_distr_r : forall n m p, Qmin (n + p) (m + p) == Qmin n m + p. -Proof. - intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p). - apply plus_min_distr_l. -Qed. + Lemma plus_min_distr_r : forall n m p, Qmin (n + p) (m + p) == Qmin n m + p. + Proof. + intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p). + apply plus_min_distr_l. + Qed. End Q. diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v index 6ffae36533..59b7f4ab1f 100644 --- a/theories/QArith/Qpower.v +++ b/theories/QArith/Qpower.v @@ -16,71 +16,71 @@ From Stdlib Require Import Qfield Qreduction. Lemma Qpower_positive_1 : forall n, Qpower_positive 1 n == 1. Proof. -induction n; -simpl; try rewrite IHn; reflexivity. + induction n; + simpl; try rewrite IHn; reflexivity. Qed. Lemma Qpower_positive_0 : forall n, Qpower_positive 0 n == 0. Proof. -induction n; -simpl; try rewrite IHn; reflexivity. + induction n; + simpl; try rewrite IHn; reflexivity. Qed. (** ** Relation of Qpower_positive to zero *) Lemma Qpower_not_0_positive : forall a n, ~a==0 -> ~Qpower_positive a n == 0. Proof. -intros a n X H. -apply X; clear X. -induction n; simpl in *; try assumption; -destruct (Qmult_integral _ _ H); -try destruct (Qmult_integral _ _ H0); auto. + intros a n X H. + apply X; clear X. + induction n; simpl in *; try assumption; + destruct (Qmult_integral _ _ H); + try destruct (Qmult_integral _ _ H0); auto. Qed. Lemma Qpower_pos_positive : forall p n, 0 <= p -> 0 <= Qpower_positive p n. Proof. -intros p n Hp. -induction n; simpl; repeat apply Qmult_le_0_compat;assumption. + intros p n Hp. + induction n; simpl; repeat apply Qmult_le_0_compat;assumption. Qed. (** ** Qpower_positive and multiplication, exponent subtraction *) Lemma Qmult_power_positive : forall a b n, Qpower_positive (a*b) n == (Qpower_positive a n)*(Qpower_positive b n). Proof. -induction n; -simpl; repeat rewrite IHn; ring. + induction n; + simpl; repeat rewrite IHn; ring. Qed. Lemma Qpower_plus_positive : forall a n m, Qpower_positive a (n+m) == (Qpower_positive a n)*(Qpower_positive a m). Proof. -intros a n m. -unfold Qpower_positive. -apply pow_pos_add. -- apply Q_Setoid. -- apply Qmult_comp. -- apply Qmult_assoc. + intros a n m. + unfold Qpower_positive. + apply pow_pos_add. + - apply Q_Setoid. + - apply Qmult_comp. + - apply Qmult_assoc. Qed. (** ** Qpower_positive and inversion, division, exponent subtraction *) Lemma Qinv_power_positive : forall a n, Qpower_positive (/a) n == /(Qpower_positive a n). Proof. -induction n; -simpl; repeat (rewrite IHn || rewrite Qinv_mult_distr); reflexivity. + induction n; + simpl; repeat (rewrite IHn || rewrite Qinv_mult_distr); reflexivity. Qed. Lemma Qpower_minus_positive : forall a (n m:positive), (m < n)%positive -> Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m). Proof. -intros a n m H. -destruct (Qeq_dec a 0) as [EQ|NEQ]. -- now rewrite EQ, !Qpower_positive_0. -- rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by - (now apply Qpower_not_0_positive). - f_equiv. - rewrite <- Qpower_plus_positive. - now rewrite Pos.sub_add. + intros a n m H. + destruct (Qeq_dec a 0) as [EQ|NEQ]. + - now rewrite EQ, !Qpower_positive_0. + - rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by + (now apply Qpower_not_0_positive). + f_equiv. + rewrite <- Qpower_plus_positive. + now rewrite Pos.sub_add. Qed. (** ** Qpower and exponent multiplication *) @@ -88,15 +88,15 @@ Qed. Lemma Qpower_mult_positive : forall a n m, Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m. Proof. -intros a n m. -induction n using Pos.peano_ind. -- reflexivity. -- rewrite Pos.mul_succ_l. - rewrite <- Pos.add_1_l. - do 2 rewrite Qpower_plus_positive. - rewrite IHn. - rewrite Qmult_power_positive. - reflexivity. + intros a n m. + induction n using Pos.peano_ind. + - reflexivity. + - rewrite Pos.mul_succ_l. + rewrite <- Pos.add_1_l. + do 2 rewrite Qpower_plus_positive. + rewrite IHn. + rewrite Qmult_power_positive. + reflexivity. Qed. (** ** Qpower_positive decomposition *) @@ -104,19 +104,19 @@ Qed. Lemma Qpower_decomp_positive p x y : Qpower_positive (x#y) p = x ^ Zpos p # (y ^ p). Proof. -induction p; intros; simpl Qpower_positive; rewrite ?IHp. -- (* xI *) - unfold Qmult, Qnum, Qden. f_equal. - + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. - + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. - now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. -- (* xO *) - unfold Qmult, Qnum, Qden. f_equal. - + now rewrite <- Z.pow_twice_r. - + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. - now rewrite <- Z.pow_twice_r. -- (* xO *) - now rewrite Z.pow_1_r, Pos.pow_1_r. + induction p; intros; simpl Qpower_positive; rewrite ?IHp. + - (* xI *) + unfold Qmult, Qnum, Qden. f_equal. + + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. + + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. + - (* xO *) + unfold Qmult, Qnum, Qden. f_equal. + + now rewrite <- Z.pow_twice_r. + + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. + now rewrite <- Z.pow_twice_r. + - (* xO *) + now rewrite Z.pow_1_r, Pos.pow_1_r. Qed. (* This notation will be deprecated with a planned larger rework of Q lemma naming *) @@ -246,27 +246,27 @@ Qed. Lemma Qpower_plus : forall a n m, ~a==0 -> a^(n+m) == a^n*a^m. Proof. -intros a [|n|n] [|m|m] H; simpl; try ring; -try rewrite Qpower_plus_positive; -try apply Qinv_mult_distr; try reflexivity; -rewrite ?Z.pos_sub_spec; -case Pos.compare_spec; intros H0; simpl; subst; - try rewrite Qpower_minus_positive; - try (field; try split; apply Qpower_not_0_positive); - assumption. + intros a [|n|n] [|m|m] H; simpl; try ring; + try rewrite Qpower_plus_positive; + try apply Qinv_mult_distr; try reflexivity; + rewrite ?Z.pos_sub_spec; + case Pos.compare_spec; intros H0; simpl; subst; + try rewrite Qpower_minus_positive; + try (field; try split; apply Qpower_not_0_positive); + assumption. Qed. Lemma Qpower_plus' : forall a n m, (n+m <> 0)%Z -> a^(n+m) == a^n*a^m. Proof. -intros a n m H. -destruct (Qeq_dec a 0)as [X|X]. -- rewrite X. - rewrite Qpower_0 by assumption. - destruct n; destruct m; try (elim H; reflexivity); - simpl; repeat rewrite Qpower_positive_0; ring_simplify; - reflexivity. -- apply Qpower_plus. - assumption. + intros a n m H. + destruct (Qeq_dec a 0)as [X|X]. + - rewrite X. + rewrite Qpower_0 by assumption. + destruct n; destruct m; try (elim H; reflexivity); + simpl; repeat rewrite Qpower_positive_0; ring_simplify; + reflexivity. + - apply Qpower_plus. + assumption. Qed. (** ** Qpower and inversion, division, exponent subtraction *) @@ -280,27 +280,27 @@ Qed. Lemma Qdiv_power : forall a b n, (a/b)^n == (a^n/b^n). Proof. -unfold Qdiv. -intros a b n. -rewrite Qmult_power. -rewrite Qinv_power. -reflexivity. + unfold Qdiv. + intros a b n. + rewrite Qmult_power. + rewrite Qinv_power. + reflexivity. Qed. Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z (Zpos p))^n. Proof. -intros n p. -rewrite Qmake_Qdiv. -rewrite Qdiv_power. -rewrite Qpower_1. -unfold Qdiv. -ring. + intros n p. + rewrite Qmake_Qdiv. + rewrite Qdiv_power. + rewrite Qpower_1. + unfold Qdiv. + ring. Qed. Lemma Qpower_opp : forall a n, a^(-n) == /a^n. Proof. -intros a [|n|n]; simpl; try reflexivity. -symmetry; apply Qinv_involutive. + intros a [|n|n]; simpl; try reflexivity. + symmetry; apply Qinv_involutive. Qed. Lemma Qpower_minus: forall (a : Q) (n m : Z), @@ -336,12 +336,12 @@ Qed. Lemma Qpower_mult : forall a n m, a^(n*m) == (a^n)^m. Proof. -intros a [|n|n] [|m|m]; simpl; - try rewrite Qpower_positive_1; - try rewrite Qpower_mult_positive; - try rewrite Qinv_power_positive; - try rewrite Qinv_involutive; - try reflexivity. + intros a [|n|n] [|m|m]; simpl; + try rewrite Qpower_positive_1; + try rewrite Qpower_mult_positive; + try rewrite Qinv_power_positive; + try rewrite Qinv_involutive; + try reflexivity. Qed. (** ** Qpower decomposition *) @@ -432,32 +432,32 @@ Qed. Lemma Zpower_Qpower : forall (a n:Z), (0<=n)%Z -> inject_Z (a^n) == (inject_Z a)^n. Proof. -intros a [|n|n] H;[reflexivity| |elim H; reflexivity]. -induction n using Pos.peano_ind. -- replace (a^1)%Z with a by ring. - ring. -- rewrite Pos2Z.inj_succ. - unfold Z.succ. - rewrite Z.pow_add_r; auto with *; try discriminate. - rewrite Qpower_plus' by discriminate. - rewrite <- IHn by discriminate. - replace (a^Zpos n*a^1)%Z with (a^Zpos n*a)%Z by ring. - ring_simplify. - reflexivity. + intros a [|n|n] H;[reflexivity| |elim H; reflexivity]. + induction n using Pos.peano_ind. + - replace (a^1)%Z with a by ring. + ring. + - rewrite Pos2Z.inj_succ. + unfold Z.succ. + rewrite Z.pow_add_r; auto with *; try discriminate. + rewrite Qpower_plus' by discriminate. + rewrite <- IHn by discriminate. + replace (a^Zpos n*a^1)%Z with (a^Zpos n*a)%Z by ring. + ring_simplify. + reflexivity. Qed. (** ** Square *) Lemma Qsqr_nonneg : forall a, 0 <= a^2. Proof. -intros a. -destruct (Qlt_le_dec 0 a) as [A|A]. -- apply (Qmult_le_0_compat a a); - (apply Qlt_le_weak; assumption). -- setoid_replace (a^2) with ((-a)*(-a)) by ring. - rewrite Qle_minus_iff in A. - setoid_replace (0+ - a) with (-a) in A by ring. - apply Qmult_le_0_compat; assumption. + intros a. + destruct (Qlt_le_dec 0 a) as [A|A]. + - apply (Qmult_le_0_compat a a); + (apply Qlt_le_weak; assumption). + - setoid_replace (a^2) with ((-a)*(-a)) by ring. + rewrite Qle_minus_iff in A. + setoid_replace (0+ - a) with (-a) in A by ring. + apply Qmult_le_0_compat; assumption. Qed. (** ** Power of 2 positive upper bound *) diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 2e2f3ada15..f48168634e 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -76,10 +76,10 @@ Qed. Lemma Qred_eq_iff q q' : Qred q = Qred q' <-> q == q'. Proof. - split. - - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). - now rewrite E. - - apply Qred_complete. + split. + - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). + now rewrite E. + - apply Qred_complete. Qed. Add Morphism Qred with signature (Qeq ==> Qeq) as Qred_comp. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index caf6fba286..820aea8686 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -20,29 +20,29 @@ Definition Qceiling (x:Q) := (-(Qfloor (-x)))%Z. Lemma Qfloor_Z : forall z:Z, Qfloor z = z. Proof. -intros z. -simpl. -auto with *. + intros z. + simpl. + auto with *. Qed. Lemma Qceiling_Z : forall z:Z, Qceiling z = z. Proof. -intros z. -unfold Qceiling. -simpl. -rewrite Z.div_1_r. -apply Z.opp_involutive. + intros z. + unfold Qceiling. + simpl. + rewrite Z.div_1_r. + apply Z.opp_involutive. Qed. Lemma Qfloor_le : forall x, Qfloor x <= x. Proof. -intros [n d]. -simpl. -unfold Qle. -simpl. -replace (n*1)%Z with n by ring. -rewrite Z.mul_comm. -now apply Z.mul_div_le. + intros [n d]. + simpl. + unfold Qle. + simpl. + replace (n*1)%Z with n by ring. + rewrite Z.mul_comm. + now apply Z.mul_div_le. Qed. #[global] @@ -50,12 +50,12 @@ Hint Resolve Qfloor_le : qarith. Lemma Qle_ceiling : forall x, x <= Qceiling x. Proof. -intros x. -apply Qle_trans with (- - x). -- rewrite Qopp_involutive. - auto with *. -- change (Qceiling x:Q) with (-(Qfloor(-x))). - auto with *. + intros x. + apply Qle_trans with (- - x). + - rewrite Qopp_involutive. + auto with *. + - change (Qceiling x:Q) with (-(Qfloor(-x))). + auto with *. Qed. #[global] @@ -63,22 +63,22 @@ Hint Resolve Qle_ceiling : qarith. Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x. Proof. -eauto with qarith. + eauto with qarith. Qed. Lemma Qlt_floor : forall x, x < (Qfloor x+1)%Z. Proof. -intros [n d]. -simpl. -unfold Qlt. -simpl. -replace (n*1)%Z with n by ring. -ring_simplify. -replace (n / Zpos d * Zpos d + Zpos d)%Z with - ((Zpos d * (n / Zpos d) + n mod Zpos d) + Zpos d - n mod Zpos d)%Z by ring. -rewrite <- Z_div_mod_eq_full. -rewrite <- Z.lt_add_lt_sub_r. -apply Z.add_lt_mono_l, Z.mod_pos_bound, eq_refl. + intros [n d]. + simpl. + unfold Qlt. + simpl. + replace (n*1)%Z with n by ring. + ring_simplify. + replace (n / Zpos d * Zpos d + Zpos d)%Z with + ((Zpos d * (n / Zpos d) + n mod Zpos d) + Zpos d - n mod Zpos d)%Z by ring. + rewrite <- Z_div_mod_eq_full. + rewrite <- Z.lt_add_lt_sub_r. + apply Z.add_lt_mono_l, Z.mod_pos_bound, eq_refl. Qed. #[global] @@ -86,13 +86,13 @@ Hint Resolve Qlt_floor : qarith. Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x. Proof. -intros x. -unfold Qceiling. -replace (- Qfloor (- x) - 1)%Z with (-(Qfloor (-x) + 1))%Z by ring. -change ((- (Qfloor (- x) + 1))%Z:Q) with (-(Qfloor (- x) + 1)%Z). -apply Qlt_le_trans with (- - x); auto with *. -rewrite Qopp_involutive. -apply Qle_refl. + intros x. + unfold Qceiling. + replace (- Qfloor (- x) - 1)%Z with (-(Qfloor (-x) + 1))%Z by ring. + change ((- (Qfloor (- x) + 1))%Z:Q) with (-(Qfloor (- x) + 1)%Z). + apply Qlt_le_trans with (- - x); auto with *. + rewrite Qopp_involutive. + apply Qle_refl. Qed. #[global] @@ -100,13 +100,13 @@ Hint Resolve Qceiling_lt : qarith. Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z. Proof. -intros [xn xd] [yn yd] Hxy. -unfold Qle in *. -simpl in *. -rewrite <- (Zdiv_mult_cancel_r xn (Zpos xd) (Zpos yd)); auto with *. -rewrite <- (Zdiv_mult_cancel_r yn (Zpos yd) (Zpos xd)); auto with *. -rewrite (Z.mul_comm (Zpos yd) (Zpos xd)). -apply Z.div_le_mono, Hxy; apply eq_refl. + intros [xn xd] [yn yd] Hxy. + unfold Qle in *. + simpl in *. + rewrite <- (Zdiv_mult_cancel_r xn (Zpos xd) (Zpos yd)); auto with *. + rewrite <- (Zdiv_mult_cancel_r yn (Zpos yd) (Zpos xd)); auto with *. + rewrite (Z.mul_comm (Zpos yd) (Zpos xd)). + apply Z.div_le_mono, Hxy; apply eq_refl. Qed. #[global] @@ -114,9 +114,9 @@ Hint Resolve Qfloor_resp_le : qarith. Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. Proof. -intros x y Hxy. -unfold Qceiling. -rewrite <- Z.opp_le_mono; auto with qarith. + intros x y Hxy. + unfold Qceiling. + rewrite <- Z.opp_le_mono; auto with qarith. Qed. #[global] @@ -124,27 +124,27 @@ Hint Resolve Qceiling_resp_le : qarith. Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp. Proof. -intros x y H. -apply Z.le_antisymm. -- auto with *. -- symmetry in H; auto with *. + intros x y H. + apply Z.le_antisymm. + - auto with *. + - symmetry in H; auto with *. Qed. Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp. Proof. -intros x y H. -apply Z.le_antisymm. -- auto with *. -- symmetry in H; auto with *. + intros x y H. + apply Z.le_antisymm. + - auto with *. + - symmetry in H; auto with *. Qed. Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m). Proof. - unfold Qfloor. intros. simpl. - destruct m as [ | | p]; simpl. - - now rewrite Z.div_0_r, Z.mul_0_r. - - now rewrite Z.mul_1_r. - - rewrite <- Z.opp_eq_mul_m1. - rewrite <- (Z.opp_involutive (Zpos p)). - now rewrite Zdiv_opp_opp. + unfold Qfloor. intros. simpl. + destruct m as [ | | p]; simpl. + - now rewrite Z.div_0_r, Z.mul_0_r. + - now rewrite Z.mul_1_r. + - rewrite <- Z.opp_eq_mul_m1. + rewrite <- (Z.opp_involutive (Zpos p)). + now rewrite Zdiv_opp_opp. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index e32bdafcc9..fc06f9eaec 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -495,8 +495,8 @@ Qed. Lemma Qabs_Qgt_condition: forall x y : Q, (x < Qabs y)%Q <-> (x < y \/ x < -y)%Q. Proof. - intros x y. - apply Qabs_case; lra. + intros x y. + apply Qabs_case; lra. Qed. Lemma CReal_from_cauchy_seq_bound : diff --git a/theories/Reals/Cauchy/QExtra.v b/theories/Reals/Cauchy/QExtra.v index 9bc201ec52..866d2aab38 100644 --- a/theories/Reals/Cauchy/QExtra.v +++ b/theories/Reals/Cauchy/QExtra.v @@ -127,10 +127,10 @@ Definition Qbound_lt_ZExp2 (q : Q) : Z := | Zpos p => Z.pos_sub (Pos.succ (Pos_log2floor_plus1 p)) (Pos_log2floor_plus1 (Qden q)) end. -Remark Qbound_lt_ZExp2_test_1 : Qbound_lt_ZExp2 (4#4) = 1%Z. reflexivity. Qed. -Remark Qbound_lt_ZExp2_test_2 : Qbound_lt_ZExp2 (5#4) = 1%Z. reflexivity. Qed. -Remark Qbound_lt_ZExp2_test_3 : Qbound_lt_ZExp2 (4#5) = 1%Z. reflexivity. Qed. -Remark Qbound_lt_ZExp2_test_4 : Qbound_lt_ZExp2 (7#5) = 1%Z. reflexivity. Qed. +Remark Qbound_lt_ZExp2_test_1 : Qbound_lt_ZExp2 (4#4) = 1%Z. Proof. reflexivity. Qed. +Remark Qbound_lt_ZExp2_test_2 : Qbound_lt_ZExp2 (5#4) = 1%Z. Proof. reflexivity. Qed. +Remark Qbound_lt_ZExp2_test_3 : Qbound_lt_ZExp2 (4#5) = 1%Z. Proof. reflexivity. Qed. +Remark Qbound_lt_ZExp2_test_4 : Qbound_lt_ZExp2 (7#5) = 1%Z. Proof. reflexivity. Qed. Lemma Qbound_lt_ZExp2_spec : forall (q : Q), (q < 2^(Qbound_lt_ZExp2 q))%Q. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index 73fb9da4e7..62210b4e3c 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -54,271 +54,271 @@ Theorem cos_plus_form : (0 < n)%nat -> A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). Proof. -intros. -unfold A1, B1. -rewrite - (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) - (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) ( - S n)). -2:nia. -rewrite - (cauchy_finite - (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H). -unfold Reste. -replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * - x ^ (2 * S (l + k)) * - ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) * - y ^ (2 * (S n - l)))) (pred (S n - k))) ( - pred (S n))) with (Reste1 x y (S n)). -2:{ unfold Reste1; apply sum_eq; intros. - apply sum_eq; intros. nra. } -replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 + intros. + unfold A1, B1. + rewrite + (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) + (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) ( + S n)). + 2:nia. + rewrite + (cauchy_finite + (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) + (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H). + unfold Reste. + replace + (sum_f_R0 + (fun k:nat => + sum_f_R0 + (fun l:nat => + (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * + x ^ (2 * S (l + k)) * + ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) * + y ^ (2 * (S n - l)))) (pred (S n - k))) ( + pred (S n))) with (Reste1 x y (S n)). + 2:{ unfold Reste1; apply sum_eq; intros. + apply sum_eq; intros. nra. } + replace + (sum_f_R0 + (fun k:nat => + sum_f_R0 + (fun l:nat => + (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * + x ^ (2 * S (l + k) + 1) * + ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) * + y ^ (2 * (n - l) + 1))) (pred (n - k))) ( + pred n)) with (Reste2 x y n). + 2:{ unfold Reste2; apply sum_eq; intros. + apply sum_eq; intros. nra. } + replace + (sum_f_R0 + (fun k:nat => + sum_f_R0 + (fun p:nat => + (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) * + ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p)))) + k) (S n)) with + (sum_f_R0 + (fun k:nat => + (-1) ^ k / INR (fact (2 * k)) * + sum_f_R0 + (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k) + (S n)). + 2:{ apply sum_eq; intros. + rewrite scal_sum. + apply sum_eq; intros. + unfold Rdiv. + repeat rewrite <- Rmult_assoc. + rewrite <- (Rmult_comm (/ INR (fact (2 * i)))). + repeat rewrite <- Rmult_assoc. + replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with + (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))). + { replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)). + - ring. + - pattern i at 2; replace i with (i0 + (i - i0))%nat by nia. + rewrite pow_add. + ring. } + unfold C. + unfold Rdiv; repeat rewrite <- Rmult_assoc. + rewrite Rinv_l. + 2:apply INR_fact_neq_0. + rewrite Rmult_1_l. + rewrite Rinv_mult. + replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat by lia. + reflexivity. } + pose + (sin_nnn := + fun n:nat => + match n with + | O => 0 + | S p => + (-1) ^ S p / INR (fact (2 * S p)) * + sum_f_R0 + (fun l:nat => + C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p + end). + ring_simplify. + unfold Rminus. + replace + (* (- old ring compat *) + (- + sum_f_R0 + (fun k:nat => + sum_f_R0 + (fun p:nat => + (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) * + ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) * + y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)). + - rewrite <- sum_plus. + unfold C1. + apply sum_eq; intros. + induction i as [| i Hreci]. + { unfold C; simpl. nra. } + unfold sin_nnn. + rewrite <- Rmult_plus_distr_l. + apply Rmult_eq_compat_l. + rewrite binomial. + pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)). + replace + (sum_f_R0 + (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l))) + (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)). + 2:{ apply sum_eq; intros. + unfold Wn. + apply Rmult_eq_compat_l. + replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat by lia. + reflexivity. } + replace + (sum_f_R0 (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * - x ^ (2 * S (l + k) + 1) * - ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) * - y ^ (2 * (n - l) + 1))) (pred (n - k))) ( - pred n)) with (Reste2 x y n). -2:{ unfold Reste2; apply sum_eq; intros. - apply sum_eq; intros. nra. } -replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun p:nat => - (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) * - ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p)))) - k) (S n)) with - (sum_f_R0 - (fun k:nat => - (-1) ^ k / INR (fact (2 * k)) * - sum_f_R0 - (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k) - (S n)). -2:{ apply sum_eq; intros. + C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with + (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i). + { apply sum_decomposition. } + apply sum_eq; intros. + unfold Wn. + apply Rmult_eq_compat_l. + replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))) by lia. + reflexivity. + - match goal with + |- _ = - ?r => + replace (- r) with (-1 * r) by ring + end. + rewrite scal_sum. + rewrite decomp_sum. + 2:nia. + replace (sin_nnn 0%nat) with 0 by reflexivity. + rewrite Rplus_0_l. + change (pred (S n)) with n. + apply sum_eq; intros. + rewrite Rmult_comm. + unfold sin_nnn. + rewrite scal_sum. rewrite scal_sum. apply sum_eq; intros. unfold Rdiv. repeat rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (/ INR (fact (2 * i)))). + rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))). repeat rewrite <- Rmult_assoc. - replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with - (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))). - { replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)). - - ring. - - pattern i at 2; replace i with (i0 + (i - i0))%nat by nia. - rewrite pow_add. - ring. } + replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with + (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))). + { replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ]. + replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ]. + replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)). + { ring. } + simpl. + pattern i at 2; replace i with (i0 + (i - i0))%nat by nia. + rewrite pow_add. + ring. } unfold C. unfold Rdiv; repeat rewrite <- Rmult_assoc. rewrite Rinv_l. 2:apply INR_fact_neq_0. rewrite Rmult_1_l. rewrite Rinv_mult. - replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat by lia. - reflexivity. } -pose - (sin_nnn := - fun n:nat => - match n with - | O => 0 - | S p => - (-1) ^ S p / INR (fact (2 * S p)) * - sum_f_R0 - (fun l:nat => - C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p - end). -ring_simplify. -unfold Rminus. -replace -(* (- old ring compat *) - (- - sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun p:nat => - (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) * - ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) * - y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)). -- rewrite <- sum_plus. - unfold C1. - apply sum_eq; intros. - induction i as [| i Hreci]. - { unfold C; simpl. nra. } - unfold sin_nnn. - rewrite <- Rmult_plus_distr_l. - apply Rmult_eq_compat_l. - rewrite binomial. - pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)). - replace - (sum_f_R0 - (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l))) - (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)). - 2:{ apply sum_eq; intros. - unfold Wn. - apply Rmult_eq_compat_l. - replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat by lia. - reflexivity. } - replace - (sum_f_R0 - (fun l:nat => - C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with - (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i). - { apply sum_decomposition. } - apply sum_eq; intros. - unfold Wn. - apply Rmult_eq_compat_l. - replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))) by lia. - reflexivity. -- match goal with - |- _ = - ?r => - replace (- r) with (-1 * r) by ring - end. - rewrite scal_sum. - rewrite decomp_sum. - 2:nia. - replace (sin_nnn 0%nat) with 0 by reflexivity. - rewrite Rplus_0_l. - change (pred (S n)) with n. - apply sum_eq; intros. - rewrite Rmult_comm. - unfold sin_nnn. - rewrite scal_sum. - rewrite scal_sum. - apply sum_eq; intros. - unfold Rdiv. - repeat rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))). - repeat rewrite <- Rmult_assoc. - replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with - (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))). - { replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ]. - replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ]. - replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)). - { ring. } - simpl. - pattern i at 2; replace i with (i0 + (i - i0))%nat by nia. - rewrite pow_add. - ring. } - unfold C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:apply INR_fact_neq_0. - rewrite Rmult_1_l. - rewrite Rinv_mult. - replace (S (2 * i0)) with (2 * i0 + 1)%nat; - [ apply Rmult_eq_compat_l | ring ]. - replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat by lia. - reflexivity. + replace (S (2 * i0)) with (2 * i0 + 1)%nat; + [ apply Rmult_eq_compat_l | ring ]. + replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat by lia. + reflexivity. Qed. Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. Proof. -intros. -assert (H := pow_Rsqr x i). -unfold Rsqr in H; exact H. + intros. + assert (H := pow_Rsqr x i). + unfold Rsqr in H; exact H. Qed. Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). Proof. -intro. -unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p). -unfold cos_in, cos_n, infinite_sum, Rdist in p. -unfold Un_cv, Rdist; intros. -destruct (p eps H) as (x1,H0). -exists x1; intros. -unfold A1. -replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). -- apply H0; assumption. -- apply sum_eq. - intros. - replace ((x * x) ^ i) with (x ^ (2 * i)). - + reflexivity. - + apply pow_sqr. + intro. + unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p). + unfold cos_in, cos_n, infinite_sum, Rdist in p. + unfold Un_cv, Rdist; intros. + destruct (p eps H) as (x1,H0). + exists x1; intros. + unfold A1. + replace + (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with + (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). + - apply H0; assumption. + - apply sum_eq. + intros. + replace ((x * x) ^ i) with (x ^ (2 * i)). + + reflexivity. + + apply pow_sqr. Qed. Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). Proof. -intros. -unfold cos. -destruct (exist_cos (Rsqr (x + y))) as (x0,p). -unfold cos_in, cos_n, infinite_sum, Rdist in p. -unfold Un_cv, Rdist; intros. -destruct (p eps H) as (x1,H0). -exists x1; intros. -unfold C1. -replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n) - with - (sum_f_R0 - (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). -- apply H0; assumption. -- apply sum_eq. intros. - replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). - + reflexivity. - + apply pow_sqr. + unfold cos. + destruct (exist_cos (Rsqr (x + y))) as (x0,p). + unfold cos_in, cos_n, infinite_sum, Rdist in p. + unfold Un_cv, Rdist; intros. + destruct (p eps H) as (x1,H0). + exists x1; intros. + unfold C1. + replace + (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n) + with + (sum_f_R0 + (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). + - apply H0; assumption. + - apply sum_eq. + intros. + replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). + + reflexivity. + + apply pow_sqr. Qed. Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). Proof. -intro. -case (Req_dec x 0); intro. -{ rewrite H. - rewrite sin_0. + intro. + case (Req_dec x 0); intro. + { rewrite H. + rewrite sin_0. + unfold B1. + unfold Un_cv; unfold Rdist; intros; exists 0%nat; intros. + replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1)) n) with 0. + { unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. } + - induction n as [| n Hrecn]. + { simpl; ring. } + rewrite tech5; rewrite <- Hrecn. + { simpl; ring. } + unfold ge; apply Nat.le_0_l. } + unfold sin. destruct (exist_sin (Rsqr x)) as (x0,p). + unfold sin_in, sin_n, infinite_sum, Rdist in p. + unfold Un_cv, Rdist; intros. + cut (0 < eps / Rabs x); + [ intro + | unfold Rdiv; apply Rmult_lt_0_compat; + [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. + destruct (p (eps / Rabs x) H1) as (x1,H2). + exists x1; intros. unfold B1. - unfold Un_cv; unfold Rdist; intros; exists 0%nat; intros. - replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1)) n) with 0. - { unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. } - - induction n as [| n Hrecn]. - { simpl; ring. } - rewrite tech5; rewrite <- Hrecn. - { simpl; ring. } - unfold ge; apply Nat.le_0_l. } -unfold sin. destruct (exist_sin (Rsqr x)) as (x0,p). -unfold sin_in, sin_n, infinite_sum, Rdist in p. -unfold Un_cv, Rdist; intros. -cut (0 < eps / Rabs x); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. -destruct (p (eps / Rabs x) H1) as (x1,H2). -exists x1; intros. -unfold B1. -replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - n) with - (x * - sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). -2:{ rewrite scal_sum. - apply sum_eq. - intros. - rewrite pow_add. - rewrite pow_sqr. - simpl. - ring. } -replace - (x * - sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - - x * x0) with - (x * - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - - x0)); [ idtac | ring ]. -rewrite Rabs_mult. -apply Rmult_lt_reg_l with (/ Rabs x). -{ apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } -rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l, <- (Rmult_comm eps). -- apply H2; assumption. -- apply Rabs_no_R0; assumption. + replace + (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) + n) with + (x * + sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). + 2:{ rewrite scal_sum. + apply sum_eq. + intros. + rewrite pow_add. + rewrite pow_sqr. + simpl. + ring. } + replace + (x * + sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - + x * x0) with + (x * + (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - + x0)); [ idtac | ring ]. + rewrite Rabs_mult. + apply Rmult_lt_reg_l with (/ Rabs x). + { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } + rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l, <- (Rmult_comm eps). + - apply H2; assumption. + - apply Rabs_no_R0; assumption. Qed. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 5e935b1880..50aac84440 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -14,14 +14,14 @@ From Stdlib Require Import Lia. Lemma Rlt_R0_R2 : 0 < 2. Proof. -change 2 with (INR 2); apply lt_INR_0; apply PeanoNat.Nat.lt_0_succ. + change 2 with (INR 2); apply lt_INR_0; apply PeanoNat.Nat.lt_0_succ. Qed. Notation Rplus_lt_pos := Rplus_lt_0_compat (only parsing). Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2. Proof. -intros; rewrite H; reflexivity. + intros; rewrite H; reflexivity. Qed. Ltac discrR := diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index d289a09121..dbda991b67 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -649,22 +649,22 @@ Lemma MVT_abs : exists c : R, Rabs (f b - f a) = Rabs (f' c) * Rabs (b - a) /\ Rmin a b <= c <= Rmax a b. Proof. -intros f f' a b. -destruct (Rle_dec a b) as [aleb | blta]. -- destruct (Req_dec a b) as [ab | anb]. - + unfold Rminus; intros _; exists a; split. - * now rewrite <- ab, !Rplus_opp_r, Rabs_R0, Rmult_0_r. - * split;[apply Rmin_l | apply Rmax_l]. - + rewrite Rmax_right, Rmin_left; auto; intros derv. - destruct (MVT_cor2 f f' a b) as [c [hc intc]]; - [destruct aleb;[assumption | contradiction] | apply derv | ]. - exists c; rewrite hc, Rabs_mult;split; - [reflexivity | unfold Rle; tauto]. -- assert (b < a) by (apply Rnot_le_gt; assumption). - assert (b <= a) by (apply Rlt_le; assumption). - rewrite Rmax_left, Rmin_right; try assumption; intros derv. - destruct (MVT_cor2 f f' b a) as [c [hc intc]]; - [assumption | apply derv | ]. - exists c; rewrite <- Rabs_Ropp, Ropp_minus_distr, hc, Rabs_mult. - split;[now rewrite <- (Rabs_Ropp (b - a)), Ropp_minus_distr| unfold Rle; tauto]. + intros f f' a b. + destruct (Rle_dec a b) as [aleb | blta]. + - destruct (Req_dec a b) as [ab | anb]. + + unfold Rminus; intros _; exists a; split. + * now rewrite <- ab, !Rplus_opp_r, Rabs_R0, Rmult_0_r. + * split;[apply Rmin_l | apply Rmax_l]. + + rewrite Rmax_right, Rmin_left; auto; intros derv. + destruct (MVT_cor2 f f' a b) as [c [hc intc]]; + [destruct aleb;[assumption | contradiction] | apply derv | ]. + exists c; rewrite hc, Rabs_mult;split; + [reflexivity | unfold Rle; tauto]. + - assert (b < a) by (apply Rnot_le_gt; assumption). + assert (b <= a) by (apply Rlt_le; assumption). + rewrite Rmax_left, Rmin_right; try assumption; intros derv. + destruct (MVT_cor2 f f' b a) as [c [hc intc]]; + [assumption | apply derv | ]. + exists c; rewrite <- Rabs_Ropp, Ropp_minus_distr, hc, Rabs_mult. + split;[now rewrite <- (Rabs_Ropp (b - a)), Ropp_minus_distr| unfold Rle; tauto]. Qed. diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 4f8ae59852..264dbe1cba 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -31,101 +31,101 @@ Lemma atan_sub_correct : -PI/2 < atan (atan_sub u v) < PI/2 -> atan u = atan v + atan (atan_sub u v). Proof. -intros u v pn0 uvint aint. -assert (cos (atan u) <> 0). -{ destruct (atan_bound u); apply Rgt_not_eq, cos_gt_0; auto. - rewrite <- Rdiv_opp_l; assumption. } -assert (cos (atan v) <> 0). -{ destruct (atan_bound v); apply Rgt_not_eq, cos_gt_0; auto. - rewrite <- Rdiv_opp_l; assumption. } -assert (t : forall a b c, a - b = c -> a = b + c) by (intros; subst; field). -apply t, tan_inj; clear t; try assumption. -rewrite tan_minus; auto. -- rewrite !tan_atan; reflexivity. -- apply Rgt_not_eq, cos_gt_0; rewrite <- ?Rdiv_opp_l; tauto. -- rewrite !tan_atan; assumption. + intros u v pn0 uvint aint. + assert (cos (atan u) <> 0). + { destruct (atan_bound u); apply Rgt_not_eq, cos_gt_0; auto. + rewrite <- Rdiv_opp_l; assumption. } + assert (cos (atan v) <> 0). + { destruct (atan_bound v); apply Rgt_not_eq, cos_gt_0; auto. + rewrite <- Rdiv_opp_l; assumption. } + assert (t : forall a b c, a - b = c -> a = b + c) by (intros; subst; field). + apply t, tan_inj; clear t; try assumption. + rewrite tan_minus; auto. + - rewrite !tan_atan; reflexivity. + - apply Rgt_not_eq, cos_gt_0; rewrite <- ?Rdiv_opp_l; tauto. + - rewrite !tan_atan; assumption. Qed. Lemma tech : forall x y , -1 <= x <= 1 -> -1 < y < 1 -> -PI/2 < atan x - atan y < PI/2. Proof. -assert (ut := PI_RGT_0). -intros x y [xm1 x1] [ym1 y1]. -assert (-(PI/4) <= atan x). -{ destruct xm1 as [xm1 | xm1]. - { rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing. + assert (ut := PI_RGT_0). + intros x y [xm1 x1] [ym1 y1]. + assert (-(PI/4) <= atan x). + { destruct xm1 as [xm1 | xm1]. + { rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing. + assumption. } + solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl]. } + assert (-(PI/4) < atan y). + { rewrite <- atan_1, <- atan_opp; apply atan_increasing. assumption. } - solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl]. } -assert (-(PI/4) < atan y). -{ rewrite <- atan_1, <- atan_opp; apply atan_increasing. - assumption. } -assert (atan x <= PI/4). -{ destruct x1 as [x1 | x1]. - { rewrite <- atan_1; apply Rlt_le, atan_increasing. + assert (atan x <= PI/4). + { destruct x1 as [x1 | x1]. + { rewrite <- atan_1; apply Rlt_le, atan_increasing. + assumption. } + solve[rewrite x1, atan_1; apply Rle_refl]. } + assert (atan y < PI/4). + { rewrite <- atan_1; apply atan_increasing. assumption. } - solve[rewrite x1, atan_1; apply Rle_refl]. } -assert (atan y < PI/4). -{ rewrite <- atan_1; apply atan_increasing. - assumption. } -rewrite Rdiv_opp_l; split; lra. + rewrite Rdiv_opp_l; split; lra. Qed. (* A simple formula, reasonably efficient. *) Lemma Machin_2_3 : PI/4 = atan(/2) + atan(/3). Proof. -assert (utility : 0 < PI/2) by (apply PI2_RGT_0). -rewrite <- atan_1. -rewrite (atan_sub_correct 1 (/2)). -- apply f_equal, f_equal; unfold atan_sub; field. -- apply Rgt_not_eq; lra. -- apply tech; try split; try lra. -- apply atan_bound. + assert (utility : 0 < PI/2) by (apply PI2_RGT_0). + rewrite <- atan_1. + rewrite (atan_sub_correct 1 (/2)). + - apply f_equal, f_equal; unfold atan_sub; field. + - apply Rgt_not_eq; lra. + - apply tech; try split; try lra. + - apply atan_bound. Qed. Lemma Machin_4_5_239 : PI/4 = 4 * atan (/5) - atan(/239). Proof. -rewrite <- atan_1. -rewrite (atan_sub_correct 1 (/5)); - [ | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (4 * atan (/5) - atan (/239)) with - (atan (/5) + (atan (/5) + (atan (/5) + (atan (/5) + - - atan (/239))))) by ring. -apply f_equal. -replace (atan_sub 1 (/5)) with (2/3) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (2/3) (/5)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (atan_sub (2/3) (/5)) with (7/17) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (7/17) (/5)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (atan_sub (7/17) (/5)) with (9/46) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (9/46) (/5)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -rewrite <- atan_opp; apply f_equal. -unfold atan_sub; field. + rewrite <- atan_1. + rewrite (atan_sub_correct 1 (/5)); + [ | apply Rgt_not_eq; lra | apply tech; try split; lra | + apply atan_bound ]. + replace (4 * atan (/5) - atan (/239)) with + (atan (/5) + (atan (/5) + (atan (/5) + (atan (/5) + - + atan (/239))))) by ring. + apply f_equal. + replace (atan_sub 1 (/5)) with (2/3) by + (unfold atan_sub; field). + rewrite (atan_sub_correct (2/3) (/5)); + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | + apply atan_bound ]. + replace (atan_sub (2/3) (/5)) with (7/17) by + (unfold atan_sub; field). + rewrite (atan_sub_correct (7/17) (/5)); + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | + apply atan_bound ]. + replace (atan_sub (7/17) (/5)) with (9/46) by + (unfold atan_sub; field). + rewrite (atan_sub_correct (9/46) (/5)); + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | + apply atan_bound ]. + rewrite <- atan_opp; apply f_equal. + unfold atan_sub; field. Qed. Lemma Machin_2_3_7 : PI/4 = 2 * atan(/3) + (atan (/7)). Proof. -rewrite <- atan_1. -rewrite (atan_sub_correct 1 (/3)); - [ | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (2 * atan (/3) + atan (/7)) with - (atan (/3) + (atan (/3) + atan (/7))) by ring. -apply f_equal. -replace (atan_sub 1 (/3)) with (/2) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (/2) (/3)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -apply f_equal; unfold atan_sub; field. + rewrite <- atan_1. + rewrite (atan_sub_correct 1 (/3)); + [ | apply Rgt_not_eq; lra | apply tech; try split; lra | + apply atan_bound ]. + replace (2 * atan (/3) + atan (/7)) with + (atan (/3) + (atan (/3) + atan (/7))) by ring. + apply f_equal. + replace (atan_sub 1 (/3)) with (/2) by + (unfold atan_sub; field). + rewrite (atan_sub_correct (/2) (/3)); + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | + apply atan_bound ]. + apply f_equal; unfold atan_sub; field. Qed. (* More efficient way to compute approximations of PI. *) @@ -138,47 +138,47 @@ Lemma PI_2_3_7_ineq : sum_f_R0 (tg_alt PI_2_3_7_tg) (S (2 * N)) <= PI / 4 <= sum_f_R0 (tg_alt PI_2_3_7_tg) (2 * N). Proof. -assert (dec3 : 0 <= /3 <= 1) by (split; lra). -assert (dec7 : 0 <= /7 <= 1) by (split; lra). -assert (decr : Un_decreasing PI_2_3_7_tg). -{ apply Ratan_seq_decreasing in dec3. - apply Ratan_seq_decreasing in dec7. - intros n; apply Rplus_le_compat. - { apply Rmult_le_compat_l; [ lra | exact (dec3 n)]. } - exact (dec7 n). } -assert (cv : Un_cv PI_2_3_7_tg 0). -{ apply Ratan_seq_converging in dec3. - apply Ratan_seq_converging in dec7. - intros eps ep. - assert (ep' : 0 < eps /3) by lra. - destruct (dec3 _ ep') as [N1 Pn1]; destruct (dec7 _ ep') as [N2 Pn2]. - exists (N1 + N2)%nat; intros n Nn. - unfold PI_2_3_7_tg. - rewrite <- (Rplus_0_l 0). - apply Rle_lt_trans with - (1 := Rdist_plus (2 * Ratan_seq (/3) n) 0 (Ratan_seq (/7) n) 0). - replace eps with (2 * eps/3 + eps/3) by field. - apply Rplus_lt_compat. - { unfold Rdist, Rminus, Rdiv. - rewrite <- (Rmult_0_r 2), <- Ropp_mult_distr_r_reverse. - rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|lra]. - rewrite Rmult_assoc; apply Rmult_lt_compat_l;[lra | ]. - apply (Pn1 n); lia. } - apply (Pn2 n); lia. } -rewrite Machin_2_3_7. -rewrite !atan_eq_ps_atan; try (split; lra). -unfold ps_atan; destruct (in_int (/3)); destruct (in_int (/7)); - try match goal with id : ~ _ |- _ => case id; split; lra end. -destruct (ps_atan_exists_1 (/3)) as [v3 Pv3]. -destruct (ps_atan_exists_1 (/7)) as [v7 Pv7]. -assert (main : Un_cv (sum_f_R0 (tg_alt PI_2_3_7_tg)) (2 * v3 + v7)). -{ assert (main :Un_cv (fun n => 2 * sum_f_R0 (tg_alt (Ratan_seq (/3))) n + - sum_f_R0 (tg_alt (Ratan_seq (/7))) n) (2 * v3 + v7)). - { apply CV_plus;[ | assumption]. - apply CV_mult;[ | assumption]. - exists 0%nat; intros; rewrite Rdist_eq; assumption. } - apply Un_cv_ext with (2 := main). - intros n; rewrite scal_sum, <- plus_sum; apply sum_eq; intros. - rewrite Rmult_comm; unfold PI_2_3_7_tg, tg_alt; field. } -intros N; apply (alternated_series_ineq _ _ _ decr cv main). + assert (dec3 : 0 <= /3 <= 1) by (split; lra). + assert (dec7 : 0 <= /7 <= 1) by (split; lra). + assert (decr : Un_decreasing PI_2_3_7_tg). + { apply Ratan_seq_decreasing in dec3. + apply Ratan_seq_decreasing in dec7. + intros n; apply Rplus_le_compat. + { apply Rmult_le_compat_l; [ lra | exact (dec3 n)]. } + exact (dec7 n). } + assert (cv : Un_cv PI_2_3_7_tg 0). + { apply Ratan_seq_converging in dec3. + apply Ratan_seq_converging in dec7. + intros eps ep. + assert (ep' : 0 < eps /3) by lra. + destruct (dec3 _ ep') as [N1 Pn1]; destruct (dec7 _ ep') as [N2 Pn2]. + exists (N1 + N2)%nat; intros n Nn. + unfold PI_2_3_7_tg. + rewrite <- (Rplus_0_l 0). + apply Rle_lt_trans with + (1 := Rdist_plus (2 * Ratan_seq (/3) n) 0 (Ratan_seq (/7) n) 0). + replace eps with (2 * eps/3 + eps/3) by field. + apply Rplus_lt_compat. + { unfold Rdist, Rminus, Rdiv. + rewrite <- (Rmult_0_r 2), <- Ropp_mult_distr_r_reverse. + rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|lra]. + rewrite Rmult_assoc; apply Rmult_lt_compat_l;[lra | ]. + apply (Pn1 n); lia. } + apply (Pn2 n); lia. } + rewrite Machin_2_3_7. + rewrite !atan_eq_ps_atan; try (split; lra). + unfold ps_atan; destruct (in_int (/3)); destruct (in_int (/7)); + try match goal with id : ~ _ |- _ => case id; split; lra end. + destruct (ps_atan_exists_1 (/3)) as [v3 Pv3]. + destruct (ps_atan_exists_1 (/7)) as [v7 Pv7]. + assert (main : Un_cv (sum_f_R0 (tg_alt PI_2_3_7_tg)) (2 * v3 + v7)). + { assert (main :Un_cv (fun n => 2 * sum_f_R0 (tg_alt (Ratan_seq (/3))) n + + sum_f_R0 (tg_alt (Ratan_seq (/7))) n) (2 * v3 + v7)). + { apply CV_plus;[ | assumption]. + apply CV_mult;[ | assumption]. + exists 0%nat; intros; rewrite Rdist_eq; assumption. } + apply Un_cv_ext with (2 := main). + intros n; rewrite scal_sum, <- plus_sum; apply sum_eq; intros. + rewrite Rmult_comm; unfold PI_2_3_7_tg, tg_alt; field. } + intros N; apply (alternated_series_ineq _ _ _ decr cv main). Qed. diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 73a6ea2c53..78a8e4095f 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -50,21 +50,21 @@ Qed. (* $\int_a^a f$ exists forall a:R and f:R->R *) Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a. Proof. -intros f a; unfold Newton_integrable; - exists (fct_cte (f a) * id)%F; left; - unfold antiderivative; split. -2:right;reflexivity. -intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x). -{ apply derivable_pt_mult. - { apply derivable_pt_const. } - apply derivable_pt_id. } -exists H1; assert (H2 : x = a). -{ elim H; intros; apply Rle_antisym; assumption. } -symmetry ; apply derive_pt_eq_0; - replace (f x) with (0 * id x + fct_cte (f a) x * 1); - [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x); - [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ] - | unfold id, fct_cte; rewrite H2; ring ]. + intros f a; unfold Newton_integrable; + exists (fct_cte (f a) * id)%F; left; + unfold antiderivative; split. + 2:right;reflexivity. + intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x). + { apply derivable_pt_mult. + { apply derivable_pt_const. } + apply derivable_pt_id. } + exists H1; assert (H2 : x = a). + { elim H; intros; apply Rle_antisym; assumption. } + symmetry ; apply derive_pt_eq_0; + replace (f x) with (0 * id x + fct_cte (f a) x * 1); + [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x); + [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ] + | unfold id, fct_cte; rewrite H2; ring ]. Qed. (* $\int_a^a f = 0$ *) @@ -101,72 +101,72 @@ Lemma NewtonInt_P5 : Newton_integrable g a b -> Newton_integrable (fun x:R => l * f x + g x) a b. Proof. -unfold Newton_integrable; intros f g l a b X X0; - elim X; intros x p; elim X0; intros x0 p0; - exists (fun y:R => l * x y + x0 y). -elim p; intro; elim p0; intro. -- left; unfold antiderivative; unfold antiderivative in H, H0; elim H; - clear H; intros; elim H0; clear H0; intros H0 _. - split. 2:assumption. - intros; elim (H _ H2); elim (H0 _ H2); intros. - assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. -- unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro. - { elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)). } - left; rewrite <- H5; unfold antiderivative; split. - 2:right;reflexivity. - intros; elim H6; intros; assert (H9 : x1 = a). - { apply Rle_antisym; assumption. } - assert (H10 : a <= x1 <= b). - { split; right; [ symmetry ; assumption | rewrite <- H5; assumption ]. } - assert (H11 : b <= x1 <= a). - { split; right; [ rewrite <- H5; symmetry ; assumption | assumption ]. } - assert (H12 : derivable_pt x x1). - { unfold derivable_pt; exists (f x1); elim (H3 _ H10); intros; - eapply derive_pt_eq_1; symmetry ; apply H12. } - assert (H13 : derivable_pt x0 x1). - { unfold derivable_pt; exists (g x1); elim (H1 _ H11); intros; - eapply derive_pt_eq_1; symmetry ; apply H13. } - assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H14; symmetry ; reg. - assert (H15 : derive_pt x0 x1 H13 = g x1). - { elim (H1 _ H11); intros; rewrite H15; apply pr_nu. } - assert (H16 : derive_pt x x1 H12 = f x1). - { elim (H3 _ H10); intros; rewrite H16; apply pr_nu. } - rewrite H15; rewrite H16; ring. -- unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro. - { elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)). } - left; rewrite H5; unfold antiderivative; split. - 2:{ right;reflexivity. } - intros; elim H6; intros; assert (H9 : x1 = a). - { apply Rle_antisym; assumption. } - assert (H10 : a <= x1 <= b). - { split; right; [ symmetry ; assumption | rewrite H5; assumption ]. } - assert (H11 : b <= x1 <= a). - { split; right; [ rewrite H5; symmetry ; assumption | assumption ]. } - assert (H12 : derivable_pt x x1). - { unfold derivable_pt; exists (f x1); elim (H3 _ H11); intros; - eapply derive_pt_eq_1; symmetry ; apply H12. } - assert (H13 : derivable_pt x0 x1). - { unfold derivable_pt; exists (g x1); elim (H1 _ H10); intros; - eapply derive_pt_eq_1; symmetry ; apply H13. } - assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H14; symmetry ; reg. - assert (H15 : derive_pt x0 x1 H13 = g x1). - { elim (H1 _ H10); intros; rewrite H15; apply pr_nu. } - assert (H16 : derive_pt x x1 H12 = f x1). - { elim (H3 _ H11); intros; rewrite H16; apply pr_nu. } - rewrite H15; rewrite H16; ring. -- right; unfold antiderivative; unfold antiderivative in H, H0; elim H; - clear H; intros; elim H0; clear H0; intros H0 _; split. - 2:assumption. - intros; elim (H _ H2); elim (H0 _ H2); intros. - assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. + unfold Newton_integrable; intros f g l a b X X0; + elim X; intros x p; elim X0; intros x0 p0; + exists (fun y:R => l * x y + x0 y). + elim p; intro; elim p0; intro. + - left; unfold antiderivative; unfold antiderivative in H, H0; elim H; + clear H; intros; elim H0; clear H0; intros H0 _. + split. 2:assumption. + intros; elim (H _ H2); elim (H0 _ H2); intros. + assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1). + { reg. } + exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. + - unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro. + { elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)). } + left; rewrite <- H5; unfold antiderivative; split. + 2:right;reflexivity. + intros; elim H6; intros; assert (H9 : x1 = a). + { apply Rle_antisym; assumption. } + assert (H10 : a <= x1 <= b). + { split; right; [ symmetry ; assumption | rewrite <- H5; assumption ]. } + assert (H11 : b <= x1 <= a). + { split; right; [ rewrite <- H5; symmetry ; assumption | assumption ]. } + assert (H12 : derivable_pt x x1). + { unfold derivable_pt; exists (f x1); elim (H3 _ H10); intros; + eapply derive_pt_eq_1; symmetry ; apply H12. } + assert (H13 : derivable_pt x0 x1). + { unfold derivable_pt; exists (g x1); elim (H1 _ H11); intros; + eapply derive_pt_eq_1; symmetry ; apply H13. } + assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1). + { reg. } + exists H14; symmetry ; reg. + assert (H15 : derive_pt x0 x1 H13 = g x1). + { elim (H1 _ H11); intros; rewrite H15; apply pr_nu. } + assert (H16 : derive_pt x x1 H12 = f x1). + { elim (H3 _ H10); intros; rewrite H16; apply pr_nu. } + rewrite H15; rewrite H16; ring. + - unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro. + { elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)). } + left; rewrite H5; unfold antiderivative; split. + 2:{ right;reflexivity. } + intros; elim H6; intros; assert (H9 : x1 = a). + { apply Rle_antisym; assumption. } + assert (H10 : a <= x1 <= b). + { split; right; [ symmetry ; assumption | rewrite H5; assumption ]. } + assert (H11 : b <= x1 <= a). + { split; right; [ rewrite H5; symmetry ; assumption | assumption ]. } + assert (H12 : derivable_pt x x1). + { unfold derivable_pt; exists (f x1); elim (H3 _ H11); intros; + eapply derive_pt_eq_1; symmetry ; apply H12. } + assert (H13 : derivable_pt x0 x1). + { unfold derivable_pt; exists (g x1); elim (H1 _ H10); intros; + eapply derive_pt_eq_1; symmetry ; apply H13. } + assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1). + { reg. } + exists H14; symmetry ; reg. + assert (H15 : derive_pt x0 x1 H13 = g x1). + { elim (H1 _ H10); intros; rewrite H15; apply pr_nu. } + assert (H16 : derive_pt x x1 H12 = f x1). + { elim (H3 _ H11); intros; rewrite H16; apply pr_nu. } + rewrite H15; rewrite H16; ring. + - right; unfold antiderivative; unfold antiderivative in H, H0; elim H; + clear H; intros; elim H0; clear H0; intros H0 _; split. + 2:assumption. + intros; elim (H _ H2); elim (H0 _ H2); intros. + assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1). + { reg. } + exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. Qed. (**********) @@ -192,42 +192,42 @@ Lemma NewtonInt_P6 : NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) = l * NewtonInt f a b pr1 + NewtonInt g a b pr2. Proof. -intros f g l a b pr1 pr2; unfold NewtonInt; - destruct (NewtonInt_P5 f g l a b pr1 pr2) as (x,o); destruct pr1 as (x0,o0); - destruct pr2 as (x1,o1); destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. -- elim o; intro. - 2:{ unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hlt)). } - elim o0; intro. - 2:{ unfold antiderivative in H0; elim H0; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). } - elim o1; intro. - 2:{ unfold antiderivative in H1; elim H1; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hlt)). } - assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); - elim H3; intros; assert (H5 : a <= a <= b). - { split; [ right; reflexivity | left; assumption ]. } - assert (H6 : a <= b <= b). - { split; [ left; assumption | right; reflexivity ]. } - assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. -- rewrite Heq; ring. -- elim o; intro. - { unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hgt)). } - elim o0; intro. - { unfold antiderivative in H0; elim H0; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)). } - elim o1; intro. - { unfold antiderivative in H1; elim H1; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hgt)). } - assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); - elim H3; intros; assert (H5 : b <= a <= a). - { split; [ left; assumption | right; reflexivity ]. } - assert (H6 : b <= b <= a). - { split; [ right; reflexivity | left; assumption ]. } - assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. + intros f g l a b pr1 pr2; unfold NewtonInt; + destruct (NewtonInt_P5 f g l a b pr1 pr2) as (x,o); destruct pr1 as (x0,o0); + destruct pr2 as (x1,o1); destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. + - elim o; intro. + 2:{ unfold antiderivative in H; elim H; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hlt)). } + elim o0; intro. + 2:{ unfold antiderivative in H0; elim H0; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). } + elim o1; intro. + 2:{ unfold antiderivative in H1; elim H1; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hlt)). } + assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1); + assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); + elim H3; intros; assert (H5 : a <= a <= b). + { split; [ right; reflexivity | left; assumption ]. } + assert (H6 : a <= b <= b). + { split; [ left; assumption | right; reflexivity ]. } + assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. + - rewrite Heq; ring. + - elim o; intro. + { unfold antiderivative in H; elim H; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hgt)). } + elim o0; intro. + { unfold antiderivative in H0; elim H0; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)). } + elim o1; intro. + { unfold antiderivative in H1; elim H1; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hgt)). } + assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1); + assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); + elim H3; intros; assert (H5 : b <= a <= a). + { split; [ left; assumption | right; reflexivity ]. } + assert (H6 : b <= b <= a). + { split; [ right; reflexivity | left; assumption ]. } + assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. Qed. Lemma antiderivative_P2 : @@ -241,142 +241,142 @@ Lemma antiderivative_P2 : | right _ => F1 x + (F0 b - F1 b) end) a c. Proof. -intros; destruct H as (H,H1), H0 as (H0,H2); split. -2: apply Rle_trans with b; assumption. -intros x (H3,H4); destruct (total_order_T x b) as [[Hlt|Heq]|Hgt]. -- assert (H5 : a <= x <= b). - { split; [ assumption | left; assumption ]. } - destruct (H _ H5) as (x0,H6). - assert - (H7 : - derivable_pt_lim - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x (f x)). - { unfold derivable_pt_lim. intros eps H9. - assert (H7 : derive_pt F0 x x0 = f x) by (symmetry; assumption). - destruct (derive_pt_eq_1 F0 x (f x) x0 H7 _ H9) as (x1,H10); set (D := Rmin x1 (b - x)). - assert (H11 : 0 < D). - { unfold D, Rmin; case (Rle_dec x1 (b - x)); intro. - { apply (cond_pos x1). } - apply Rlt_0_minus; assumption. } - exists (mkposreal _ H11); intros h H12 H13. case (Rle_dec x b) as [|[]]. - 2:left;assumption. - case (Rle_dec (x + h) b) as [|[]]. - { apply H10. - { assumption. } - apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. } - left; apply Rlt_le_trans with (x + D). - { apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h). - { apply RRle_abs. } - apply H13. } - apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_l; rewrite Rplus_comm; unfold D; - apply Rmin_r. } - assert - (H8 : - derivable_pt - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x). - { unfold derivable_pt; exists (f x); apply H7. } - exists H8; symmetry ; apply derive_pt_eq_0; apply H7. -- assert (H5 : a <= x <= b). - { split; [ assumption | right; assumption ]. } - assert (H6 : b <= x <= c). - { split; [ right; symmetry ; assumption | assumption ]. } - elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x). - { symmetry ; assumption. } - assert (H10 : derive_pt F1 x x0 = f x). - { symmetry ; assumption. } - assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9); - assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10); + intros; destruct H as (H,H1), H0 as (H0,H2); split. + 2: apply Rle_trans with b; assumption. + intros x (H3,H4); destruct (total_order_T x b) as [[Hlt|Heq]|Hgt]. + - assert (H5 : a <= x <= b). + { split; [ assumption | left; assumption ]. } + destruct (H _ H5) as (x0,H6). assert - (H13 : + (H7 : derivable_pt_lim (fun x:R => match Rle_dec x b with | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) end) x (f x)). - { unfold derivable_pt_lim; unfold derivable_pt_lim in H11, H12; intros; - elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3); - assert (H16 : 0 < D). - { unfold D; unfold Rmin; case (Rle_dec x2 x3); intro. - { apply (cond_pos x2). } - apply (cond_pos x3). } - exists (mkposreal _ H16); intros; case (Rle_dec x b) as [|[]]. - 2:right;assumption. - case (Rle_dec (x + h) b); intro. - { apply H15. - { assumption. } - apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_r ]. } - replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x). - { apply H14. - { assumption. } - apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. } - rewrite Heq; ring. } - assert - (H14 : - derivable_pt - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x). - { unfold derivable_pt; exists (f x); apply H13. } - exists H14; symmetry ; apply derive_pt_eq_0; apply H13. -- assert (H5 : b <= x <= c). - { split; [ left; assumption | assumption ]. } - assert (H6 := H0 _ H5); elim H6; clear H6; intros; + { unfold derivable_pt_lim. intros eps H9. + assert (H7 : derive_pt F0 x x0 = f x) by (symmetry; assumption). + destruct (derive_pt_eq_1 F0 x (f x) x0 H7 _ H9) as (x1,H10); set (D := Rmin x1 (b - x)). + assert (H11 : 0 < D). + { unfold D, Rmin; case (Rle_dec x1 (b - x)); intro. + { apply (cond_pos x1). } + apply Rlt_0_minus; assumption. } + exists (mkposreal _ H11); intros h H12 H13. case (Rle_dec x b) as [|[]]. + 2:left;assumption. + case (Rle_dec (x + h) b) as [|[]]. + { apply H10. + { assumption. } + apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. } + left; apply Rlt_le_trans with (x + D). + { apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h). + { apply RRle_abs. } + apply H13. } + apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l; + rewrite Rplus_0_l; rewrite Rplus_comm; unfold D; + apply Rmin_r. } assert - (H7 : - derivable_pt_lim + (H8 : + derivable_pt (fun x:R => match Rle_dec x b with | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) - end) x (f x)). - { unfold derivable_pt_lim; assert (H7 : derive_pt F1 x x0 = f x). + end) x). + { unfold derivable_pt; exists (f x); apply H7. } + exists H8; symmetry ; apply derive_pt_eq_0; apply H7. + - assert (H5 : a <= x <= b). + { split; [ assumption | right; assumption ]. } + assert (H6 : b <= x <= c). + { split; [ right; symmetry ; assumption | assumption ]. } + elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x). { symmetry ; assumption. } - assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8; - intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b)); - assert (H11 : 0 < D). - { unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro. - { apply (cond_pos x1). } - apply Rlt_0_minus; assumption. } - exists (mkposreal _ H11); intros; destruct (Rle_dec x b) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). } - destruct (Rle_dec (x + h) b) as [Hle'|Hnle']. - { cut (b < x + h). - { intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14)). } - apply Rplus_lt_reg_l with (- h - b); replace (- h - b + b) with (- h); - [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); - [ idtac | ring ]; apply Rle_lt_trans with (Rabs h). - { rewrite <- Rabs_Ropp; apply RRle_abs. } + assert (H10 : derive_pt F1 x x0 = f x). + { symmetry ; assumption. } + assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9); + assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10); + assert + (H13 : + derivable_pt_lim + (fun x:R => + match Rle_dec x b with + | left _ => F0 x + | right _ => F1 x + (F0 b - F1 b) + end) x (f x)). + { unfold derivable_pt_lim; unfold derivable_pt_lim in H11, H12; intros; + elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3); + assert (H16 : 0 < D). + { unfold D; unfold Rmin; case (Rle_dec x2 x3); intro. + { apply (cond_pos x2). } + apply (cond_pos x3). } + exists (mkposreal _ H16); intros; case (Rle_dec x b) as [|[]]. + 2:right;assumption. + case (Rle_dec (x + h) b); intro. + { apply H15. + { assumption. } + apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_r ]. } + replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x). + { apply H14. + { assumption. } + apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. } + rewrite Heq; ring. } + assert + (H14 : + derivable_pt + (fun x:R => + match Rle_dec x b with + | left _ => F0 x + | right _ => F1 x + (F0 b - F1 b) + end) x). + { unfold derivable_pt; exists (f x); apply H13. } + exists H14; symmetry ; apply derive_pt_eq_0; apply H13. + - assert (H5 : b <= x <= c). + { split; [ left; assumption | assumption ]. } + assert (H6 := H0 _ H5); elim H6; clear H6; intros; + assert + (H7 : + derivable_pt_lim + (fun x:R => + match Rle_dec x b with + | left _ => F0 x + | right _ => F1 x + (F0 b - F1 b) + end) x (f x)). + { unfold derivable_pt_lim; assert (H7 : derive_pt F1 x x0 = f x). + { symmetry ; assumption. } + assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8; + intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b)); + assert (H11 : 0 < D). + { unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro. + { apply (cond_pos x1). } + apply Rlt_0_minus; assumption. } + exists (mkposreal _ H11); intros; destruct (Rle_dec x b) as [Hle|Hnle]. + { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). } + destruct (Rle_dec (x + h) b) as [Hle'|Hnle']. + { cut (b < x + h). + { intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14)). } + apply Rplus_lt_reg_l with (- h - b); replace (- h - b + b) with (- h); + [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); + [ idtac | ring ]; apply Rle_lt_trans with (Rabs h). + { rewrite <- Rabs_Ropp; apply RRle_abs. } + apply Rlt_le_trans with D. + { apply H13. } + unfold D; apply Rmin_r. } + replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with + (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10. + { assumption. } apply Rlt_le_trans with D. - { apply H13. } - unfold D; apply Rmin_r. } - replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with - (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10. - { assumption. } - apply Rlt_le_trans with D. - { assumption. } - unfold D; apply Rmin_l. } - assert - (H8 : - derivable_pt - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x). - { unfold derivable_pt; exists (f x); apply H7. } - exists H8; symmetry ; apply derive_pt_eq_0; apply H7. + { assumption. } + unfold D; apply Rmin_l. } + assert + (H8 : + derivable_pt + (fun x:R => + match Rle_dec x b with + | left _ => F0 x + | right _ => F1 x + (F0 b - F1 b) + end) x). + { unfold derivable_pt; exists (f x); apply H7. } + exists H8; symmetry ; apply derive_pt_eq_0; apply H7. Qed. Lemma antiderivative_P3 : @@ -385,20 +385,20 @@ Lemma antiderivative_P3 : antiderivative f F1 c b -> antiderivative f F1 c a \/ antiderivative f F0 a c. Proof. -intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0; - intros; destruct (total_order_T a c) as [[Hle|Heq]|Hgt]. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ assumption | apply Rle_trans with c; assumption ]. } - left; assumption. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ assumption | apply Rle_trans with c; assumption ]. } - right; assumption. -- left; unfold antiderivative; split. - { intros; apply H; elim H3; intros; split; - [ assumption | apply Rle_trans with a; assumption ]. } - left; assumption. + intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0; + intros; destruct (total_order_T a c) as [[Hle|Heq]|Hgt]. + - right; unfold antiderivative; split. + { intros; apply H1; elim H3; intros; split; + [ assumption | apply Rle_trans with c; assumption ]. } + left; assumption. + - right; unfold antiderivative; split. + { intros; apply H1; elim H3; intros; split; + [ assumption | apply Rle_trans with c; assumption ]. } + right; assumption. + - left; unfold antiderivative; split. + { intros; apply H; elim H3; intros; split; + [ assumption | apply Rle_trans with a; assumption ]. } + left; assumption. Qed. Lemma antiderivative_P4 : @@ -407,20 +407,20 @@ Lemma antiderivative_P4 : antiderivative f F1 a c -> antiderivative f F1 b c \/ antiderivative f F0 c b. Proof. -intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0; - intros; destruct (total_order_T c b) as [[Hlt|Heq]|Hgt]. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ apply Rle_trans with c; assumption | assumption ]. } - left; assumption. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ apply Rle_trans with c; assumption | assumption ]. } - right; assumption. -- left; unfold antiderivative; split. - { intros; apply H; elim H3; intros; split; - [ apply Rle_trans with b; assumption | assumption ]. } - left; assumption. + intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0; + intros; destruct (total_order_T c b) as [[Hlt|Heq]|Hgt]. + - right; unfold antiderivative; split. + { intros; apply H1; elim H3; intros; split; + [ apply Rle_trans with c; assumption | assumption ]. } + left; assumption. + - right; unfold antiderivative; split. + { intros; apply H1; elim H3; intros; split; + [ apply Rle_trans with c; assumption | assumption ]. } + right; assumption. + - left; unfold antiderivative; split. + { intros; apply H; elim H3; intros; split; + [ apply Rle_trans with b; assumption | assumption ]. } + left; assumption. Qed. Lemma NewtonInt_P7 : @@ -430,25 +430,25 @@ Lemma NewtonInt_P7 : Newton_integrable f a b -> Newton_integrable f b c -> Newton_integrable f a c. Proof. -unfold Newton_integrable; intros f a b c Hab Hbc X X0; elim X; - clear X; intros F0 H0; elim X0; clear X0; intros F1 H1; - set - (g := - fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end); - exists g; left; unfold g; - apply antiderivative_P2. -{ elim H0; intro. + unfold Newton_integrable; intros f a b c Hab Hbc X X0; elim X; + clear X; intros F0 H0; elim X0; clear X0; intros F1 H1; + set + (g := + fun x:R => + match Rle_dec x b with + | left _ => F0 x + | right _ => F1 x + (F0 b - F1 b) + end); + exists g; left; unfold g; + apply antiderivative_P2. + { elim H0; intro. + { assumption. } + unfold antiderivative in H; elim H; clear H; intros; + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)). } + elim H1; intro. { assumption. } unfold antiderivative in H; elim H; clear H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)). } -elim H1; intro. -{ assumption. } -unfold antiderivative in H; elim H; clear H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)). Qed. Lemma NewtonInt_P8 : @@ -456,97 +456,97 @@ Lemma NewtonInt_P8 : Newton_integrable f a b -> Newton_integrable f b c -> Newton_integrable f a c. Proof. -intros. -elim X; intros F0 H0. -elim X0; intros F1 H1. -destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. -- destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. - + (* a - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end). - elim H0; intro. - { elim H1; intro. - { left; apply antiderivative_P2; assumption. } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')). } - unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)). - + (* ac *) - destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt'']. - * unfold Newton_integrable; exists F0. - left. - elim H1; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } - elim H0; intro. - { assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H). - elim H3; intro. - { unfold antiderivative in H4; elim H4; clear H4; intros _ H4. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')). } - assumption. } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). - * rewrite Heq''; apply NewtonInt_P1. - * unfold Newton_integrable; exists F1. - right. - elim H1; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } - elim H0; intro. - { assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H). - elim H3; intro. - { assumption. } - unfold antiderivative in H4; elim H4; clear H4; intros _ H4. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')). } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). -- (* a=b *) - rewrite Heq; apply X0. -- destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. - (* a>b & b + match Rle_dec x b with + | left _ => F0 x + | right _ => F1 x + (F0 b - F1 b) + end). elim H0; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } - elim H1; intro. - { assert (H3 := antiderivative_P4 f F0 F1 b a c H H2). - elim H3; intro. - { unfold antiderivative in H4; elim H4; clear H4; intros _ H4. + { elim H1; intro. + { left; apply antiderivative_P2; assumption. } + unfold antiderivative in H2; elim H2; clear H2; intros _ H2. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')). } + unfold antiderivative in H; elim H; clear H; intros _ H. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)). + + (* ac *) + destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt'']. + * unfold Newton_integrable; exists F0. + left. + elim H1; intro. + { unfold antiderivative in H; elim H; clear H; intros _ H. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } + elim H0; intro. + { assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H). + elim H3; intro. + { unfold antiderivative in H4; elim H4; clear H4; intros _ H4. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')). } + assumption. } + unfold antiderivative in H2; elim H2; clear H2; intros _ H2. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). + * rewrite Heq''; apply NewtonInt_P1. + * unfold Newton_integrable; exists F1. + right. + elim H1; intro. + { unfold antiderivative in H; elim H; clear H; intros _ H. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } + elim H0; intro. + { assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H). + elim H3; intro. + { assumption. } + unfold antiderivative in H4; elim H4; clear H4; intros _ H4. elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')). } - assumption. } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')). - + (* a>b & b=c *) - rewrite Heq' in X; apply X. - + (* a>b & b>c *) - assert (X1 := NewtonInt_P3 f a b X). - assert (X2 := NewtonInt_P3 f b c X0). - apply NewtonInt_P3. - apply NewtonInt_P7 with b; assumption. + unfold antiderivative in H2; elim H2; clear H2; intros _ H2. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). + - (* a=b *) + rewrite Heq; apply X0. + - destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. + (* a>b & bb & b=c *) + rewrite Heq' in X; apply X. + + (* a>b & b>c *) + assert (X1 := NewtonInt_P3 f a b X). + assert (X2 := NewtonInt_P3 f b c X0). + apply NewtonInt_P3. + apply NewtonInt_P7 with b; assumption. Qed. (* Chasles' relation *) @@ -556,198 +556,198 @@ Lemma NewtonInt_P9 : NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) = NewtonInt f a b pr1 + NewtonInt f b c pr2. Proof. -intros; unfold NewtonInt. -case (NewtonInt_P8 f a b c pr1 pr2) as (x,Hor). -case pr1 as (x0,Hor0). -case pr2 as (x1,Hor1). -destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. -- destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. - + (* a - match Rle_dec x b with - | left _ => x0 x - | right _ => x1 x + (x0 b - x1 b) - end) a c H1 H2). - elim H3; intros. - assert (H5 : a <= a <= c). - { split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ]. } - assert (H6 : a <= c <= c). - { split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ]. } - rewrite (H4 _ H5); rewrite (H4 _ H6). - destruct (Rle_dec a b) as [Hlea|Hnlea]. - { destruct (Rle_dec c b) as [Hlec|Hnlec]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlec Hlt')). } - ring. } - elim Hnlea; left; assumption. - + (* ac *) - elim Hor1; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } - elim Hor0; intro. - 2:{ unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)). } - elim Hor; intro. - * assert (H2 := antiderivative_P2 f x x1 a c b H1 H). - assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2). + intros; unfold NewtonInt. + case (NewtonInt_P8 f a b c pr1 pr2) as (x,Hor). + case pr1 as (x0,Hor0). + case pr2 as (x1,Hor1). + destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. + - destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. + + (* a + match Rle_dec x b with + | left _ => x0 x + | right _ => x1 x + (x0 b - x1 b) + end) a c H1 H2). elim H3; intros. - rewrite (H4 a). - { rewrite (H4 b). - { destruct (Rle_dec b c) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt')). } - destruct (Rle_dec a c) as [Hle'|Hnle']. - { ring. } - elim Hnle'; unfold antiderivative in H1; elim H1; intros; assumption. } - split; [ left; assumption | right; reflexivity ]. } - split; [ right; reflexivity | left; assumption ]. - * assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0). - assert (H3 := antiderivative_Ucte _ _ _ c b H H2). - elim H3; intros. - rewrite (H4 c). - { rewrite (H4 b). - { destruct (Rle_dec b a) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hlt)). } - destruct (Rle_dec c a) as [Hle'|[]]. - { ring. } - unfold antiderivative in H1; elim H1; intros; assumption. } - split; [ left; assumption | right; reflexivity ]. } - split; [ right; reflexivity | left; assumption ]. -- (* a=b *) - rewrite Heq in Hor |- *. - elim Hor; intro. - + elim Hor1; intro. - * assert (H1 := antiderivative_Ucte _ _ _ b c H H0). + assert (H5 : a <= a <= c). + { split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ]. } + assert (H6 : a <= c <= c). + { split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ]. } + rewrite (H4 _ H5); rewrite (H4 _ H6). + destruct (Rle_dec a b) as [Hlea|Hnlea]. + { destruct (Rle_dec c b) as [Hlec|Hnlec]. + { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlec Hlt')). } + ring. } + elim Hnlea; left; assumption. + + (* ac *) + elim Hor1; intro. + { unfold antiderivative in H; elim H; clear H; intros _ H. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } + elim Hor0; intro. + 2:{ unfold antiderivative in H0; elim H0; clear H0; intros _ H0. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)). } + elim Hor; intro. + * assert (H2 := antiderivative_P2 f x x1 a c b H1 H). + assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2). + elim H3; intros. + rewrite (H4 a). + { rewrite (H4 b). + { destruct (Rle_dec b c) as [Hle|Hnle]. + { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt')). } + destruct (Rle_dec a c) as [Hle'|Hnle']. + { ring. } + elim Hnle'; unfold antiderivative in H1; elim H1; intros; assumption. } + split; [ left; assumption | right; reflexivity ]. } + split; [ right; reflexivity | left; assumption ]. + * assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0). + assert (H3 := antiderivative_Ucte _ _ _ c b H H2). + elim H3; intros. + rewrite (H4 c). + { rewrite (H4 b). + { destruct (Rle_dec b a) as [Hle|Hnle]. + { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hlt)). } + destruct (Rle_dec c a) as [Hle'|[]]. + { ring. } + unfold antiderivative in H1; elim H1; intros; assumption. } + split; [ left; assumption | right; reflexivity ]. } + split; [ right; reflexivity | left; assumption ]. + - (* a=b *) + rewrite Heq in Hor |- *. + elim Hor; intro. + + elim Hor1; intro. + * assert (H1 := antiderivative_Ucte _ _ _ b c H H0). + elim H1; intros. + assert (H3 : b <= c). + { unfold antiderivative in H; elim H; intros; assumption. } + rewrite (H2 b). + { rewrite (H2 c). + { ring. } + split; [ assumption | right; reflexivity ]. } + split; [ right; reflexivity | assumption ]. + * assert (H1 : b = c). + { unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym; + assumption. } + rewrite H1; ring. + + elim Hor1; intro. + * assert (H1 : b = c). + { unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym; + assumption. } + rewrite H1; ring. + * assert (H1 := antiderivative_Ucte _ _ _ c b H H0). + elim H1; intros. + assert (H3 : c <= b). + { unfold antiderivative in H; elim H; intros; assumption. } + rewrite (H2 c). + { rewrite (H2 b). + { ring. } + split; [ assumption | right; reflexivity ]. } + split; [ right; reflexivity | assumption ]. + - (* a>b & bb & b=c *) + rewrite <- Heq'. + unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r. + rewrite <- Heq' in Hor. + elim Hor0; intro. + { unfold antiderivative in H; elim H; clear H; intros _ H. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } + elim Hor; intro. + { unfold antiderivative in H0; elim H0; clear H0; intros _ H0. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt)). } + assert (H1 := antiderivative_Ucte f x x0 b a H0 H). elim H1; intros. - assert (H3 : c <= b). - { unfold antiderivative in H; elim H; intros; assumption. } - rewrite (H2 c). - { rewrite (H2 b). + rewrite (H2 b). + { rewrite (H2 a). { ring. } - split; [ assumption | right; reflexivity ]. } - split; [ right; reflexivity | assumption ]. -- (* a>b & bb & b>c *) + elim Hor0; intro. + { unfold antiderivative in H; elim H; clear H; intros _ H. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } + elim Hor1; intro. + { unfold antiderivative in H0; elim H0; clear H0; intros _ H0. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt')). } + elim Hor; intro. + { unfold antiderivative in H1; elim H1; clear H1; intros _ H1. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hgt' Hgt))). } + assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H). + assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2). elim H3; intros. - rewrite (H4 a). - 2:{ split; [ left; assumption | right; reflexivity ]. } - rewrite (H4 b). - 2:{ split; [ right; reflexivity | left; assumption ]. } - case (Rle_dec b c) as [|[]]. - 2:{ left; assumption. } - case (Rle_dec a c) as [|]. - { assert (H5 : a = c). - { unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption. } - rewrite H5; ring. } - ring. - + (* a>b & b=c *) - rewrite <- Heq'. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r. - rewrite <- Heq' in Hor. - elim Hor0; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } - elim Hor; intro. - { unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt)). } - assert (H1 := antiderivative_Ucte f x x0 b a H0 H). - elim H1; intros. - rewrite (H2 b). - { rewrite (H2 a). - { ring. } - split; [ left; assumption | right; reflexivity ]. } - split; [ right; reflexivity | left; assumption ]. - + (* a>b & b>c *) - elim Hor0; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } - elim Hor1; intro. - { unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt')). } - elim Hor; intro. - { unfold antiderivative in H1; elim H1; clear H1; intros _ H1. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hgt' Hgt))). } - assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H). - assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2). - elim H3; intros. - assert (H5 : c <= a). - { unfold antiderivative in H1; elim H1; intros; assumption. } - rewrite (H4 c). - { rewrite (H4 a). - { destruct (Rle_dec a b) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). } - destruct (Rle_dec c b) as [|[]]. - { ring. } - left; assumption. } - split; [ assumption | right; reflexivity ]. } - split; [ right; reflexivity | assumption ]. + assert (H5 : c <= a). + { unfold antiderivative in H1; elim H1; intros; assumption. } + rewrite (H4 c). + { rewrite (H4 a). + { destruct (Rle_dec a b) as [Hle|Hnle]. + { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). } + destruct (Rle_dec c b) as [|[]]. + { ring. } + left; assumption. } + split; [ assumption | right; reflexivity ]. } + split; [ right; reflexivity | assumption ]. Qed. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 689b09c0f7..47b60022a9 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -25,103 +25,103 @@ Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r. Lemma Boule_convex : forall c d x y z, Boule c d x -> Boule c d y -> x <= z <= y -> Boule c d z. Proof. -intros c d x y z bx b_y intz. -unfold Boule in bx, b_y; apply Rabs_def2 in bx; -apply Rabs_def2 in b_y; apply Rabs_def1; - [apply Rle_lt_trans with (y - c);[apply Rplus_le_compat_r|]| - apply Rlt_le_trans with (x - c);[|apply Rplus_le_compat_r]];tauto. + intros c d x y z bx b_y intz. + unfold Boule in bx, b_y; apply Rabs_def2 in bx; + apply Rabs_def2 in b_y; apply Rabs_def1; + [apply Rle_lt_trans with (y - c);[apply Rplus_le_compat_r|]| + apply Rlt_le_trans with (x - c);[|apply Rplus_le_compat_r]];tauto. Qed. Definition boule_of_interval x y (h : x < y) : {c :R & {r : posreal | c - r = x /\ c + r = y}}. Proof. -exists ((x + y)/2). -assert (radius : 0 < (y - x)/2). -- unfold Rdiv; apply Rmult_lt_0_compat. - + apply Rlt_0_minus; assumption. - + now apply Rinv_0_lt_compat, Rlt_0_2. -- exists (mkposreal _ radius). - simpl; split; unfold Rdiv; field. + exists ((x + y)/2). + assert (radius : 0 < (y - x)/2). + - unfold Rdiv; apply Rmult_lt_0_compat. + + apply Rlt_0_minus; assumption. + + now apply Rinv_0_lt_compat, Rlt_0_2. + - exists (mkposreal _ radius). + simpl; split; unfold Rdiv; field. Qed. Definition boule_in_interval x y z (h : x < z < y) : {c : R & {r | Boule c r z /\ x < c - r /\ c + r < y}}. Proof. -assert (cmp : x * /2 + z * /2 < z * /2 + y * /2). { - destruct h as [h1 h2]. - rewrite Rplus_comm; apply Rplus_lt_compat_l, Rmult_lt_compat_r. - - apply Rinv_0_lt_compat, Rlt_0_2. - - apply Rlt_trans with z; assumption. -} -destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]]. -assert (0 < /2) by (apply Rinv_0_lt_compat, Rlt_0_2). -exists c, r; split. -- destruct h; unfold Boule; simpl; apply Rabs_def1. - + apply Rplus_lt_reg_l with c; rewrite P2; - replace (c + (z - c)) with (z * / 2 + z * / 2) by field. - apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption. - + apply Rplus_lt_reg_l with c; change (c + - r) with (c - r); - rewrite P1; - replace (c + (z - c)) with (z * / 2 + z * / 2) by field. - apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption. -- destruct h; split. - + replace x with (x * / 2 + x * / 2) by field; rewrite P1. - apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption. - + replace y with (y * / 2 + y * /2) by field; rewrite P2. - apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption. + assert (cmp : x * /2 + z * /2 < z * /2 + y * /2). { + destruct h as [h1 h2]. + rewrite Rplus_comm; apply Rplus_lt_compat_l, Rmult_lt_compat_r. + - apply Rinv_0_lt_compat, Rlt_0_2. + - apply Rlt_trans with z; assumption. + } + destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]]. + assert (0 < /2) by (apply Rinv_0_lt_compat, Rlt_0_2). + exists c, r; split. + - destruct h; unfold Boule; simpl; apply Rabs_def1. + + apply Rplus_lt_reg_l with c; rewrite P2; + replace (c + (z - c)) with (z * / 2 + z * / 2) by field. + apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption. + + apply Rplus_lt_reg_l with c; change (c + - r) with (c - r); + rewrite P1; + replace (c + (z - c)) with (z * / 2 + z * / 2) by field. + apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption. + - destruct h; split. + + replace x with (x * / 2 + x * / 2) by field; rewrite P1. + apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption. + + replace y with (y * / 2 + y * /2) by field; rewrite P2. + apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption. Qed. Lemma Ball_in_inter : forall c1 c2 r1 r2 x, Boule c1 r1 x -> Boule c2 r2 x -> {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}. Proof. -intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2. -assert (Rmax (c1 - r1)(c2 - r2) < x). { - apply Rmax_lub_lt;[revert in1 | revert in2]; intros h; - apply Rabs_def2 in h; destruct h as [_ u]; - apply (fun h => Rplus_lt_reg_r _ _ _ (Rle_lt_trans _ _ _ h u)), Req_le; ring. } -assert (x < Rmin (c1 + r1) (c2 + r2)). { - apply Rmin_glb_lt;[revert in1 | revert in2]; intros h; - apply Rabs_def2 in h; destruct h as [u _]; - apply (fun h => Rplus_lt_reg_r _ _ _ (Rlt_le_trans _ _ _ u h)), Req_le; ring. } -assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x)). { - apply Rmin_glb_lt; apply Rlt_0_minus; assumption. } -exists (mkposreal _ t). -apply Rabs_def2 in in1; destruct in1. -apply Rabs_def2 in in2; destruct in2. -assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l. -assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r. -assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l. -assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r. -assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2)) - by apply Rmin_l. -assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x) - by apply Rmin_r. -simpl. -intros y h; apply Rabs_def2 in h; destruct h as [h h']. -apply Rmin_Rgt in h; destruct h as [cmp1 cmp2]. -apply Rplus_lt_reg_r in cmp2; apply Rmin_Rgt in cmp2. -rewrite Ropp_Rmin, Ropp_minus_distr in h'. -apply Rmax_Rlt in h'; destruct h' as [cmp3 cmp4]; -apply Rplus_lt_reg_r in cmp3; apply Rmax_Rlt in cmp3; -split; apply Rabs_def1. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj1 cmp2))), Req_le; - ring. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj1 cmp3) h)), Req_le; - ring. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj2 cmp2))), Req_le; - ring. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj2 cmp3) h)), Req_le; - ring. + intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2. + assert (Rmax (c1 - r1)(c2 - r2) < x). { + apply Rmax_lub_lt;[revert in1 | revert in2]; intros h; + apply Rabs_def2 in h; destruct h as [_ u]; + apply (fun h => Rplus_lt_reg_r _ _ _ (Rle_lt_trans _ _ _ h u)), Req_le; ring. } + assert (x < Rmin (c1 + r1) (c2 + r2)). { + apply Rmin_glb_lt;[revert in1 | revert in2]; intros h; + apply Rabs_def2 in h; destruct h as [u _]; + apply (fun h => Rplus_lt_reg_r _ _ _ (Rlt_le_trans _ _ _ u h)), Req_le; ring. } + assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2)) + (Rmin (c1 + r1) (c2 + r2) - x)). { + apply Rmin_glb_lt; apply Rlt_0_minus; assumption. } + exists (mkposreal _ t). + apply Rabs_def2 in in1; destruct in1. + apply Rabs_def2 in in2; destruct in2. + assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l. + assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r. + assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l. + assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r. + assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) + (Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2)) + by apply Rmin_l. + assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) + (Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x) + by apply Rmin_r. + simpl. + intros y h; apply Rabs_def2 in h; destruct h as [h h']. + apply Rmin_Rgt in h; destruct h as [cmp1 cmp2]. + apply Rplus_lt_reg_r in cmp2; apply Rmin_Rgt in cmp2. + rewrite Ropp_Rmin, Ropp_minus_distr in h'. + apply Rmax_Rlt in h'; destruct h' as [cmp3 cmp4]; + apply Rplus_lt_reg_r in cmp3; apply Rmax_Rlt in cmp3; + split; apply Rabs_def1. + - apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj1 cmp2))), Req_le; + ring. + - apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj1 cmp3) h)), Req_le; + ring. + - apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj2 cmp2))), Req_le; + ring. + - apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj2 cmp3) h)), Req_le; + ring. Qed. Lemma Boule_center : forall x r, Boule x r x. Proof. -intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r. -rewrite Rabs_pos_eq;[assumption | apply Rle_refl]. + intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r. + rewrite Rabs_pos_eq;[assumption | apply Rle_refl]. Qed. (** Uniform convergence *) @@ -365,8 +365,8 @@ Qed. Lemma CVU_cv : forall f g c d, CVU f g c d -> forall x, Boule c d x -> Un_cv (fun n => f n x) (g x). Proof. -intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn]. - exists N; intros n nN; rewrite Rdist_sym; apply Pn; assumption. + intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn]. + exists N; intros n nN; rewrite Rdist_sym; apply Pn; assumption. Qed. (* convergence is preserved through extensional equality *) @@ -374,8 +374,8 @@ Lemma CVU_ext_lim : forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) -> CVU f g2 c d. Proof. -intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn]. -exists N; intros; rewrite <- q; auto. + intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn]. + exists N; intros; rewrite <- q; auto. Qed. (* When a sequence of derivable functions converge pointwise towards @@ -389,223 +389,223 @@ Lemma CVU_derivable : (forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) -> forall x, Boule c d x -> derivable_pt_lim g x (g' x). Proof. -intros f f' g g' c d cvu cvp dff' x bx. -set (rho_ := - fun n y => - if Req_dec_T y x then - f' n x - else ((f n y - f n x)/ (y - x))). -set (rho := fun y => - if Req_dec_T y x then - g' x - else (g y - g x)/(y - x)). -assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z). { - intros n z bz. - destruct (Req_dec_T x z) as [xz | xnz]. - - rewrite <- xz. - intros eps' ep'. - destruct (dff' n x bx eps' ep') as [alp Pa]. - exists (pos alp);split;[apply cond_pos | ]. - intros z'; unfold rho_, D_x, dist, R_met; simpl; intros [[_ xnz'] dxz']. - destruct (Req_dec_T z' x) as [abs | _]. - { case xnz'; symmetry; exact abs. } - destruct (Req_dec_T x x) as [_ | abs];[ | case abs; reflexivity]. - pattern z' at 1; replace z' with (x + (z' - x)) by ring. - apply Pa;[intros h; case xnz'; - replace z' with (z' - x + x) by ring; rewrite h, Rplus_0_l; - reflexivity | exact dxz']. - - destruct (Ball_in_inter c c d d z bz bz) as [delta Pd]. - assert (dz : 0 < Rmin delta (Rabs (z - x))). { - now apply Rmin_glb_lt;[apply cond_pos - | apply Rabs_pos_lt; intros zx0; case xnz; - replace z with (z - x + x) by ring; rewrite zx0, Rplus_0_l]. - } - assert (t' : forall y : R, - Rdist y z < Rmin delta (Rabs (z - x)) -> - (fun z : R => (f n z - f n x) / (z - x)) y = rho_ n y). { - intros y dyz; unfold rho_; destruct (Req_dec_T y x) as [xy | xny]. - - rewrite xy in dyz. - destruct (Rle_dec delta (Rabs (z - x))). - + rewrite Rmin_left, Rdist_sym in dyz; unfold Rdist in dyz; lra. - + rewrite Rmin_right, Rdist_sym in dyz; unfold Rdist in dyz; - [case (Rlt_irrefl _ dyz) |apply Rlt_le, Rnot_le_gt; assumption]. - - reflexivity. - } - apply (continuity_pt_locally_ext (fun z => (f n z - f n x)/(z - x)) - (rho_ n) _ z dz t'); clear t'. - apply continuity_pt_div. - 1:apply continuity_pt_minus. - 1:apply derivable_continuous_pt; eapply exist; apply dff'; assumption. - 1:apply continuity_pt_const; intro; intro; reflexivity. - 1:apply continuity_pt_minus; - [apply derivable_continuous_pt; exists 1; apply derivable_pt_lim_id - | apply continuity_pt_const; intro; reflexivity]. - lra. -} -assert (CVU rho_ rho c d ). { - intros eps ep. - assert (ep8 : 0 < eps/8) by lra. - destruct (cvu _ ep8) as [N Pn1]. - assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat -> - forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4). { - intros n p nN pN z bz; replace (eps/4) with (eps/8 + eps/8) by field. - rewrite <- Rabs_Ropp. - replace (-(f' n z - f' p z)) with (g' z - f' n z - (g' z - f' p z)) by ring. - apply Rle_lt_trans with (1 := Rabs_triang _ _); rewrite Rabs_Ropp. - apply Rplus_lt_compat; apply Pn1; assumption. + intros f f' g g' c d cvu cvp dff' x bx. + set (rho_ := + fun n y => + if Req_dec_T y x then + f' n x + else ((f n y - f n x)/ (y - x))). + set (rho := fun y => + if Req_dec_T y x then + g' x + else (g y - g x)/(y - x)). + assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z). { + intros n z bz. + destruct (Req_dec_T x z) as [xz | xnz]. + - rewrite <- xz. + intros eps' ep'. + destruct (dff' n x bx eps' ep') as [alp Pa]. + exists (pos alp);split;[apply cond_pos | ]. + intros z'; unfold rho_, D_x, dist, R_met; simpl; intros [[_ xnz'] dxz']. + destruct (Req_dec_T z' x) as [abs | _]. + { case xnz'; symmetry; exact abs. } + destruct (Req_dec_T x x) as [_ | abs];[ | case abs; reflexivity]. + pattern z' at 1; replace z' with (x + (z' - x)) by ring. + apply Pa;[intros h; case xnz'; + replace z' with (z' - x + x) by ring; rewrite h, Rplus_0_l; + reflexivity | exact dxz']. + - destruct (Ball_in_inter c c d d z bz bz) as [delta Pd]. + assert (dz : 0 < Rmin delta (Rabs (z - x))). { + now apply Rmin_glb_lt;[apply cond_pos + | apply Rabs_pos_lt; intros zx0; case xnz; + replace z with (z - x + x) by ring; rewrite zx0, Rplus_0_l]. + } + assert (t' : forall y : R, + Rdist y z < Rmin delta (Rabs (z - x)) -> + (fun z : R => (f n z - f n x) / (z - x)) y = rho_ n y). { + intros y dyz; unfold rho_; destruct (Req_dec_T y x) as [xy | xny]. + - rewrite xy in dyz. + destruct (Rle_dec delta (Rabs (z - x))). + + rewrite Rmin_left, Rdist_sym in dyz; unfold Rdist in dyz; lra. + + rewrite Rmin_right, Rdist_sym in dyz; unfold Rdist in dyz; + [case (Rlt_irrefl _ dyz) |apply Rlt_le, Rnot_le_gt; assumption]. + - reflexivity. + } + apply (continuity_pt_locally_ext (fun z => (f n z - f n x)/(z - x)) + (rho_ n) _ z dz t'); clear t'. + apply continuity_pt_div. + 1:apply continuity_pt_minus. + 1:apply derivable_continuous_pt; eapply exist; apply dff'; assumption. + 1:apply continuity_pt_const; intro; intro; reflexivity. + 1:apply continuity_pt_minus; + [apply derivable_continuous_pt; exists 1; apply derivable_pt_lim_id + | apply continuity_pt_const; intro; reflexivity]. + lra. } - assert (step_2 : forall n p, (N <= n)%nat -> (N <= p)%nat -> - forall y, Boule c d y -> x <> y -> - Rabs ((f n y - f n x)/(y - x) - (f p y - f p x)/(y - x)) < eps/4). { - intros n p nN pN y b_y xny. - assert (mm0 : (Rmin x y = x /\ Rmax x y = y) \/ - (Rmin x y = y /\ Rmax x y = x)). { - destruct (Rle_dec x y) as [H | H]. - - rewrite Rmin_left, Rmax_right. - + left; split; reflexivity. - + assumption. - + assumption. - - rewrite Rmin_right, Rmax_left. - + right; split; reflexivity. - + apply Rlt_le, Rnot_le_gt; assumption. - + apply Rlt_le, Rnot_le_gt; assumption. - } - assert (mm : Rmin x y < Rmax x y). { - destruct mm0 as [[q1 q2] | [q1 q2]]; generalize (Rminmax x y); rewrite q1, q2. - - intros h; destruct h;[ assumption| contradiction]. - - intros h; destruct h as [h | h];[assumption | rewrite h in xny; case xny; reflexivity]. - } - assert (dm : forall z, Rmin x y <= z <= Rmax x y -> - derivable_pt_lim (fun x => f n x - f p x) z (f' n z - f' p z)). { - intros z intz; apply derivable_pt_lim_minus. - - apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y); - destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros; - try assumption. - - apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y); - destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros; - try assumption. + assert (CVU rho_ rho c d ). { + intros eps ep. + assert (ep8 : 0 < eps/8) by lra. + destruct (cvu _ ep8) as [N Pn1]. + assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat -> + forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4). { + intros n p nN pN z bz; replace (eps/4) with (eps/8 + eps/8) by field. + rewrite <- Rabs_Ropp. + replace (-(f' n z - f' p z)) with (g' z - f' n z - (g' z - f' p z)) by ring. + apply Rle_lt_trans with (1 := Rabs_triang _ _); rewrite Rabs_Ropp. + apply Rplus_lt_compat; apply Pn1; assumption. } + assert (step_2 : forall n p, (N <= n)%nat -> (N <= p)%nat -> + forall y, Boule c d y -> x <> y -> + Rabs ((f n y - f n x)/(y - x) - (f p y - f p x)/(y - x)) < eps/4). { + intros n p nN pN y b_y xny. + assert (mm0 : (Rmin x y = x /\ Rmax x y = y) \/ + (Rmin x y = y /\ Rmax x y = x)). { + destruct (Rle_dec x y) as [H | H]. + - rewrite Rmin_left, Rmax_right. + + left; split; reflexivity. + + assumption. + + assumption. + - rewrite Rmin_right, Rmax_left. + + right; split; reflexivity. + + apply Rlt_le, Rnot_le_gt; assumption. + + apply Rlt_le, Rnot_le_gt; assumption. + } + assert (mm : Rmin x y < Rmax x y). { + destruct mm0 as [[q1 q2] | [q1 q2]]; generalize (Rminmax x y); rewrite q1, q2. + - intros h; destruct h;[ assumption| contradiction]. + - intros h; destruct h as [h | h];[assumption | rewrite h in xny; case xny; reflexivity]. + } + assert (dm : forall z, Rmin x y <= z <= Rmax x y -> + derivable_pt_lim (fun x => f n x - f p x) z (f' n z - f' p z)). { + intros z intz; apply derivable_pt_lim_minus. + - apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y); + destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros; + try assumption. + - apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y); + destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros; + try assumption. + } - replace ((f n y - f n x) / (y - x) - (f p y - f p x) / (y - x)) - with (((f n y - f p y) - (f n x - f p x))/(y - x)) by - (field; intros yx0; case xny; replace y with (y - x + x) by ring; - rewrite yx0, Rplus_0_l; reflexivity). - destruct (MVT_cor2 (fun x => f n x - f p x) (fun x => f' n x - f' p x) - (Rmin x y) (Rmax x y) mm dm) as [z [Pz inz]]. - destruct mm0 as [[q1 q2] | [q1 q2]]. - - replace ((f n y - f p y - (f n x - f p x))/(y - x)) with - ((f n (Rmax x y) - f p (Rmax x y) - (f n (Rmin x y) - f p (Rmin x y))) - / (Rmax x y - Rmin x y)) by (rewrite q1, q2; reflexivity). - unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r. - + apply cauchy1; auto. - apply Boule_convex with (Rmin x y) (Rmax x y); - revert inz; rewrite ?q1, ?q2; intros; - try assumption. - split; apply Rlt_le; tauto. - + rewrite q1, q2; apply Rminus_eq_contra, not_eq_sym; assumption. - - replace ((f n y - f p y - (f n x - f p x))/(y - x)) with - ((f n (Rmax x y) - f p (Rmax x y) - (f n (Rmin x y) - f p (Rmin x y)))/ - (Rmax x y - Rmin x y)). - + unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r. - * apply cauchy1; auto. + replace ((f n y - f n x) / (y - x) - (f p y - f p x) / (y - x)) + with (((f n y - f p y) - (f n x - f p x))/(y - x)) by + (field; intros yx0; case xny; replace y with (y - x + x) by ring; + rewrite yx0, Rplus_0_l; reflexivity). + destruct (MVT_cor2 (fun x => f n x - f p x) (fun x => f' n x - f' p x) + (Rmin x y) (Rmax x y) mm dm) as [z [Pz inz]]. + destruct mm0 as [[q1 q2] | [q1 q2]]. + - replace ((f n y - f p y - (f n x - f p x))/(y - x)) with + ((f n (Rmax x y) - f p (Rmax x y) - (f n (Rmin x y) - f p (Rmin x y))) + / (Rmax x y - Rmin x y)) by (rewrite q1, q2; reflexivity). + unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r. + + apply cauchy1; auto. apply Boule_convex with (Rmin x y) (Rmax x y); revert inz; rewrite ?q1, ?q2; intros; - try assumption; split; apply Rlt_le; tauto. - * rewrite q1, q2; apply Rminus_eq_contra; assumption. - + rewrite q1, q2; field; split; - apply Rminus_eq_contra;[apply not_eq_sym |]; assumption. - } - assert (unif_ac : - forall n p, (N <= n)%nat -> (N <= p)%nat -> - forall y, Boule c d y -> - Rabs (rho_ n y - rho_ p y) <= eps/2). { - intros n p nN pN y b_y. - destruct (Req_dec_T x y) as [xy | xny]. - - destruct (Ball_in_inter c c d d x bx bx) as [delta Pdelta]. - destruct (ctrho n y b_y _ ep8) as [d' [dp Pd]]. - destruct (ctrho p y b_y _ ep8) as [d2 [dp2 Pd2]]. - assert (mmpos : 0 < (Rmin (Rmin d' d2) delta)/2). { - apply Rmult_lt_0_compat; repeat apply Rmin_glb_lt; try assumption. - { apply cond_pos. } - apply Rinv_0_lt_compat, Rlt_0_2. } - apply Rle_trans with (1 := Rdist_tri _ _ (rho_ n (y + Rmin (Rmin d' d2) delta/2))). - replace (eps/2) with (eps/8 + (eps/4 + eps/8)) by field. - apply Rplus_le_compat. - + rewrite Rdist_sym; apply Rlt_le, Pd;split;[split;[exact I | ] | ]. - * symmetry; apply Rminus_not_eq; rewrite Rplus_comm; unfold Rminus; - rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r; apply Rgt_not_eq; assumption. - * simpl; unfold Rdist. - unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. - rewrite Rabs_pos_eq;[ |apply Rlt_le; assumption ]. - apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[lra | ]. - apply Rle_trans with (Rmin d' d2); apply Rmin_l. - + apply Rle_trans with (1 := Rdist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))). + try assumption. + split; apply Rlt_le; tauto. + + rewrite q1, q2; apply Rminus_eq_contra, not_eq_sym; assumption. + - replace ((f n y - f p y - (f n x - f p x))/(y - x)) with + ((f n (Rmax x y) - f p (Rmax x y) - (f n (Rmin x y) - f p (Rmin x y)))/ + (Rmax x y - Rmin x y)). + + unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r. + * apply cauchy1; auto. + apply Boule_convex with (Rmin x y) (Rmax x y); + revert inz; rewrite ?q1, ?q2; intros; + try assumption; split; apply Rlt_le; tauto. + * rewrite q1, q2; apply Rminus_eq_contra; assumption. + + rewrite q1, q2; field; split; + apply Rminus_eq_contra;[apply not_eq_sym |]; assumption. + } + assert (unif_ac : + forall n p, (N <= n)%nat -> (N <= p)%nat -> + forall y, Boule c d y -> + Rabs (rho_ n y - rho_ p y) <= eps/2). { + intros n p nN pN y b_y. + destruct (Req_dec_T x y) as [xy | xny]. + - destruct (Ball_in_inter c c d d x bx bx) as [delta Pdelta]. + destruct (ctrho n y b_y _ ep8) as [d' [dp Pd]]. + destruct (ctrho p y b_y _ ep8) as [d2 [dp2 Pd2]]. + assert (mmpos : 0 < (Rmin (Rmin d' d2) delta)/2). { + apply Rmult_lt_0_compat; repeat apply Rmin_glb_lt; try assumption. + { apply cond_pos. } + apply Rinv_0_lt_compat, Rlt_0_2. } + apply Rle_trans with (1 := Rdist_tri _ _ (rho_ n (y + Rmin (Rmin d' d2) delta/2))). + replace (eps/2) with (eps/8 + (eps/4 + eps/8)) by field. apply Rplus_le_compat. - * apply Rlt_le. - replace (rho_ n (y + Rmin (Rmin d' d2) delta / 2)) with - ((f n (y + Rmin (Rmin d' d2) delta / 2) - f n x)/ - ((y + Rmin (Rmin d' d2) delta / 2) - x)). - 1:replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with - ((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/ - ((y + Rmin (Rmin d' d2) delta / 2) - x)). - 2,3:unfold rho_; - destruct (Req_dec_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx]; - [case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); lra - |reflexivity]. - apply step_2; auto; try lra. - assert (0 < pos delta) by (apply cond_pos). - apply Boule_convex with y (y + delta/2). - -- assumption. - -- destruct (Pdelta (y + delta/2)); auto. - rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try lra; auto. - -- split; try lra. - apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r]. - now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2. + + rewrite Rdist_sym; apply Rlt_le, Pd;split;[split;[exact I | ] | ]. + * symmetry; apply Rminus_not_eq; rewrite Rplus_comm; unfold Rminus; + rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r; apply Rgt_not_eq; assumption. + * simpl; unfold Rdist. + unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. + rewrite Rabs_pos_eq;[ |apply Rlt_le; assumption ]. + apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[lra | ]. + apply Rle_trans with (Rmin d' d2); apply Rmin_l. + + apply Rle_trans with (1 := Rdist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))). + apply Rplus_le_compat. + * apply Rlt_le. + replace (rho_ n (y + Rmin (Rmin d' d2) delta / 2)) with + ((f n (y + Rmin (Rmin d' d2) delta / 2) - f n x)/ + ((y + Rmin (Rmin d' d2) delta / 2) - x)). + 1:replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with + ((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/ + ((y + Rmin (Rmin d' d2) delta / 2) - x)). + 2,3:unfold rho_; + destruct (Req_dec_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx]; + [case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); lra + |reflexivity]. + apply step_2; auto; try lra. + assert (0 < pos delta) by (apply cond_pos). + apply Boule_convex with y (y + delta/2). + -- assumption. + -- destruct (Pdelta (y + delta/2)); auto. + rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try lra; auto. + -- split; try lra. + apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r]. + now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2. - * apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; lra] | ]. - simpl; unfold Rdist. - unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. - rewrite Rabs_pos_eq;[ | lra]. - apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [lra |]. - apply Rle_trans with (Rmin d' d2). - -- solve[apply Rmin_l]. - -- solve[apply Rmin_r]. - - apply Rlt_le, Rlt_le_trans with (eps/4);[ | lra]. - unfold rho_; destruct (Req_dec_T y x); solve[auto]. - } - assert (unif_ac' : forall p, (N <= p)%nat -> - forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps). { - assert (cvrho : forall y, Boule c d y -> Un_cv (fun n => rho_ n y) (rho y)). { - intros y b_y; unfold rho_, rho; destruct (Req_dec_T y x). - - intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2]. - exists N2; intros n nN2; rewrite Rdist_sym; apply Pn2; assumption. - - apply CV_mult. - + apply CV_minus. - * apply cvp; assumption. - * apply cvp; assumption. - + intros eps' ep'; simpl; exists 0%nat; intros; rewrite Rdist_eq; assumption. + * apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; lra] | ]. + simpl; unfold Rdist. + unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. + rewrite Rabs_pos_eq;[ | lra]. + apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [lra |]. + apply Rle_trans with (Rmin d' d2). + -- solve[apply Rmin_l]. + -- solve[apply Rmin_r]. + - apply Rlt_le, Rlt_le_trans with (eps/4);[ | lra]. + unfold rho_; destruct (Req_dec_T y x); solve[auto]. } - intros p pN y b_y. - replace eps with (eps/2 + eps/2) by field. - assert (ep2 : 0 < eps/2) by lra. - destruct (cvrho y b_y _ ep2) as [N2 Pn2]. - apply Rle_lt_trans with (1 := Rdist_tri _ _ (rho_ (max N N2) y)). - apply Rplus_lt_le_compat. - - solve[rewrite Rdist_sym; apply Pn2, Nat.le_max_r]. - - apply unif_ac; auto; solve [apply Nat.le_max_l]. + assert (unif_ac' : forall p, (N <= p)%nat -> + forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps). { + assert (cvrho : forall y, Boule c d y -> Un_cv (fun n => rho_ n y) (rho y)). { + intros y b_y; unfold rho_, rho; destruct (Req_dec_T y x). + - intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2]. + exists N2; intros n nN2; rewrite Rdist_sym; apply Pn2; assumption. + - apply CV_mult. + + apply CV_minus. + * apply cvp; assumption. + * apply cvp; assumption. + + intros eps' ep'; simpl; exists 0%nat; intros; rewrite Rdist_eq; assumption. + } + intros p pN y b_y. + replace eps with (eps/2 + eps/2) by field. + assert (ep2 : 0 < eps/2) by lra. + destruct (cvrho y b_y _ ep2) as [N2 Pn2]. + apply Rle_lt_trans with (1 := Rdist_tri _ _ (rho_ (max N N2) y)). + apply Rplus_lt_le_compat. + - solve[rewrite Rdist_sym; apply Pn2, Nat.le_max_r]. + - apply unif_ac; auto; solve [apply Nat.le_max_l]. + } + exists N; intros; apply unif_ac'; solve[auto]. } - exists N; intros; apply unif_ac'; solve[auto]. -} -intros eps ep. -destruct (CVU_continuity _ _ _ _ H ctrho x bx eps ep) as [delta [dp Pd]]. -exists (mkposreal _ dp); intros h hn0 dh. -replace ((g (x + h) - g x) / h) with (rho (x + h)). -- replace (g' x) with (rho x). - + apply Pd; unfold D_x, no_cond;split;[split;[solve[auto] | ] | ]. - * intros xxh; case hn0; replace h with (x + h - x) by ring; rewrite <- xxh; ring. - * simpl; unfold Rdist; replace (x + h - x) with h by ring; exact dh. - + unfold rho; destruct (Req_dec_T x x) as [ _ | abs];[ | case abs]; reflexivity. -- unfold rho; destruct (Req_dec_T (x + h) x) as [abs | _];[ | ]. - + case hn0; replace h with (x + h - x) by ring; rewrite abs; ring. - + replace (x + h - x) with h by ring; reflexivity. + intros eps ep. + destruct (CVU_continuity _ _ _ _ H ctrho x bx eps ep) as [delta [dp Pd]]. + exists (mkposreal _ dp); intros h hn0 dh. + replace ((g (x + h) - g x) / h) with (rho (x + h)). + - replace (g' x) with (rho x). + + apply Pd; unfold D_x, no_cond;split;[split;[solve[auto] | ] | ]. + * intros xxh; case hn0; replace h with (x + h - x) by ring; rewrite <- xxh; ring. + * simpl; unfold Rdist; replace (x + h - x) with h by ring; exact dh. + + unfold rho; destruct (Req_dec_T x x) as [ _ | abs];[ | case abs]; reflexivity. + - unfold rho; destruct (Req_dec_T (x + h) x) as [abs | _];[ | ]. + + case hn0; replace h with (x + h - x) by ring; rewrite abs; ring. + + replace (x + h - x) with h by ring; reflexivity. Qed. diff --git a/theories/Reals/Qreals.v b/theories/Reals/Qreals.v index af6d7ac325..e947474499 100644 --- a/theories/Reals/Qreals.v +++ b/theories/Reals/Qreals.v @@ -15,8 +15,8 @@ From Stdlib Require Export QArith_base. Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R. Proof. -intros. -now apply not_O_IZR. + intros. + now apply not_O_IZR. Qed. #[global] @@ -24,160 +24,160 @@ Hint Resolve IZR_nz Rmult_integral_contrapositive : core. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. Proof. -unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -apply eq_IZR. -do 2 rewrite mult_IZR. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R). -- rewrite <- H; field; auto. -- rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto. + unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; + intros. + apply eq_IZR. + do 2 rewrite mult_IZR. + set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); + set (X2 := IZR (Zpos x2)) in *. + set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); + set (Y2 := IZR (Zpos y2)) in *. + assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R). + - rewrite <- H; field; auto. + - rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto. Qed. Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y. Proof. -unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert ((X1 * Y2)%R = (Y1 * X2)%R). -- unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - f_equal; auto. -- clear H. - field_simplify_eq; auto. - rewrite H0; ring. + unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; + intros. + set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); + set (X2 := IZR (Zpos x2)) in *. + set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); + set (Y2 := IZR (Zpos y2)) in *. + assert ((X1 * Y2)%R = (Y1 * X2)%R). + - unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. + f_equal; auto. + - clear H. + field_simplify_eq; auto. + rewrite H0; ring. Qed. Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y. Proof. -unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -apply le_IZR. -do 2 rewrite mult_IZR. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto). -replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto). -apply Rmult_le_compat_r; auto. -apply Rmult_le_pos. -- now apply IZR_le. -- now apply IZR_le. + unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; + intros. + apply le_IZR. + do 2 rewrite mult_IZR. + set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); + set (X2 := IZR (Zpos x2)) in *. + set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); + set (Y2 := IZR (Zpos y2)) in *. + replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto). + replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto). + apply Rmult_le_compat_r; auto. + apply Rmult_le_pos. + - now apply IZR_le. + - now apply IZR_le. Qed. Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R. Proof. -unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert (X1 * Y2 <= Y1 * X2)%R. -- unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - apply IZR_le; auto. -- clear H. - replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). - replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). - apply Rmult_le_compat_r; auto. - apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat. - + now apply IZR_lt. - + now apply IZR_lt. + unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; + intros. + set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); + set (X2 := IZR (Zpos x2)) in *. + set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); + set (Y2 := IZR (Zpos y2)) in *. + assert (X1 * Y2 <= Y1 * X2)%R. + - unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. + apply IZR_le; auto. + - clear H. + replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). + replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). + apply Rmult_le_compat_r; auto. + apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat. + + now apply IZR_lt. + + now apply IZR_lt. Qed. Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x (Q2R x < Q2R y)%R. Proof. -unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert (X1 * Y2 < Y1 * X2)%R. -- unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - apply IZR_lt; auto. -- clear H. - replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). - replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). - apply Rmult_lt_compat_r; auto. - apply Rmult_lt_0_compat; apply Rinv_0_lt_compat. - + now apply IZR_lt. - + now apply IZR_lt. + unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; + intros. + set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); + set (X2 := IZR (Zpos x2)) in *. + set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); + set (Y2 := IZR (Zpos y2)) in *. + assert (X1 * Y2 < Y1 * X2)%R. + - unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. + apply IZR_lt; auto. + - clear H. + replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). + replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). + apply Rmult_lt_compat_r; auto. + apply Rmult_lt_0_compat; apply Rinv_0_lt_compat. + + now apply IZR_lt. + + now apply IZR_lt. Qed. Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R. Proof. -unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2); - unfold Qden, Qnum. -simpl_mult. -rewrite plus_IZR. -do 3 rewrite mult_IZR. -field; auto. + unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2); + unfold Qden, Qnum. + simpl_mult. + rewrite plus_IZR. + do 3 rewrite mult_IZR. + field; auto. Qed. Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R. Proof. -unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2); - unfold Qden, Qnum. -simpl_mult. -do 2 rewrite mult_IZR. -field; auto. + unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2); + unfold Qden, Qnum. + simpl_mult. + do 2 rewrite mult_IZR. + field; auto. Qed. Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R. Proof. -unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum. -rewrite Ropp_Ropp_IZR. -field; auto. + unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum. + rewrite Ropp_Ropp_IZR. + field; auto. Qed. Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R. Proof. -unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto. + unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto. Qed. Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R. Proof. -unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. -- simpl; intros; elim H; trivial. -- intros; field; auto. -- intros; - change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R; - change (IZR (Zneg p)) with (- IZR (Zpos p))%R; - simpl; field; (*auto 8 with real.*) - repeat split; auto; auto with real. + unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. + - simpl; intros; elim H; trivial. + - intros; field; auto. + - intros; + change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R; + change (IZR (Zneg p)) with (- IZR (Zpos p))%R; + simpl; field; (*auto 8 with real.*) + repeat split; auto; auto with real. Qed. Lemma Q2R_div : forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R. Proof. -unfold Qdiv, Rdiv. -intros; rewrite Q2R_mult. -rewrite Q2R_inv; auto. + unfold Qdiv, Rdiv. + intros; rewrite Q2R_mult. + rewrite Q2R_inv; auto. Qed. #[global] Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 7a195294f6..6429b42851 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -954,11 +954,11 @@ Hint Resolve Rinv_neq_0_compat: real. Lemma Rinv_inv r : / / r = r. Proof. -destruct (Req_dec r 0) as [-> | H]. -- now rewrite Rinv_0, Rinv_0. -- symmetry; apply Rmult_inv_r_uniq. - * now apply Rinv_neq_0_compat. - * now rewrite Rinv_l. + destruct (Req_dec r 0) as [-> | H]. + - now rewrite Rinv_0, Rinv_0. + - symmetry; apply Rmult_inv_r_uniq. + * now apply Rinv_neq_0_compat. + * now rewrite Rinv_l. Qed. #[global] Hint Resolve Rinv_inv: real. @@ -968,14 +968,14 @@ Proof. now intros r1 r2 H%Rinv_eq_compat; rewrite !Rinv_inv in H. Qed. Lemma Rinv_mult r1 r2 : / (r1 * r2) = / r1 * / r2. Proof. -destruct (Req_dec r1 0) as [-> | H1]. -- now rewrite Rinv_0, 2!Rmult_0_l, Rinv_0. -- destruct (Req_dec r2 0) as [-> | H2]. - + now rewrite Rinv_0, 2!Rmult_0_r, Rinv_0. - + symmetry; apply Rmult_inv_r_uniq. - { now apply Rmult_integral_contrapositive_currified. } - rewrite (Rmult_comm r1), Rmult_assoc, <-(Rmult_assoc r1). - now rewrite Rinv_r, Rmult_1_l, Rinv_r. + destruct (Req_dec r1 0) as [-> | H1]. + - now rewrite Rinv_0, 2!Rmult_0_l, Rinv_0. + - destruct (Req_dec r2 0) as [-> | H2]. + + now rewrite Rinv_0, 2!Rmult_0_r, Rinv_0. + + symmetry; apply Rmult_inv_r_uniq. + { now apply Rmult_integral_contrapositive_currified. } + rewrite (Rmult_comm r1), Rmult_assoc, <-(Rmult_assoc r1). + now rewrite Rinv_r, Rmult_1_l, Rinv_r. Qed. Lemma Rinv_opp r : / - r = - / r. diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v index 1f67418426..7fa783178e 100644 --- a/theories/Reals/ROrderedType.v +++ b/theories/Reals/ROrderedType.v @@ -23,15 +23,15 @@ Qed. Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false. Lemma Reqb_eq : forall r1 r2, Reqb r1 r2 = true <-> r1=r2. Proof. - intros; unfold Reqb; destruct Req_dec as [EQ|NEQ]; auto with *. - split; try discriminate. intro EQ; elim NEQ; auto. + intros; unfold Reqb; destruct Req_dec as [EQ|NEQ]; auto with *. + split; try discriminate. intro EQ; elim NEQ; auto. Qed. Module R_as_UBE <: UsualBoolEq. - Definition t := R. - Definition eq := @eq R. - Definition eqb := Reqb. - Definition eqb_eq := Reqb_eq. + Definition t := R. + Definition eq := @eq R. + Definition eqb := Reqb. + Definition eqb_eq := Reqb_eq. End R_as_UBE. Module R_as_DT <: UsualDecidableTypeFull := Make_UDTF R_as_UBE. @@ -59,28 +59,28 @@ Definition Rcompare x y := Lemma Rcompare_spec : forall x y, CompareSpec (x=y) (xLogic.eq==>iff) Rlt. - Proof. repeat red; intros; subst; auto. Qed. + #[global] + Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Rlt. + Proof. repeat red; intros; subst; auto. Qed. - Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y. - Proof. unfold Rle; auto with *. Qed. + Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y. + Proof. unfold Rle; auto with *. Qed. - Definition compare_spec := Rcompare_spec. + Definition compare_spec := Rcompare_spec. End R_as_OT. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 26feba8286..306a1f1d05 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -97,7 +97,8 @@ Proof. Qed. Lemma sqrt_pow2 : forall x, 0 <= x -> sqrt (x ^ 2) = x. -intros; simpl; rewrite Rmult_1_r, sqrt_square; auto. +Proof. + intros; simpl; rewrite Rmult_1_r, sqrt_square; auto. Qed. Lemma pow2_sqrt x : 0 <= x -> sqrt x ^ 2 = x. @@ -159,19 +160,21 @@ Proof. Qed. Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -- apply Rmult_lt_compat_l; auto with real. -- ring. +Proof. + intros x y H H0; try assumption. + replace 0 with (x * 0). + - apply Rmult_lt_compat_l; auto with real. + - ring. Qed. Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -- red; left. - apply Rlt_mult_inv_pos; auto with real. -- rewrite <- H1. - red; right; ring. +Proof. + intros x y H H0; try assumption. + case H; intros. + - red; left. + apply Rlt_mult_inv_pos; auto with real. + - rewrite <- H1. + red; right; ring. Qed. Lemma sqrt_div_alt : @@ -338,29 +341,29 @@ Qed. Lemma sqrt_inv x : sqrt (/ x) = / sqrt x. Proof. -destruct (Rlt_or_le 0 x) as [H|H]. -- assert (sqrt x <> 0). - + apply Rgt_not_eq. - now apply sqrt_lt_R0. - + apply Rmult_eq_reg_r with (sqrt x); auto. - rewrite Rinv_l; auto. - rewrite <- sqrt_mult_alt. - * now rewrite -> Rinv_l, sqrt_1; auto with real. - * apply Rlt_le. - now apply Rinv_0_lt_compat. -- rewrite sqrt_neg_0 with (1 := H). - rewrite sqrt_neg_0. - + apply eq_sym, Rinv_0. - + destruct H as [H| ->]. - * now apply Rlt_le, Rinv_lt_0_compat. - * rewrite Rinv_0. - apply Rle_refl. + destruct (Rlt_or_le 0 x) as [H|H]. + - assert (sqrt x <> 0). + + apply Rgt_not_eq. + now apply sqrt_lt_R0. + + apply Rmult_eq_reg_r with (sqrt x); auto. + rewrite Rinv_l; auto. + rewrite <- sqrt_mult_alt. + * now rewrite -> Rinv_l, sqrt_1; auto with real. + * apply Rlt_le. + now apply Rinv_0_lt_compat. + - rewrite sqrt_neg_0 with (1 := H). + rewrite sqrt_neg_0. + + apply eq_sym, Rinv_0. + + destruct H as [H| ->]. + * now apply Rlt_le, Rinv_lt_0_compat. + * rewrite Rinv_0. + apply Rle_refl. Qed. Lemma inv_sqrt_depr x : 0 < x -> / sqrt x = sqrt (/ x). Proof. -intros _. -apply eq_sym, sqrt_inv. + intros _. + apply eq_sym, sqrt_inv. Qed. #[deprecated(since="8.16",note="Use sqrt_inv.")] diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 43145433a8..420d688c84 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -85,17 +85,18 @@ Arguments continuity f%_F. Lemma continuity_pt_locally_ext : forall f g a x, 0 < a -> (forall y, Rdist y x < a -> f y = g y) -> continuity_pt f x -> continuity_pt g x. -intros f g a x a0 q cf eps ep. -destruct (cf eps ep) as [a' [a'p Pa']]. -exists (Rmin a a'); split. -- unfold Rmin; destruct (Rle_dec a a'). - + assumption. - + assumption. -- intros y cy; rewrite <- !q. - + apply Pa'. - split;[| apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_r]];tauto. - + rewrite Rdist_eq; assumption. - + apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto. +Proof. + intros f g a x a0 q cf eps ep. + destruct (cf eps ep) as [a' [a'p Pa']]. + exists (Rmin a a'); split. + - unfold Rmin; destruct (Rle_dec a a'). + + assumption. + + assumption. + - intros y cy; rewrite <- !q. + + apply Pa'. + split;[| apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_r]];tauto. + + rewrite Rdist_eq; assumption. + + apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto. Qed. @@ -503,8 +504,9 @@ Qed. Lemma derivable_pt_lim_ext : forall f g x l, (forall z, f z = g z) -> derivable_pt_lim f x l -> derivable_pt_lim g x l. -intros f g x l fg df e ep; destruct (df e ep) as [d pd]; exists d; intros h; -rewrite <- !fg; apply pd. +Proof. + intros f g x l fg df e ep; destruct (df e ep) as [d pd]; exists d; intros h; + rewrite <- !fg; apply pd. Qed. (* extensionally equal functions have the same derivative, locally. *) @@ -513,31 +515,32 @@ Lemma derivable_pt_lim_locally_ext : forall f g x a b l, a < x < b -> (forall z, a < z < b -> f z = g z) -> derivable_pt_lim f x l -> derivable_pt_lim g x l. -intros f g x a b l axb fg df e ep. -destruct (df e ep) as [d pd]. -assert (d'h : 0 < Rmin d (Rmin (b - x) (x - a))). -- apply Rmin_pos;[apply cond_pos | apply Rmin_pos; apply Rlt_0_minus; tauto]. -- exists (mkposreal _ d'h); simpl; intros h hn0 cmp. - rewrite <- !fg;[ |assumption | ]. - + apply pd;[assumption |]. - apply Rlt_le_trans with (1 := cmp), Rmin_l. - + assert (-h < x - a). - * apply Rle_lt_trans with (1 := Rle_abs _). - rewrite Rabs_Ropp; apply Rlt_le_trans with (1 := cmp). - rewrite Rmin_assoc; apply Rmin_r. - * assert (h < b - x). - -- apply Rle_lt_trans with (1 := Rle_abs _). - apply Rlt_le_trans with (1 := cmp). - rewrite Rmin_comm, <- Rmin_assoc; apply Rmin_l. - -- split. - ++ apply (Rplus_lt_reg_l (- h)). - replace ((-h) + (x + h)) with x by ring. - apply (Rplus_lt_reg_r (- a)). - replace (((-h) + a) + - a) with (-h) by ring. - assumption. - ++ apply (Rplus_lt_reg_r (- x)). - replace (x + h + - x) with h by ring. - assumption. +Proof. + intros f g x a b l axb fg df e ep. + destruct (df e ep) as [d pd]. + assert (d'h : 0 < Rmin d (Rmin (b - x) (x - a))). + - apply Rmin_pos;[apply cond_pos | apply Rmin_pos; apply Rlt_0_minus; tauto]. + - exists (mkposreal _ d'h); simpl; intros h hn0 cmp. + rewrite <- !fg;[ |assumption | ]. + + apply pd;[assumption |]. + apply Rlt_le_trans with (1 := cmp), Rmin_l. + + assert (-h < x - a). + * apply Rle_lt_trans with (1 := Rle_abs _). + rewrite Rabs_Ropp; apply Rlt_le_trans with (1 := cmp). + rewrite Rmin_assoc; apply Rmin_r. + * assert (h < b - x). + -- apply Rle_lt_trans with (1 := Rle_abs _). + apply Rlt_le_trans with (1 := cmp). + rewrite Rmin_comm, <- Rmin_assoc; apply Rmin_l. + -- split. + ++ apply (Rplus_lt_reg_l (- h)). + replace ((-h) + (x + h)) with x by ring. + apply (Rplus_lt_reg_r (- a)). + replace (((-h) + a) + - a) with (-h) by ring. + assumption. + ++ apply (Rplus_lt_reg_r (- x)). + replace (x + h + - x) with h by ring. + assumption. Qed. @@ -701,6 +704,7 @@ Lemma derivable_pt_lim_plus : forall f1 f2 (x l1 l2:R), derivable_pt_lim f1 x l1 -> derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 + f2) x (l1 + l2). +Proof. intros. apply uniqueness_step3. assert (H1 := uniqueness_step2 _ _ _ H). @@ -801,19 +805,21 @@ Qed. Lemma derivable_pt_lim_div_scal : forall f x l a, derivable_pt_lim f x l -> derivable_pt_lim (fun y => f y / a) x (l / a). -intros f x l a df; - apply (derivable_pt_lim_ext (fun y => /a * f y)). -- intros z; rewrite Rmult_comm; reflexivity. -- unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. +Proof. + intros f x l a df; + apply (derivable_pt_lim_ext (fun y => /a * f y)). + - intros z; rewrite Rmult_comm; reflexivity. + - unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. Qed. Lemma derivable_pt_lim_scal_right : forall f x l a, derivable_pt_lim f x l -> derivable_pt_lim (fun y => f y * a) x (l * a). -intros f x l a df; - apply (derivable_pt_lim_ext (fun y => a * f y)). -- intros z; rewrite Rmult_comm; reflexivity. -- unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. +Proof. + intros f x l a df; + apply (derivable_pt_lim_ext (fun y => a * f y)). + - intros z; rewrite Rmult_comm; reflexivity. + - unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. Qed. Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x). diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 38e2525a10..366452ea6d 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -23,652 +23,652 @@ Theorem derivable_pt_lim_div : f2 x <> 0 -> derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)). Proof. - intros f1 f2 x l1 l2 H H0 H1. - cut (derivable_pt f2 x); - [ intro X | unfold derivable_pt; exists l2; exact H0 ]. - assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1). - elim H2; clear H2; intros eps_f2 H2. - unfold div_fct. - assert (H3 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3; - unfold limit_in in H3; unfold dist in H3. - simpl in H3; unfold Rdist in H3. - elim (H3 (Rabs (f2 x) / 2)); - [ idtac - | unfold Rdiv; change (0 < Rabs (f2 x) * / 2); - apply Rmult_lt_0_compat; - [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - clear H3; intros alp_f2 H3. - assert - (H4:forall x0:R, - Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2). { + intros f1 f2 x l1 l2 H H0 H1. + cut (derivable_pt f2 x); + [ intro X | unfold derivable_pt; exists l2; exact H0 ]. + assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1). + elim H2; clear H2; intros eps_f2 H2. + unfold div_fct. + assert (H3 := derivable_continuous_pt _ _ X). + unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3; + unfold limit_in in H3; unfold dist in H3. + simpl in H3; unfold Rdist in H3. + elim (H3 (Rabs (f2 x) / 2)); + [ idtac + | unfold Rdiv; change (0 < Rabs (f2 x) * / 2); + apply Rmult_lt_0_compat; + [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. + clear H3; intros alp_f2 H3. + assert + (H4:forall x0:R, + Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2). { + intros. + case (Req_dec x x0); intro. + + rewrite <- H5; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; + unfold Rdiv; apply Rmult_lt_0_compat; + [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ]. + + elim H3; intros. + apply H7. + split. + * unfold D_x, no_cond; split. + -- trivial. + -- assumption. + * assumption. + } + assert (H5:forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)). { + intros. + assert (H6 := H4 a H5). + rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6. + rewrite Ropp_minus_distr in H6. + assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6). + apply Rplus_lt_reg_l with (- Rabs (f2 a) + Rabs (f2 x) / 2). + rewrite Rplus_assoc. + rewrite Rplus_half_diag. + do 2 rewrite (Rplus_comm (- Rabs (f2 a))). + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r. + unfold Rminus in H7; assumption. + } + assert + (Maj:forall a:R, + Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)). { + intros. + unfold Rdiv. + apply Rmult_lt_reg_l with (Rabs (f2 (x + a))). + - apply Rabs_pos_lt; apply H2. + apply Rlt_le_trans with (Rmin eps_f2 alp_f2). + + assumption. + + apply Rmin_l. + - rewrite Rinv_r. + + apply Rmult_lt_reg_l with (Rabs (f2 x)). + { apply Rabs_pos_lt; assumption. } + rewrite Rmult_1_r. + rewrite (Rmult_comm (Rabs (f2 x))). + repeat rewrite Rmult_assoc. + rewrite Rinv_l. + 2:{ apply Rabs_no_R0; assumption. } + rewrite Rmult_1_r. + apply Rmult_lt_reg_l with (/ 2). + { apply Rinv_0_lt_compat; prove_sup0. } + repeat rewrite (Rmult_comm (/ 2)). + repeat rewrite Rmult_assoc. + rewrite Rinv_r. + 2:{ discrR. } + rewrite Rmult_1_r. + unfold Rdiv in H5; apply H5. + replace (x + a - x) with a by ring. + assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption. + + apply Rabs_no_R0; apply H2. + assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption. + } + unfold derivable_pt_lim; intros. + elim (H (Rabs (eps * f2 x / 8))); + [ idtac + | unfold Rdiv; change (0 < Rabs (eps * f2 x * / 8)); + apply Rabs_pos_lt; repeat apply prod_neq_R0; + [ red; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6) + | assumption + | apply Rinv_neq_0_compat; discrR ] ]. + intros alp_f1d H7. + case (Req_dec (f1 x) 0); intro. + 1:case (Req_dec l1 0); intro. + 3:case (Req_dec l1 0); intro. + 3:case (Req_dec l2 0); intro. + 5:case (Req_dec l2 0); intro. + (***********************************) + (* First case *) + (* (f1 x)=0 l1 =0 *) + (***********************************) + - cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d)); + [ intro + | repeat apply Rmin_pos; + [ apply (cond_pos eps_f2) + | elim H3; intros; assumption + | apply (cond_pos alp_f1d) ] ]. + exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10). + simpl; intros. + assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)). + assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)). + assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)). + assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)). + assert (H17 := H7 _ H11 H15). + rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ]. + apply Rle_lt_trans with + (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + + Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + + Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + + Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). + { unfold Rminus. + rewrite <- + (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). + apply Rabs_4. } + repeat rewrite Rabs_mult. + replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. + cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); + try assumption || apply H2. + - apply H14. + - apply Rmin_2; assumption. } + cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). + 2:{ rewrite H9. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + cut + (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < + eps / 4). + 2:{ rewrite H8. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + cut + (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < + eps / 4). + 2:{ rewrite H8. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + intros. lra. + (***********************************) + (* Second case *) + (* (f1 x)=0 l1<>0 *) + (***********************************) + - assert (H10 := derivable_continuous_pt _ _ X). + unfold continuity_pt in H10. + unfold continue_in in H10. + unfold limit1_in in H10. + unfold limit_in in H10. + unfold dist in H10. + simpl in H10. + unfold Rdist in H10. + elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). + 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))). + apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; + repeat apply prod_neq_R0. + - lra. + - assumption. + - assumption. + - apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. } + clear H10; intros alp_f2t2 H10. + assert + (H11:forall a:R, + Rabs a < alp_f2t2 -> + Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). { + intros. + elim H10; intros. + case (Req_dec a 0); intro. + - rewrite H14; rewrite Rplus_0_r. + unfold Rminus; rewrite Rplus_opp_r. + rewrite Rabs_R0. + apply Rabs_pos_lt. + unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc. + repeat apply prod_neq_R0; try assumption. + + now apply Rgt_not_eq. + + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. + - apply H13. + split. + + apply D_x_no_cond; assumption. + + replace (x + a - x) with a; [ assumption | ring ]. + } + assert (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)). { + repeat apply Rmin_pos. + - apply (cond_pos eps_f2). + - apply (cond_pos alp_f1d). + - elim H3; intros; assumption. + - elim H10; intros; assumption. + } + exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12). + simpl. intros. - case (Req_dec x x0); intro. - + rewrite <- H5; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - unfold Rdiv; apply Rmult_lt_0_compat; - [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ]. - + elim H3; intros. - apply H7. - split. - * unfold D_x, no_cond; split. - -- trivial. - -- assumption. - * assumption. - } - assert (H5:forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)). { + assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)). + assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)). + assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). + assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). + assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). + assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). + clear H14 H15 H16. + rewrite formule; try assumption. + 2:{ apply H2; assumption. } + apply Rle_lt_trans with + (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + + Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + + Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + + Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). + { unfold Rminus. + rewrite <- + (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). + apply Rabs_4. } + repeat rewrite Rabs_mult. + replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. + cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < + eps / 4). + 2:{ rewrite H8. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + cut + (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < + eps / 4). + 2:{ rewrite H8. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + intros. lra. + (***********************************) + (* Third case *) + (* (f1 x)<>0 l1=0 l2=0 *) + (***********************************) + - elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); + [ idtac + | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; + repeat apply prod_neq_R0 ; + [ assumption + | assumption + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. + intros alp_f2d H12. + assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). { + repeat apply Rmin_pos. + - apply (cond_pos eps_f2). + - elim H3; intros; assumption. + - apply (cond_pos alp_f1d). + - apply (cond_pos alp_f2d). + } + exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11). + simpl. intros. - assert (H6 := H4 a H5). - rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6. - rewrite Ropp_minus_distr in H6. - assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6). - apply Rplus_lt_reg_l with (- Rabs (f2 a) + Rabs (f2 x) / 2). - rewrite Rplus_assoc. - rewrite Rplus_half_diag. - do 2 rewrite (Rplus_comm (- Rabs (f2 a))). - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r. - unfold Rminus in H7; assumption. - } - assert - (Maj:forall a:R, - Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)). { + assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)). + assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)). + assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). + assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). + assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). + assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). + clear H15 H16. + rewrite formule; try assumption. + 2:{ apply H2; assumption. } + apply Rle_lt_trans with + (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + + Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + + Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + + Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). + { unfold Rminus. + rewrite <- + (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). + apply Rabs_4. } + repeat rewrite Rabs_mult. + replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. + cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). + 2:{ rewrite H9. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + cut + (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < + eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < + eps / 4). + 2:{ rewrite H10. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + intros. lra. + (***********************************) + (* Fourth case *) + (* (f1 x)<>0 l1=0 l2<>0 *) + (***********************************) + - elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); + [ idtac + | apply Rabs_pos_lt; unfold Rsqr, Rdiv; + repeat apply prod_neq_R0 ; + [ assumption.. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. + intros alp_f2d H11. + assert (H12 := derivable_continuous_pt _ _ X). + unfold continuity_pt in H12. + unfold continue_in in H12. + unfold limit1_in in H12. + unfold limit_in in H12. + unfold dist in H12. + simpl in H12. + unfold Rdist in H12. + elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))). + 2:{ change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). + apply Rabs_pos_lt. + unfold Rsqr, Rdiv. + repeat rewrite Rinv_mult. + repeat apply prod_neq_R0; try assumption. + - lra. + - apply Rinv_neq_0_compat; discrR. + - apply Rinv_neq_0_compat; assumption. + - apply Rinv_neq_0_compat; assumption. } + intros alp_f2c H13. + assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))). { + repeat apply Rmin_pos. + - apply (cond_pos eps_f2). + - elim H3; intros; assumption. + - apply (cond_pos alp_f1d). + - apply (cond_pos alp_f2d). + - elim H13; intros; assumption. + } + exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))) H14). + simpl; intros. + assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). + assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). + assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). + assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)). + assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)). + assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). + assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). + assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). + clear H16 H17 H18 H19. + assert + (forall a:R, + Rabs a < alp_f2c -> + Rabs (f2 (x + a) - f2 x) < + Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). { + intros. + case (Req_dec a 0); intro. + - rewrite H17; rewrite Rplus_0_r. + unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0. + apply Rabs_pos_lt. + unfold Rdiv, Rsqr. + repeat rewrite Rinv_mult. + repeat apply prod_neq_R0; try assumption. + + red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). + + apply Rinv_neq_0_compat; discrR. + + apply Rinv_neq_0_compat; assumption. + + apply Rinv_neq_0_compat; assumption. + - discrR. + elim H13; intros. + apply H19. + split. + + apply D_x_no_cond; assumption. + + replace (x + a - x) with a; [ assumption | ring ]. + } + rewrite formule; try assumption. + 2:{ apply H2; assumption. } + apply Rle_lt_trans with + (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + + Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + + Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + + Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). + { unfold Rminus. + rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). + apply Rabs_4. } + repeat rewrite Rabs_mult. + replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. + cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). + 2:{ rewrite H9. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + cut + (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < + eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < + eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + intros. lra. + (***********************************) + (* Fifth case *) + (* (f1 x)<>0 l1<>0 l2=0 *) + (***********************************) + - assert (H11 := derivable_continuous_pt _ _ X). + unfold continuity_pt in H11. + unfold continue_in in H11. + unfold limit1_in in H11. + unfold limit_in in H11. + unfold dist in H11. + simpl in H11. + unfold Rdist in H11. + elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). + 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))). + apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0;try apply Rinv_neq_0_compat; lra. } + clear H11; intros alp_f2t2 H11. + elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). + 2:{ apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } + intros alp_f2d H12. + assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))). { + repeat apply Rmin_pos. + - apply (cond_pos eps_f2). + - elim H3; intros; assumption. + - apply (cond_pos alp_f1d). + - apply (cond_pos alp_f2d). + - elim H11; intros; assumption. + } + exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13). + simpl. intros. - unfold Rdiv. - apply Rmult_lt_reg_l with (Rabs (f2 (x + a))). - - apply Rabs_pos_lt; apply H2. - apply Rlt_le_trans with (Rmin eps_f2 alp_f2). - + assumption. - + apply Rmin_l. - - rewrite Rinv_r. - + apply Rmult_lt_reg_l with (Rabs (f2 x)). - { apply Rabs_pos_lt; assumption. } - rewrite Rmult_1_r. - rewrite (Rmult_comm (Rabs (f2 x))). - repeat rewrite Rmult_assoc. - rewrite Rinv_l. - 2:{ apply Rabs_no_R0; assumption. } - rewrite Rmult_1_r. - apply Rmult_lt_reg_l with (/ 2). - { apply Rinv_0_lt_compat; prove_sup0. } - repeat rewrite (Rmult_comm (/ 2)). - repeat rewrite Rmult_assoc. - rewrite Rinv_r. - 2:{ discrR. } - rewrite Rmult_1_r. - unfold Rdiv in H5; apply H5. - replace (x + a - x) with a by ring. - assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption. - + apply Rabs_no_R0; apply H2. - assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption. - } - unfold derivable_pt_lim; intros. - elim (H (Rabs (eps * f2 x / 8))); - [ idtac - | unfold Rdiv; change (0 < Rabs (eps * f2 x * / 8)); - apply Rabs_pos_lt; repeat apply prod_neq_R0; - [ red; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6) - | assumption - | apply Rinv_neq_0_compat; discrR ] ]. - intros alp_f1d H7. - case (Req_dec (f1 x) 0); intro. - 1:case (Req_dec l1 0); intro. - 3:case (Req_dec l1 0); intro. - 3:case (Req_dec l2 0); intro. - 5:case (Req_dec l2 0); intro. -(***********************************) -(* First case *) -(* (f1 x)=0 l1 =0 *) -(***********************************) - - cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d)); - [ intro - | repeat apply Rmin_pos; - [ apply (cond_pos eps_f2) - | elim H3; intros; assumption - | apply (cond_pos alp_f1d) ] ]. - exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10). - simpl; intros. - assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)). - assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)). - assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)). - assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)). - assert (H17 := H7 _ H11 H15). - rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ]. - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- - (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); - try assumption || apply H2. - - apply H14. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite H9. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Second case *) -(* (f1 x)=0 l1<>0 *) -(***********************************) -- assert (H10 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H10. - unfold continue_in in H10. - unfold limit1_in in H10. - unfold limit_in in H10. - unfold dist in H10. - simpl in H10. - unfold Rdist in H10. - elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). - 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))). - apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0. - - lra. - - assumption. - - assumption. - - apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. } - clear H10; intros alp_f2t2 H10. - assert - (H11:forall a:R, + assert + (forall a:R, Rabs a < alp_f2t2 -> Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). { - intros. - elim H10; intros. - case (Req_dec a 0); intro. - - rewrite H14; rewrite Rplus_0_r. - unfold Rminus; rewrite Rplus_opp_r. - rewrite Rabs_R0. - apply Rabs_pos_lt. - unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc. - repeat apply prod_neq_R0; try assumption. - + now apply Rgt_not_eq. - + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. - - apply H13. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. - } - assert (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - apply (cond_pos alp_f1d). - - elim H3; intros; assumption. - - elim H10; intros; assumption. - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12). - simpl. - intros. - assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)). - assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)). - assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). - assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). - clear H14 H15 H16. - rewrite formule; try assumption. - 2:{ apply H2; assumption. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- - (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Third case *) -(* (f1 x)<>0 l1=0 l2=0 *) -(***********************************) -- elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); - [ idtac - | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0 ; - [ assumption - | assumption - | now apply Rgt_not_eq - | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. - intros alp_f2d H12. - assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11). - simpl. - intros. - assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)). - assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)). - assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). - assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). - clear H15 H16. - rewrite formule; try assumption. - 2:{ apply H2; assumption. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- - (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite H9. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H10. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Fourth case *) -(* (f1 x)<>0 l1=0 l2<>0 *) -(***********************************) -- elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); - [ idtac - | apply Rabs_pos_lt; unfold Rsqr, Rdiv; - repeat apply prod_neq_R0 ; - [ assumption.. - | now apply Rgt_not_eq - | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. - intros alp_f2d H11. - assert (H12 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H12. - unfold continue_in in H12. - unfold limit1_in in H12. - unfold limit_in in H12. - unfold dist in H12. - simpl in H12. - unfold Rdist in H12. - elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))). - 2:{ change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). - apply Rabs_pos_lt. - unfold Rsqr, Rdiv. - repeat rewrite Rinv_mult. - repeat apply prod_neq_R0; try assumption. - - lra. - - apply Rinv_neq_0_compat; discrR. - - apply Rinv_neq_0_compat; assumption. - - apply Rinv_neq_0_compat; assumption. } - intros alp_f2c H13. - assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - - elim H13; intros; assumption. - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))) H14). - simpl; intros. - assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). - assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)). - assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)). - assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). - assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). - assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). - clear H16 H17 H18 H19. - assert - (forall a:R, - Rabs a < alp_f2c -> - Rabs (f2 (x + a) - f2 x) < - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). { - intros. - case (Req_dec a 0); intro. - - rewrite H17; rewrite Rplus_0_r. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0. - apply Rabs_pos_lt. - unfold Rdiv, Rsqr. - repeat rewrite Rinv_mult. - repeat apply prod_neq_R0; try assumption. - + red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). - + apply Rinv_neq_0_compat; discrR. - + apply Rinv_neq_0_compat; assumption. - + apply Rinv_neq_0_compat; assumption. - - discrR. - elim H13; intros. - apply H19. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. - } - rewrite formule; try assumption. - 2:{ apply H2; assumption. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite H9. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - intros. lra. -(***********************************) -(* Fifth case *) -(* (f1 x)<>0 l1<>0 l2=0 *) -(***********************************) -- assert (H11 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H11. - unfold continue_in in H11. - unfold limit1_in in H11. - unfold limit_in in H11. - unfold dist in H11. - simpl in H11. - unfold Rdist in H11. - elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). - 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))). - apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0;try apply Rinv_neq_0_compat; lra. } - clear H11; intros alp_f2t2 H11. - elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). - 2:{ apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2d H12. - assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - - elim H11; intros; assumption. - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13). - simpl. - intros. - assert - (forall a:R, - Rabs a < alp_f2t2 -> - Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). { - intros. - case (Req_dec a 0); intro. - - rewrite H17; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0. - apply Rabs_pos_lt. - unfold Rdiv; rewrite Rinv_mult. - unfold Rsqr. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat;lra. - - elim H11; intros. - apply H19. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. - } - assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). - assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). - assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). - assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). - assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)). - assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)). - clear H15 H17 H18 H21. - rewrite formule; auto; try assumption. - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H10. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Sixth case *) -(* (f1 x)<>0 l1<>0 l2<>0 *) -(***********************************) -- elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). - 2:{ apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2d H11. - assert (H12 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H12. - unfold continue_in in H12. - unfold limit1_in in H12. - unfold limit_in in H12. - unfold dist in H12. - simpl in H12. - unfold Rdist in H12. - elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))). - 2:{ change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))); - apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2c H13. - elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). - 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))); apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2t2 H14. - assert - (0 < - Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) - (Rmin alp_f2c alp_f2t2)). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - - elim H13; intros; assumption. - - elim H14; intros; assumption. - } - exists - (mkposreal - (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) - (Rmin alp_f2c alp_f2t2)) H15). - simpl. - intros. - assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). - assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). - assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). - assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). - assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)). - assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)). - assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)). - assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)). - assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)). - assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)). - clear H17 H18 H19 H20 H21. - cut - (forall a:R, - Rabs a < alp_f2t2 -> - Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). - 2:{ intros. - case (Req_dec a 0); intro. - - rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. - - elim H14; intros. - apply H20. - split. - + unfold D_x, no_cond; split. - * trivial. - * symmetry; apply Rminus_not_eq. - replace (x + a - x) with a; [ assumption | ring ]. - + replace (x + a - x) with a; [ assumption | ring ]. } - cut - (forall a:R, - Rabs a < alp_f2c -> - Rabs (f2 (x + a) - f2 x) < - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). - 2:{ intros. + intros. case (Req_dec a 0); intro. - - rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. - - elim H13; intros. - apply H20. + - rewrite H17; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; + rewrite Rabs_R0. + apply Rabs_pos_lt. + unfold Rdiv; rewrite Rinv_mult. + unfold Rsqr. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat;lra. + - elim H11; intros. + apply H19. split. + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. } - intros. - rewrite formule; try assumption. 2:{ auto. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - intros. lra. + + replace (x + a - x) with a; [ assumption | ring ]. + } + assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). + assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). + assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). + assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). + assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). + assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). + assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)). + assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)). + clear H15 H17 H18 H21. + rewrite formule; auto; try assumption. + apply Rle_lt_trans with + (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + + Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + + Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + + Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). + { unfold Rminus. + rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). + apply Rabs_4. } + repeat rewrite Rabs_mult. + replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. + cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < + eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < + eps / 4). + 2:{ rewrite H10. + unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. + rewrite Rabs_R0; rewrite Rmult_0_l. + apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } + intros. lra. + (***********************************) + (* Sixth case *) + (* (f1 x)<>0 l1<>0 l2<>0 *) + (***********************************) + - elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). + 2:{ apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } + intros alp_f2d H11. + assert (H12 := derivable_continuous_pt _ _ X). + unfold continuity_pt in H12. + unfold continue_in in H12. + unfold limit1_in in H12. + unfold limit_in in H12. + unfold dist in H12. + simpl in H12. + unfold Rdist in H12. + elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))). + 2:{ change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))); + apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } + intros alp_f2c H13. + elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). + 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))); apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } + intros alp_f2t2 H14. + assert + (0 < + Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) + (Rmin alp_f2c alp_f2t2)). { + repeat apply Rmin_pos. + - apply (cond_pos eps_f2). + - elim H3; intros; assumption. + - apply (cond_pos alp_f1d). + - apply (cond_pos alp_f2d). + - elim H13; intros; assumption. + - elim H14; intros; assumption. + } + exists + (mkposreal + (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) + (Rmin alp_f2c alp_f2t2)) H15). + simpl. + intros. + assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). + assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). + assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). + assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). + assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)). + assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)). + assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)). + assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)). + assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)). + assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)). + clear H17 H18 H19 H20 H21. + cut + (forall a:R, + Rabs a < alp_f2t2 -> + Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). + 2:{ intros. + case (Req_dec a 0); intro. + - rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; + rewrite Rabs_R0; apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. + - elim H14; intros. + apply H20. + split. + + unfold D_x, no_cond; split. + * trivial. + * symmetry; apply Rminus_not_eq. + replace (x + a - x) with a; [ assumption | ring ]. + + replace (x + a - x) with a; [ assumption | ring ]. } + cut + (forall a:R, + Rabs a < alp_f2c -> + Rabs (f2 (x + a) - f2 x) < + Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). + 2:{ intros. + case (Req_dec a 0); intro. + - rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; + rewrite Rabs_R0; apply Rabs_pos_lt. + unfold Rdiv, Rsqr; rewrite Rinv_mult. + repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. + - elim H13; intros. + apply H20. + split. + + apply D_x_no_cond; assumption. + + replace (x + a - x) with a; [ assumption | ring ]. } + intros. + rewrite formule; try assumption. 2:{ auto. } + apply Rle_lt_trans with + (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + + Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + + Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + + Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). + { unfold Rminus. + rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). + apply Rabs_4. } + repeat rewrite Rabs_mult. + replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. + cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < + eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + cut + (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < + eps / 4). + 2:{ rewrite <- Rabs_mult. + apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption. + - apply H2; assumption. + - apply Rmin_2; assumption. } + intros. lra. Qed. Lemma derivable_pt_div : diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 467e112d3a..ca33f39e06 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -384,11 +384,12 @@ Proof. Qed. Lemma sinh_lt : forall x y, x < y -> sinh x < sinh y. -intros x y xy; destruct (MVT_cor2 sinh cosh x y xy) as [c [Pc _]]. -- intros; apply derivable_pt_lim_sinh. -- apply Rplus_lt_reg_l with (Ropp (sinh x)); rewrite Rplus_opp_l, Rplus_comm. - unfold Rminus at 1 in Pc; rewrite Pc; apply Rmult_lt_0_compat;[ | ]. - + unfold cosh; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat, Rlt_0_2]. - now apply Rplus_lt_0_compat; apply exp_pos. - + now apply Rlt_0_minus; assumption. +Proof. + intros x y xy; destruct (MVT_cor2 sinh cosh x y xy) as [c [Pc _]]. + - intros; apply derivable_pt_lim_sinh. + - apply Rplus_lt_reg_l with (Ropp (sinh x)); rewrite Rplus_opp_l, Rplus_comm. + unfold Rminus at 1 in Pc; rewrite Pc; apply Rmult_lt_0_compat;[ | ]. + + unfold cosh; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat, Rlt_0_2]. + now apply Rplus_lt_0_compat; apply exp_pos. + + now apply Rlt_0_minus; assumption. Qed. diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index 10124c1570..3d8cfc894a 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -63,8 +63,8 @@ Lemma derivable_pt_id_interv : forall (lb ub x:R), lb <= x <= ub -> derivable_pt id x. Proof. -intros. - reg. + intros. + reg. Qed. Lemma pr_nu_var2_interv : forall (f g : R -> R) (lb ub x : R) (pr1 : derivable_pt f x) @@ -628,11 +628,11 @@ Lemma continuity_pt_recip_interv : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub), f lb < b < f ub -> continuity_pt g b. Proof. -intros f g lb ub lb_lt_ub f_incr_interv f_eq_g g_wf. -assert (g_eq_f_prelim := leftinv_is_rightinv_interv f g lb ub f_incr_interv f_eq_g). -assert (g_eq_f : forall x, lb <= x <= ub -> (comp g f) x = id x). -{ intro x ; apply g_eq_f_prelim ; assumption. } -apply (continuity_pt_recip_prelim f g lb ub lb_lt_ub f_incr_interv g_eq_f). + intros f g lb ub lb_lt_ub f_incr_interv f_eq_g g_wf. + assert (g_eq_f_prelim := leftinv_is_rightinv_interv f g lb ub f_incr_interv f_eq_g). + assert (g_eq_f : forall x, lb <= x <= ub -> (comp g f) x = id x). + { intro x ; apply g_eq_f_prelim ; assumption. } + apply (continuity_pt_recip_prelim f g lb ub lb_lt_ub f_incr_interv g_eq_f). Qed. (** * Derivability of the reciprocal function *) @@ -825,10 +825,10 @@ Lemma derivable_pt_recip_interv_prelim0 : forall (f g : R -> R) (lb ub x : R) derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 -> derivable_pt g x. Proof. -intros f g lb ub x Prf g_cont_pt lb_lt_ub x_encad Prg_incr f_eq_g Df_neq. -unfold derivable_pt, derivable_pt_abs. -exists (1 / derive_pt f (g x) (Prf (g x) Prg_incr)). -apply derivable_pt_lim_recip_interv ; assumption. + intros f g lb ub x Prf g_cont_pt lb_lt_ub x_encad Prg_incr f_eq_g Df_neq. + unfold derivable_pt, derivable_pt_abs. + exists (1 / derive_pt f (g x) (Prf (g x) Prg_incr)). + apply derivable_pt_lim_recip_interv ; assumption. Qed. Lemma derivable_pt_recip_interv_prelim1 : forall (f g:R->R) (lb ub x : R), @@ -912,36 +912,36 @@ Lemma derivable_pt_recip_interv_decr (f g:R->R) (lb ub x : R) <> 0 -> derivable_pt g x. Proof. - intros. - apply derivable_pt_opp_rev. - unshelve eapply (derivable_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). -- lra. -- unfold mirr_fct; repeat rewrite Ropp_involutive; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2; unfold opp_fct. - rewrite Ropp_involutive in H1,H2. - pose proof g_wf x0 as g_wfs; lra. -- intros x0 H1. - apply derivable_pt_mirr, f_derivable; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. - rewrite Ropp_involutive in H1,H2 |-*. - apply f_eq_g; lra. -- intros x0 y0 H1 H2 H3. - unfold mirr_fct. - apply f_decr; lra. -- (* In order to rewrite with derive_pt_mirr the term must have the form + intros. + apply derivable_pt_opp_rev. + unshelve eapply (derivable_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). + - lra. + - unfold mirr_fct; repeat rewrite Ropp_involutive; lra. + - intros x0 H1 H2. + unfold mirr_fct in H1,H2; unfold opp_fct. + rewrite Ropp_involutive in H1,H2. + pose proof g_wf x0 as g_wfs; lra. + - intros x0 H1. + apply derivable_pt_mirr, f_derivable; lra. + - intros x0 H1 H2. + unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. + rewrite Ropp_involutive in H1,H2 |-*. + apply f_eq_g; lra. + - intros x0 y0 H1 H2 H3. + unfold mirr_fct. + apply f_decr; lra. + - (* In order to rewrite with derive_pt_mirr the term must have the form derive_pt (mirr_fct f) _ (derivable_pt_mirr ... pr_nu is a sort of proof irrelevance lemma for derive_pt equalities *) - unshelve erewrite (pr_nu _ _ _). - + apply derivable_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - apply f_derivable; apply g_wf; lra. - + rewrite derive_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - match goal with H:context[derive_pt _ _ ?pr] |- _ => rewrite (pr_nu f (g x) _ pr) end. - apply Ropp_neq_0_compat. - assumption. + unshelve erewrite (pr_nu _ _ _). + + apply derivable_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + apply f_derivable; apply g_wf; lra. + + rewrite derive_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + match goal with H:context[derive_pt _ _ ?pr] |- _ => rewrite (pr_nu f (g x) _ pr) end. + apply Ropp_neq_0_compat. + assumption. Qed. (****************************************************) @@ -980,11 +980,11 @@ Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R), (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) -> lb < g x < ub. Proof. -intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. - assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf). - assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf). - unfold comp, id in Left_inv. - split ; [rewrite <- Left_inv with (x:=lb) | rewrite <- Left_inv ];intuition. + intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. + assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf). + assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf). + unfold comp, id in Left_inv. + split ; [rewrite <- Left_inv with (x:=lb) | rewrite <- Left_inv ];intuition. Qed. Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R), @@ -995,9 +995,9 @@ Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R), (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) -> lb <= g x <= ub. Proof. -intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. - assert (Temp := derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). - split ; apply Rlt_le ; intuition. + intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. + assert (Temp := derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). + split ; apply Rlt_le ; intuition. Qed. Lemma derive_pt_recip_interv_prelim1_1_decr : forall (f g:R->R) (lb ub x:R), @@ -1008,22 +1008,22 @@ Lemma derive_pt_recip_interv_prelim1_1_decr : forall (f g:R->R) (lb ub x:R), (forall x, f ub <= x -> x <= f lb -> (comp f g) x = id x) -> lb <= g x <= ub. Proof. - intros f g lb ub x lb_lt_ub x_encad f_decr g_wf f_eq_g. - enough (-ub <= - g x <= - lb) by lra. - unshelve eapply (derive_pt_recip_interv_prelim1_1 (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). -- lra. -- unfold mirr_fct; repeat rewrite Ropp_involutive; lra. -- intros x0 y0 H1 H2 H3. - unfold mirr_fct. - apply f_decr; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2; unfold opp_fct. - rewrite Ropp_involutive in H1,H2. - pose proof g_wf x0 as g_wfs; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. - rewrite Ropp_involutive in H1,H2 |-*. - apply f_eq_g; lra. + intros f g lb ub x lb_lt_ub x_encad f_decr g_wf f_eq_g. + enough (-ub <= - g x <= - lb) by lra. + unshelve eapply (derive_pt_recip_interv_prelim1_1 (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). + - lra. + - unfold mirr_fct; repeat rewrite Ropp_involutive; lra. + - intros x0 y0 H1 H2 H3. + unfold mirr_fct. + apply f_decr; lra. + - intros x0 H1 H2. + unfold mirr_fct in H1,H2; unfold opp_fct. + rewrite Ropp_involutive in H1,H2. + pose proof g_wf x0 as g_wfs; lra. + - intros x0 H1 H2. + unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. + rewrite Ropp_involutive in H1,H2 |-*. + apply f_eq_g; lra. Qed. Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R) @@ -1040,16 +1040,16 @@ Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R) 1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g))). Proof. -intros. - assert(g_incr := (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub - x_encad f_incr g_wf f_eq_g)). - apply derive_pt_recip_interv_prelim0 with (lb:=f lb) (ub:=f ub) ; - [intuition |assumption | intuition |]. - intro Hfalse ; apply Df_neq. rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) - (pr2:= (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub x_encad - f_incr g_wf f_eq_g))) ; - [intuition | intuition | | intuition]. - exact (derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). + intros. + assert(g_incr := (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub + x_encad f_incr g_wf f_eq_g)). + apply derive_pt_recip_interv_prelim0 with (lb:=f lb) (ub:=f ub) ; + [intuition |assumption | intuition |]. + intro Hfalse ; apply Df_neq. rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) + (pr2:= (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub x_encad + f_incr g_wf f_eq_g))) ; + [intuition | intuition | | intuition]. + exact (derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). Qed. Lemma derive_pt_recip_interv_decr : forall (f g:R->R) (lb ub x:R) @@ -1067,57 +1067,57 @@ Lemma derive_pt_recip_interv_decr : forall (f g:R->R) (lb ub x:R) 1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1_decr f g lb ub x lb_lt_ub x_encad f_decr g_wf f_eq_g))). Proof. - (* This proof based on derive_pt_recip_interv looks fairly long compared to the direct proof above, + (* This proof based on derive_pt_recip_interv looks fairly long compared to the direct proof above, but the direct proof needs a lot of lengthy preparation lemmas e.g. derivable_pt_lim_recip_interv. *) - intros. - (* Note: here "unshelve epose" with proving the premises first does not work. + intros. + (* Note: here "unshelve epose" with proving the premises first does not work. The more abstract form with the unbound evars has less issues with dependent rewriting. *) - epose proof (derive_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x) _ _ _ _ _ _ _). - rewrite derive_pt_mirr_rev in H. - rewrite derive_pt_opp_rev in H. - unfold opp_fct in H. - match goal with - | H:context[derive_pt ?f ?x1 ?pr1] |- context[derive_pt ?f ?x2 ?pr2] => - rewrite (pr_nu_xeq f x1 x2 pr1 pr2 (Ropp_involutive x2)) in H - end. - match goal with - | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => - rewrite (pr_nu f x pr1 pr2) in H - end. - apply Ropp_eq_compat in H; rewrite Ropp_involutive in H. - rewrite H; field. - pose proof Df_neq as Df_neq'. - match goal with - | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => - rewrite (pr_nu f x pr1 pr2) in H - end. - assumption. + epose proof (derive_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x) _ _ _ _ _ _ _). + rewrite derive_pt_mirr_rev in H. + rewrite derive_pt_opp_rev in H. + unfold opp_fct in H. + match goal with + | H:context[derive_pt ?f ?x1 ?pr1] |- context[derive_pt ?f ?x2 ?pr2] => + rewrite (pr_nu_xeq f x1 x2 pr1 pr2 (Ropp_involutive x2)) in H + end. + match goal with + | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => + rewrite (pr_nu f x pr1 pr2) in H + end. + apply Ropp_eq_compat in H; rewrite Ropp_involutive in H. + rewrite H; field. + pose proof Df_neq as Df_neq'. + match goal with + | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => + rewrite (pr_nu f x pr1 pr2) in H + end. + assumption. -Unshelve. -- abstract lra. -- unfold mirr_fct; repeat rewrite Ropp_involutive; abstract lra. -- intros x0 y0 H1 H2 H3. - unfold mirr_fct. - apply f_decr; abstract lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2; unfold opp_fct. - rewrite Ropp_involutive in H1,H2. - pose proof g_wf x0 as g_wfs; abstract lra. -- intros x0 H1. - apply derivable_pt_mirr, Prf; abstract lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. - rewrite Ropp_involutive in H1,H2 |-*. - apply f_eq_g; abstract lra. -- unshelve erewrite (pr_nu _ _ _). - { apply derivable_pt_mirr. + Unshelve. + - abstract lra. + - unfold mirr_fct; repeat rewrite Ropp_involutive; abstract lra. + - intros x0 y0 H1 H2 H3. + unfold mirr_fct. + apply f_decr; abstract lra. + - intros x0 H1 H2. + unfold mirr_fct in H1,H2; unfold opp_fct. + rewrite Ropp_involutive in H1,H2. + pose proof g_wf x0 as g_wfs; abstract lra. + - intros x0 H1. + apply derivable_pt_mirr, Prf; abstract lra. + - intros x0 H1 H2. + unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. + rewrite Ropp_involutive in H1,H2 |-*. + apply f_eq_g; abstract lra. + - unshelve erewrite (pr_nu _ _ _). + { apply derivable_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + apply Prf; apply g_wf; abstract lra. } + rewrite derive_pt_mirr. unfold opp_fct; rewrite Ropp_involutive. - apply Prf; apply g_wf; abstract lra. } - rewrite derive_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - apply Ropp_neq_0_compat. - erewrite (pr_nu _ _ _). - apply Df_neq. + apply Ropp_neq_0_compat. + erewrite (pr_nu _ _ _). + apply Df_neq. Qed. (****************************************************) @@ -1127,12 +1127,13 @@ Qed. (* begin hide *) Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2. Proof. -intros x ub lb lb_lt_x x_lt_ub. -lra. + intros x ub lb lb_lt_x x_lt_ub. + lra. Qed. Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb 0 <= x <= 1. Proof. -unfold Boule, posreal_half; simpl. -intros x b; apply Rabs_def2 in b; destruct b; split; lra. + unfold Boule, posreal_half; simpl. + intros x b; apply Rabs_def2 in b; destruct b; split; lra. Qed. Lemma Boule_lt : forall c r x, Boule c r x -> Rabs x < Rabs c + r. Proof. -unfold Boule; intros c r x h. -apply Rabs_def2 in h; destruct h; apply Rabs_def1; - (destruct (Rle_lt_dec 0 c);[rewrite Rabs_pos_eq; lra | - rewrite <- Rabs_Ropp, Rabs_pos_eq; lra]). + unfold Boule; intros c r x h. + apply Rabs_def2 in h; destruct h; apply Rabs_def1; + (destruct (Rle_lt_dec 0 c);[rewrite Rabs_pos_eq; lra | + rewrite <- Rabs_Ropp, Rabs_pos_eq; lra]). Qed. (* The following lemma does not belong here. *) @@ -55,8 +55,8 @@ Lemma Un_cv_ext : forall un vn, forall l, Un_cv un l -> Un_cv vn l. Proof. -intros un vn quv l P eps ep; destruct (P eps ep) as [N Pn]; exists N. -intro n; rewrite <- quv; apply Pn. + intros un vn quv l P eps ep; destruct (P eps ep) as [N Pn]; exists N. + intro n; rewrite <- quv; apply Pn. Qed. (* The following two lemmas are general purposes about alternated series. @@ -217,22 +217,22 @@ Qed. Lemma derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> derivable_pt tan x. Proof. -intros x xint. - unfold derivable_pt, tan. - apply derivable_pt_div ; [reg | reg | ]. - apply Rgt_not_eq. - unfold Rgt ; apply cos_gt_0; - [unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse; fold (-PI/2) |];tauto. + intros x xint. + unfold derivable_pt, tan. + apply derivable_pt_div ; [reg | reg | ]. + apply Rgt_not_eq. + unfold Rgt ; apply cos_gt_0; + [unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse; fold (-PI/2) |];tauto. Qed. Lemma derive_pt_tan : forall x, forall (Pr1: -PI/2 < x < PI/2), derive_pt tan x (derivable_pt_tan x Pr1) = 1 + (tan x)^2. Proof. -intros x pr. -assert (cos x <> 0). -{ apply Rgt_not_eq, cos_gt_0; rewrite <- ?Rdiv_opp_l; tauto. } -unfold tan; reg; unfold pow, Rsqr; field; assumption. + intros x pr. + assert (cos x <> 0). + { apply Rgt_not_eq, cos_gt_0; rewrite <- ?Rdiv_opp_l; tauto. } + unfold tan; reg; unfold pow, Rsqr; field; assumption. Qed. (** *** Proof that tangent is a bijection *) @@ -245,53 +245,53 @@ Lemma derive_increasing_interv : forall (a b : R) (f : R -> R), (forall t:R, forall (t_encad : a < t < b), 0 < derive_pt f t (pr t t_encad)) -> forall x y:R, a < x < b -> a < y < b -> x < y -> f x < f y. Proof. -intros a b f a_lt_b pr Df_gt_0 x y x_encad y_encad x_lt_y. -assert (derivable_id_interv : forall c : R, x < c < y -> derivable_pt id c). -{ intros ; apply derivable_pt_id. } -assert (derivable_f_interv : forall c : R, x < c < y -> derivable_pt f c). -{ intros c c_encad. apply pr. split. - { apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. } - apply Rlt_trans with (r2:=y) ; [exact (proj2 c_encad) | exact (proj2 y_encad)]. } -assert (f_cont_interv : forall c : R, x <= c <= y -> continuity_pt f c). -{ intros c c_encad; apply derivable_continuous_pt ; apply pr. split. - { apply Rlt_le_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. } - apply Rle_lt_trans with (r2:=y) ; [ exact (proj2 c_encad) | exact (proj2 y_encad)]. } -assert (id_cont_interv : forall c : R, x <= c <= y -> continuity_pt id c). -{ intros ; apply derivable_continuous_pt ; apply derivable_pt_id. } -elim (MVT f id x y derivable_f_interv derivable_id_interv x_lt_y f_cont_interv id_cont_interv). -intros c Temp ; elim Temp ; clear Temp ; intros Pr eq. -replace (id y - id x) with (y - x) in eq by intuition. -replace (derive_pt id c (derivable_id_interv c Pr)) with 1 in eq. -2:{ symmetry ; rewrite derive_pt_eq ; apply derivable_pt_lim_id. } -apply Rminus_gt. -rewrite Rmult_1_r in eq. rewrite <- eq. -apply Rmult_gt_0_compat. -{ apply Rgt_minus ; assumption. } -assert (c_encad2 : a <= c < b). -{ split. - { apply Rlt_le ; apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)]. } - apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)]. } -assert (c_encad : a < c < b). -{ split. - { apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)]. } - apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)]. } -rewrite (pr_nu f c (derivable_f_interv c Pr) (pr c c_encad)). -apply (Df_gt_0 c c_encad). + intros a b f a_lt_b pr Df_gt_0 x y x_encad y_encad x_lt_y. + assert (derivable_id_interv : forall c : R, x < c < y -> derivable_pt id c). + { intros ; apply derivable_pt_id. } + assert (derivable_f_interv : forall c : R, x < c < y -> derivable_pt f c). + { intros c c_encad. apply pr. split. + { apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. } + apply Rlt_trans with (r2:=y) ; [exact (proj2 c_encad) | exact (proj2 y_encad)]. } + assert (f_cont_interv : forall c : R, x <= c <= y -> continuity_pt f c). + { intros c c_encad; apply derivable_continuous_pt ; apply pr. split. + { apply Rlt_le_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. } + apply Rle_lt_trans with (r2:=y) ; [ exact (proj2 c_encad) | exact (proj2 y_encad)]. } + assert (id_cont_interv : forall c : R, x <= c <= y -> continuity_pt id c). + { intros ; apply derivable_continuous_pt ; apply derivable_pt_id. } + elim (MVT f id x y derivable_f_interv derivable_id_interv x_lt_y f_cont_interv id_cont_interv). + intros c Temp ; elim Temp ; clear Temp ; intros Pr eq. + replace (id y - id x) with (y - x) in eq by intuition. + replace (derive_pt id c (derivable_id_interv c Pr)) with 1 in eq. + 2:{ symmetry ; rewrite derive_pt_eq ; apply derivable_pt_lim_id. } + apply Rminus_gt. + rewrite Rmult_1_r in eq. rewrite <- eq. + apply Rmult_gt_0_compat. + { apply Rgt_minus ; assumption. } + assert (c_encad2 : a <= c < b). + { split. + { apply Rlt_le ; apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)]. } + apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)]. } + assert (c_encad : a < c < b). + { split. + { apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)]. } + apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)]. } + rewrite (pr_nu f c (derivable_f_interv c Pr) (pr c c_encad)). + apply (Df_gt_0 c c_encad). Qed. (* begin hide *) Lemma plus_Rsqr_gt_0 : forall x, 1 + x ^ 2 > 0. Proof. -intro m. replace 0 with (0+0) by intuition. -apply Rplus_gt_ge_compat. { intuition. } -destruct (total_order_T m 0) as [[m_cond|H']|?]. -- replace 0 with (0*0) by intuition. - replace (m ^ 2) with ((-m)^2). - { apply Rle_ge ; apply Rmult_le_compat ; intuition ; - apply Rlt_le ; rewrite Rmult_1_r ; intuition. } - field. -- rewrite H' ; right ; field. -- left. intuition. + intro m. replace 0 with (0+0) by intuition. + apply Rplus_gt_ge_compat. { intuition. } + destruct (total_order_T m 0) as [[m_cond|H']|?]. + - replace 0 with (0*0) by intuition. + replace (m ^ 2) with ((-m)^2). + { apply Rle_ge ; apply Rmult_le_compat ; intuition ; + apply Rlt_le ; rewrite Rmult_1_r ; intuition. } + field. + - rewrite H' ; right ; field. + - left. intuition. Qed. (* end hide *) @@ -299,32 +299,32 @@ Qed. Lemma PI2_lower_bound : forall x, 0 < x < 2 -> 0 < cos x -> x < PI/2. Proof. -intros x [xp xlt2] cx. -destruct (Rtotal_order x (PI/2)) as [xltpi2 | [xeqpi2 | xgtpi2]]. -- assumption. -- now case (Rgt_not_eq _ _ cx); rewrite xeqpi2, cos_PI2. -- destruct (MVT_cor1 cos (PI/2) x derivable_cos xgtpi2) as - [c [Pc [cint1 cint2]]]. - revert Pc; rewrite cos_PI2, Rminus_0_r. - rewrite <- (pr_nu cos c (derivable_pt_cos c)), derive_pt_cos. - assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); lra). - assert (0 < sin c) by now apply sin_pos_tech. - intros Pc. - case (Rlt_not_le _ _ cx). - rewrite <- (Rplus_0_l (cos x)), Pc, Ropp_mult_distr_l_reverse. - apply Rle_minus, Rmult_le_pos;[apply Rlt_le; assumption | lra ]. + intros x [xp xlt2] cx. + destruct (Rtotal_order x (PI/2)) as [xltpi2 | [xeqpi2 | xgtpi2]]. + - assumption. + - now case (Rgt_not_eq _ _ cx); rewrite xeqpi2, cos_PI2. + - destruct (MVT_cor1 cos (PI/2) x derivable_cos xgtpi2) as + [c [Pc [cint1 cint2]]]. + revert Pc; rewrite cos_PI2, Rminus_0_r. + rewrite <- (pr_nu cos c (derivable_pt_cos c)), derive_pt_cos. + assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); lra). + assert (0 < sin c) by now apply sin_pos_tech. + intros Pc. + case (Rlt_not_le _ _ cx). + rewrite <- (Rplus_0_l (cos x)), Pc, Ropp_mult_distr_l_reverse. + apply Rle_minus, Rmult_le_pos;[apply Rlt_le; assumption | lra ]. Qed. Lemma PI2_3_2 : 3/2 < PI/2. Proof. -apply PI2_lower_bound;[split; lra | ]. -destruct (pre_cos_bound (3/2) 1) as [t _]; [lra | lra | ]. -apply Rlt_le_trans with (2 := t); clear t. -unfold cos_approx; simpl; unfold cos_term. -rewrite !INR_IZR_INZ. -cbv -[IZR]. (* faster than simpl: 0.005s vs 0.2s *) -field_simplify. -apply Rdiv_lt_0_compat ; now apply IZR_lt. + apply PI2_lower_bound;[split; lra | ]. + destruct (pre_cos_bound (3/2) 1) as [t _]; [lra | lra | ]. + apply Rlt_le_trans with (2 := t); clear t. + unfold cos_approx; simpl; unfold cos_term. + rewrite !INR_IZR_INZ. + cbv -[IZR]. (* faster than simpl: 0.005s vs 0.2s *) + field_simplify. + apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. Lemma PI2_1 : 1 < PI/2. @@ -334,20 +334,20 @@ Lemma tan_increasing : forall x y, -PI/2 < x -> x < y -> y < PI/2 -> tan x < tan y. Proof. -intros x y Z_le_x x_lt_y y_le_1. -assert (x_encad : -PI/2 < x < PI/2). -{ split ; [assumption | apply Rlt_trans with (r2:=y) ; assumption]. } -assert (y_encad : -PI/2 < y < PI/2). -{ split ; [apply Rlt_trans with (r2:=x) ; intuition | intuition ]. } -assert (local_derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> - derivable_pt tan x). -{ intros ; apply derivable_pt_tan ; intuition. } -apply derive_increasing_interv with (a:=-PI/2) (b:=PI/2) (pr:=local_derivable_pt_tan) ; intuition. -{ lra. } -assert (Temp := pr_nu tan t (derivable_pt_tan t t_encad) (local_derivable_pt_tan t t_encad)) ; - rewrite <- Temp ; clear Temp. -assert (Temp := derive_pt_tan t t_encad) ; rewrite Temp ; clear Temp. -apply plus_Rsqr_gt_0. + intros x y Z_le_x x_lt_y y_le_1. + assert (x_encad : -PI/2 < x < PI/2). + { split ; [assumption | apply Rlt_trans with (r2:=y) ; assumption]. } + assert (y_encad : -PI/2 < y < PI/2). + { split ; [apply Rlt_trans with (r2:=x) ; intuition | intuition ]. } + assert (local_derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> + derivable_pt tan x). + { intros ; apply derivable_pt_tan ; intuition. } + apply derive_increasing_interv with (a:=-PI/2) (b:=PI/2) (pr:=local_derivable_pt_tan) ; intuition. + { lra. } + assert (Temp := pr_nu tan t (derivable_pt_tan t t_encad) (local_derivable_pt_tan t t_encad)) ; + rewrite <- Temp ; clear Temp. + assert (Temp := derive_pt_tan t t_encad) ; rewrite Temp ; clear Temp. + apply plus_Rsqr_gt_0. Qed. @@ -372,43 +372,43 @@ Lemma exists_atan_in_frame : forall lb ub y, tan lb < y < tan ub -> {x | lb < x < ub /\ tan x = y}. Proof. -intros lb ub y lb_lt_ub lb_cond ub_cond y_encad. -case y_encad ; intros y_encad1 y_encad2. -assert (f_cont : forall a : R, lb <= a <= ub -> continuity_pt tan a). -{ intros a a_encad. apply derivable_continuous_pt ; apply derivable_pt_tan. - split. - - apply Rlt_le_trans with (r2:=lb) ; intuition. - - apply Rle_lt_trans with (r2:=ub) ; intuition. } -assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => tan x - y) a). -{ intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold Rdist. - intros eps eps_pos. elim (f_cont a a_encad eps eps_pos). - intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp). - exists alpha. split. - { assumption. } - intros x x_cond. - replace (tan x - y - (tan a - y)) with (tan x - tan a) by field. - exact (Temp x x_cond). } -assert (H1 : (fun x => tan x - y) lb < 0). -{ apply Rlt_minus. assumption. } -assert (H2 : 0 < (fun x => tan x - y) ub). -{ apply Rgt_minus. assumption. } -destruct (IVT_interv (fun x => tan x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx). -exists x. -destruct Hx as (Hyp,Result). -intuition. -- assert (Temp2 : x <> lb). - { intro Hfalse. rewrite Hfalse in Result. - assert (Temp2 : y <> tan lb) by (now apply Rgt_not_eq, Rlt_minus_0). - rewrite Result in H1. now apply (Rlt_irrefl 0). - } - now case H3; intros hyp; [assumption |]; rewrite hyp in Temp2. -- assert (Temp : x <> ub). - { intro Hfalse. rewrite Hfalse in Result. - assert (Temp2 : y <> tan ub). - { apply Rlt_not_eq ; assumption. } - clear - Temp2 Result. apply Temp2. - symmetry; intuition. } - case H4 ; intuition. + intros lb ub y lb_lt_ub lb_cond ub_cond y_encad. + case y_encad ; intros y_encad1 y_encad2. + assert (f_cont : forall a : R, lb <= a <= ub -> continuity_pt tan a). + { intros a a_encad. apply derivable_continuous_pt ; apply derivable_pt_tan. + split. + - apply Rlt_le_trans with (r2:=lb) ; intuition. + - apply Rle_lt_trans with (r2:=ub) ; intuition. } + assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => tan x - y) a). + { intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold Rdist. + intros eps eps_pos. elim (f_cont a a_encad eps eps_pos). + intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp). + exists alpha. split. + { assumption. } + intros x x_cond. + replace (tan x - y - (tan a - y)) with (tan x - tan a) by field. + exact (Temp x x_cond). } + assert (H1 : (fun x => tan x - y) lb < 0). + { apply Rlt_minus. assumption. } + assert (H2 : 0 < (fun x => tan x - y) ub). + { apply Rgt_minus. assumption. } + destruct (IVT_interv (fun x => tan x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx). + exists x. + destruct Hx as (Hyp,Result). + intuition. + - assert (Temp2 : x <> lb). + { intro Hfalse. rewrite Hfalse in Result. + assert (Temp2 : y <> tan lb) by (now apply Rgt_not_eq, Rlt_minus_0). + rewrite Result in H1. now apply (Rlt_irrefl 0). + } + now case H3; intros hyp; [assumption |]; rewrite hyp in Temp2. + - assert (Temp : x <> ub). + { intro Hfalse. rewrite Hfalse in Result. + assert (Temp2 : y <> tan ub). + { apply Rlt_not_eq ; assumption. } + clear - Temp2 Result. apply Temp2. + symmetry; intuition. } + case H4 ; intuition. Qed. (*********************************************************) @@ -419,21 +419,21 @@ Qed. Lemma tan_1_gt_1 : tan 1 > 1. Proof. -assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); lra). -assert (t1 : cos 1 <= 1 - 1/2 + 1/24). -{ destruct (pre_cos_bound 1 0) as [_ t]; try lra; revert t. - unfold cos_approx, cos_term; simpl; intros t; apply Rle_trans with (1:=t). - clear t; apply Req_le; field. } -assert (t2 : 1 - 1/6 <= sin 1). -{ destruct (pre_sin_bound 1 0) as [t _]; try lra; revert t. - unfold sin_approx, sin_term; simpl; intros t; apply Rle_trans with (2:=t). - clear t; apply Req_le; field. } -pattern 1 at 2; replace 1 with - (cos 1 / cos 1) by (field; apply Rgt_not_eq; lra). -apply Rlt_gt; apply (Rmult_lt_compat_r (/ cos 1) (cos 1) (sin 1)). -{ apply Rinv_0_lt_compat; assumption. } -apply Rle_lt_trans with (1 := t1); apply Rlt_le_trans with (2 := t2). -lra. + assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); lra). + assert (t1 : cos 1 <= 1 - 1/2 + 1/24). + { destruct (pre_cos_bound 1 0) as [_ t]; try lra; revert t. + unfold cos_approx, cos_term; simpl; intros t; apply Rle_trans with (1:=t). + clear t; apply Req_le; field. } + assert (t2 : 1 - 1/6 <= sin 1). + { destruct (pre_sin_bound 1 0) as [t _]; try lra; revert t. + unfold sin_approx, sin_term; simpl; intros t; apply Rle_trans with (2:=t). + clear t; apply Req_le; field. } + pattern 1 at 2; replace 1 with + (cos 1 / cos 1) by (field; apply Rgt_not_eq; lra). + apply Rlt_gt; apply (Rmult_lt_compat_r (/ cos 1) (cos 1) (sin 1)). + { apply Rinv_0_lt_compat; assumption. } + apply Rle_lt_trans with (1 := t1); apply Rlt_le_trans with (2 := t2). + lra. Qed. Lemma sin_lt_x x : 0 < x -> sin x < x. @@ -454,77 +454,77 @@ Qed. Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}. Proof. -destruct (total_order_T (Rabs y) 1) as [Hs|Hgt]. -{ assert (yle1 : Rabs y <= 1) by (destruct Hs; lra). - clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ]. - apply Rle_lt_trans with (1 := yle1); exact tan_1_gt_1. } -assert (0 < / (Rabs y + 1)). -{ apply Rinv_0_lt_compat; lra. } -set (u := /2 * / (Rabs y + 1)). -assert (0 < u). -{ apply Rmult_lt_0_compat; [lra | assumption]. } -assert (vlt1 : / (Rabs y + 1) < 1). -{ apply Rmult_lt_reg_r with (Rabs y + 1). - { assert (t := Rabs_pos y); lra. } - rewrite Rinv_l; [rewrite Rmult_1_l | apply Rgt_not_eq]; lra. } -assert (vlt2 : u < 1). -{ apply Rlt_trans with (/ (Rabs y + 1)). - { rewrite <-Rplus_half_diag. - assert (t : forall x, 0 < x -> x < x + x) by (clear; intros; lra). - unfold u; rewrite Rmult_comm; apply t. - unfold Rdiv; rewrite Rmult_comm; assumption. } - assumption. } -assert(int : 0 < PI / 2 - u < PI / 2). -{ split. - { assert (t := PI2_1); apply Rlt_0_minus, Rlt_trans with (2 := t); assumption. } - assert (dumb : forall x y, 0 < y -> x - y < x) by (clear; intros; lra). - apply dumb; clear dumb; assumption. } -exists (PI/2 - u). -assert (0 < sin u). -{ apply sin_gt_0;[ assumption | ]. - assert (t := PI2_Rlt_PI); assert (t' := PI2_1). - apply Rlt_trans with (2 := Rlt_trans _ _ _ t' t); assumption. } -split. -{ assumption. } -apply Rlt_trans with (/2 * / cos(PI / 2 - u)). -- rewrite cos_shift. - assert (sin u < u) by (apply sin_lt_x;assumption). - apply Rlt_trans with (Rabs y + 1);[lra | ]. - rewrite <- (Rinv_inv (Rabs y + 1)). - rewrite <- Rinv_mult. - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat. - { apply Rmult_lt_0_compat;[lra | assumption]. } + destruct (total_order_T (Rabs y) 1) as [Hs|Hgt]. + { assert (yle1 : Rabs y <= 1) by (destruct Hs; lra). + clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ]. + apply Rle_lt_trans with (1 := yle1); exact tan_1_gt_1. } + assert (0 < / (Rabs y + 1)). + { apply Rinv_0_lt_compat; lra. } + set (u := /2 * / (Rabs y + 1)). + assert (0 < u). + { apply Rmult_lt_0_compat; [lra | assumption]. } + assert (vlt1 : / (Rabs y + 1) < 1). + { apply Rmult_lt_reg_r with (Rabs y + 1). + { assert (t := Rabs_pos y); lra. } + rewrite Rinv_l; [rewrite Rmult_1_l | apply Rgt_not_eq]; lra. } + assert (vlt2 : u < 1). + { apply Rlt_trans with (/ (Rabs y + 1)). + { rewrite <-Rplus_half_diag. + assert (t : forall x, 0 < x -> x < x + x) by (clear; intros; lra). + unfold u; rewrite Rmult_comm; apply t. + unfold Rdiv; rewrite Rmult_comm; assumption. } assumption. } - replace (/(Rabs y + 1)) with (2 * u). - { lra. } - unfold u; field; apply Rgt_not_eq; clear -Hgt; lra. -- unfold tan. - set (u' := PI / 2); unfold Rdiv; apply Rmult_lt_compat_r; unfold u'. - { apply Rinv_0_lt_compat. - rewrite cos_shift; assumption. } - assert (vlt3 : u < /4). - { replace (/4) with (/2 * /2) by field. - unfold u; apply Rmult_lt_compat_l;[lra | ]. - apply Rinv_lt_contravar;lra. } - assert (1 < PI / 2 - u) by (assert (t := PI2_3_2); lra). - apply Rlt_trans with (sin 1). - { assert (t' : 1 <= 4) by lra. - destruct (pre_sin_bound 1 0 (Rlt_le _ _ Rlt_0_1) t') as [t _]. - apply Rlt_le_trans with (2 := t); clear t. - simpl plus; replace (sin_approx 1 1) with (5/6);[lra | ]. - unfold sin_approx, sin_term; simpl; field. } - apply sin_increasing_1. - + assert (t := PI2_1); lra. - + apply Rlt_le, PI2_1. - + assert (t := PI2_1); lra. - + lra. - + assumption. + assert(int : 0 < PI / 2 - u < PI / 2). + { split. + { assert (t := PI2_1); apply Rlt_0_minus, Rlt_trans with (2 := t); assumption. } + assert (dumb : forall x y, 0 < y -> x - y < x) by (clear; intros; lra). + apply dumb; clear dumb; assumption. } + exists (PI/2 - u). + assert (0 < sin u). + { apply sin_gt_0;[ assumption | ]. + assert (t := PI2_Rlt_PI); assert (t' := PI2_1). + apply Rlt_trans with (2 := Rlt_trans _ _ _ t' t); assumption. } + split. + { assumption. } + apply Rlt_trans with (/2 * / cos(PI / 2 - u)). + - rewrite cos_shift. + assert (sin u < u) by (apply sin_lt_x;assumption). + apply Rlt_trans with (Rabs y + 1);[lra | ]. + rewrite <- (Rinv_inv (Rabs y + 1)). + rewrite <- Rinv_mult. + apply Rinv_lt_contravar. + { apply Rmult_lt_0_compat. + { apply Rmult_lt_0_compat;[lra | assumption]. } + assumption. } + replace (/(Rabs y + 1)) with (2 * u). + { lra. } + unfold u; field; apply Rgt_not_eq; clear -Hgt; lra. + - unfold tan. + set (u' := PI / 2); unfold Rdiv; apply Rmult_lt_compat_r; unfold u'. + { apply Rinv_0_lt_compat. + rewrite cos_shift; assumption. } + assert (vlt3 : u < /4). + { replace (/4) with (/2 * /2) by field. + unfold u; apply Rmult_lt_compat_l;[lra | ]. + apply Rinv_lt_contravar;lra. } + assert (1 < PI / 2 - u) by (assert (t := PI2_3_2); lra). + apply Rlt_trans with (sin 1). + { assert (t' : 1 <= 4) by lra. + destruct (pre_sin_bound 1 0 (Rlt_le _ _ Rlt_0_1) t') as [t _]. + apply Rlt_le_trans with (2 := t); clear t. + simpl plus; replace (sin_approx 1 1) with (5/6);[lra | ]. + unfold sin_approx, sin_term; simpl; field. } + apply sin_increasing_1. + + assert (t := PI2_1); lra. + + apply Rlt_le, PI2_1. + + assert (t := PI2_1); lra. + + lra. + + assumption. Qed. Lemma ub_opp : forall x, x < PI/2 -> -PI/2 < -x. Proof. -intros x h; rewrite Rdiv_opp_l; apply Ropp_lt_contravar; assumption. + intros x h; rewrite Rdiv_opp_l; apply Ropp_lt_contravar; assumption. Qed. Lemma pos_opp_lt : forall x, 0 < x -> -x < x. @@ -532,18 +532,18 @@ Proof. intros; lra. Qed. Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y. Proof. -intros; rewrite tan_neg; assumption. + intros; rewrite tan_neg; assumption. Qed. Definition pre_atan (y : R) : {x : R | -PI/2 < x < PI/2 /\ tan x = y}. Proof. -destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]]. -set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub))) - (proj1 (Rabs_def2 _ _ Ptan_ub)))). -destruct (exists_atan_in_frame (-ub) ub y (pos_opp_lt _ ub0) (ub_opp _ ubpi2) - ubpi2 pr) as [v [[vl vu] vq]]. -exists v; clear pr. -split;[rewrite Rdiv_opp_l; split; lra | assumption]. + destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]]. + set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub))) + (proj1 (Rabs_def2 _ _ Ptan_ub)))). + destruct (exists_atan_in_frame (-ub) ub y (pos_opp_lt _ ub0) (ub_opp _ ubpi2) + ubpi2 pr) as [v [[vl vu] vq]]. + exists v; clear pr. + split;[rewrite Rdiv_opp_l; split; lra | assumption]. Qed. Definition atan x := let (v, _) := pre_atan x in v. @@ -551,13 +551,13 @@ Definition atan x := let (v, _) := pre_atan x in v. Lemma atan_bound : forall x, -PI/2 < atan x < PI/2. Proof. -intros x; unfold atan; destruct (pre_atan x) as [v [int _]]; exact int. + intros x; unfold atan; destruct (pre_atan x) as [v [int _]]; exact int. Qed. Lemma tan_atan : forall x, tan (atan x) = x. Proof. -intros x; unfold atan; destruct (pre_atan x) as [v [_ q]]; exact q. + intros x; unfold atan; destruct (pre_atan x) as [v [_ q]]; exact q. Qed. Notation atan_right_inv := tan_atan (only parsing). (* compat *) @@ -565,138 +565,138 @@ Notation atan_right_inv := tan_atan (only parsing). (* compat *) Lemma atan_opp : forall x, atan (- x) = - atan x. Proof. -intros x; generalize (atan_bound (-x)); rewrite Rdiv_opp_l;intros [a b]. -generalize (atan_bound x); rewrite Rdiv_opp_l; intros [c d]. -apply tan_inj; try rewrite Rdiv_opp_l; try split; try lra. -rewrite tan_neg, !tan_atan; reflexivity. + intros x; generalize (atan_bound (-x)); rewrite Rdiv_opp_l;intros [a b]. + generalize (atan_bound x); rewrite Rdiv_opp_l; intros [c d]. + apply tan_inj; try rewrite Rdiv_opp_l; try split; try lra. + rewrite tan_neg, !tan_atan; reflexivity. Qed. Lemma derivable_pt_atan : forall x, derivable_pt atan x. Proof. -intros x. -destruct (frame_tan x) as [ub [[ub0 ubpi] P]]. -assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. -assert (xint : tan(-ub) < x < tan ub). -{ assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, P. - rewrite tan_neg; tauto. } -assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> - comp tan atan x = id x). -{ intros; apply tan_atan. } -assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> - -ub <= atan y <= ub). -{ clear -ub0 ubpi; intros y lo up; split. - { destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. - assert (y < tan (-ub)). + intros x. + destruct (frame_tan x) as [ub [[ub0 ubpi] P]]. + assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. + assert (xint : tan(-ub) < x < tan ub). + { assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, P. + rewrite tan_neg; tauto. } + assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> + comp tan atan x = id x). + { intros; apply tan_atan. } + assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> + -ub <= atan y <= ub). + { clear -ub0 ubpi; intros y lo up; split. + { destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. + assert (y < tan (-ub)). + { rewrite <- (tan_atan y); apply tan_increasing. + - destruct (atan_bound y); assumption. + - assumption. + - lra. } + lra. } + destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. + assert (tan ub < y). { rewrite <- (tan_atan y); apply tan_increasing. - - destruct (atan_bound y); assumption. + - rewrite Rdiv_opp_l; lra. - assumption. - - lra. } + - destruct (atan_bound y); assumption. } lra. } - destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. - assert (tan ub < y). - { rewrite <- (tan_atan y); apply tan_increasing. + assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). + { intros y z l yz u; apply tan_increasing. - rewrite Rdiv_opp_l; lra. - assumption. - - destruct (atan_bound y); assumption. } - lra. } -assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). -{ intros y z l yz u; apply tan_increasing. - - rewrite Rdiv_opp_l; lra. - - assumption. - - lra. } -assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). -{ intros a [la ua]; apply derivable_pt_tan. - rewrite Rdiv_opp_l; split; lra. } -assert (df_neq : derive_pt - tan (atan x) - (derivable_pt_recip_interv_prelim1 tan atan (- ub) ub x lb_lt_ub xint int_tan der) - <> 0). -{ rewrite <- (pr_nu tan (atan x) (derivable_pt_tan (atan x) (atan_bound x))). - rewrite derive_pt_tan. - solve[apply Rgt_not_eq, plus_Rsqr_gt_0]. } -apply (derivable_pt_recip_interv - tan atan (-ub) ub x - lb_lt_ub xint inv_p int_tan incr der). -exact df_neq. + - lra. } + assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). + { intros a [la ua]; apply derivable_pt_tan. + rewrite Rdiv_opp_l; split; lra. } + assert (df_neq : derive_pt + tan (atan x) + (derivable_pt_recip_interv_prelim1 tan atan (- ub) ub x lb_lt_ub xint int_tan der) + <> 0). + { rewrite <- (pr_nu tan (atan x) (derivable_pt_tan (atan x) (atan_bound x))). + rewrite derive_pt_tan. + solve[apply Rgt_not_eq, plus_Rsqr_gt_0]. } + apply (derivable_pt_recip_interv + tan atan (-ub) ub x + lb_lt_ub xint inv_p int_tan incr der). + exact df_neq. Qed. Lemma atan_increasing : forall x y, x < y -> atan x < atan y. Proof. -intros x y d. -assert (t1 := atan_bound x). -assert (t2 := atan_bound y). -destruct (Rlt_le_dec (atan x) (atan y)) as [lt | bad]. -{ assumption. } -apply Rlt_not_le in d. -case d. -rewrite <- (tan_atan y), <- (tan_atan x). -destruct bad as [ylt | yx]. -{ apply Rlt_le, tan_increasing; try tauto. } -solve[rewrite yx; apply Rle_refl]. + intros x y d. + assert (t1 := atan_bound x). + assert (t2 := atan_bound y). + destruct (Rlt_le_dec (atan x) (atan y)) as [lt | bad]. + { assumption. } + apply Rlt_not_le in d. + case d. + rewrite <- (tan_atan y), <- (tan_atan x). + destruct bad as [ylt | yx]. + { apply Rlt_le, tan_increasing; try tauto. } + solve[rewrite yx; apply Rle_refl]. Qed. Lemma atan_0 : atan 0 = 0. Proof. -apply tan_inj; try (apply atan_bound). -{ assert (t := PI_RGT_0); rewrite Rdiv_opp_l; split; lra. } -rewrite tan_atan, tan_0. -reflexivity. + apply tan_inj; try (apply atan_bound). + { assert (t := PI_RGT_0); rewrite Rdiv_opp_l; split; lra. } + rewrite tan_atan, tan_0. + reflexivity. Qed. Lemma atan_eq0 : forall x, atan x = 0 -> x = 0. Proof. -intros x. -generalize (atan_increasing 0 x) (atan_increasing x 0). -rewrite atan_0. -lra. + intros x. + generalize (atan_increasing 0 x) (atan_increasing x 0). + rewrite atan_0. + lra. Qed. Lemma atan_1 : atan 1 = PI/4. Proof. -assert (ut := PI_RGT_0). -assert (-PI/2 < PI/4 < PI/2) by (rewrite Rdiv_opp_l; split; lra). -assert (t := atan_bound 1). -apply tan_inj; auto. -rewrite tan_PI4, tan_atan; reflexivity. + assert (ut := PI_RGT_0). + assert (-PI/2 < PI/4 < PI/2) by (rewrite Rdiv_opp_l; split; lra). + assert (t := atan_bound 1). + apply tan_inj; auto. + rewrite tan_PI4, tan_atan; reflexivity. Qed. Lemma atan_tan : forall x, - (PI / 2) < x < PI / 2 -> atan (tan x) = x. Proof. -intros x xB. -apply tan_inj. -- now apply atan_bound. -- lra. -- now apply tan_atan. + intros x xB. + apply tan_inj. + - now apply atan_bound. + - lra. + - now apply tan_atan. Qed. Lemma atan_inv : forall x, (0 < x)%R -> atan (/ x) = (PI / 2 - atan x)%R. Proof. -intros x Hx. -apply tan_inj. -- apply atan_bound. -- split. - + apply Rlt_trans with R0. - * unfold Rdiv. - rewrite Ropp_mult_distr_l_reverse. - apply Ropp_lt_gt_0_contravar. - apply PI2_RGT_0. - * apply Rgt_minus. - apply atan_bound. - + apply Rplus_lt_reg_r with (atan x - PI / 2)%R. - ring_simplify. - rewrite <- atan_0. - now apply atan_increasing. -- rewrite tan_atan. - unfold tan. - rewrite sin_shift. - rewrite cos_shift. - rewrite <- Rinv_div. - apply f_equal, sym_eq, tan_atan. + intros x Hx. + apply tan_inj. + - apply atan_bound. + - split. + + apply Rlt_trans with R0. + * unfold Rdiv. + rewrite Ropp_mult_distr_l_reverse. + apply Ropp_lt_gt_0_contravar. + apply PI2_RGT_0. + * apply Rgt_minus. + apply atan_bound. + + apply Rplus_lt_reg_r with (atan x - PI / 2)%R. + ring_simplify. + rewrite <- atan_0. + now apply atan_increasing. + - rewrite tan_atan. + unfold tan. + rewrite sin_shift. + rewrite cos_shift. + rewrite <- Rinv_div. + apply f_equal, sym_eq, tan_atan. Qed. (** ** Derivative of arctangent *) @@ -704,69 +704,69 @@ Qed. Lemma derive_pt_atan : forall x, derive_pt atan x (derivable_pt_atan x) = 1 / (1 + x²). Proof. -intros x. -destruct (frame_tan x) as [ub [[ub0 ubpi] Pub]]. -assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. -assert (xint : tan(-ub) < x < tan ub). -{ assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, Pub. - rewrite tan_neg; tauto. } -assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> - comp tan atan x = id x). -{ intros; apply tan_atan. } -assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> - -ub <= atan y <= ub). -{ clear -ub0 ubpi; intros y lo up; split. - { destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. - assert (y < tan (-ub)). + intros x. + destruct (frame_tan x) as [ub [[ub0 ubpi] Pub]]. + assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. + assert (xint : tan(-ub) < x < tan ub). + { assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, Pub. + rewrite tan_neg; tauto. } + assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> + comp tan atan x = id x). + { intros; apply tan_atan. } + assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> + -ub <= atan y <= ub). + { clear -ub0 ubpi; intros y lo up; split. + { destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. + assert (y < tan (-ub)). + { rewrite <- (tan_atan y); apply tan_increasing. + - destruct (atan_bound y); assumption. + - assumption. + - lra. } + lra. } + destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. + assert (tan ub < y). { rewrite <- (tan_atan y); apply tan_increasing. - - destruct (atan_bound y); assumption. + - rewrite Rdiv_opp_l; lra. - assumption. - - lra. } + - destruct (atan_bound y); assumption. } lra. } - destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. - assert (tan ub < y). - { rewrite <- (tan_atan y); apply tan_increasing. + assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). + { intros y z l yz u; apply tan_increasing. - rewrite Rdiv_opp_l; lra. - assumption. - - destruct (atan_bound y); assumption. } - lra. } -assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). -{ intros y z l yz u; apply tan_increasing. - - rewrite Rdiv_opp_l; lra. - - assumption. - - lra. } -assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). -{ intros a [la ua]; apply derivable_pt_tan. - rewrite Rdiv_opp_l; split; lra. } -assert (df_neq : derive_pt tan (atan x) - (derivable_pt_recip_interv_prelim1 - tan atan - (- ub) ub x lb_lt_ub xint int_tan der) <> 0). -{ rewrite <- (pr_nu tan (atan x) - (derivable_pt_tan (atan x) (atan_bound x))). - rewrite derive_pt_tan. - solve[apply Rgt_not_eq, plus_Rsqr_gt_0]. } -assert (t := derive_pt_recip_interv tan atan (-ub) ub x lb_lt_ub - xint incr int_tan der inv_p df_neq). -rewrite <- (pr_nu atan x (derivable_pt_recip_interv - tan atan (- ub) ub - x lb_lt_ub xint inv_p int_tan incr der df_neq)). -rewrite t. -assert (t' := atan_bound x). -rewrite <- (pr_nu tan (atan x) (derivable_pt_tan _ t')). -rewrite derive_pt_tan, tan_atan. -replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). -reflexivity. + - lra. } + assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). + { intros a [la ua]; apply derivable_pt_tan. + rewrite Rdiv_opp_l; split; lra. } + assert (df_neq : derive_pt tan (atan x) + (derivable_pt_recip_interv_prelim1 + tan atan + (- ub) ub x lb_lt_ub xint int_tan der) <> 0). + { rewrite <- (pr_nu tan (atan x) + (derivable_pt_tan (atan x) (atan_bound x))). + rewrite derive_pt_tan. + solve[apply Rgt_not_eq, plus_Rsqr_gt_0]. } + assert (t := derive_pt_recip_interv tan atan (-ub) ub x lb_lt_ub + xint incr int_tan der inv_p df_neq). + rewrite <- (pr_nu atan x (derivable_pt_recip_interv + tan atan (- ub) ub + x lb_lt_ub xint inv_p int_tan incr der df_neq)). + rewrite t. + assert (t' := atan_bound x). + rewrite <- (pr_nu tan (atan x) (derivable_pt_tan _ t')). + rewrite derive_pt_tan, tan_atan. + replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). + reflexivity. Qed. Lemma derivable_pt_lim_atan : forall x, derivable_pt_lim atan x (/ (1 + x^2)). Proof. -intros x. -apply derive_pt_eq_1 with (derivable_pt_atan x). -replace (x ^ 2) with (x * x) by ring. -rewrite <- (Rmult_1_l (Rinv _)). -apply derive_pt_atan. + intros x. + apply derive_pt_eq_1 with (derivable_pt_atan x). + replace (x ^ 2) with (x * x) by ring. + rewrite <- (Rmult_1_l (Rinv _)). + apply derive_pt_atan. Qed. (** ** Definition of the arctangent function as the sum of the arctan power series *) @@ -778,162 +778,162 @@ Definition Ratan_seq x := fun n => (x ^ (2 * n + 1) / INR (2 * n + 1))%R. Lemma Ratan_seq_decreasing : forall x, (0 <= x <= 1)%R -> Un_decreasing (Ratan_seq x). Proof. -intros x Hx n. -unfold Ratan_seq, Rdiv. -apply Rmult_le_compat. -- apply pow_le. - exact (proj1 Hx). -- apply Rlt_le. - apply Rinv_0_lt_compat. - apply lt_INR_0. - lia. -- destruct (proj1 Hx) as [Hx1|Hx1]. - 1:destruct (proj2 Hx) as [Hx2|Hx2]. - + (* . 0 < x < 1 *) - rewrite <- (Rinv_inv x). - repeat rewrite (pow_inv (/ x)). - apply Rlt_le. - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat ; apply pow_lt ; auto with real. } - apply Rlt_pow. - { rewrite <- Rinv_1. + intros x Hx n. + unfold Ratan_seq, Rdiv. + apply Rmult_le_compat. + - apply pow_le. + exact (proj1 Hx). + - apply Rlt_le. + apply Rinv_0_lt_compat. + apply lt_INR_0. + lia. + - destruct (proj1 Hx) as [Hx1|Hx1]. + 1:destruct (proj2 Hx) as [Hx2|Hx2]. + + (* . 0 < x < 1 *) + rewrite <- (Rinv_inv x). + repeat rewrite (pow_inv (/ x)). + apply Rlt_le. apply Rinv_lt_contravar. - { rewrite Rmult_1_r. - exact Hx1. } - exact Hx2. } + { apply Rmult_lt_0_compat ; apply pow_lt ; auto with real. } + apply Rlt_pow. + { rewrite <- Rinv_1. + apply Rinv_lt_contravar. + { rewrite Rmult_1_r. + exact Hx1. } + exact Hx2. } + lia. + + (* . x = 1 *) + rewrite Hx2. + do 2 rewrite pow1. + apply Rle_refl. + + (* . x = 0 *) + rewrite <- Hx1. + do 2 (rewrite pow_i ; [ idtac | lia ]). + apply Rle_refl. + - apply Rlt_le. + apply Rinv_lt_contravar. + { apply Rmult_lt_0_compat ; apply lt_INR_0 ; lia. } + apply lt_INR. lia. - + (* . x = 1 *) - rewrite Hx2. - do 2 rewrite pow1. - apply Rle_refl. - + (* . x = 0 *) - rewrite <- Hx1. - do 2 (rewrite pow_i ; [ idtac | lia ]). - apply Rle_refl. -- apply Rlt_le. - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat ; apply lt_INR_0 ; lia. } - apply lt_INR. - lia. Qed. Lemma Ratan_seq_converging : forall x, (0 <= x <= 1)%R -> Un_cv (Ratan_seq x) 0. Proof. -intros x Hx eps Heps. -destruct (archimed (/ eps)) as (HN,_). -assert (0 < up (/ eps))%Z. -{ apply lt_IZR. - apply Rlt_trans with (2 := HN). - apply Rinv_0_lt_compat. - exact Heps. } -case_eq (up (/ eps)) ; - intros ; rewrite H0 in H ; try discriminate H. -rewrite H0 in HN. -simpl in HN. -pose (N := Pos.to_nat p). -fold N in HN. -clear H H0. -exists N. -intros n Hn. -unfold Rdist. -rewrite Rminus_0_r. -unfold Ratan_seq. -rewrite Rabs_right. -2:{ apply Rle_ge. - unfold Rdiv. - apply Rmult_le_pos. - { apply pow_le. - exact (proj1 Hx). } - apply Rlt_le. - apply Rinv_0_lt_compat. - apply lt_INR_0. - lia. } -apply Rle_lt_trans with (1 ^ (2 * n + 1) / INR (2 * n + 1))%R. -{ unfold Rdiv. - apply Rmult_le_compat_r. - { apply Rlt_le. - apply Rinv_0_lt_compat. - apply lt_INR_0. - lia. } - apply pow_incr. - exact Hx. } -rewrite pow1. -apply Rle_lt_trans with (/ INR (2 * N + 1))%R. -{ unfold Rdiv. - rewrite Rmult_1_l. - apply Rinv_le_contravar. - { apply lt_INR_0. - lia. } - apply le_INR. - lia. } -rewrite <- (Rinv_inv eps). -apply Rinv_lt_contravar. -{ apply Rmult_lt_0_compat. - { auto with real. } - apply lt_INR_0. - lia. } -apply Rlt_trans with (INR N). -{ destruct (archimed (/ eps)) as (H,_). + intros x Hx eps Heps. + destruct (archimed (/ eps)) as (HN,_). assert (0 < up (/ eps))%Z. { apply lt_IZR. - apply Rlt_trans with (2 := H). + apply Rlt_trans with (2 := HN). apply Rinv_0_lt_compat. exact Heps. } - unfold N. - rewrite INR_IZR_INZ, positive_nat_Z. - exact HN. } -apply lt_INR. -lia. + case_eq (up (/ eps)) ; + intros ; rewrite H0 in H ; try discriminate H. + rewrite H0 in HN. + simpl in HN. + pose (N := Pos.to_nat p). + fold N in HN. + clear H H0. + exists N. + intros n Hn. + unfold Rdist. + rewrite Rminus_0_r. + unfold Ratan_seq. + rewrite Rabs_right. + 2:{ apply Rle_ge. + unfold Rdiv. + apply Rmult_le_pos. + { apply pow_le. + exact (proj1 Hx). } + apply Rlt_le. + apply Rinv_0_lt_compat. + apply lt_INR_0. + lia. } + apply Rle_lt_trans with (1 ^ (2 * n + 1) / INR (2 * n + 1))%R. + { unfold Rdiv. + apply Rmult_le_compat_r. + { apply Rlt_le. + apply Rinv_0_lt_compat. + apply lt_INR_0. + lia. } + apply pow_incr. + exact Hx. } + rewrite pow1. + apply Rle_lt_trans with (/ INR (2 * N + 1))%R. + { unfold Rdiv. + rewrite Rmult_1_l. + apply Rinv_le_contravar. + { apply lt_INR_0. + lia. } + apply le_INR. + lia. } + rewrite <- (Rinv_inv eps). + apply Rinv_lt_contravar. + { apply Rmult_lt_0_compat. + { auto with real. } + apply lt_INR_0. + lia. } + apply Rlt_trans with (INR N). + { destruct (archimed (/ eps)) as (H,_). + assert (0 < up (/ eps))%Z. + { apply lt_IZR. + apply Rlt_trans with (2 := H). + apply Rinv_0_lt_compat. + exact Heps. } + unfold N. + rewrite INR_IZR_INZ, positive_nat_Z. + exact HN. } + apply lt_INR. + lia. Qed. Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) : {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}. Proof. -exact (alternated_series (Ratan_seq x) - (Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)). + exact (alternated_series (Ratan_seq x) + (Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)). Defined. Lemma Ratan_seq_opp : forall x n, Ratan_seq (-x) n = -Ratan_seq x n. Proof. -intros x n; unfold Ratan_seq. -rewrite !pow_add, !pow_mult, !pow_1. -unfold Rdiv; replace ((-x) ^ 2) with (x ^ 2) by ring; ring. + intros x n; unfold Ratan_seq. + rewrite !pow_add, !pow_mult, !pow_1. + unfold Rdiv; replace ((-x) ^ 2) with (x ^ 2) by ring; ring. Qed. Lemma sum_Ratan_seq_opp : forall x n, sum_f_R0 (tg_alt (Ratan_seq (- x))) n = - sum_f_R0 (tg_alt (Ratan_seq x)) n. Proof. -intros x n; replace (-sum_f_R0 (tg_alt (Ratan_seq x)) n) with - (-1 * sum_f_R0 (tg_alt (Ratan_seq x)) n) by ring. -rewrite scal_sum; apply sum_eq; intros i _; unfold tg_alt. -rewrite Ratan_seq_opp; ring. + intros x n; replace (-sum_f_R0 (tg_alt (Ratan_seq x)) n) with + (-1 * sum_f_R0 (tg_alt (Ratan_seq x)) n) by ring. + rewrite scal_sum; apply sum_eq; intros i _; unfold tg_alt. + rewrite Ratan_seq_opp; ring. Qed. Definition ps_atan_exists_1 (x : R) (Hx : -1 <= x <= 1) : {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}. Proof. -destruct (Rle_lt_dec 0 x). -{ assert (pr : 0 <= x <= 1) by tauto. - exact (ps_atan_exists_01 x pr). } -assert (pr : 0 <= -x <= 1) by (destruct Hx; split; lra). -destruct (ps_atan_exists_01 _ pr) as [v Pv]. -exists (-v). -apply (Un_cv_ext (fun n => (- 1) * sum_f_R0 (tg_alt (Ratan_seq (- x))) n)). -{ intros n; rewrite sum_Ratan_seq_opp; ring. } -replace (-v) with (-1 * v) by ring. -apply CV_mult;[ | assumption]. -solve[intros; exists 0%nat; intros; rewrite Rdist_eq; auto]. + destruct (Rle_lt_dec 0 x). + { assert (pr : 0 <= x <= 1) by tauto. + exact (ps_atan_exists_01 x pr). } + assert (pr : 0 <= -x <= 1) by (destruct Hx; split; lra). + destruct (ps_atan_exists_01 _ pr) as [v Pv]. + exists (-v). + apply (Un_cv_ext (fun n => (- 1) * sum_f_R0 (tg_alt (Ratan_seq (- x))) n)). + { intros n; rewrite sum_Ratan_seq_opp; ring. } + replace (-v) with (-1 * v) by ring. + apply CV_mult;[ | assumption]. + solve[intros; exists 0%nat; intros; rewrite Rdist_eq; auto]. Qed. Definition in_int (x : R) : {-1 <= x <= 1}+{~ -1 <= x <= 1}. Proof. -destruct (Rle_lt_dec x 1). -1:destruct (Rle_lt_dec (-1) x). -- left;split; auto. -- right;intros [a1 a2]; lra. -- right;intros [a1 a2]; lra. + destruct (Rle_lt_dec x 1). + 1:destruct (Rle_lt_dec (-1) x). + - left;split; auto. + - right;intros [a1 a2]; lra. + - right;intros [a1 a2]; lra. Qed. Definition ps_atan (x : R) : R := @@ -946,46 +946,46 @@ Definition ps_atan (x : R) : R := Lemma ps_atan0_0 : ps_atan 0 = 0. Proof. -unfold ps_atan. -destruct (in_int 0) as [h1 | h2]. -{ destruct (ps_atan_exists_1 0 h1) as [v P]. - apply (UL_sequence _ _ _ P). - apply (Un_cv_ext (fun n => 0)). - { symmetry;apply sum_eq_R0. - intros i _; unfold tg_alt, Ratan_seq; rewrite Nat.add_comm; simpl. - unfold Rdiv; rewrite !Rmult_0_l, Rmult_0_r; reflexivity. } - intros eps ep; exists 0%nat; intros n _; unfold Rdist. - rewrite Rminus_0_r, Rabs_pos_eq; auto with real. } -case h2; split; lra. + unfold ps_atan. + destruct (in_int 0) as [h1 | h2]. + { destruct (ps_atan_exists_1 0 h1) as [v P]. + apply (UL_sequence _ _ _ P). + apply (Un_cv_ext (fun n => 0)). + { symmetry;apply sum_eq_R0. + intros i _; unfold tg_alt, Ratan_seq; rewrite Nat.add_comm; simpl. + unfold Rdiv; rewrite !Rmult_0_l, Rmult_0_r; reflexivity. } + intros eps ep; exists 0%nat; intros n _; unfold Rdist. + rewrite Rminus_0_r, Rabs_pos_eq; auto with real. } + case h2; split; lra. Qed. Lemma ps_atan_exists_1_opp : forall x h h', proj1_sig (ps_atan_exists_1 (-x) h) = -(proj1_sig (ps_atan_exists_1 x h')). Proof. -intros x h h'; destruct (ps_atan_exists_1 (-x) h) as [v Pv]. -destruct (ps_atan_exists_1 x h') as [u Pu]; simpl. -assert (Pu' : Un_cv (fun N => (-1) * sum_f_R0 (tg_alt (Ratan_seq x)) N) (-1 * u)). -{ apply CV_mult;[ | assumption]. - intros eps ep; exists 0%nat; intros; rewrite Rdist_eq; assumption. } -assert (Pv' : Un_cv - (fun N : nat => -1 * sum_f_R0 (tg_alt (Ratan_seq x)) N) v). -{ apply Un_cv_ext with (2 := Pv); intros n; rewrite sum_Ratan_seq_opp; ring. } -replace (-u) with (-1 * u) by ring. -apply UL_sequence with (1:=Pv') (2:= Pu'). + intros x h h'; destruct (ps_atan_exists_1 (-x) h) as [v Pv]. + destruct (ps_atan_exists_1 x h') as [u Pu]; simpl. + assert (Pu' : Un_cv (fun N => (-1) * sum_f_R0 (tg_alt (Ratan_seq x)) N) (-1 * u)). + { apply CV_mult;[ | assumption]. + intros eps ep; exists 0%nat; intros; rewrite Rdist_eq; assumption. } + assert (Pv' : Un_cv + (fun N : nat => -1 * sum_f_R0 (tg_alt (Ratan_seq x)) N) v). + { apply Un_cv_ext with (2 := Pv); intros n; rewrite sum_Ratan_seq_opp; ring. } + replace (-u) with (-1 * u) by ring. + apply UL_sequence with (1:=Pv') (2:= Pu'). Qed. Lemma ps_atan_opp : forall x, ps_atan (-x) = -ps_atan x. Proof. -intros x; unfold ps_atan. -destruct (in_int (- x)) as [inside | outside]. -{ destruct (in_int x) as [ins' | outs']. - { generalize (ps_atan_exists_1_opp x inside ins'). - intros h; exact h. } - destruct inside; case outs'; split; lra. } -destruct (in_int x) as [ins' | outs']. -{ destruct outside; case ins'; split; lra. } -apply atan_opp. + intros x; unfold ps_atan. + destruct (in_int (- x)) as [inside | outside]. + { destruct (in_int x) as [ins' | outs']. + { generalize (ps_atan_exists_1_opp x inside ins'). + intros h; exact h. } + destruct inside; case outs'; split; lra. } + destruct (in_int x) as [ins' | outs']. + { destruct outside; case ins'; split; lra. } + apply atan_opp. Qed. (** atan = ps_atan *) @@ -994,63 +994,63 @@ Lemma ps_atanSeq_continuity_pt_1 : forall (N : nat) (x : R), 0 <= x -> x <= 1 -> continuity_pt (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x. Proof. - assert (Sublemma : forall (x:R) (N:nat), - sum_f_R0 (tg_alt (Ratan_seq x)) N - = x * (comp (fun x => sum_f_R0 (fun n => (fun i : nat => (-1) ^ i / INR (2 * i + 1)) n * x ^ n) N) - (fun x => x ^ 2) x)). -{ intros x N. - induction N. - { unfold tg_alt, Ratan_seq, comp ; simpl ; field. } - simpl sum_f_R0 at 1. - rewrite IHN. - replace (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) (S N)) (fun x => x ^ 2)) - with (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) N + (-1) ^ (S N) / INR (2 * (S N) + 1) * x ^ (S N)) (fun x => x ^ 2)) - by intuition. - unfold comp. - rewrite Rmult_plus_distr_l. - apply Rplus_eq_compat_l. - unfold tg_alt, Ratan_seq. - rewrite <- Rmult_assoc. - case (Req_dec x 0) ; intro Hyp. - { rewrite Hyp ; rewrite pow_i. - { rewrite Rmult_0_l ; rewrite Rmult_0_l. - unfold Rdiv ; rewrite Rmult_0_l ; rewrite Rmult_0_r ; reflexivity. } - intuition. } - replace (x * ((-1) ^ S N / INR (2 * S N + 1)) * (x ^ 2) ^ S N) with (x ^ (2 * S N + 1) * ((-1) ^ S N / INR (2 * S N + 1))). - { lra. } - rewrite Rmult_assoc. - replace (x * ((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N)) with (((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N) * x) by ring. - rewrite Rmult_assoc. - replace ((x ^ 2) ^ S N * x) with (x ^ (2 * S N + 1)). - { rewrite Rmult_comm at 1 ; reflexivity. } - rewrite <- pow_mult. - assert (Temp : forall x n, x ^ n * x = x ^ (n+1)). - { intros a n ; induction n. { rewrite pow_O. simpl ; intuition. } - simpl ; rewrite Rmult_assoc ; rewrite IHn ; intuition. } - rewrite Temp ; reflexivity. } -intros N x x_lb x_ub. -intros eps eps_pos. -assert (continuity_id : continuity id). -{ apply derivable_continuous ; exact derivable_id. } -assert (Temp := continuity_mult id - (comp - (fun x1 : R => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N) - (fun x1 : R => x1 ^ 2)) - continuity_id). -assert (Temp2 : continuity - (comp - (fun x1 : R => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N) - (fun x1 : R => x1 ^ 2))). -{ apply continuity_comp. - { reg. } - apply continuity_finite_sum. } -elim (Temp Temp2 x eps eps_pos) ; clear Temp Temp2 ; intros alpha T ; destruct T as (alpha_pos, T). -exists alpha ; split. -{ intuition. } -intros x0 x0_cond. -rewrite Sublemma ; rewrite Sublemma. -apply T. -intuition. + assert (Sublemma : forall (x:R) (N:nat), + sum_f_R0 (tg_alt (Ratan_seq x)) N + = x * (comp (fun x => sum_f_R0 (fun n => (fun i : nat => (-1) ^ i / INR (2 * i + 1)) n * x ^ n) N) + (fun x => x ^ 2) x)). + { intros x N. + induction N. + { unfold tg_alt, Ratan_seq, comp ; simpl ; field. } + simpl sum_f_R0 at 1. + rewrite IHN. + replace (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) (S N)) (fun x => x ^ 2)) + with (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) N + (-1) ^ (S N) / INR (2 * (S N) + 1) * x ^ (S N)) (fun x => x ^ 2)) + by intuition. + unfold comp. + rewrite Rmult_plus_distr_l. + apply Rplus_eq_compat_l. + unfold tg_alt, Ratan_seq. + rewrite <- Rmult_assoc. + case (Req_dec x 0) ; intro Hyp. + { rewrite Hyp ; rewrite pow_i. + { rewrite Rmult_0_l ; rewrite Rmult_0_l. + unfold Rdiv ; rewrite Rmult_0_l ; rewrite Rmult_0_r ; reflexivity. } + intuition. } + replace (x * ((-1) ^ S N / INR (2 * S N + 1)) * (x ^ 2) ^ S N) with (x ^ (2 * S N + 1) * ((-1) ^ S N / INR (2 * S N + 1))). + { lra. } + rewrite Rmult_assoc. + replace (x * ((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N)) with (((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N) * x) by ring. + rewrite Rmult_assoc. + replace ((x ^ 2) ^ S N * x) with (x ^ (2 * S N + 1)). + { rewrite Rmult_comm at 1 ; reflexivity. } + rewrite <- pow_mult. + assert (Temp : forall x n, x ^ n * x = x ^ (n+1)). + { intros a n ; induction n. { rewrite pow_O. simpl ; intuition. } + simpl ; rewrite Rmult_assoc ; rewrite IHn ; intuition. } + rewrite Temp ; reflexivity. } + intros N x x_lb x_ub. + intros eps eps_pos. + assert (continuity_id : continuity id). + { apply derivable_continuous ; exact derivable_id. } + assert (Temp := continuity_mult id + (comp + (fun x1 : R => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N) + (fun x1 : R => x1 ^ 2)) + continuity_id). + assert (Temp2 : continuity + (comp + (fun x1 : R => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N) + (fun x1 : R => x1 ^ 2))). + { apply continuity_comp. + { reg. } + apply continuity_finite_sum. } + elim (Temp Temp2 x eps eps_pos) ; clear Temp Temp2 ; intros alpha T ; destruct T as (alpha_pos, T). + exists alpha ; split. + { intuition. } + intros x0 x0_cond. + rewrite Sublemma ; rewrite Sublemma. + apply T. + intuition. Qed. (** Definition of ps_atan's derivative *) @@ -1061,402 +1061,402 @@ Lemma pow_lt_1_compat : forall x n, 0 <= x < 1 -> (0 < n)%nat -> 0 <= x ^ n < 1. Proof. -intros x n hx; induction 1; simpl. -{ rewrite Rmult_1_r; tauto. } -split. -{ apply Rmult_le_pos; tauto. } -rewrite <- (Rmult_1_r 1); apply Rmult_le_0_lt_compat; intuition. + intros x n hx; induction 1; simpl. + { rewrite Rmult_1_r; tauto. } + split. + { apply Rmult_le_pos; tauto. } + rewrite <- (Rmult_1_r 1); apply Rmult_le_0_lt_compat; intuition. Qed. Lemma Datan_seq_Rabs : forall x n, Datan_seq (Rabs x) n = Datan_seq x n. Proof. -intros x n; unfold Datan_seq; rewrite !pow_mult, pow2_abs; reflexivity. + intros x n; unfold Datan_seq; rewrite !pow_mult, pow2_abs; reflexivity. Qed. Lemma Datan_seq_pos : forall x n, 0 < x -> 0 < Datan_seq x n. Proof. -intros x n x_lb ; unfold Datan_seq ; induction n. -{ simpl ; intuition. } -replace (x ^ (2 * S n)) with ((x ^ 2) * (x ^ (2 * n))). -{ apply Rmult_gt_0_compat. - { replace (x^2) with (x*x) by field ; apply Rmult_gt_0_compat ; assumption. } - assumption. } -replace (2 * S n)%nat with (S (S (2 * n))) by lia. -simpl ; field. + intros x n x_lb ; unfold Datan_seq ; induction n. + { simpl ; intuition. } + replace (x ^ (2 * S n)) with ((x ^ 2) * (x ^ (2 * n))). + { apply Rmult_gt_0_compat. + { replace (x^2) with (x*x) by field ; apply Rmult_gt_0_compat ; assumption. } + assumption. } + replace (2 * S n)%nat with (S (S (2 * n))) by lia. + simpl ; field. Qed. Lemma Datan_sum_eq :forall x n, sum_f_R0 (tg_alt (Datan_seq x)) n = (1 - (- x ^ 2) ^ S n)/(1 + x ^ 2). Proof. -intros x n. -assert (dif : - x ^ 2 <> 1). -{ nra. } -replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). -apply sum_eq; unfold tg_alt, Datan_seq; intros i _. -rewrite pow_mult, <- Rpow_mult_distr. -f_equal. -ring. + intros x n. + assert (dif : - x ^ 2 <> 1). + { nra. } + replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). + apply sum_eq; unfold tg_alt, Datan_seq; intros i _. + rewrite pow_mult, <- Rpow_mult_distr. + f_equal. + ring. Qed. Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n. Proof. -intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. -assert (y_pos : y > 0). { apply Rle_lt_trans with (r2:=x) ; intuition. } -induction n. { lia. } -clear -x_encad x_pos y_pos ; induction n ; unfold Datan_seq. -{ case x_pos ; clear x_pos ; intro x_pos. - { simpl ; apply Rmult_gt_0_lt_compat ; intuition. lra. } - rewrite x_pos ; rewrite pow_i. - { replace (y ^ (2*1)) with (y*y). - { apply Rmult_gt_0_compat ; assumption. } + intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. + assert (y_pos : y > 0). { apply Rle_lt_trans with (r2:=x) ; intuition. } + induction n. { lia. } + clear -x_encad x_pos y_pos ; induction n ; unfold Datan_seq. + { case x_pos ; clear x_pos ; intro x_pos. + { simpl ; apply Rmult_gt_0_lt_compat ; intuition. lra. } + rewrite x_pos ; rewrite pow_i. + { replace (y ^ (2*1)) with (y*y). + { apply Rmult_gt_0_compat ; assumption. } + simpl ; field. } + intuition. } + assert (Hrew : forall a, a^(2 * S (S n)) = (a ^ 2) * (a ^ (2 * S n))). + { clear ; intro a ; replace (2 * S (S n))%nat with (S (S (2 * S n)))%nat by lia. simpl ; field. } - intuition. } -assert (Hrew : forall a, a^(2 * S (S n)) = (a ^ 2) * (a ^ (2 * S n))). -{ clear ; intro a ; replace (2 * S (S n))%nat with (S (S (2 * S n)))%nat by lia. - simpl ; field. } -case x_pos ; clear x_pos ; intro x_pos. -{ rewrite Hrew ; rewrite Hrew. - apply Rmult_gt_0_lt_compat ; intuition. - apply Rmult_gt_0_lt_compat ; intuition ; lra. } -rewrite x_pos. -rewrite pow_i. { intuition. } lia. + case x_pos ; clear x_pos ; intro x_pos. + { rewrite Hrew ; rewrite Hrew. + apply Rmult_gt_0_lt_compat ; intuition. + apply Rmult_gt_0_lt_compat ; intuition ; lra. } + rewrite x_pos. + rewrite pow_i. { intuition. } lia. Qed. Lemma Datan_seq_decreasing : forall x, -1 < x -> x < 1 -> Un_decreasing (Datan_seq x). Proof. -intros x x_lb x_ub n. -unfold Datan_seq. -replace (2 * S n)%nat with (2 + 2 * n)%nat by ring. -rewrite <- (Rmult_1_l (x ^ (2 * n))). -rewrite pow_add. -apply Rmult_le_compat_r. -{ rewrite pow_mult; apply pow_le, pow2_ge_0. } -apply Rlt_le; rewrite <- pow2_abs. -assert (intabs : 0 <= Rabs x < 1). -{ split;[apply Rabs_pos | apply Rabs_def1]; tauto. } -apply (pow_lt_1_compat (Rabs x) 2) in intabs. -{ tauto. } -lia. + intros x x_lb x_ub n. + unfold Datan_seq. + replace (2 * S n)%nat with (2 + 2 * n)%nat by ring. + rewrite <- (Rmult_1_l (x ^ (2 * n))). + rewrite pow_add. + apply Rmult_le_compat_r. + { rewrite pow_mult; apply pow_le, pow2_ge_0. } + apply Rlt_le; rewrite <- pow2_abs. + assert (intabs : 0 <= Rabs x < 1). + { split;[apply Rabs_pos | apply Rabs_def1]; tauto. } + apply (pow_lt_1_compat (Rabs x) 2) in intabs. + { tauto. } + lia. Qed. Lemma Datan_seq_CV_0 : forall x, -1 < x -> x < 1 -> Un_cv (Datan_seq x) 0. Proof. -intros x x_lb x_ub eps eps_pos. -assert (x_ub2 : Rabs (x^2) < 1). -{ rewrite Rabs_pos_eq;[ | apply pow2_ge_0]. - rewrite <- pow2_abs. - assert (H: 0 <= Rabs x < 1) - by (split;[apply Rabs_pos | apply Rabs_def1; auto]). - apply (pow_lt_1_compat _ 2) in H;[tauto | lia]. } -elim (pow_lt_1_zero (x^2) x_ub2 eps eps_pos) ; intros N HN ; exists N ; intros n Hn. -unfold Rdist, Datan_seq. -replace (x ^ (2 * n) - 0) with ((x ^ 2) ^ n). { apply HN ; assumption. } -rewrite pow_mult ; field. + intros x x_lb x_ub eps eps_pos. + assert (x_ub2 : Rabs (x^2) < 1). + { rewrite Rabs_pos_eq;[ | apply pow2_ge_0]. + rewrite <- pow2_abs. + assert (H: 0 <= Rabs x < 1) + by (split;[apply Rabs_pos | apply Rabs_def1; auto]). + apply (pow_lt_1_compat _ 2) in H;[tauto | lia]. } + elim (pow_lt_1_zero (x^2) x_ub2 eps eps_pos) ; intros N HN ; exists N ; intros n Hn. + unfold Rdist, Datan_seq. + replace (x ^ (2 * n) - 0) with ((x ^ 2) ^ n). { apply HN ; assumption. } + rewrite pow_mult ; field. Qed. Lemma Datan_lim : forall x, -1 < x -> x < 1 -> Un_cv (fun N : nat => sum_f_R0 (tg_alt (Datan_seq x)) N) (/ (1 + x ^ 2)). Proof. -intros x x_lb x_ub eps eps_pos. -assert (Tool0 : 0 <= x ^ 2) by apply pow2_ge_0. -assert (Tool1 : 0 < (1 + x ^ 2)). -{ solve[apply Rplus_lt_le_0_compat ; intuition]. } -assert (Tool2 : / (1 + x ^ 2) > 0). -{ apply Rinv_0_lt_compat ; tauto. } -assert (x_ub2' : 0<= Rabs (x^2) < 1). -{ rewrite Rabs_pos_eq, <- pow2_abs;[ | apply pow2_ge_0]. - apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | lia]. - apply Rabs_def1; assumption. } -assert (x_ub2 : Rabs (x^2) < 1) by tauto. -assert (eps'_pos : ((1 + x^2)*eps) > 0). -{ apply Rmult_gt_0_compat ; assumption. } -elim (pow_lt_1_zero _ x_ub2 _ eps'_pos) ; intros N HN ; exists N. -intros n Hn. -assert (H1 : - x^2 <> 1). -{ apply Rlt_not_eq; apply Rle_lt_trans with (2 := Rlt_0_1). - assert (t := pow2_ge_0 x); lra. } -rewrite Datan_sum_eq. -unfold Rdist. -assert (tool : forall a b, a / b - /b = (-1 + a) /b). -{ intros a b; rewrite <- (Rmult_1_l (/b)); unfold Rdiv, Rminus. - rewrite <- Ropp_mult_distr_l_reverse, Rmult_plus_distr_r, Rplus_comm. - reflexivity. } -set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. -unfold Rdiv, u. -change (-1) with (-(1)). -rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. -rewrite Rabs_mult; clear tool u. -assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). -{ clear -Tool0; induction k;[simpl; rewrite Rabs_R1;tauto | ]. - rewrite <- !(tech_pow_Rmult _ k), !Rabs_mult, Rabs_Ropp, IHk, Rabs_pos_eq. - { reflexivity. } - exact Tool0. } -rewrite tool, (Rabs_pos_eq (/ _)); clear tool;[ | apply Rlt_le; assumption]. -assert (tool : forall a b c, 0 < b -> a < b * c -> a * / b < c). -{ intros a b c bp h; replace c with (b * c * /b). - { apply Rmult_lt_compat_r. - { apply Rinv_0_lt_compat; assumption. } - assumption. } - field; apply Rgt_not_eq; exact bp. } -apply tool;[exact Tool1 | ]. -apply HN; lia. + intros x x_lb x_ub eps eps_pos. + assert (Tool0 : 0 <= x ^ 2) by apply pow2_ge_0. + assert (Tool1 : 0 < (1 + x ^ 2)). + { solve[apply Rplus_lt_le_0_compat ; intuition]. } + assert (Tool2 : / (1 + x ^ 2) > 0). + { apply Rinv_0_lt_compat ; tauto. } + assert (x_ub2' : 0<= Rabs (x^2) < 1). + { rewrite Rabs_pos_eq, <- pow2_abs;[ | apply pow2_ge_0]. + apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | lia]. + apply Rabs_def1; assumption. } + assert (x_ub2 : Rabs (x^2) < 1) by tauto. + assert (eps'_pos : ((1 + x^2)*eps) > 0). + { apply Rmult_gt_0_compat ; assumption. } + elim (pow_lt_1_zero _ x_ub2 _ eps'_pos) ; intros N HN ; exists N. + intros n Hn. + assert (H1 : - x^2 <> 1). + { apply Rlt_not_eq; apply Rle_lt_trans with (2 := Rlt_0_1). + assert (t := pow2_ge_0 x); lra. } + rewrite Datan_sum_eq. + unfold Rdist. + assert (tool : forall a b, a / b - /b = (-1 + a) /b). + { intros a b; rewrite <- (Rmult_1_l (/b)); unfold Rdiv, Rminus. + rewrite <- Ropp_mult_distr_l_reverse, Rmult_plus_distr_r, Rplus_comm. + reflexivity. } + set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. + unfold Rdiv, u. + change (-1) with (-(1)). + rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. + rewrite Rabs_mult; clear tool u. + assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). + { clear -Tool0; induction k;[simpl; rewrite Rabs_R1;tauto | ]. + rewrite <- !(tech_pow_Rmult _ k), !Rabs_mult, Rabs_Ropp, IHk, Rabs_pos_eq. + { reflexivity. } + exact Tool0. } + rewrite tool, (Rabs_pos_eq (/ _)); clear tool;[ | apply Rlt_le; assumption]. + assert (tool : forall a b c, 0 < b -> a < b * c -> a * / b < c). + { intros a b c bp h; replace c with (b * c * /b). + { apply Rmult_lt_compat_r. + { apply Rinv_0_lt_compat; assumption. } + assumption. } + field; apply Rgt_not_eq; exact bp. } + apply tool;[exact Tool1 | ]. + apply HN; lia. Qed. Lemma Datan_CVU_prelim : forall c (r : posreal), Rabs c + r < 1 -> CVU (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N) (fun y : R => / (1 + y ^ 2)) c r. Proof. -intros c r ub_ub eps eps_pos. -apply (Alt_CVU (fun x n => Datan_seq n x) - (fun x => /(1 + x ^ 2)) - (Datan_seq (Rabs c + r)) c r). -- intros x inb; apply Datan_seq_decreasing; - apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; lra. -- intros x inb; apply Datan_seq_CV_0; - apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; lra. -- intros x inb; apply (Datan_lim x); - apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; lra. -- intros x [ | n] inb. - { solve[unfold Datan_seq; apply Rle_refl]. } - rewrite <- (Datan_seq_Rabs x); apply Rlt_le, Datan_seq_increasing. - { lia. } - apply Boule_lt in inb; intuition. - solve[apply Rabs_pos]. -- apply Datan_seq_CV_0. - { apply Rlt_trans with 0;[lra | ]. - apply Rplus_le_lt_0_compat. - { solve[apply Rabs_pos]. } - destruct r; assumption. } - assumption. -- assumption. + intros c r ub_ub eps eps_pos. + apply (Alt_CVU (fun x n => Datan_seq n x) + (fun x => /(1 + x ^ 2)) + (Datan_seq (Rabs c + r)) c r). + - intros x inb; apply Datan_seq_decreasing; + apply Boule_lt in inb; apply Rabs_def2 in inb; + destruct inb; lra. + - intros x inb; apply Datan_seq_CV_0; + apply Boule_lt in inb; apply Rabs_def2 in inb; + destruct inb; lra. + - intros x inb; apply (Datan_lim x); + apply Boule_lt in inb; apply Rabs_def2 in inb; + destruct inb; lra. + - intros x [ | n] inb. + { solve[unfold Datan_seq; apply Rle_refl]. } + rewrite <- (Datan_seq_Rabs x); apply Rlt_le, Datan_seq_increasing. + { lia. } + apply Boule_lt in inb; intuition. + solve[apply Rabs_pos]. + - apply Datan_seq_CV_0. + { apply Rlt_trans with 0;[lra | ]. + apply Rplus_le_lt_0_compat. + { solve[apply Rabs_pos]. } + destruct r; assumption. } + assumption. + - assumption. Qed. Lemma Datan_is_datan : forall (N : nat) (x : R), -1 <= x -> x < 1 -> derivable_pt_lim (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x (sum_f_R0 (tg_alt (Datan_seq x)) N). Proof. -assert (Tool : forall N, (-1) ^ (S (2 * N)) = - 1). -{ intro n ; induction n. - { simpl ; field. } - replace ((-1) ^ S (2 * S n)) with ((-1) ^ 2 * (-1) ^ S (2*n)). - { rewrite IHn ; field. } - rewrite <- pow_add. - replace (2 + S (2 * n))%nat with (S (2 * S n))%nat. - { reflexivity. } - lia. } -intros N x x_lb x_ub. -induction N. -{ unfold Datan_seq, Ratan_seq, tg_alt ; simpl. + assert (Tool : forall N, (-1) ^ (S (2 * N)) = - 1). + { intro n ; induction n. + { simpl ; field. } + replace ((-1) ^ S (2 * S n)) with ((-1) ^ 2 * (-1) ^ S (2*n)). + { rewrite IHn ; field. } + rewrite <- pow_add. + replace (2 + S (2 * n))%nat with (S (2 * S n))%nat. + { reflexivity. } + lia. } + intros N x x_lb x_ub. + induction N. + { unfold Datan_seq, Ratan_seq, tg_alt ; simpl. + intros eps eps_pos. + elim (derivable_pt_lim_id x eps eps_pos) ; intros delta Hdelta ; exists delta. + intros h hneq h_b. + replace (1 * ((x + h) * 1 / 1) - 1 * (x * 1 / 1)) with (id (x + h) - id x). + { rewrite Rmult_1_r. + apply Hdelta ; assumption. } + unfold id ; field ; assumption. } intros eps eps_pos. - elim (derivable_pt_lim_id x eps eps_pos) ; intros delta Hdelta ; exists delta. - intros h hneq h_b. - replace (1 * ((x + h) * 1 / 1) - 1 * (x * 1 / 1)) with (id (x + h) - id x). - { rewrite Rmult_1_r. - apply Hdelta ; assumption. } - unfold id ; field ; assumption. } -intros eps eps_pos. -assert (eps_3_pos : (eps/3) > 0) by lra. -elim (IHN (eps/3) eps_3_pos) ; intros delta1 Hdelta1. -assert (Main : derivable_pt_lim (fun x =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))). -{ clear -Tool ; intros eps' eps'_pos. - elim (derivable_pt_lim_pow x (2 * (S N) + 1) eps' eps'_pos) ; intros delta Hdelta ; exists delta. - intros h h_neq h_b ; unfold tg_alt, Ratan_seq, Datan_seq. - replace (((-1) ^ S N * ((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - - (-1) ^ S N * (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - - (-1) ^ S N * x ^ (2 * S N)) - with (((-1)^(S N)) * ((((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - x ^ (2 * S N))) - by (field ; split ; [apply Rgt_not_eq |] ; intuition). - rewrite Rabs_mult ; rewrite pow_1_abs ; rewrite Rmult_1_l. - replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) - - x ^ (2 * S N + 1) / INR (2 * S N + 1)) / h - x ^ (2 * S N)) - with ((/INR (2* S N + 1)) * (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - - INR (2 * S N + 1) * x ^ pred (2 * S N + 1))). - { rewrite Rabs_mult. - case (Req_dec (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - - INR (2 * S N + 1) * x ^ pred (2 * S N + 1)) 0) ; intro Heq. - { rewrite Heq ; rewrite Rabs_R0 ; rewrite Rmult_0_r ; assumption. } - apply Rlt_trans with (r2:=Rabs - (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - - INR (2 * S N + 1) * x ^ pred (2 * S N + 1))). - 2:{ apply Hdelta; assumption. } - rewrite <- Rmult_1_l ; apply Rmult_lt_compat_r. - { apply Rabs_pos_lt ; assumption. } - rewrite Rabs_right. - { replace 1 with (/1) by field. - apply Rinv_0_lt_contravar. { lra. } apply lt_1_INR; lia. } - apply Rgt_ge ; replace (INR (2 * S N + 1)) with (INR (2*S N) + 1) ; - [apply RiemannInt.RinvN_pos | ]. - replace (2 * S N + 1)%nat with (S (2 * S N))%nat by lia. - rewrite S_INR ; reflexivity. } - rewrite Rmult_minus_distr_l. - replace (/ INR (2 * S N + 1) * (INR (2 * S N + 1) * x ^ pred (2 * S N + 1))) with (x ^ (2 * S N)). - 2:{ clear ; replace (pred (2 * S N + 1)) with (2 * S N)%nat by lia. - field ; apply Rgt_not_eq ; intuition. } - unfold Rminus ; rewrite Rplus_comm. - replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) + - - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h + - x ^ (2 * S N)) - with (- x ^ (2 * S N) + (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) + - - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h)) - by intuition. - apply Rplus_eq_compat_l. field. - split ; [apply Rgt_not_eq|] ; intuition. } -elim (Main (eps/3) eps_3_pos) ; intros delta2 Hdelta2. -destruct delta1 as (delta1, delta1_pos) ; destruct delta2 as (delta2, delta2_pos). -pose (mydelta := Rmin delta1 delta2). -assert (mydelta_pos : mydelta > 0). -{ unfold mydelta ; rewrite Rmin_Rgt ; split ; assumption. } -pose (delta := mkposreal mydelta mydelta_pos) ; exists delta ; intros h h_neq h_b. -clear Main IHN. -unfold Rminus at 1. -apply Rle_lt_trans with (r2:=eps/3 + eps / 3). -{ assert (Temp : (sum_f_R0 (tg_alt (Ratan_seq (x + h))) (S N) - - sum_f_R0 (tg_alt (Ratan_seq x)) (S N)) / h + - - sum_f_R0 (tg_alt (Datan_seq x)) (S N) - = ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N - - sum_f_R0 (tg_alt (Ratan_seq x)) N) / h) + - (- sum_f_R0 (tg_alt (Datan_seq x)) N) + - ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) - / h - tg_alt (Datan_seq x) (S N))). - { simpl ; field ; intuition. } - apply Rle_trans with (r2:= Rabs ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N - - sum_f_R0 (tg_alt (Ratan_seq x)) N) / h + - - sum_f_R0 (tg_alt (Datan_seq x)) N) + - Rabs ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) - / h - tg_alt (Datan_seq x) (S N))). - { rewrite Temp ; clear Temp ; apply Rabs_triang. } - apply Rplus_le_compat ; apply Rlt_le ; [apply Hdelta1 | apply Hdelta2] ; - intuition ; apply Rlt_le_trans with (r2:=delta) ; intuition unfold delta, mydelta. - { apply Rmin_l. } - apply Rmin_r. } -lra. + assert (eps_3_pos : (eps/3) > 0) by lra. + elim (IHN (eps/3) eps_3_pos) ; intros delta1 Hdelta1. + assert (Main : derivable_pt_lim (fun x =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))). + { clear -Tool ; intros eps' eps'_pos. + elim (derivable_pt_lim_pow x (2 * (S N) + 1) eps' eps'_pos) ; intros delta Hdelta ; exists delta. + intros h h_neq h_b ; unfold tg_alt, Ratan_seq, Datan_seq. + replace (((-1) ^ S N * ((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - + (-1) ^ S N * (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - + (-1) ^ S N * x ^ (2 * S N)) + with (((-1)^(S N)) * ((((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - + (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - x ^ (2 * S N))) + by (field ; split ; [apply Rgt_not_eq |] ; intuition). + rewrite Rabs_mult ; rewrite pow_1_abs ; rewrite Rmult_1_l. + replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) - + x ^ (2 * S N + 1) / INR (2 * S N + 1)) / h - x ^ (2 * S N)) + with ((/INR (2* S N + 1)) * (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - + INR (2 * S N + 1) * x ^ pred (2 * S N + 1))). + { rewrite Rabs_mult. + case (Req_dec (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - + INR (2 * S N + 1) * x ^ pred (2 * S N + 1)) 0) ; intro Heq. + { rewrite Heq ; rewrite Rabs_R0 ; rewrite Rmult_0_r ; assumption. } + apply Rlt_trans with (r2:=Rabs + (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - + INR (2 * S N + 1) * x ^ pred (2 * S N + 1))). + 2:{ apply Hdelta; assumption. } + rewrite <- Rmult_1_l ; apply Rmult_lt_compat_r. + { apply Rabs_pos_lt ; assumption. } + rewrite Rabs_right. + { replace 1 with (/1) by field. + apply Rinv_0_lt_contravar. { lra. } apply lt_1_INR; lia. } + apply Rgt_ge ; replace (INR (2 * S N + 1)) with (INR (2*S N) + 1) ; + [apply RiemannInt.RinvN_pos | ]. + replace (2 * S N + 1)%nat with (S (2 * S N))%nat by lia. + rewrite S_INR ; reflexivity. } + rewrite Rmult_minus_distr_l. + replace (/ INR (2 * S N + 1) * (INR (2 * S N + 1) * x ^ pred (2 * S N + 1))) with (x ^ (2 * S N)). + 2:{ clear ; replace (pred (2 * S N + 1)) with (2 * S N)%nat by lia. + field ; apply Rgt_not_eq ; intuition. } + unfold Rminus ; rewrite Rplus_comm. + replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) + + - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h + - x ^ (2 * S N)) + with (- x ^ (2 * S N) + (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) + + - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h)) + by intuition. + apply Rplus_eq_compat_l. field. + split ; [apply Rgt_not_eq|] ; intuition. } + elim (Main (eps/3) eps_3_pos) ; intros delta2 Hdelta2. + destruct delta1 as (delta1, delta1_pos) ; destruct delta2 as (delta2, delta2_pos). + pose (mydelta := Rmin delta1 delta2). + assert (mydelta_pos : mydelta > 0). + { unfold mydelta ; rewrite Rmin_Rgt ; split ; assumption. } + pose (delta := mkposreal mydelta mydelta_pos) ; exists delta ; intros h h_neq h_b. + clear Main IHN. + unfold Rminus at 1. + apply Rle_lt_trans with (r2:=eps/3 + eps / 3). + { assert (Temp : (sum_f_R0 (tg_alt (Ratan_seq (x + h))) (S N) - + sum_f_R0 (tg_alt (Ratan_seq x)) (S N)) / h + + - sum_f_R0 (tg_alt (Datan_seq x)) (S N) + = ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N - + sum_f_R0 (tg_alt (Ratan_seq x)) N) / h) + + (- sum_f_R0 (tg_alt (Datan_seq x)) N) + + ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) + / h - tg_alt (Datan_seq x) (S N))). + { simpl ; field ; intuition. } + apply Rle_trans with (r2:= Rabs ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N - + sum_f_R0 (tg_alt (Ratan_seq x)) N) / h + + - sum_f_R0 (tg_alt (Datan_seq x)) N) + + Rabs ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) + / h - tg_alt (Datan_seq x) (S N))). + { rewrite Temp ; clear Temp ; apply Rabs_triang. } + apply Rplus_le_compat ; apply Rlt_le ; [apply Hdelta1 | apply Hdelta2] ; + intuition ; apply Rlt_le_trans with (r2:=delta) ; intuition unfold delta, mydelta. + { apply Rmin_l. } + apply Rmin_r. } + lra. Qed. Lemma Ratan_CVU' : CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N) ps_atan (/2) posreal_half. Proof. -apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) posreal_half); - lazy beta. -- now intros; apply Ratan_seq_decreasing, Boule_half_to_interval. -- now intros; apply Ratan_seq_converging, Boule_half_to_interval. -- intros x b; apply Boule_half_to_interval in b. - unfold ps_atan; destruct (in_int x) as [inside | outside]; - [ | destruct b; case outside; split; lra]. - destruct (ps_atan_exists_1 x inside) as [v Pv]. - apply Un_cv_ext with (2 := Pv);[reflexivity]. -- intros x n b; apply Boule_half_to_interval in b. - rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. - apply Rmult_le_compat_r. - { apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); lia. } - rewrite <- (pow1 (2 * n + 1)); apply pow_incr; assumption. -- exact PI_tg_cv. + apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) posreal_half); + lazy beta. + - now intros; apply Ratan_seq_decreasing, Boule_half_to_interval. + - now intros; apply Ratan_seq_converging, Boule_half_to_interval. + - intros x b; apply Boule_half_to_interval in b. + unfold ps_atan; destruct (in_int x) as [inside | outside]; + [ | destruct b; case outside; split; lra]. + destruct (ps_atan_exists_1 x inside) as [v Pv]. + apply Un_cv_ext with (2 := Pv);[reflexivity]. + - intros x n b; apply Boule_half_to_interval in b. + rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. + apply Rmult_le_compat_r. + { apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); lia. } + rewrite <- (pow1 (2 * n + 1)); apply pow_incr; assumption. + - exact PI_tg_cv. Qed. Lemma Ratan_CVU : CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N) ps_atan 0 (mkposreal 1 Rlt_0_1). Proof. -intros eps ep; destruct (Ratan_CVU' eps ep) as [N Pn]. -exists N; intros n x nN b_y. -case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]]. -- assert (Boule (/2) posreal_half x). - { revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. - destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. } - apply Pn; assumption. -- rewrite <- x0, ps_atan0_0. - rewrite <- (sum_eq (fun _ => 0)), sum_cte, Rmult_0_l, Rminus_0_r, Rabs_pos_eq. - + assumption. - + apply Rle_refl. - + intros i _; unfold tg_alt, Ratan_seq, Rdiv; rewrite Nat.add_comm; simpl. - solve[rewrite !Rmult_0_l, Rmult_0_r; auto]. -- replace (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) n) with - (-(ps_atan (-x) - sum_f_R0 (tg_alt (Ratan_seq (-x))) n)). - { rewrite Rabs_Ropp. - assert (Boule (/2) posreal_half (-x)). + intros eps ep; destruct (Ratan_CVU' eps ep) as [N Pn]. + exists N; intros n x nN b_y. + case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]]. + - assert (Boule (/2) posreal_half x). { revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. } - apply Pn; assumption. } - unfold Rminus; rewrite ps_atan_opp, Ropp_plus_distr, sum_Ratan_seq_opp. - rewrite !Ropp_involutive; reflexivity. + apply Pn; assumption. + - rewrite <- x0, ps_atan0_0. + rewrite <- (sum_eq (fun _ => 0)), sum_cte, Rmult_0_l, Rminus_0_r, Rabs_pos_eq. + + assumption. + + apply Rle_refl. + + intros i _; unfold tg_alt, Ratan_seq, Rdiv; rewrite Nat.add_comm; simpl. + solve[rewrite !Rmult_0_l, Rmult_0_r; auto]. + - replace (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) n) with + (-(ps_atan (-x) - sum_f_R0 (tg_alt (Ratan_seq (-x))) n)). + { rewrite Rabs_Ropp. + assert (Boule (/2) posreal_half (-x)). + { revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. + destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. } + apply Pn; assumption. } + unfold Rminus; rewrite ps_atan_opp, Ropp_plus_distr, sum_Ratan_seq_opp. + rewrite !Ropp_involutive; reflexivity. Qed. Lemma Alt_PI_tg : forall n, PI_tg n = Ratan_seq 1 n. Proof. -intros n; unfold PI_tg, Ratan_seq, Rdiv; rewrite pow1, Rmult_1_l. -reflexivity. + intros n; unfold PI_tg, Ratan_seq, Rdiv; rewrite pow1, Rmult_1_l. + reflexivity. Qed. Lemma Ratan_is_ps_atan : forall eps, eps > 0 -> exists N, forall n, (n >= N)%nat -> forall x, -1 < x -> x < 1 -> Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) n - ps_atan x) < eps. Proof. -intros eps ep. -destruct (Ratan_CVU _ ep) as [N1 PN1]. -exists N1; intros n nN x xm1 x1; rewrite <- Rabs_Ropp, Ropp_minus_distr. -apply PN1; [assumption | ]. -unfold Boule; simpl; rewrite Rminus_0_r; apply Rabs_def1; assumption. + intros eps ep. + destruct (Ratan_CVU _ ep) as [N1 PN1]. + exists N1; intros n nN x xm1 x1; rewrite <- Rabs_Ropp, Ropp_minus_distr. + apply PN1; [assumption | ]. + unfold Boule; simpl; rewrite Rminus_0_r; apply Rabs_def1; assumption. Qed. Lemma Datan_continuity : continuity (fun x => /(1 + x^2)). Proof. -apply continuity_inv. -{ apply continuity_plus. - { apply continuity_const ; unfold constant ; intuition. } - apply derivable_continuous ; apply derivable_pow. } -intro x ; apply Rgt_not_eq ; apply Rge_gt_trans with (1+0) ; [|lra] ; - apply Rplus_ge_compat_l. -replace (x^2) with (x²). -{ apply Rle_ge ; apply Rle_0_sqr. } -unfold Rsqr ; field. + apply continuity_inv. + { apply continuity_plus. + { apply continuity_const ; unfold constant ; intuition. } + apply derivable_continuous ; apply derivable_pow. } + intro x ; apply Rgt_not_eq ; apply Rge_gt_trans with (1+0) ; [|lra] ; + apply Rplus_ge_compat_l. + replace (x^2) with (x²). + { apply Rle_ge ; apply Rle_0_sqr. } + unfold Rsqr ; field. Qed. Lemma derivable_pt_lim_ps_atan : forall x, -1 < x < 1 -> derivable_pt_lim ps_atan x ((fun y => /(1 + y ^ 2)) x). Proof. -intros x x_encad. -destruct (boule_in_interval (-1) 1 x x_encad) as [c [r [Pcr1 [P1 P2]]]]. -change (/ (1 + x ^ 2)) with ((fun u => /(1 + u ^ 2)) x). -assert (t := derivable_pt_lim_CVU). -apply derivable_pt_lim_CVU with - (fn := (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N)) - (fn' := (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N)) - (c := c) (r := r). -- assumption. -- intros y N inb; apply Rabs_def2 in inb; destruct inb. - apply Datan_is_datan. - { lra. } - lra. -- intros y inb; apply Rabs_def2 in inb; destruct inb. - assert (y_gt_0 : -1 < y) by lra. - assert (y_lt_1 : y < 1) by lra. - intros eps eps_pos ; elim (Ratan_is_ps_atan eps eps_pos). - intros N HN ; exists N; intros n n_lb ; apply HN ; tauto. -- apply Datan_CVU_prelim. - replace ((c - r + (c + r)) / 2) with c by field. - unfold mkposreal_lb_ub; simpl. - replace ((c + r - (c - r)) / 2) with (r :R) by field. - assert (Rabs c < 1 - r). - { unfold Boule in Pcr1; destruct r; simpl in *; apply Rabs_def1; - apply Rabs_def2 in Pcr1; destruct Pcr1; lra. } - lra. -- intros; apply Datan_continuity. + intros x x_encad. + destruct (boule_in_interval (-1) 1 x x_encad) as [c [r [Pcr1 [P1 P2]]]]. + change (/ (1 + x ^ 2)) with ((fun u => /(1 + u ^ 2)) x). + assert (t := derivable_pt_lim_CVU). + apply derivable_pt_lim_CVU with + (fn := (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N)) + (fn' := (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N)) + (c := c) (r := r). + - assumption. + - intros y N inb; apply Rabs_def2 in inb; destruct inb. + apply Datan_is_datan. + { lra. } + lra. + - intros y inb; apply Rabs_def2 in inb; destruct inb. + assert (y_gt_0 : -1 < y) by lra. + assert (y_lt_1 : y < 1) by lra. + intros eps eps_pos ; elim (Ratan_is_ps_atan eps eps_pos). + intros N HN ; exists N; intros n n_lb ; apply HN ; tauto. + - apply Datan_CVU_prelim. + replace ((c - r + (c + r)) / 2) with c by field. + unfold mkposreal_lb_ub; simpl. + replace ((c + r - (c - r)) / 2) with (r :R) by field. + assert (Rabs c < 1 - r). + { unfold Boule in Pcr1; destruct r; simpl in *; apply Rabs_def1; + apply Rabs_def2 in Pcr1; destruct Pcr1; lra. } + lra. + - intros; apply Datan_continuity. Qed. Lemma derivable_pt_ps_atan : forall x, -1 < x < 1 -> derivable_pt ps_atan x. Proof. -intros x x_encad. -exists (/(1 + x^2)) ; apply derivable_pt_lim_ps_atan; assumption. + intros x x_encad. + exists (/(1 + x^2)) ; apply derivable_pt_lim_ps_atan; assumption. Qed. Lemma ps_atan_continuity_pt_1 : forall eps : R, @@ -1464,192 +1464,192 @@ Lemma ps_atan_continuity_pt_1 : forall eps : R, exists alp : R, alp > 0 /\ (forall x, x < 1 -> 0 < x -> Rdist x 1 < alp -> dist R_met (ps_atan x) (Alt_PI/4) < eps). Proof. -intros eps eps_pos. -assert (eps_3_pos : eps / 3 > 0) by lra. -elim (Ratan_is_ps_atan (eps / 3) eps_3_pos) ; intros N1 HN1. -unfold Alt_PI. -destruct exist_PI as [v Pv]; replace ((4 * v)/4) with v by field. -assert (Pv' : Un_cv (sum_f_R0 (tg_alt (Ratan_seq 1))) v). -{ apply Un_cv_ext with (2:= Pv). - intros; apply sum_eq; intros; unfold tg_alt; rewrite Alt_PI_tg; tauto. } -destruct (Pv' (eps / 3) eps_3_pos) as [N2 HN2]. -set (N := (N1 + N2)%nat). -assert (O_lb : 0 <= 1) by intuition ; assert (O_ub : 1 <= 1) by intuition ; - elim (ps_atanSeq_continuity_pt_1 N 1 O_lb O_ub (eps / 3) eps_3_pos) ; intros alpha Halpha ; - clear -HN1 HN2 Halpha eps_3_pos; destruct Halpha as (alpha_pos, Halpha). -exists alpha ; split;[assumption | ]. -intros x x_ub x_lb x_bounds. -simpl ; unfold Rdist. -replace (ps_atan x - v) with - ((ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) - + (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) - + (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)) - by ring. -apply Rle_lt_trans with - (r2:=Rabs (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) + - Rabs ((sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + - (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v))). -{ rewrite Rplus_assoc ; apply Rabs_triang. } -replace eps with (2 / 3 * eps + eps / 3) by field. -rewrite Rplus_comm. -apply Rplus_lt_compat. -{ apply Rle_lt_trans with - (r2 := Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + - Rabs (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)). - { apply Rabs_triang. } - apply Rlt_le_trans with (r2:= eps / 3 + eps / 3). - { apply Rplus_lt_compat. - { simpl in Halpha ; unfold Rdist in Halpha. - apply Halpha ; split. - { unfold D_x, no_cond ; split ; [ | apply Rgt_not_eq ] ; intuition. } - intuition. } - apply HN2; unfold N; lia. } - lra. } -rewrite <- Rabs_Ropp, Ropp_minus_distr; apply HN1. -- unfold N; lia. -- lra. -- assumption. + intros eps eps_pos. + assert (eps_3_pos : eps / 3 > 0) by lra. + elim (Ratan_is_ps_atan (eps / 3) eps_3_pos) ; intros N1 HN1. + unfold Alt_PI. + destruct exist_PI as [v Pv]; replace ((4 * v)/4) with v by field. + assert (Pv' : Un_cv (sum_f_R0 (tg_alt (Ratan_seq 1))) v). + { apply Un_cv_ext with (2:= Pv). + intros; apply sum_eq; intros; unfold tg_alt; rewrite Alt_PI_tg; tauto. } + destruct (Pv' (eps / 3) eps_3_pos) as [N2 HN2]. + set (N := (N1 + N2)%nat). + assert (O_lb : 0 <= 1) by intuition ; assert (O_ub : 1 <= 1) by intuition ; + elim (ps_atanSeq_continuity_pt_1 N 1 O_lb O_ub (eps / 3) eps_3_pos) ; intros alpha Halpha ; + clear -HN1 HN2 Halpha eps_3_pos; destruct Halpha as (alpha_pos, Halpha). + exists alpha ; split;[assumption | ]. + intros x x_ub x_lb x_bounds. + simpl ; unfold Rdist. + replace (ps_atan x - v) with + ((ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) + + (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + + (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)) + by ring. + apply Rle_lt_trans with + (r2:=Rabs (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) + + Rabs ((sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + + (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v))). + { rewrite Rplus_assoc ; apply Rabs_triang. } + replace eps with (2 / 3 * eps + eps / 3) by field. + rewrite Rplus_comm. + apply Rplus_lt_compat. + { apply Rle_lt_trans with + (r2 := Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + + Rabs (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)). + { apply Rabs_triang. } + apply Rlt_le_trans with (r2:= eps / 3 + eps / 3). + { apply Rplus_lt_compat. + { simpl in Halpha ; unfold Rdist in Halpha. + apply Halpha ; split. + { unfold D_x, no_cond ; split ; [ | apply Rgt_not_eq ] ; intuition. } + intuition. } + apply HN2; unfold N; lia. } + lra. } + rewrite <- Rabs_Ropp, Ropp_minus_distr; apply HN1. + - unfold N; lia. + - lra. + - assumption. Qed. Lemma Datan_eq_DatanSeq_interv : forall x, -1 < x < 1 -> forall (Pratan:derivable_pt ps_atan x) (Prmymeta:derivable_pt atan x), derive_pt ps_atan x Pratan = derive_pt atan x Prmymeta. Proof. -assert (freq : 0 < tan 1) by apply (Rlt_trans _ _ _ Rlt_0_1 tan_1_gt_1). -intros x x_encad Pratan Prmymeta. -rewrite pr_nu_var2_interv with - (g:=ps_atan) (lb:=-1) (ub:=tan 1) - (pr2 := derivable_pt_ps_atan x x_encad). -- rewrite pr_nu_var2_interv with (f:=atan) (g:=atan) (lb:=-1) (ub:= 1) (pr2:=derivable_pt_atan x). - + assert (Temp := derivable_pt_lim_ps_atan x x_encad). - assert (Hrew1 : derive_pt ps_atan x (derivable_pt_ps_atan x x_encad) = (/(1 + x^2))). - { apply derive_pt_eq_0 ; assumption. } - rewrite derive_pt_atan. - rewrite Hrew1. - replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). - unfold Rdiv; rewrite Rmult_1_l; reflexivity. - + lra. - + assumption. - + intros; reflexivity. -- lra. -- assert (t := tan_1_gt_1); split;destruct x_encad; lra. -- intros; reflexivity. + assert (freq : 0 < tan 1) by apply (Rlt_trans _ _ _ Rlt_0_1 tan_1_gt_1). + intros x x_encad Pratan Prmymeta. + rewrite pr_nu_var2_interv with + (g:=ps_atan) (lb:=-1) (ub:=tan 1) + (pr2 := derivable_pt_ps_atan x x_encad). + - rewrite pr_nu_var2_interv with (f:=atan) (g:=atan) (lb:=-1) (ub:= 1) (pr2:=derivable_pt_atan x). + + assert (Temp := derivable_pt_lim_ps_atan x x_encad). + assert (Hrew1 : derive_pt ps_atan x (derivable_pt_ps_atan x x_encad) = (/(1 + x^2))). + { apply derive_pt_eq_0 ; assumption. } + rewrite derive_pt_atan. + rewrite Hrew1. + replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). + unfold Rdiv; rewrite Rmult_1_l; reflexivity. + + lra. + + assumption. + + intros; reflexivity. + - lra. + - assert (t := tan_1_gt_1); split;destruct x_encad; lra. + - intros; reflexivity. Qed. Lemma atan_eq_ps_atan : forall x, 0 < x < 1 -> atan x = ps_atan x. Proof. -intros x x_encad. -assert (pr1 : forall c : R, 0 < c < x -> derivable_pt (atan - ps_atan) c). -{ intros c c_encad. - apply derivable_pt_minus. - { exact (derivable_pt_atan c). } - apply derivable_pt_ps_atan. - destruct x_encad; destruct c_encad; split; lra. } -assert (pr2 : forall c : R, 0 < c < x -> derivable_pt id c). -{ intros ; apply derivable_pt_id; lra. } -assert (delta_cont : forall c : R, 0 <= c <= x -> continuity_pt (atan - ps_atan) c). -{ intros c [[c_encad1 | c_encad1 ] [c_encad2 | c_encad2]]; - apply continuity_pt_minus. - - apply derivable_continuous_pt ; apply derivable_pt_atan. - - apply derivable_continuous_pt ; apply derivable_pt_ps_atan. - split; destruct x_encad; lra. - - apply derivable_continuous_pt, derivable_pt_atan. - - apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; destruct x_encad; split; lra. - - apply derivable_continuous_pt, derivable_pt_atan. - - apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; split; lra. - - apply derivable_continuous_pt, derivable_pt_atan. - - apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; destruct x_encad; split; lra. } -assert (id_cont : forall c : R, 0 <= c <= x -> continuity_pt id c). -{ intros ; apply derivable_continuous ; apply derivable_id. } -assert (x_lb : 0 < x) by (destruct x_encad; lra). -elim (MVT (atan - ps_atan)%F id 0 x pr1 pr2 x_lb delta_cont id_cont) ; intros d Temp ; elim Temp ; intros d_encad Main. -clear - Main x_encad. -assert (Temp : forall (pr: derivable_pt (atan - ps_atan) d), derive_pt (atan - ps_atan) d pr = 0). -{ intro pr. - assert (d_encad3 : -1 < d < 1). - { destruct d_encad; destruct x_encad; split; lra. } - pose (pr3 := derivable_pt_minus atan ps_atan d (derivable_pt_atan d) (derivable_pt_ps_atan d d_encad3)). - rewrite <- pr_nu_var2_interv with (f:=(atan - ps_atan)%F) (g:=(atan - ps_atan)%F) (lb:=0) (ub:=x) (pr1:=pr3) (pr2:=pr). - - unfold pr3. rewrite derive_pt_minus. - rewrite Datan_eq_DatanSeq_interv with (Prmymeta := derivable_pt_atan d). - { intuition. } - assumption. - - destruct d_encad; lra. - - assumption. - - reflexivity. } -assert (iatan0 : atan 0 = 0). -{ apply tan_inj. - - apply atan_bound. - - rewrite Rdiv_opp_l; assert (t := PI2_RGT_0); split; lra. - - rewrite tan_0, tan_atan; reflexivity. } -generalize Main; rewrite Temp, Rmult_0_r. -replace ((atan - ps_atan)%F x) with (atan x - ps_atan x) by intuition. -replace ((atan - ps_atan)%F 0) with (atan 0 - ps_atan 0) by intuition. -rewrite iatan0, ps_atan0_0, !Rminus_0_r. -replace (derive_pt id d (pr2 d d_encad)) with 1. -{ rewrite Rmult_1_r. - solve[intros M; apply Rminus_diag_uniq; auto]. } -rewrite pr_nu_var with (g:=id) (pr2:=derivable_pt_id d). -{ symmetry ; apply derive_pt_id. } -tauto. + intros x x_encad. + assert (pr1 : forall c : R, 0 < c < x -> derivable_pt (atan - ps_atan) c). + { intros c c_encad. + apply derivable_pt_minus. + { exact (derivable_pt_atan c). } + apply derivable_pt_ps_atan. + destruct x_encad; destruct c_encad; split; lra. } + assert (pr2 : forall c : R, 0 < c < x -> derivable_pt id c). + { intros ; apply derivable_pt_id; lra. } + assert (delta_cont : forall c : R, 0 <= c <= x -> continuity_pt (atan - ps_atan) c). + { intros c [[c_encad1 | c_encad1 ] [c_encad2 | c_encad2]]; + apply continuity_pt_minus. + - apply derivable_continuous_pt ; apply derivable_pt_atan. + - apply derivable_continuous_pt ; apply derivable_pt_ps_atan. + split; destruct x_encad; lra. + - apply derivable_continuous_pt, derivable_pt_atan. + - apply derivable_continuous_pt, derivable_pt_ps_atan. + subst c; destruct x_encad; split; lra. + - apply derivable_continuous_pt, derivable_pt_atan. + - apply derivable_continuous_pt, derivable_pt_ps_atan. + subst c; split; lra. + - apply derivable_continuous_pt, derivable_pt_atan. + - apply derivable_continuous_pt, derivable_pt_ps_atan. + subst c; destruct x_encad; split; lra. } + assert (id_cont : forall c : R, 0 <= c <= x -> continuity_pt id c). + { intros ; apply derivable_continuous ; apply derivable_id. } + assert (x_lb : 0 < x) by (destruct x_encad; lra). + elim (MVT (atan - ps_atan)%F id 0 x pr1 pr2 x_lb delta_cont id_cont) ; intros d Temp ; elim Temp ; intros d_encad Main. + clear - Main x_encad. + assert (Temp : forall (pr: derivable_pt (atan - ps_atan) d), derive_pt (atan - ps_atan) d pr = 0). + { intro pr. + assert (d_encad3 : -1 < d < 1). + { destruct d_encad; destruct x_encad; split; lra. } + pose (pr3 := derivable_pt_minus atan ps_atan d (derivable_pt_atan d) (derivable_pt_ps_atan d d_encad3)). + rewrite <- pr_nu_var2_interv with (f:=(atan - ps_atan)%F) (g:=(atan - ps_atan)%F) (lb:=0) (ub:=x) (pr1:=pr3) (pr2:=pr). + - unfold pr3. rewrite derive_pt_minus. + rewrite Datan_eq_DatanSeq_interv with (Prmymeta := derivable_pt_atan d). + { intuition. } + assumption. + - destruct d_encad; lra. + - assumption. + - reflexivity. } + assert (iatan0 : atan 0 = 0). + { apply tan_inj. + - apply atan_bound. + - rewrite Rdiv_opp_l; assert (t := PI2_RGT_0); split; lra. + - rewrite tan_0, tan_atan; reflexivity. } + generalize Main; rewrite Temp, Rmult_0_r. + replace ((atan - ps_atan)%F x) with (atan x - ps_atan x) by intuition. + replace ((atan - ps_atan)%F 0) with (atan 0 - ps_atan 0) by intuition. + rewrite iatan0, ps_atan0_0, !Rminus_0_r. + replace (derive_pt id d (pr2 d d_encad)) with 1. + { rewrite Rmult_1_r. + solve[intros M; apply Rminus_diag_uniq; auto]. } + rewrite pr_nu_var with (g:=id) (pr2:=derivable_pt_id d). + { symmetry ; apply derive_pt_id. } + tauto. Qed. Theorem Alt_PI_eq : Alt_PI = PI. Proof. -apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4); - [ | apply Rgt_not_eq; lra]. -assert (0 < PI/6) by (apply PI6_RGT_0). -assert (t1:= PI2_1). -assert (t2 := PI_4). -assert (m := Alt_PI_RGT_0). -assert (-PI/2 < 1 < PI/2) by (rewrite Rdiv_opp_l; split; lra). -apply cond_eq; intros eps ep. -change (Rdist (Alt_PI/4) (PI/4) < eps). -assert (ca : continuity_pt atan 1). -{ apply derivable_continuous_pt, derivable_pt_atan. } -assert (Xe : exists eps', exists eps'', - eps' + eps'' <= eps /\ 0 < eps' /\ 0 < eps''). -{ exists (eps/2); exists (eps/2); repeat apply conj; lra. } -destruct Xe as [eps' [eps'' [eps_ineq [ep' ep'']]]]. -destruct (ps_atan_continuity_pt_1 _ ep') as [alpha [a0 Palpha]]. -destruct (ca _ ep'') as [beta [b0 Pbeta]]. -assert (Xa : exists a, 0 < a < 1 /\ Rdist a 1 < alpha /\ - Rdist a 1 < beta). -{ exists (Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))). - assert (/2 <= Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_l. - assert (Rmax (1 - alpha /2) (1 - beta /2) <= - Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_r. - assert ((1 - alpha /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_l. - assert ((1 - beta /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_r. - assert (Rmax (1 - alpha /2) (1 - beta /2) < 1) - by (apply Rmax_lub_lt; lra). - split;[split;[ | apply Rmax_lub_lt]; lra | ]. - assert (0 <= 1 - Rmax (/ 2) (Rmax (1 - alpha / 2) (1 - beta / 2))). - { assert (Rmax (/2) (Rmax (1 - alpha / 2) - (1 - beta /2)) <= 1) by (apply Rmax_lub; lra). - lra. } - split; unfold Rdist; rewrite <-Rabs_Ropp, Ropp_minus_distr, - Rabs_pos_eq;lra. } -destruct Xa as [a [[Pa0 Pa1] [P1 P2]]]. -apply Rle_lt_trans with (1 := Rdist_tri _ _ (ps_atan a)). -apply Rlt_le_trans with (2 := eps_ineq). -apply Rplus_lt_compat. -{ rewrite Rdist_sym; apply Palpha; assumption. } -rewrite <- atan_eq_ps_atan. -{ rewrite <- atan_1; apply (Pbeta a); auto. - split; [ | exact P2]. - split;[exact I | apply Rgt_not_eq; assumption]. } -split; assumption. + apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4); + [ | apply Rgt_not_eq; lra]. + assert (0 < PI/6) by (apply PI6_RGT_0). + assert (t1:= PI2_1). + assert (t2 := PI_4). + assert (m := Alt_PI_RGT_0). + assert (-PI/2 < 1 < PI/2) by (rewrite Rdiv_opp_l; split; lra). + apply cond_eq; intros eps ep. + change (Rdist (Alt_PI/4) (PI/4) < eps). + assert (ca : continuity_pt atan 1). + { apply derivable_continuous_pt, derivable_pt_atan. } + assert (Xe : exists eps', exists eps'', + eps' + eps'' <= eps /\ 0 < eps' /\ 0 < eps''). + { exists (eps/2); exists (eps/2); repeat apply conj; lra. } + destruct Xe as [eps' [eps'' [eps_ineq [ep' ep'']]]]. + destruct (ps_atan_continuity_pt_1 _ ep') as [alpha [a0 Palpha]]. + destruct (ca _ ep'') as [beta [b0 Pbeta]]. + assert (Xa : exists a, 0 < a < 1 /\ Rdist a 1 < alpha /\ + Rdist a 1 < beta). + { exists (Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))). + assert (/2 <= Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_l. + assert (Rmax (1 - alpha /2) (1 - beta /2) <= + Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_r. + assert ((1 - alpha /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_l. + assert ((1 - beta /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_r. + assert (Rmax (1 - alpha /2) (1 - beta /2) < 1) + by (apply Rmax_lub_lt; lra). + split;[split;[ | apply Rmax_lub_lt]; lra | ]. + assert (0 <= 1 - Rmax (/ 2) (Rmax (1 - alpha / 2) (1 - beta / 2))). + { assert (Rmax (/2) (Rmax (1 - alpha / 2) + (1 - beta /2)) <= 1) by (apply Rmax_lub; lra). + lra. } + split; unfold Rdist; rewrite <-Rabs_Ropp, Ropp_minus_distr, + Rabs_pos_eq;lra. } + destruct Xa as [a [[Pa0 Pa1] [P1 P2]]]. + apply Rle_lt_trans with (1 := Rdist_tri _ _ (ps_atan a)). + apply Rlt_le_trans with (2 := eps_ineq). + apply Rplus_lt_compat. + { rewrite Rdist_sym; apply Palpha; assumption. } + rewrite <- atan_eq_ps_atan. + { rewrite <- atan_1; apply (Pbeta a); auto. + split; [ | exact P2]. + split;[exact I | apply Rgt_not_eq; assumption]. } + split; assumption. Qed. Lemma PI_ineq : forall N : nat, sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI/4 <= sum_f_R0 (tg_alt PI_tg) (2 * N). Proof. -intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. + intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. Qed. (** ** Relation between arctangent and sine and cosine *) @@ -1657,25 +1657,25 @@ Qed. Lemma sin_atan: forall x, sin (atan x) = x / sqrt (1 + x²). Proof. -intros x. -pose proof (atan_right_inv x) as Hatan. -remember (atan(x)) as α. -rewrite <- Hatan. -apply sin_tan. -apply cos_gt_0. -1,2: pose proof atan_bound x; lra. + intros x. + pose proof (atan_right_inv x) as Hatan. + remember (atan(x)) as α. + rewrite <- Hatan. + apply sin_tan. + apply cos_gt_0. + 1,2: pose proof atan_bound x; lra. Qed. Lemma cos_atan: forall x, cos (atan x) = 1 / sqrt(1 + x²). Proof. -intros x. -pose proof (atan_right_inv x) as Hatan. -remember (atan(x)) as α. -rewrite <- Hatan. -apply cos_tan. -apply cos_gt_0. -1,2: pose proof atan_bound x; lra. + intros x. + pose proof (atan_right_inv x) as Hatan. + remember (atan(x)) as α. + rewrite <- Hatan. + apply cos_tan. + apply cos_gt_0. + 1,2: pose proof atan_bound x; lra. Qed. (*********************************************************) @@ -1694,54 +1694,54 @@ Definition asin x := Lemma asin_atan : forall x, -1 < x < 1 -> asin x = atan (x / sqrt (1 - x²)). Proof. -intros x. -unfold asin; repeat case Rle_dec; intros; lra. + intros x. + unfold asin; repeat case Rle_dec; intros; lra. Qed. (** ** arcsine of specific values *) Lemma asin_0 : asin 0 = 0. Proof. -unfold asin; repeat case Rle_dec; intros; try lra. -replace (0/_) with 0. -- apply atan_0. -- field. - rewrite Rsqr_pow2; field_simplify (1 - 0^2). - rewrite sqrt_1; lra. + unfold asin; repeat case Rle_dec; intros; try lra. + replace (0/_) with 0. + - apply atan_0. + - field. + rewrite Rsqr_pow2; field_simplify (1 - 0^2). + rewrite sqrt_1; lra. Qed. Lemma asin_1 : asin 1 = PI / 2. Proof. -unfold asin; repeat case Rle_dec; lra. + unfold asin; repeat case Rle_dec; lra. Qed. Lemma asin_inv_sqrt2 : asin (/sqrt 2) = PI/4. Proof. -rewrite asin_atan. -{ pose proof sqrt2_neq_0 as SH. - rewrite Rsqr_pow2, pow_inv, <- Rsqr_pow2, Rsqr_sqrt; try lra. - replace (1 - /2) with (/2) by lra. - rewrite sqrt_inv. - now rewrite <- atan_1; apply f_equal; field. } -split. -{ apply (Rlt_trans _ 0); try lra. - apply Rinv_0_lt_compat; apply sqrt_lt_R0; lra. } -replace 1 with (/ sqrt 1). -{ apply Rinv_0_lt_contravar. - { rewrite sqrt_1; lra. } - apply sqrt_lt_1; lra. } -rewrite sqrt_1; lra. + rewrite asin_atan. + { pose proof sqrt2_neq_0 as SH. + rewrite Rsqr_pow2, pow_inv, <- Rsqr_pow2, Rsqr_sqrt; try lra. + replace (1 - /2) with (/2) by lra. + rewrite sqrt_inv. + now rewrite <- atan_1; apply f_equal; field. } + split. + { apply (Rlt_trans _ 0); try lra. + apply Rinv_0_lt_compat; apply sqrt_lt_R0; lra. } + replace 1 with (/ sqrt 1). + { apply Rinv_0_lt_contravar. + { rewrite sqrt_1; lra. } + apply sqrt_lt_1; lra. } + rewrite sqrt_1; lra. Qed. Lemma asin_opp : forall x, asin (- x) = - asin x. Proof. -intros x. -unfold asin; repeat case Rle_dec; intros; try lra. -rewrite <- Rsqr_neg. -rewrite Rdiv_opp_l. -rewrite atan_opp. -reflexivity. + intros x. + unfold asin; repeat case Rle_dec; intros; try lra. + rewrite <- Rsqr_neg. + rewrite Rdiv_opp_l. + rewrite atan_opp. + reflexivity. Qed. (** ** Bounds of arcsine *) @@ -1749,21 +1749,21 @@ Qed. Lemma asin_bound : forall x, - (PI/2) <= asin x <= PI/2. Proof. -intros x. -pose proof PI_RGT_0. -unfold asin; repeat case Rle_dec; try lra. -intros Hx1 Hx2. -pose proof atan_bound (x / sqrt (1 - x²)); lra. + intros x. + pose proof PI_RGT_0. + unfold asin; repeat case Rle_dec; try lra. + intros Hx1 Hx2. + pose proof atan_bound (x / sqrt (1 - x²)); lra. Qed. Lemma asin_bound_lt : forall x, -1 < x < 1 -> - (PI/2) < asin x < PI/2. Proof. -intros x HxB. -pose proof PI_RGT_0. -unfold asin; repeat case Rle_dec; try lra. -intros Hx1 Hx2. -pose proof atan_bound (x / sqrt (1 - x²)); lra. + intros x HxB. + pose proof PI_RGT_0. + unfold asin; repeat case Rle_dec; try lra. + intros Hx1 Hx2. + pose proof atan_bound (x / sqrt (1 - x²)); lra. Qed. (** ** arcsine is the left and right inverse of sine *) @@ -1771,31 +1771,31 @@ Qed. Lemma sin_asin : forall x, -1 <= x <= 1 -> sin (asin x) = x. Proof. -intros x. -unfold asin; repeat case Rle_dec. -- rewrite sin_antisym, sin_PI2; lra. -- rewrite sin_PI2; lra. -- intros Hx1 Hx2 Hx3. - pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxsqr; rewrite Rsqr_1 in Hxsqr. - rewrite sin_atan. - unfold Rdiv at 1 2. - rewrite Rmult_assoc, <- Rinv_mult. - rewrite <- sqrt_mult_alt by lra. - rewrite Rsqr_div', Rsqr_sqrt by lra. - field_simplify ((1 - x²) * (1 + x² / (1 - x²))). - { rewrite sqrt_1. - field. } - lra. + intros x. + unfold asin; repeat case Rle_dec. + - rewrite sin_antisym, sin_PI2; lra. + - rewrite sin_PI2; lra. + - intros Hx1 Hx2 Hx3. + pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxsqr; rewrite Rsqr_1 in Hxsqr. + rewrite sin_atan. + unfold Rdiv at 1 2. + rewrite Rmult_assoc, <- Rinv_mult. + rewrite <- sqrt_mult_alt by lra. + rewrite Rsqr_div', Rsqr_sqrt by lra. + field_simplify ((1 - x²) * (1 + x² / (1 - x²))). + { rewrite sqrt_1. + field. } + lra. Qed. Lemma asin_sin : forall x, -(PI/2) <= x <= PI/2 -> asin (sin x) = x. Proof. -intros x HB. -apply sin_inj; auto. -{ apply asin_bound. } -apply sin_asin. -apply SIN_bound. + intros x HB. + apply sin_inj; auto. + { apply asin_bound. } + apply sin_asin. + apply SIN_bound. Qed. (** ** Relation between arcsin, cosine and tangent *) @@ -2101,37 +2101,37 @@ Qed. Lemma derive_pt_acos : forall (x : R) (Hxrange : -1 < x < 1), derive_pt acos x (derivable_pt_acos x Hxrange) = -1 / sqrt (1 - x²). Proof. - intros x Hxrange. + intros x Hxrange. - epose proof (derive_pt_recip_interv_decr cos acos 0 PI x _ _ _ _ _ _ _ ) as Hd. + epose proof (derive_pt_recip_interv_decr cos acos 0 PI x _ _ _ _ _ _ _ ) as Hd. - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))) in Hd. - rewrite <- (pr_nu acos x (derivable_pt_acos x Hxrange)) in Hd. - rewrite derive_pt_cos in Hd. - rewrite sin_acos in Hd by lra. - rewrite Hd; field. - apply Rgt_not_eq, Rlt_gt; rewrite <- sqrt_0. - pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. - apply sqrt_lt_1; lra. - -Unshelve. - - pose proof PI_RGT_0; lra. - - rewrite cos_PI,cos_0; lra. - - intros x1 x2 Ha Hb Hc. - apply cos_decreasing_1; lra. - - intros x0 Ha Hb. - pose proof acos_bound x0; lra. - - intros a Ha; reg. - - intros x0 Ha Hb. - unfold comp,id. - apply cos_acos. - rewrite cos_PI in Ha; rewrite cos_0 in Hb; lra. - - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))). - rewrite derive_pt_cos. - rewrite sin_acos by lra. - apply Rlt_not_eq; rewrite <- Ropp_0; apply Ropp_lt_contravar; rewrite <- sqrt_0. + rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))) in Hd. + rewrite <- (pr_nu acos x (derivable_pt_acos x Hxrange)) in Hd. + rewrite derive_pt_cos in Hd. + rewrite sin_acos in Hd by lra. + rewrite Hd; field. + apply Rgt_not_eq, Rlt_gt; rewrite <- sqrt_0. pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. apply sqrt_lt_1; lra. + + Unshelve. + - pose proof PI_RGT_0; lra. + - rewrite cos_PI,cos_0; lra. + - intros x1 x2 Ha Hb Hc. + apply cos_decreasing_1; lra. + - intros x0 Ha Hb. + pose proof acos_bound x0; lra. + - intros a Ha; reg. + - intros x0 Ha Hb. + unfold comp,id. + apply cos_acos. + rewrite cos_PI in Ha; rewrite cos_0 in Hb; lra. + - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))). + rewrite derive_pt_cos. + rewrite sin_acos by lra. + apply Rlt_not_eq; rewrite <- Ropp_0; apply Ropp_lt_contravar; rewrite <- sqrt_0. + pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. + apply sqrt_lt_1; lra. Qed. Lemma sin_gt_x x : x < 0 -> x < sin x. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 1bdf6907bc..99403f3f31 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -266,11 +266,11 @@ Qed. Lemma Rmax_Rlt : forall x y z, Rmax x y < z <-> x < z /\ y < z. Proof. -intros x y z; split. -- unfold Rmax; case (Rle_dec x y). - + intros xy yz; split;[apply Rle_lt_trans with y|]; assumption. - + intros xz xy; split;[|apply Rlt_trans with x;[apply Rnot_le_gt|]];assumption. -- intros [h h']; apply Rmax_lub_lt; assumption. + intros x y z; split. + - unfold Rmax; case (Rle_dec x y). + + intros xy yz; split;[apply Rle_lt_trans with y|]; assumption. + + intros xz xy; split;[|apply Rlt_trans with x;[apply Rnot_le_gt|]];assumption. + - intros [h h']; apply Rmax_lub_lt; assumption. Qed. (*********) @@ -308,8 +308,8 @@ Qed. Lemma Rabs_R1 : Rabs 1 = 1. Proof. -unfold Rabs; case (Rcase_abs 1); auto with real. -intros H; absurd (1 < 0); auto with real. + unfold Rabs; case (Rcase_abs 1); auto with real. + intros H; absurd (1 < 0); auto with real. Qed. (*********) @@ -365,9 +365,9 @@ Definition RRle_abs := Rle_abs. Lemma Rabs_le : forall a b, -b <= a <= b -> Rabs a <= b. Proof. -intros a b; unfold Rabs; case Rcase_abs. -- intros _ [it _]; apply Ropp_le_cancel; rewrite Ropp_involutive; exact it. -- intros _ [_ it]; exact it. + intros a b; unfold Rabs; case Rcase_abs. + - intros _ [it _]; apply Ropp_le_cancel; rewrite Ropp_involutive; exact it. + - intros _ [_ it]; exact it. Qed. (*********) @@ -639,48 +639,50 @@ Proof. Qed. Lemma Ropp_Rmax : forall x y, - Rmax x y = Rmin (-x) (-y). -intros x y; apply Rmax_case_strong. -- now intros w; rewrite Rmin_left;[ | apply Rge_le, Ropp_le_ge_contravar]. -- now intros w; rewrite Rmin_right; [ | apply Rge_le, Ropp_le_ge_contravar]. +Proof. + intros x y; apply Rmax_case_strong. + - now intros w; rewrite Rmin_left;[ | apply Rge_le, Ropp_le_ge_contravar]. + - now intros w; rewrite Rmin_right; [ | apply Rge_le, Ropp_le_ge_contravar]. Qed. Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y). -intros x y; apply Rmin_case_strong. -- now intros w; rewrite Rmax_left;[ | apply Rge_le, Ropp_le_ge_contravar]. -- now intros w; rewrite Rmax_right; [ | apply Rge_le, Ropp_le_ge_contravar]. +Proof. + intros x y; apply Rmin_case_strong. + - now intros w; rewrite Rmax_left;[ | apply Rge_le, Ropp_le_ge_contravar]. + - now intros w; rewrite Rmax_right; [ | apply Rge_le, Ropp_le_ge_contravar]. Qed. Lemma Rmax_assoc : forall a b c, Rmax a (Rmax b c) = Rmax (Rmax a b) c. Proof. -intros a b c. -unfold Rmax; destruct (Rle_dec b c); destruct (Rle_dec a b); - destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real; - match goal with - | id : ~ ?x <= ?y, id2 : ?x <= ?z |- _ => - case id; apply Rle_trans with z; auto with real - | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ => - case id; apply Rle_trans with z; auto with real - end. + intros a b c. + unfold Rmax; destruct (Rle_dec b c); destruct (Rle_dec a b); + destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real; + match goal with + | id : ~ ?x <= ?y, id2 : ?x <= ?z |- _ => + case id; apply Rle_trans with z; auto with real + | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ => + case id; apply Rle_trans with z; auto with real + end. Qed. Lemma Rminmax : forall a b, Rmin a b <= Rmax a b. Proof. -intros a b; destruct (Rle_dec a b). -- rewrite Rmin_left, Rmax_right; assumption. -- now rewrite Rmin_right, Rmax_left; assumption || - apply Rlt_le, Rnot_le_gt. + intros a b; destruct (Rle_dec a b). + - rewrite Rmin_left, Rmax_right; assumption. + - now rewrite Rmin_right, Rmax_left; assumption || + apply Rlt_le, Rnot_le_gt. Qed. Lemma Rmin_assoc : forall x y z, Rmin x (Rmin y z) = Rmin (Rmin x y) z. Proof. -intros a b c. -unfold Rmin; destruct (Rle_dec b c); destruct (Rle_dec a b); - destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real; - match goal with - | id : ~ ?x <= ?y, id2 : ?x <= ?z |- _ => - case id; apply Rle_trans with z; auto with real - | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ => - case id; apply Rle_trans with z; auto with real - end. + intros a b c. + unfold Rmin; destruct (Rle_dec b c); destruct (Rle_dec a b); + destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real; + match goal with + | id : ~ ?x <= ?y, id2 : ?x <= ?z |- _ => + case id; apply Rle_trans with z; auto with real + | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ => + case id; apply Rle_trans with z; auto with real + end. Qed. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 2c3d11c67b..4bd2ad353d 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -85,11 +85,11 @@ Qed. Lemma Rpow_mult_distr : forall (x y:R) (n:nat), (x * y) ^ n = x^n * y^n. Proof. -intros x y n ; induction n. -- field. -- simpl. - repeat (rewrite Rmult_assoc) ; apply Rmult_eq_compat_l. - rewrite IHn ; field. + intros x y n ; induction n. + - field. + - simpl. + repeat (rewrite Rmult_assoc) ; apply Rmult_eq_compat_l. + rewrite IHn ; field. Qed. Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0. @@ -285,16 +285,16 @@ Qed. Lemma pow_inv x n : (/ x)^n = / x^n. Proof. -induction n as [|n IH] ; simpl. -- apply eq_sym, Rinv_1. -- rewrite Rinv_mult. - now apply f_equal. + induction n as [|n IH] ; simpl. + - apply eq_sym, Rinv_1. + - rewrite Rinv_mult. + now apply f_equal. Qed. Lemma Rinv_pow_depr : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n. Proof. -intros x n _. -apply eq_sym, pow_inv. + intros x n _. + apply eq_sym, pow_inv. Qed. #[deprecated(since="8.16",note="Use pow_inv.")] @@ -524,7 +524,7 @@ Qed. Lemma Rsqr_pow2 : forall x, Rsqr x = x ^ 2. Proof. -intros; unfold Rsqr; simpl; rewrite Rmult_1_r; reflexivity. + intros; unfold Rsqr; simpl; rewrite Rmult_1_r; reflexivity. Qed. @@ -535,236 +535,236 @@ Qed. Section PowerRZ. -#[local] Coercion Z_of_nat : nat >-> Z. - -(* the following section should probably be somewhere else, but not sure where *) -Section Z_compl. - -#[local] Open Scope Z_scope. - -(* Provides a way to reason directly on Z in terms of nats instead of positive *) -Inductive Z_spec (x : Z) : Z -> Type := -| ZintNull : x = 0 -> Z_spec x 0 -| ZintPos (n : nat) : x = n -> Z_spec x n -| ZintNeg (n : nat) : x = - n -> Z_spec x (- n). - -Lemma intP (x : Z) : Z_spec x x. -Proof. - destruct x as [|p|p]. - - now apply ZintNull. - - rewrite <-positive_nat_Z at 2. - apply ZintPos. - now rewrite positive_nat_Z. - - rewrite <-Pos2Z.opp_pos. - rewrite <-positive_nat_Z at 2. - apply ZintNeg. - now rewrite positive_nat_Z. -Qed. - -End Z_compl. - -Definition powerRZ (x:R) (n:Z) := - match n with - | Z0 => 1 - | Zpos p => x ^ Pos.to_nat p - | Zneg p => / x ^ Pos.to_nat p - end. - -#[local] Infix "^Z" := powerRZ (at level 30, right associativity) : R_scope. - -Lemma Zpower_NR0 : - forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z. -Proof. - induction n; unfold Zpower_nat; simpl; auto with zarith. -Qed. - -Lemma powerRZ_O : forall x:R, x ^Z 0 = 1. -Proof. - reflexivity. -Qed. - -Lemma powerRZ_1 : forall x:R, x ^Z Z.succ 0 = x. -Proof. - simpl; auto with real. -Qed. - -Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0. -Proof. - destruct z; simpl; auto with real. -Qed. - -Lemma powerRZ_pos_sub (x:R) (n m:positive) : x <> 0 -> - x ^Z (Z.pos_sub n m) = x ^ Pos.to_nat n * / x ^ Pos.to_nat m. -Proof. - intro Hx. - rewrite Z.pos_sub_spec. - case Pos.compare_spec; intro H; simpl. - - subst; symmetry; auto with real. - - rewrite Pos2Nat.inj_sub by trivial. - rewrite Pos2Nat.inj_lt in H. - rewrite (pow_RN_plus x _ (Pos.to_nat n)) by auto with real. - rewrite Nat.sub_add; [ | apply Nat.lt_le_incl; assumption ]. - rewrite Rinv_mult, Rinv_inv; auto with real. - - rewrite Pos2Nat.inj_sub by trivial. - rewrite Pos2Nat.inj_lt in H. - rewrite (pow_RN_plus x _ (Pos.to_nat m)) by auto with real. - rewrite Nat.sub_add; [ reflexivity | apply Nat.lt_le_incl; assumption ]. -Qed. - -Lemma powerRZ_add : - forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m. -Proof. - intros x [|n|n] [|m|m]; simpl; intros; auto with real. - - (* + + *) - rewrite Pos2Nat.inj_add; auto with real. - - (* + - *) - now apply powerRZ_pos_sub. - - (* - + *) - rewrite Rmult_comm. now apply powerRZ_pos_sub. - - (* - - *) - rewrite Pos2Nat.inj_add; auto with real. - rewrite pow_add; auto with real. - apply Rinv_mult. -Qed. -#[local] -Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real. - -Lemma Zpower_nat_powerRZ : - forall n m:nat, IZR (Zpower_nat (Z.of_nat n) m) = INR n ^Z Z.of_nat m. -Proof. - intros n m; elim m; simpl; auto with real. - intros m1 H'; rewrite SuccNat2Pos.id_succ; simpl. - replace (Zpower_nat (Z.of_nat n) (S m1)) with - (Z.of_nat n * Zpower_nat (Z.of_nat n) m1)%Z. - - rewrite mult_IZR; auto with real. - repeat rewrite <- INR_IZR_INZ; simpl. - rewrite H'; simpl. - case m1; simpl; auto with real. - intros m2; rewrite SuccNat2Pos.id_succ; auto. - - unfold Zpower_nat; auto. -Qed. - -Lemma Zpower_pos_powerRZ : - forall n m, IZR (Z.pow_pos n m) = IZR n ^Z Zpos m. -Proof. - intros. - rewrite Zpower_pos_nat; simpl. - induction (Pos.to_nat m). - - easy. - - unfold Zpower_nat; simpl. - rewrite mult_IZR. - now rewrite <- IHn0. -Qed. - -Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. -Proof. - intros x z; case z; simpl; auto with real. -Qed. -#[local] -Hint Resolve powerRZ_lt: real. - -Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z. -Proof. - intros x z H'; apply Rlt_le; auto with real. -Qed. -#[local] -Hint Resolve powerRZ_le: real. - -Lemma Zpower_nat_powerRZ_absolu : - forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Z.abs_nat m)) = IZR n ^Z m. -Proof. - intros n m; case m; simpl; auto with zarith. - - intros p H'; elim (Pos.to_nat p); simpl; auto with zarith. - intros n0 H'0; rewrite <- H'0; simpl; auto with zarith. - rewrite <- mult_IZR; auto. - - intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith. -Qed. - -Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1. -Proof. - intros n; case n; simpl; auto. - - intros p; elim (Pos.to_nat p); simpl; auto; intros n0 H'; rewrite H'; - ring. - - intros p; elim (Pos.to_nat p); simpl. - + exact Rinv_1. - + intros n1 H'; rewrite Rinv_mult; try rewrite Rinv_1; try rewrite H'; - auto with real. -Qed. - -#[local] Open Scope Z_scope. - -Lemma pow_powerRZ (r : R) (n : nat) : - (r ^ n)%R = powerRZ r (Z_of_nat n). -Proof. - induction n; [easy|simpl]. - now rewrite SuccNat2Pos.id_succ. -Qed. - -Lemma powerRZ_ind (P : Z -> R -> R -> Prop) : - (forall x, P 0 x 1%R) -> - (forall x n, P (Z.of_nat n) x (x ^ n)%R) -> - (forall x n, P ((-(Z.of_nat n))%Z) x (Rinv (x ^ n))) -> - forall x (m : Z), P m x (powerRZ x m)%R. -Proof. - intros ? ? ? x m. - destruct (intP m) as [Hm|n Hm|n Hm]. - - easy. - - now rewrite <- pow_powerRZ. - - unfold powerRZ. - destruct n as [|n]; [ easy |]. - rewrite Nat2Z.inj_succ, <- Zpos_P_of_succ_nat, Pos2Z.opp_pos. - now rewrite <- Pos2Z.opp_pos, <- positive_nat_Z. -Qed. - -Lemma powerRZ_inv' x alpha : powerRZ (/ x) alpha = Rinv (powerRZ x alpha). -Proof. - destruct (intP alpha). - - now simpl; rewrite Rinv_1. - - now rewrite <-!pow_powerRZ, ?pow_inv, ?pow_powerRZ. - - unfold powerRZ. - destruct (- n). - + now rewrite Rinv_1. - + apply pow_inv. - + now rewrite pow_inv. -Qed. - -Lemma powerRZ_inv_depr x alpha : (x <> 0)%R -> powerRZ (/ x) alpha = Rinv (powerRZ x alpha). -Proof. - intros _. - apply powerRZ_inv'. -Qed. - -Lemma powerRZ_neg' x : forall alpha, powerRZ x (- alpha) = Rinv (powerRZ x alpha). -Proof. - intros [|n|n] ; simpl. - - apply eq_sym, Rinv_1. - - easy. - - now rewrite Rinv_inv. -Qed. - -Lemma powerRZ_neg_depr x : forall alpha, x <> R0 -> powerRZ x (- alpha) = powerRZ (/ x) alpha. -Proof. - intros alpha _. - rewrite powerRZ_neg'. - apply eq_sym, powerRZ_inv'. -Qed. - -Lemma powerRZ_mult m x y : (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. -Proof. - destruct (intP m) as [ | | n Hm ]. - - now simpl; rewrite Rmult_1_l. - - now rewrite <- !pow_powerRZ, Rpow_mult_distr. - - rewrite !powerRZ_neg', <- Rinv_mult. - now rewrite <- !pow_powerRZ, Rpow_mult_distr. -Qed. - -Lemma powerRZ_mult_distr_depr : - forall m x y, ((0 <= m)%Z \/ (x * y <> 0)%R) -> - (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. -Proof. - intros m x y _. - apply powerRZ_mult. -Qed. + #[local] Coercion Z_of_nat : nat >-> Z. + + (* the following section should probably be somewhere else, but not sure where *) + Section Z_compl. + + #[local] Open Scope Z_scope. + + (* Provides a way to reason directly on Z in terms of nats instead of positive *) + Inductive Z_spec (x : Z) : Z -> Type := + | ZintNull : x = 0 -> Z_spec x 0 + | ZintPos (n : nat) : x = n -> Z_spec x n + | ZintNeg (n : nat) : x = - n -> Z_spec x (- n). + + Lemma intP (x : Z) : Z_spec x x. + Proof. + destruct x as [|p|p]. + - now apply ZintNull. + - rewrite <-positive_nat_Z at 2. + apply ZintPos. + now rewrite positive_nat_Z. + - rewrite <-Pos2Z.opp_pos. + rewrite <-positive_nat_Z at 2. + apply ZintNeg. + now rewrite positive_nat_Z. + Qed. + + End Z_compl. + + Definition powerRZ (x:R) (n:Z) := + match n with + | Z0 => 1 + | Zpos p => x ^ Pos.to_nat p + | Zneg p => / x ^ Pos.to_nat p + end. + + #[local] Infix "^Z" := powerRZ (at level 30, right associativity) : R_scope. + + Lemma Zpower_NR0 : + forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z. + Proof. + induction n; unfold Zpower_nat; simpl; auto with zarith. + Qed. + + Lemma powerRZ_O : forall x:R, x ^Z 0 = 1. + Proof. + reflexivity. + Qed. + + Lemma powerRZ_1 : forall x:R, x ^Z Z.succ 0 = x. + Proof. + simpl; auto with real. + Qed. + + Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0. + Proof. + destruct z; simpl; auto with real. + Qed. + + Lemma powerRZ_pos_sub (x:R) (n m:positive) : x <> 0 -> + x ^Z (Z.pos_sub n m) = x ^ Pos.to_nat n * / x ^ Pos.to_nat m. + Proof. + intro Hx. + rewrite Z.pos_sub_spec. + case Pos.compare_spec; intro H; simpl. + - subst; symmetry; auto with real. + - rewrite Pos2Nat.inj_sub by trivial. + rewrite Pos2Nat.inj_lt in H. + rewrite (pow_RN_plus x _ (Pos.to_nat n)) by auto with real. + rewrite Nat.sub_add; [ | apply Nat.lt_le_incl; assumption ]. + rewrite Rinv_mult, Rinv_inv; auto with real. + - rewrite Pos2Nat.inj_sub by trivial. + rewrite Pos2Nat.inj_lt in H. + rewrite (pow_RN_plus x _ (Pos.to_nat m)) by auto with real. + rewrite Nat.sub_add; [ reflexivity | apply Nat.lt_le_incl; assumption ]. + Qed. + + Lemma powerRZ_add : + forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m. + Proof. + intros x [|n|n] [|m|m]; simpl; intros; auto with real. + - (* + + *) + rewrite Pos2Nat.inj_add; auto with real. + - (* + - *) + now apply powerRZ_pos_sub. + - (* - + *) + rewrite Rmult_comm. now apply powerRZ_pos_sub. + - (* - - *) + rewrite Pos2Nat.inj_add; auto with real. + rewrite pow_add; auto with real. + apply Rinv_mult. + Qed. + #[local] + Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real. + + Lemma Zpower_nat_powerRZ : + forall n m:nat, IZR (Zpower_nat (Z.of_nat n) m) = INR n ^Z Z.of_nat m. + Proof. + intros n m; elim m; simpl; auto with real. + intros m1 H'; rewrite SuccNat2Pos.id_succ; simpl. + replace (Zpower_nat (Z.of_nat n) (S m1)) with + (Z.of_nat n * Zpower_nat (Z.of_nat n) m1)%Z. + - rewrite mult_IZR; auto with real. + repeat rewrite <- INR_IZR_INZ; simpl. + rewrite H'; simpl. + case m1; simpl; auto with real. + intros m2; rewrite SuccNat2Pos.id_succ; auto. + - unfold Zpower_nat; auto. + Qed. + + Lemma Zpower_pos_powerRZ : + forall n m, IZR (Z.pow_pos n m) = IZR n ^Z Zpos m. + Proof. + intros. + rewrite Zpower_pos_nat; simpl. + induction (Pos.to_nat m). + - easy. + - unfold Zpower_nat; simpl. + rewrite mult_IZR. + now rewrite <- IHn0. + Qed. + + Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. + Proof. + intros x z; case z; simpl; auto with real. + Qed. + #[local] + Hint Resolve powerRZ_lt: real. + + Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z. + Proof. + intros x z H'; apply Rlt_le; auto with real. + Qed. + #[local] + Hint Resolve powerRZ_le: real. + + Lemma Zpower_nat_powerRZ_absolu : + forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Z.abs_nat m)) = IZR n ^Z m. + Proof. + intros n m; case m; simpl; auto with zarith. + - intros p H'; elim (Pos.to_nat p); simpl; auto with zarith. + intros n0 H'0; rewrite <- H'0; simpl; auto with zarith. + rewrite <- mult_IZR; auto. + - intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith. + Qed. + + Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1. + Proof. + intros n; case n; simpl; auto. + - intros p; elim (Pos.to_nat p); simpl; auto; intros n0 H'; rewrite H'; + ring. + - intros p; elim (Pos.to_nat p); simpl. + + exact Rinv_1. + + intros n1 H'; rewrite Rinv_mult; try rewrite Rinv_1; try rewrite H'; + auto with real. + Qed. + + #[local] Open Scope Z_scope. + + Lemma pow_powerRZ (r : R) (n : nat) : + (r ^ n)%R = powerRZ r (Z_of_nat n). + Proof. + induction n; [easy|simpl]. + now rewrite SuccNat2Pos.id_succ. + Qed. + + Lemma powerRZ_ind (P : Z -> R -> R -> Prop) : + (forall x, P 0 x 1%R) -> + (forall x n, P (Z.of_nat n) x (x ^ n)%R) -> + (forall x n, P ((-(Z.of_nat n))%Z) x (Rinv (x ^ n))) -> + forall x (m : Z), P m x (powerRZ x m)%R. + Proof. + intros ? ? ? x m. + destruct (intP m) as [Hm|n Hm|n Hm]. + - easy. + - now rewrite <- pow_powerRZ. + - unfold powerRZ. + destruct n as [|n]; [ easy |]. + rewrite Nat2Z.inj_succ, <- Zpos_P_of_succ_nat, Pos2Z.opp_pos. + now rewrite <- Pos2Z.opp_pos, <- positive_nat_Z. + Qed. + + Lemma powerRZ_inv' x alpha : powerRZ (/ x) alpha = Rinv (powerRZ x alpha). + Proof. + destruct (intP alpha). + - now simpl; rewrite Rinv_1. + - now rewrite <-!pow_powerRZ, ?pow_inv, ?pow_powerRZ. + - unfold powerRZ. + destruct (- n). + + now rewrite Rinv_1. + + apply pow_inv. + + now rewrite pow_inv. + Qed. + + Lemma powerRZ_inv_depr x alpha : (x <> 0)%R -> powerRZ (/ x) alpha = Rinv (powerRZ x alpha). + Proof. + intros _. + apply powerRZ_inv'. + Qed. + + Lemma powerRZ_neg' x : forall alpha, powerRZ x (- alpha) = Rinv (powerRZ x alpha). + Proof. + intros [|n|n] ; simpl. + - apply eq_sym, Rinv_1. + - easy. + - now rewrite Rinv_inv. + Qed. + + Lemma powerRZ_neg_depr x : forall alpha, x <> R0 -> powerRZ x (- alpha) = powerRZ (/ x) alpha. + Proof. + intros alpha _. + rewrite powerRZ_neg'. + apply eq_sym, powerRZ_inv'. + Qed. + + Lemma powerRZ_mult m x y : (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. + Proof. + destruct (intP m) as [ | | n Hm ]. + - now simpl; rewrite Rmult_1_l. + - now rewrite <- !pow_powerRZ, Rpow_mult_distr. + - rewrite !powerRZ_neg', <- Rinv_mult. + now rewrite <- !pow_powerRZ, Rpow_mult_distr. + Qed. + + Lemma powerRZ_mult_distr_depr : + forall m x y, ((0 <= m)%Z \/ (x * y <> 0)%R) -> + (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. + Proof. + intros m x y _. + apply powerRZ_mult. + Qed. End PowerRZ. @@ -914,8 +914,8 @@ Qed. Lemma Rdist_mult_l : forall a b c, Rdist (a * b) (a * c) = Rabs a * Rdist b c. Proof. -unfold Rdist. -intros a b c; rewrite <- Rmult_minus_distr_l, Rabs_mult; reflexivity. + unfold Rdist. + intros a b c; rewrite <- Rmult_minus_distr_l, Rabs_mult; reflexivity. Qed. Notation R_dist := Rdist (only parsing). diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index bb2a84fb2a..ae0a3d9038 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -392,10 +392,11 @@ Lemma Riemann_integrable_ext : forall f g a b, (forall x, Rmin a b <= x <= Rmax a b -> f x = g x) -> Riemann_integrable f a b -> Riemann_integrable g a b. -intros f g a b fg rif eps; destruct (rif eps) as [phi [psi [P1 P2]]]. -exists phi; exists psi;split;[ | assumption ]. -intros t intt; rewrite <- fg;[ | assumption]. -apply P1; assumption. +Proof. + intros f g a b fg rif eps; destruct (rif eps) as [phi [psi [P1 P2]]]. + exists phi; exists psi;split;[ | assumption ]. + intros t intt; rewrite <- fg;[ | assumption]. + apply P1; assumption. Qed. (**********) Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R := @@ -3134,21 +3135,23 @@ Lemma RiemannInt_const_bound : forall f a b l u (h : Riemann_integrable f a b), a <= b -> (forall x, a < x < b -> l <= f x <= u) -> l * (b - a) <= RiemannInt h <= u * (b - a). -intros f a b l u ri ab intf. -rewrite <- !(fun l => RiemannInt_P15 (RiemannInt_P14 a b l)). -split; apply RiemannInt_P19; try assumption; - intros x intx; unfold fct_cte; destruct (intf x intx); assumption. +Proof. + intros f a b l u ri ab intf. + rewrite <- !(fun l => RiemannInt_P15 (RiemannInt_P14 a b l)). + split; apply RiemannInt_P19; try assumption; + intros x intx; unfold fct_cte; destruct (intf x intx); assumption. Qed. Lemma Riemann_integrable_scal : forall f a b k, Riemann_integrable f a b -> Riemann_integrable (fun x => k * f x) a b. -intros f a b k ri. -apply Riemann_integrable_ext with - (f := fun x => 0 + k * f x). - { intros; ring. } -apply (RiemannInt_P10 _ (RiemannInt_P14 _ _ 0) ri). +Proof. + intros f a b k ri. + apply Riemann_integrable_ext with + (f := fun x => 0 + k * f x). + { intros; ring. } + apply (RiemannInt_P10 _ (RiemannInt_P14 _ _ 0) ri). Qed. Arguments Riemann_integrable_scal [f a b] k _ eps. @@ -3156,10 +3159,11 @@ Arguments Riemann_integrable_scal [f a b] k _ eps. Lemma Riemann_integrable_Ropp : forall f a b, Riemann_integrable f a b -> Riemann_integrable (fun x => - f x) a b. -intros ff a b h. -apply Riemann_integrable_ext with (f := fun x => (-1) * ff x). -{ intros; ring. } -apply Riemann_integrable_scal; assumption. +Proof. + intros ff a b h. + apply Riemann_integrable_ext with (f := fun x => (-1) * ff x). + { intros; ring. } + apply Riemann_integrable_scal; assumption. Qed. Arguments Riemann_integrable_Ropp [f a b] _ eps. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 917d6d115d..f59ece44b6 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -105,6 +105,7 @@ Qed. (*********) Lemma mul_factor_gt_f : forall eps l l':R, eps > 0 -> Rmin 1 (eps * mul_factor l l') > 0. +Proof. intros; apply Rmin_Rgt_r; split. - exact Rlt_0_1. - exact (mul_factor_gt eps l l' H). diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index 45d2c3b5fb..82406e803e 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -27,114 +27,114 @@ statement in the arithmetical hierarchy. *) Section Arithmetical_dec. -Variable P : nat -> Prop. -Hypothesis HP : forall n, {P n} + {~P n}. + Variable P : nat -> Prop. + Hypothesis HP : forall n, {P n} + {~P n}. -Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}. -Proof. -assert (Hi: (forall n, 0 < INR n + 1)%R). { - intros n. - apply Rplus_le_lt_0_compat with (1 := (pos_INR n)); apply Rlt_0_1. -} -set (u n := (if HP n then 0 else / (INR n + 1))%R). -assert (Bu: forall n, (u n <= 1)%R). { - intros n. - unfold u. - case HP ; intros _. - - apply Rle_0_1. - - rewrite <- S_INR, <- Rinv_1. - apply Rinv_le_contravar with (1 := Rlt_0_1). - apply (le_INR 1); apply -> Nat.succ_le_mono; apply Nat.le_0_l. -} -set (E y := exists n, y = u n). -destruct (completeness E) as [l [ub lub]]. -- exists R1. - intros y [n ->]. - apply Bu. -- exists (u O). - now exists O. -- assert (Hnp: forall n, not (P n) -> ((/ (INR n + 1) <= l)%R)). { - intros n Hp. - apply ub. - exists n. - unfold u. - now destruct (HP n). - } - destruct (Rle_lt_dec l 0) as [Hl|Hl]. - + right. - intros n. - destruct (HP n) as [H|H]. - * exact H. - * exfalso. - apply Rle_not_lt with (1 := Hl). - apply Rlt_le_trans with (/ (INR n + 1))%R. - -- now apply Rinv_0_lt_compat. - -- now apply Hnp. - + left. - set (N := Z.abs_nat (up (/l) - 2)). - assert (H1l: (1 <= /l)%R). { - rewrite <- Rinv_1. - apply Rinv_le_contravar with (1 := Hl). - apply lub. - now intros y [m ->]. + Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}. + Proof. + assert (Hi: (forall n, 0 < INR n + 1)%R). { + intros n. + apply Rplus_le_lt_0_compat with (1 := (pos_INR n)); apply Rlt_0_1. } - assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). { - unfold N. - rewrite INR_IZR_INZ. - rewrite inj_Zabs_nat. - replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. - - apply (f_equal (fun v => IZR v + 1)%R). - apply Z.abs_eq. - apply Zle_minus_le_0. - apply (Zlt_le_succ 1). - apply lt_IZR. - apply Rle_lt_trans with (1 := H1l). - apply archimed. - - rewrite minus_IZR. - simpl. - ring. + set (u n := (if HP n then 0 else / (INR n + 1))%R). + assert (Bu: forall n, (u n <= 1)%R). { + intros n. + unfold u. + case HP ; intros _. + - apply Rle_0_1. + - rewrite <- S_INR, <- Rinv_1. + apply Rinv_le_contravar with (1 := Rlt_0_1). + apply (le_INR 1); apply -> Nat.succ_le_mono; apply Nat.le_0_l. } - assert (Hl': (/ (INR (S N) + 1) < l)%R). { - rewrite <- (Rinv_inv l). - apply Rinv_0_lt_contravar. - { now apply Rinv_0_lt_compat. } - rewrite S_INR. - rewrite HN. - ring_simplify. - apply archimed. - } - exists N. - intros H. - apply Rle_not_lt with (2 := Hl'). - apply lub. - intros y [n ->]. - unfold u. - destruct (HP n) as [_|Hp]. - * apply Rlt_le. - now apply Rinv_0_lt_compat. - * apply Rinv_le_contravar. - -- apply Hi. - -- apply Rplus_le_compat_r. - apply le_INR. - destruct (Nat.le_gt_cases n N) as [Hn|Hn]. - 2: now apply Nat.le_succ_l. - exfalso. - destruct (proj1 (Nat.lt_eq_cases _ _) Hn) as [Hn'| ->]. - 2: now apply Hp. - apply Rlt_not_le with (2 := Hnp _ Hp). - rewrite <- (Rinv_inv l). - apply Rinv_0_lt_contravar. - ++ apply Rplus_le_lt_0_compat. - ** apply pos_INR. - ** apply Rlt_0_1. - ++ apply Rlt_le_trans with (INR N + 1)%R. - ** apply Rplus_lt_compat_r. - now apply lt_INR. - ** rewrite HN. - apply Rplus_le_reg_r with (-/l + 1)%R. - ring_simplify. - apply archimed. -Qed. + set (E y := exists n, y = u n). + destruct (completeness E) as [l [ub lub]]. + - exists R1. + intros y [n ->]. + apply Bu. + - exists (u O). + now exists O. + - assert (Hnp: forall n, not (P n) -> ((/ (INR n + 1) <= l)%R)). { + intros n Hp. + apply ub. + exists n. + unfold u. + now destruct (HP n). + } + destruct (Rle_lt_dec l 0) as [Hl|Hl]. + + right. + intros n. + destruct (HP n) as [H|H]. + * exact H. + * exfalso. + apply Rle_not_lt with (1 := Hl). + apply Rlt_le_trans with (/ (INR n + 1))%R. + -- now apply Rinv_0_lt_compat. + -- now apply Hnp. + + left. + set (N := Z.abs_nat (up (/l) - 2)). + assert (H1l: (1 <= /l)%R). { + rewrite <- Rinv_1. + apply Rinv_le_contravar with (1 := Hl). + apply lub. + now intros y [m ->]. + } + assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). { + unfold N. + rewrite INR_IZR_INZ. + rewrite inj_Zabs_nat. + replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. + - apply (f_equal (fun v => IZR v + 1)%R). + apply Z.abs_eq. + apply Zle_minus_le_0. + apply (Zlt_le_succ 1). + apply lt_IZR. + apply Rle_lt_trans with (1 := H1l). + apply archimed. + - rewrite minus_IZR. + simpl. + ring. + } + assert (Hl': (/ (INR (S N) + 1) < l)%R). { + rewrite <- (Rinv_inv l). + apply Rinv_0_lt_contravar. + { now apply Rinv_0_lt_compat. } + rewrite S_INR. + rewrite HN. + ring_simplify. + apply archimed. + } + exists N. + intros H. + apply Rle_not_lt with (2 := Hl'). + apply lub. + intros y [n ->]. + unfold u. + destruct (HP n) as [_|Hp]. + * apply Rlt_le. + now apply Rinv_0_lt_compat. + * apply Rinv_le_contravar. + -- apply Hi. + -- apply Rplus_le_compat_r. + apply le_INR. + destruct (Nat.le_gt_cases n N) as [Hn|Hn]. + 2: now apply Nat.le_succ_l. + exfalso. + destruct (proj1 (Nat.lt_eq_cases _ _) Hn) as [Hn'| ->]. + 2: now apply Hp. + apply Rlt_not_le with (2 := Hnp _ Hp). + rewrite <- (Rinv_inv l). + apply Rinv_0_lt_contravar. + ++ apply Rplus_le_lt_0_compat. + ** apply pos_INR. + ** apply Rlt_0_1. + ++ apply Rlt_le_trans with (INR N + 1)%R. + ** apply Rplus_lt_compat_r. + now apply lt_INR. + ** rewrite HN. + apply Rplus_le_reg_r with (-/l + 1)%R. + ring_simplify. + apply archimed. + Qed. End Arithmetical_dec. @@ -149,72 +149,72 @@ cannot be used for that purpose, since it relies on the [archimed] axiom. *) Theorem not_not_archimedean : forall r : R, ~ (forall n : nat, (INR n <= r)%R). Proof. -intros r H. -set (E := fun r => exists n : nat, r = INR n). -assert (exists x : R, E x) by - (exists 0%R; simpl; red; exists 0%nat; reflexivity). -assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H). -destruct (completeness E) as (M,(H3,H4)); try assumption. -set (M' := (M + -1)%R). -assert (H2 : ~ is_upper_bound E M'). { - intro H5. - assert (M <= M')%R by (apply H4; exact H5). - apply (Rlt_not_le M M'). { - unfold M'. - pattern M at 2. - rewrite <- Rplus_0_l. - pattern (0 + M)%R. - rewrite Rplus_comm. - rewrite <- (Rplus_opp_r 1). - apply Rplus_lt_compat_l. - rewrite Rplus_comm. - apply Rplus_pos_gt, Rlt_0_1. + intros r H. + set (E := fun r => exists n : nat, r = INR n). + assert (exists x : R, E x) by + (exists 0%R; simpl; red; exists 0%nat; reflexivity). + assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H). + destruct (completeness E) as (M,(H3,H4)); try assumption. + set (M' := (M + -1)%R). + assert (H2 : ~ is_upper_bound E M'). { + intro H5. + assert (M <= M')%R by (apply H4; exact H5). + apply (Rlt_not_le M M'). { + unfold M'. + pattern M at 2. + rewrite <- Rplus_0_l. + pattern (0 + M)%R. + rewrite Rplus_comm. + rewrite <- (Rplus_opp_r 1). + apply Rplus_lt_compat_l. + rewrite Rplus_comm. + apply Rplus_pos_gt, Rlt_0_1. + } + assumption. } + apply H2. + intros N (n,H7). + rewrite H7. + unfold M'. + assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity). + rewrite S_INR in H5. + assert (H6 : (INR n + 1 + -1 <= M + -1)%R). { + apply Rplus_le_compat_r. + assumption. + } + rewrite Rplus_assoc in H6. + rewrite Rplus_opp_r in H6. + rewrite (Rplus_comm (INR n) 0) in H6. + rewrite Rplus_0_l in H6. assumption. -} -apply H2. -intros N (n,H7). -rewrite H7. -unfold M'. -assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity). -rewrite S_INR in H5. -assert (H6 : (INR n + 1 + -1 <= M + -1)%R). { - apply Rplus_le_compat_r. - assumption. -} -rewrite Rplus_assoc in H6. -rewrite Rplus_opp_r in H6. -rewrite (Rplus_comm (INR n) 0) in H6. -rewrite Rplus_0_l in H6. -assumption. Qed. (** * Decidability of negated formulas *) Lemma sig_not_dec : forall P : Prop, {not (not P)} + {not P}. Proof. -intros P. -set (E := fun x => x = R0 \/ (x = R1 /\ P)). -destruct (completeness E) as [x H]. -- exists R1. - intros x [->|[-> _]]. - + apply Rle_0_1. - + apply Rle_refl. -- exists R0. - now left. -- destruct (Rle_lt_dec 1 x) as [H'|H']. - + left. - intros HP. - elim Rle_not_lt with (1 := H'). - apply Rle_lt_trans with (2 := Rlt_0_1). - apply H. - intros y [->|[_ Hy]]. - * apply Rle_refl. - * now elim HP. - + right. - intros HP. - apply Rlt_not_le with (1 := H'). - apply H. - right. - now split. + intros P. + set (E := fun x => x = R0 \/ (x = R1 /\ P)). + destruct (completeness E) as [x H]. + - exists R1. + intros x [->|[-> _]]. + + apply Rle_0_1. + + apply Rle_refl. + - exists R0. + now left. + - destruct (Rle_lt_dec 1 x) as [H'|H']. + + left. + intros HP. + elim Rle_not_lt with (1 := H'). + apply Rle_lt_trans with (2 := Rlt_0_1). + apply H. + intros y [->|[_ Hy]]. + * apply Rle_refl. + * now elim HP. + + right. + intros HP. + apply Rlt_not_le with (1 := H'). + apply H. + right. + now split. Qed. diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v index 5fd9c36856..936f436cf0 100644 --- a/theories/Reals/Rminmax.v +++ b/theories/Reals/Rminmax.v @@ -21,107 +21,107 @@ From Stdlib Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax. Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x. Proof. - unfold Rmax. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. + unfold Rmax. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. Qed. Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y. Proof. - unfold Rmax. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. + unfold Rmax. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. Qed. Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x. Proof. - unfold Rmin. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. + unfold Rmin. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. Qed. Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y. Proof. - unfold Rmin. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. + unfold Rmin. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. Qed. Module RHasMinMax <: HasMinMax R_as_OT. - Definition max := Rmax. - Definition min := Rmin. - Definition max_l := Rmax_l. - Definition max_r := Rmax_r. - Definition min_l := Rmin_l. - Definition min_r := Rmin_r. + Definition max := Rmax. + Definition min := Rmin. + Definition max_l := Rmax_l. + Definition max_r := Rmax_r. + Definition min_l := Rmin_l. + Definition min_r := Rmin_r. End RHasMinMax. Module R. -(** We obtain hence all the generic properties of max and min. *) - -Include UsualMinMaxProperties R_as_OT RHasMinMax. - -(** * Properties specific to the [R] domain *) - -(** Compatibilities (consequences of monotonicity) *) - -Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m. -Proof. - intros. apply max_monotone. - intros x y. apply Rplus_le_compat_l. -Qed. - -Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p. -Proof. - intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). - apply plus_max_distr_l. -Qed. - -Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m. -Proof. - intros. apply min_monotone. - intros x y. apply Rplus_le_compat_l. -Qed. - -Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p. -Proof. - intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). - apply plus_min_distr_l. -Qed. - -(** Anti-monotonicity swaps the role of [min] and [max] *) - -Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m). -Proof. - intros. symmetry. apply min_max_antimonotone. - do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. -Qed. - -Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m). -Proof. - intros. symmetry. apply max_min_antimonotone. - do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. -Qed. - -Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m. -Proof. - unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l. -Qed. - -Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p. -Proof. - unfold Rminus. intros. apply plus_max_distr_r. -Qed. - -Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m. -Proof. - unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l. -Qed. - -Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p. -Proof. - unfold Rminus. intros. apply plus_min_distr_r. -Qed. + (** We obtain hence all the generic properties of max and min. *) + + Include UsualMinMaxProperties R_as_OT RHasMinMax. + + (** * Properties specific to the [R] domain *) + + (** Compatibilities (consequences of monotonicity) *) + + Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m. + Proof. + intros. apply max_monotone. + intros x y. apply Rplus_le_compat_l. + Qed. + + Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p. + Proof. + intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). + apply plus_max_distr_l. + Qed. + + Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m. + Proof. + intros. apply min_monotone. + intros x y. apply Rplus_le_compat_l. + Qed. + + Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p. + Proof. + intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). + apply plus_min_distr_l. + Qed. + + (** Anti-monotonicity swaps the role of [min] and [max] *) + + Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m). + Proof. + intros. symmetry. apply min_max_antimonotone. + do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. + Qed. + + Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m). + Proof. + intros. symmetry. apply max_min_antimonotone. + do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. + Qed. + + Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m. + Proof. + unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l. + Qed. + + Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p. + Proof. + unfold Rminus. intros. apply plus_max_distr_r. + Qed. + + Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m. + Proof. + unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l. + Qed. + + Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p. + Proof. + unfold Rminus. intros. apply plus_min_distr_r. + Qed. End R. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index e06c4798b0..552d7667e2 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -750,25 +750,26 @@ Qed. Lemma Rpower_mult_distr : forall x y z, 0 < x -> 0 < y -> Rpower x z * Rpower y z = Rpower (x * y) z. -intros x y z x0 y0; unfold Rpower. -rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto. +Proof. + intros x y z x0 y0; unfold Rpower. + rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto. Qed. Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> Rpower a c < Rpower b c. Proof. -intros c0 [a0 ab]; apply exp_increasing. -now apply Rmult_lt_compat_l; auto; apply ln_increasing; lra. + intros c0 [a0 ab]; apply exp_increasing. + now apply Rmult_lt_compat_l; auto; apply ln_increasing; lra. Qed. Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> Rpower a c <= Rpower b c. Proof. -intros [c0 | c0]; - [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ]. -- intros [a0 [ab|ab]]. - + now apply Rlt_le, Rlt_Rpower_l;[ | split]; lra. - + rewrite ab; apply Rle_refl. -- apply Rlt_le_trans with a; tauto. -- tauto. + intros [c0 | c0]; + [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ]. + - intros [a0 [ab|ab]]. + + now apply Rlt_le, Rlt_Rpower_l;[ | split]; lra. + + rewrite ab; apply Rle_refl. + - apply Rlt_le_trans with a; tauto. + - tauto. Qed. (* arcsinh function *) @@ -776,104 +777,110 @@ Qed. Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)). Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x. -intros x; unfold sinh, arcsinh. -assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). -rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. -rewrite exp_plus. -match goal with |- context[sqrt ?a] => - replace a with (((exp x + exp(-x))/2)^2) by field -end. -rewrite sqrt_pow2; - [|apply Rlt_le, Rmult_lt_0_compat;[apply Rplus_lt_0_compat; apply exp_pos | - apply Rinv_0_lt_compat, Rlt_0_2]]. -match goal with |- context[ln ?a] => replace a with (exp x) by field end. -rewrite ln_exp; reflexivity. +Proof. + intros x; unfold sinh, arcsinh. + assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). + rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. + rewrite exp_plus. + match goal with |- context[sqrt ?a] => + replace a with (((exp x + exp(-x))/2)^2) by field + end. + rewrite sqrt_pow2; + [|apply Rlt_le, Rmult_lt_0_compat;[apply Rplus_lt_0_compat; apply exp_pos | + apply Rinv_0_lt_compat, Rlt_0_2]]. + match goal with |- context[ln ?a] => replace a with (exp x) by field end. + rewrite ln_exp; reflexivity. Qed. Lemma sinh_arcsinh x : sinh (arcsinh x) = x. -unfold sinh, arcsinh. -assert (cmp : 0 < x + sqrt (x ^ 2 + 1)). { - destruct (Rle_dec x 0). - - replace (x ^ 2) with ((-x) ^ 2) by ring. - assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). { - apply sqrt_lt_1_alt. - split;[apply pow_le | ]; lra. - } - pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). - + assert (t:= sqrt_pos ((-x)^2)); lra. - + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | lra]. - - apply Rplus_lt_le_0_compat;[apply Rnot_le_gt; assumption | apply sqrt_pos]. -} -rewrite exp_ln;[ | assumption]. -rewrite exp_Ropp, exp_ln;[ | assumption]. -assert (Rmult_minus_distr_r : - forall x y z, (x - y) * z = x * z - y * z) by (intros; ring). -apply Rminus_diag_uniq; unfold Rdiv; rewrite Rmult_minus_distr_r. -assert (t: forall x y z, x - z = y -> x - y - z = 0);[ | apply t; clear t]. -- intros a b c H; rewrite <- H; ring. -- apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ | - apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]]. - field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; lra]. - apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1]. +Proof. + unfold sinh, arcsinh. + assert (cmp : 0 < x + sqrt (x ^ 2 + 1)). { + destruct (Rle_dec x 0). + - replace (x ^ 2) with ((-x) ^ 2) by ring. + assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). { + apply sqrt_lt_1_alt. + split;[apply pow_le | ]; lra. + } + pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). + + assert (t:= sqrt_pos ((-x)^2)); lra. + + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | lra]. + - apply Rplus_lt_le_0_compat;[apply Rnot_le_gt; assumption | apply sqrt_pos]. + } + rewrite exp_ln;[ | assumption]. + rewrite exp_Ropp, exp_ln;[ | assumption]. + assert (Rmult_minus_distr_r : + forall x y z, (x - y) * z = x * z - y * z) by (intros; ring). + apply Rminus_diag_uniq; unfold Rdiv; rewrite Rmult_minus_distr_r. + assert (t: forall x y z, x - z = y -> x - y - z = 0);[ | apply t; clear t]. + - intros a b c H; rewrite <- H; ring. + - apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ | + apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]]. + field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; lra]. + apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1]. Qed. Lemma derivable_pt_lim_arcsinh : forall x, derivable_pt_lim arcsinh x (/sqrt (x ^ 2 + 1)). -intros x; unfold arcsinh. -assert (0 < x + sqrt (x ^ 2 + 1)). { - destruct (Rle_dec x 0); - [ | assert (0 < x) by (apply Rnot_le_gt; assumption); - apply Rplus_lt_le_0_compat; auto; apply sqrt_pos]. - replace (x ^ 2) with ((-x) ^ 2) by ring. - assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). { - apply sqrt_lt_1_alt. - split;[apply pow_le|]; lra. - } - pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). - - assert (t:= sqrt_pos ((-x)^2)); lra. - - simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; lra. -} -assert (0 < x ^ 2 + 1). { - apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|lra]. -} -replace (/sqrt (x ^ 2 + 1)) with - (/(x + sqrt (x ^ 2 + 1)) * - (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))). -2:{ replace (INR 2 * x ^ 1 + 0) with (2 * x) by (simpl; ring). - replace (1 + / (2 * sqrt (x ^ 2 + 1)) * (2 * x)) with - (((sqrt (x ^ 2 + 1) + x))/sqrt (x ^ 2 + 1)); - [ | field; apply Rgt_not_eq, sqrt_lt_R0; assumption]. - apply Rmult_eq_reg_l with (x + sqrt (x ^ 2 + 1)); - [ | apply Rgt_not_eq; assumption]. - field. - split;apply Rgt_not_eq; auto; apply sqrt_lt_R0; assumption. } -apply (derivable_pt_lim_comp (fun x => x + sqrt (x ^ 2 + 1)) ln). -+ apply (derivable_pt_lim_plus). - * apply derivable_pt_lim_id. - * apply (derivable_pt_lim_comp (fun x => x ^ 2 + 1) sqrt x). - -- apply derivable_pt_lim_plus. - ++ apply derivable_pt_lim_pow. - ++ apply derivable_pt_lim_const. - -- apply derivable_pt_lim_sqrt; assumption. -+ apply derivable_pt_lim_ln; assumption. +Proof. + intros x; unfold arcsinh. + assert (0 < x + sqrt (x ^ 2 + 1)). { + destruct (Rle_dec x 0); + [ | assert (0 < x) by (apply Rnot_le_gt; assumption); + apply Rplus_lt_le_0_compat; auto; apply sqrt_pos]. + replace (x ^ 2) with ((-x) ^ 2) by ring. + assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). { + apply sqrt_lt_1_alt. + split;[apply pow_le|]; lra. + } + pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). + - assert (t:= sqrt_pos ((-x)^2)); lra. + - simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; lra. + } + assert (0 < x ^ 2 + 1). { + apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|lra]. + } + replace (/sqrt (x ^ 2 + 1)) with + (/(x + sqrt (x ^ 2 + 1)) * + (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))). + 2:{ replace (INR 2 * x ^ 1 + 0) with (2 * x) by (simpl; ring). + replace (1 + / (2 * sqrt (x ^ 2 + 1)) * (2 * x)) with + (((sqrt (x ^ 2 + 1) + x))/sqrt (x ^ 2 + 1)); + [ | field; apply Rgt_not_eq, sqrt_lt_R0; assumption]. + apply Rmult_eq_reg_l with (x + sqrt (x ^ 2 + 1)); + [ | apply Rgt_not_eq; assumption]. + field. + split;apply Rgt_not_eq; auto; apply sqrt_lt_R0; assumption. } + apply (derivable_pt_lim_comp (fun x => x + sqrt (x ^ 2 + 1)) ln). + + apply (derivable_pt_lim_plus). + * apply derivable_pt_lim_id. + * apply (derivable_pt_lim_comp (fun x => x ^ 2 + 1) sqrt x). + -- apply derivable_pt_lim_plus. + ++ apply derivable_pt_lim_pow. + ++ apply derivable_pt_lim_const. + -- apply derivable_pt_lim_sqrt; assumption. + + apply derivable_pt_lim_ln; assumption. Qed. Lemma arcsinh_lt : forall x y, x < y -> arcsinh x < arcsinh y. -intros x y xy. -case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ]. -intros abs; case (Rlt_not_le _ _ xy). -rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x). -destruct abs as [lt | q];[| rewrite q; lra]. -apply Rlt_le, sinh_lt; assumption. +Proof. + intros x y xy. + case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ]. + intros abs; case (Rlt_not_le _ _ xy). + rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x). + destruct abs as [lt | q];[| rewrite q; lra]. + apply Rlt_le, sinh_lt; assumption. Qed. Lemma arcsinh_le : forall x y, x <= y -> arcsinh x <= arcsinh y. -intros x y [xy | xqy]. -- apply Rlt_le, arcsinh_lt; assumption. -- rewrite xqy; apply Rle_refl. +Proof. + intros x y [xy | xqy]. + - apply Rlt_le, arcsinh_lt; assumption. + - rewrite xqy; apply Rle_refl. Qed. Lemma arcsinh_0 : arcsinh 0 = 0. - unfold arcsinh; rewrite pow_ne_zero, !Rplus_0_l, sqrt_1, ln_1; - [reflexivity | discriminate]. -Qed. + Proof. + unfold arcsinh; rewrite pow_ne_zero, !Rplus_0_l, sqrt_1, ln_1; + [reflexivity | discriminate]. + Qed. diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 27cfef7915..4376f7501e 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -401,16 +401,18 @@ Qed. (* Convergence is preserved after shifting the indices. *) Lemma CV_shift : forall f k l, Un_cv (fun n => f (n + k)%nat) l -> Un_cv f l. -intros f' k l cvfk eps ep; destruct (cvfk eps ep) as [N Pn]. -exists (N + k)%nat; intros n nN; assert (tmp: (n = (n - k) + k)%nat). -- rewrite Nat.sub_add;[ | apply Nat.le_trans with (N + k)%nat]; auto with arith. -- rewrite tmp; apply Pn; apply Nat.le_add_le_sub_r; assumption. +Proof. + intros f' k l cvfk eps ep; destruct (cvfk eps ep) as [N Pn]. + exists (N + k)%nat; intros n nN; assert (tmp: (n = (n - k) + k)%nat). + - rewrite Nat.sub_add;[ | apply Nat.le_trans with (N + k)%nat]; auto with arith. + - rewrite tmp; apply Pn; apply Nat.le_add_le_sub_r; assumption. Qed. Lemma CV_shift' : forall f k l, Un_cv f l -> Un_cv (fun n => f (n + k)%nat) l. -intros f' k l cvf eps ep; destruct (cvf eps ep) as [N Pn]. -exists N; intros n nN; apply Pn; auto with arith. +Proof. + intros f' k l cvf eps ep; destruct (cvf eps ep) as [N Pn]. + exists N; intros n nN; apply Pn; auto with arith. Qed. (* Growing property is preserved after shifting the indices (one way only) *) @@ -418,5 +420,5 @@ Qed. Lemma Un_growing_shift : forall k un, Un_growing un -> Un_growing (fun n => un (n + k)%nat). Proof. -intros k un P n; apply P. + intros k un P n; apply P. Qed. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index 2f2d58b036..881c98acf2 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -445,10 +445,11 @@ Qed. (* A general purpose corollary. *) Lemma cv_pow_half : forall a, Un_cv (fun n => a/2^n) 0. -intros a; unfold Rdiv; replace 0 with (a * 0) by ring. -apply CV_mult. -- intros eps ep; exists 0%nat; rewrite Rdist_eq; intros n _; assumption. -- exact (cv_infty_cv_0 pow_2_n pow_2_n_infty). +Proof. + intros a; unfold Rdiv; replace 0 with (a * 0) by ring. + apply CV_mult. + - intros eps ep; exists 0%nat; rewrite Rdist_eq; intros n _; assumption. + - exact (cv_infty_cv_0 pow_2_n pow_2_n_infty). Qed. (** Intermediate Value Theorem *) diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index b4ccec5913..5f04539080 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -167,53 +167,54 @@ Qed. Lemma sin_gt_cos_7_8 : sin (7 / 8) > cos (7 / 8). Proof. -assert (lo1 : 0 <= 7/8) by lra. -assert (up1 : 7/8 <= 4) by lra. -assert (lo : -2 <= 7/8) by lra. -assert (up : 7/8 <= 2) by lra. -destruct (pre_sin_bound _ 0 lo1 up1) as [lower _ ]. -destruct (pre_cos_bound _ 0 lo up) as [_ upper]. -apply Rle_lt_trans with (1 := upper). -apply Rlt_le_trans with (2 := lower). -unfold cos_approx, sin_approx. -simpl sum_f_R0. -unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. -simpl plus; simpl mult; simpl Z_of_nat. -field_simplify. -match goal with - |- IZR ?a / ?b < ?c / ?d => - apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | - unfold Rdiv at 2; rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_comm; - [ |apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity ]]; - apply Rmult_lt_reg_r with b;[apply (IZR_lt 0); reflexivity | ] -end. -unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r; - [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity]. -rewrite <- !mult_IZR. -apply IZR_lt; reflexivity. + assert (lo1 : 0 <= 7/8) by lra. + assert (up1 : 7/8 <= 4) by lra. + assert (lo : -2 <= 7/8) by lra. + assert (up : 7/8 <= 2) by lra. + destruct (pre_sin_bound _ 0 lo1 up1) as [lower _ ]. + destruct (pre_cos_bound _ 0 lo up) as [_ upper]. + apply Rle_lt_trans with (1 := upper). + apply Rlt_le_trans with (2 := lower). + unfold cos_approx, sin_approx. + simpl sum_f_R0. + unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. + simpl plus; simpl mult; simpl Z_of_nat. + field_simplify. + match goal with + |- IZR ?a / ?b < ?c / ?d => + apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | + unfold Rdiv at 2; rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_comm; + [ |apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity ]]; + apply Rmult_lt_reg_r with b;[apply (IZR_lt 0); reflexivity | ] + end. + unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r; + [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity]. + rewrite <- !mult_IZR. + apply IZR_lt; reflexivity. Qed. Definition PI_2_aux : {z | 7/8 <= z <= 7/4 /\ -cos z = 0}. -assert (cc : continuity (fun r =>- cos r)). { - apply continuity_opp, continuity_cos. -} -assert (cvp : 0 < cos (7/8)). { - assert (int78 : -2 <= 7/8 <= 2) by (split; lra). - destruct int78 as [lower upper]. - case (pre_cos_bound _ 0 lower upper). - unfold cos_approx; simpl sum_f_R0; unfold cos_term. - intros cl _; apply Rlt_le_trans with (2 := cl); simpl. - lra. -} -assert (cun : cos (7/4) < 0). { - replace (7/4) with (7/8 + 7/8) by field. - rewrite cos_plus. - apply Rlt_minus; apply Rsqr_incrst_1. - - exact sin_gt_cos_7_8. - - apply Rlt_le; assumption. - - apply Rlt_le; apply Rlt_trans with (1 := cvp); exact sin_gt_cos_7_8. -} -apply IVT; auto; lra. +Proof. + assert (cc : continuity (fun r =>- cos r)). { + apply continuity_opp, continuity_cos. + } + assert (cvp : 0 < cos (7/8)). { + assert (int78 : -2 <= 7/8 <= 2) by (split; lra). + destruct int78 as [lower upper]. + case (pre_cos_bound _ 0 lower upper). + unfold cos_approx; simpl sum_f_R0; unfold cos_term. + intros cl _; apply Rlt_le_trans with (2 := cl); simpl. + lra. + } + assert (cun : cos (7/4) < 0). { + replace (7/4) with (7/8 + 7/8) by field. + rewrite cos_plus. + apply Rlt_minus; apply Rsqr_incrst_1. + - exact sin_gt_cos_7_8. + - apply Rlt_le; assumption. + - apply Rlt_le; apply Rlt_trans with (1 := cvp); exact sin_gt_cos_7_8. + } + apply IVT; auto; lra. Qed. Definition PI2 := proj1_sig PI_2_aux. @@ -221,12 +222,14 @@ Definition PI2 := proj1_sig PI_2_aux. Definition PI := 2 * PI2. Lemma cos_pi2 : cos PI2 = 0. -unfold PI2; case PI_2_aux; simpl. -intros x [_ q]; rewrite <- (Ropp_involutive (cos x)), q; apply Ropp_0. +Proof. + unfold PI2; case PI_2_aux; simpl. + intros x [_ q]; rewrite <- (Ropp_involutive (cos x)), q; apply Ropp_0. Qed. Lemma pi2_int : 7/8 <= PI2 <= 7/4. -unfold PI2; case PI_2_aux; simpl; tauto. +Proof. + unfold PI2; case PI_2_aux; simpl; tauto. Qed. (**********) @@ -259,37 +262,39 @@ Qed. (**********) Lemma cos_PI2 : cos (PI / 2) = 0. Proof. - unfold PI; generalize cos_pi2; replace ((2 * PI2)/2) with PI2 by field; tauto. + unfold PI; generalize cos_pi2; replace ((2 * PI2)/2) with PI2 by field; tauto. Qed. Lemma sin_pos_tech : forall x, 0 < x < 2 -> 0 < sin x. -intros x [int1 int2]. -assert (lo : 0 <= x) by (apply Rlt_le; assumption). -assert (up : x <= 4) by (apply Rlt_le, Rlt_trans with (1:=int2); lra). -destruct (pre_sin_bound _ 0 lo up) as [t _]; clear lo up. -apply Rlt_le_trans with (2:= t); clear t. -unfold sin_approx; simpl sum_f_R0; unfold sin_term; simpl. -match goal with |- _ < ?a => - replace a with (x * (1 - x^2/6)) by (simpl; field) -end. -assert (t' : x ^ 2 <= 4). { - replace 4 with (2 ^ 2) by field. - apply (pow_incr x 2); split; apply Rlt_le; assumption. -} -apply Rmult_lt_0_compat;[assumption | lra ]. +Proof. + intros x [int1 int2]. + assert (lo : 0 <= x) by (apply Rlt_le; assumption). + assert (up : x <= 4) by (apply Rlt_le, Rlt_trans with (1:=int2); lra). + destruct (pre_sin_bound _ 0 lo up) as [t _]; clear lo up. + apply Rlt_le_trans with (2:= t); clear t. + unfold sin_approx; simpl sum_f_R0; unfold sin_term; simpl. + match goal with |- _ < ?a => + replace a with (x * (1 - x^2/6)) by (simpl; field) + end. + assert (t' : x ^ 2 <= 4). { + replace 4 with (2 ^ 2) by field. + apply (pow_incr x 2); split; apply Rlt_le; assumption. + } + apply Rmult_lt_0_compat;[assumption | lra ]. Qed. Lemma sin_PI2 : sin (PI / 2) = 1. -replace (PI / 2) with PI2 by (unfold PI; field). -assert (int' : 0 < PI2 < 2). { - destruct pi2_int; split; lra. -} -assert (lo2 := sin_pos_tech PI2 int'). -assert (t2 : Rabs (sin PI2) = 1). { - rewrite <- Rabs_R1; apply Rsqr_eq_abs_0. - rewrite Rsqr_1, sin2, cos_pi2, Rsqr_0, Rminus_0_r; reflexivity. -} -revert t2; rewrite Rabs_pos_eq;[| apply Rlt_le]; tauto. +Proof. + replace (PI / 2) with PI2 by (unfold PI; field). + assert (int' : 0 < PI2 < 2). { + destruct pi2_int; split; lra. + } + assert (lo2 := sin_pos_tech PI2 int'). + assert (t2 : Rabs (sin PI2) = 1). { + rewrite <- Rabs_R1; apply Rsqr_eq_abs_0. + rewrite Rsqr_1, sin2, cos_pi2, Rsqr_0, Rminus_0_r; reflexivity. + } + revert t2; rewrite Rabs_pos_eq;[| apply Rlt_le]; tauto. Qed. Lemma PI_RGT_0 : PI > 0. @@ -332,23 +337,23 @@ Qed. Lemma sin_bound : forall (a : R) (n : nat), 0 <= a -> a <= PI -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)). Proof. -intros a n a0 api; apply pre_sin_bound. -- assumption. -- apply Rle_trans with (1:= api) (2 := PI_4). + intros a n a0 api; apply pre_sin_bound. + - assumption. + - apply Rle_trans with (1:= api) (2 := PI_4). Qed. Lemma cos_bound : forall (a : R) (n : nat), - PI / 2 <= a -> a <= PI / 2 -> cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). Proof. -intros a n lower upper; apply pre_cos_bound. -- apply Rle_trans with (2 := lower). - apply Rmult_le_reg_r with 2; [lra |]. - replace ((-PI/2) * 2) with (-PI) by field. - assert (t := PI_4); lra. -- apply Rle_trans with (1 := upper). - apply Rmult_le_reg_r with 2; [lra | ]. - replace ((PI/2) * 2) with PI by field. - generalize PI_4; intros; lra. + intros a n lower upper; apply pre_cos_bound. + - apply Rle_trans with (2 := lower). + apply Rmult_le_reg_r with 2; [lra |]. + replace ((-PI/2) * 2) with (-PI) by field. + assert (t := PI_4); lra. + - apply Rle_trans with (1 := upper). + apply Rmult_le_reg_r with 2; [lra | ]. + replace ((PI/2) * 2) with PI by field. + generalize PI_4; intros; lra. Qed. (**********) Lemma neg_cos : forall x:R, cos (x + PI) = - cos x. @@ -1137,14 +1142,14 @@ Qed. Lemma sin_inj x y : -(PI/2) <= x <= PI/2 -> -(PI/2) <= y <= PI/2 -> sin x = sin y -> x = y. Proof. -intros xP yP Hsin. -destruct (total_order_T x y) as [[H|H]|H]; auto. -- assert (sin x < sin y). - + now apply sin_increasing_1; lra. - + now lra. -- assert (sin y < sin x). - + now apply sin_increasing_1; lra. - + now lra. + intros xP yP Hsin. + destruct (total_order_T x y) as [[H|H]|H]; auto. + - assert (sin x < sin y). + + now apply sin_increasing_1; lra. + + now lra. + - assert (sin y < sin x). + + now apply sin_increasing_1; lra. + + now lra. Qed. Lemma cos_increasing_0 : @@ -1229,14 +1234,14 @@ Qed. Lemma cos_inj x y : 0 <= x <= PI -> 0 <= y <= PI -> cos x = cos y -> x = y. Proof. -intros xP yP Hcos. -destruct (total_order_T x y) as [[H|H]|H]; auto. -- assert (cos y < cos x). - + now apply cos_decreasing_1; lra. - + now lra. -- assert (cos x < cos y). - + now apply cos_decreasing_1; lra. - + now lra. + intros xP yP Hcos. + destruct (total_order_T x y) as [[H|H]|H]; auto. + - assert (cos y < cos x). + + now apply cos_decreasing_1; lra. + + now lra. + - assert (cos x < cos y). + + now apply cos_decreasing_1; lra. + + now lra. Qed. Lemma tan_diff : @@ -1686,7 +1691,7 @@ Lemma cos_eq_0_2PI_1 (x:R) : 0 <= x -> x <= 2 * PI -> x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0. Proof. - intros Lo Hi [ -> | -> ]. - - now rewrite cos_PI2. - - now rewrite cos_3PI2. + intros Lo Hi [ -> | -> ]. + - now rewrite cos_PI2. + - now rewrite cos_3PI2. Qed. diff --git a/theories/Reals/Zfloor.v b/theories/Reals/Zfloor.v index 7ff3ba0012..00b7e96848 100644 --- a/theories/Reals/Zfloor.v +++ b/theories/Reals/Zfloor.v @@ -19,36 +19,36 @@ Proof. now rewrite up_Zfloor, plus_IZR. Qed. Lemma Zfloor_bound x : IZR (Zfloor x) <= x < IZR (Zfloor x) + 1. Proof. -unfold Zfloor; rewrite minus_IZR. -generalize (archimed x); lra. + unfold Zfloor; rewrite minus_IZR. + generalize (archimed x); lra. Qed. Lemma Zfloor_lub (z : Z) x : IZR z <= x -> (z <= Zfloor x)%Z. Proof. -intro H. -assert (H1 : (z < Zfloor x + 1)%Z);[| lia]. -apply lt_IZR; rewrite plus_IZR. -now generalize (Zfloor_bound x); lra. + intro H. + assert (H1 : (z < Zfloor x + 1)%Z);[| lia]. + apply lt_IZR; rewrite plus_IZR. + now generalize (Zfloor_bound x); lra. Qed. Lemma Zfloor_eq (z : Z) x : IZR z <= x < IZR z + 1 -> Zfloor x = z. Proof. -intro xB. -assert (ZxB := Zfloor_bound x). -assert (B : (Zfloor x < z + 1 /\ z <= Zfloor x)%Z) ; [| lia]. -split; [|apply Zfloor_lub; lra]. -apply lt_IZR; rewrite plus_IZR; lra. + intro xB. + assert (ZxB := Zfloor_bound x). + assert (B : (Zfloor x < z + 1 /\ z <= Zfloor x)%Z) ; [| lia]. + split; [|apply Zfloor_lub; lra]. + apply lt_IZR; rewrite plus_IZR; lra. Qed. Lemma Zfloor_le x y : x <= y -> (Zfloor x <= Zfloor y)%Z. Proof. -intro H; apply Zfloor_lub; generalize (Zfloor_bound x); lra. + intro H; apply Zfloor_lub; generalize (Zfloor_bound x); lra. Qed. Lemma Zfloor_addz (z: Z) x : Zfloor (x + IZR z) = (Zfloor x + z)%Z. Proof. -assert (ZB := Zfloor_bound x). -now apply Zfloor_eq; rewrite plus_IZR; lra. + assert (ZB := Zfloor_bound x). + now apply Zfloor_eq; rewrite plus_IZR; lra. Qed. Lemma ZfloorZ (z : Z) : Zfloor (IZR z) = z. @@ -63,17 +63,17 @@ Lemma ZfloorD_cond r1 r2 : then Zfloor (r1 + r2) = (Zfloor r1 + Zfloor r2 + 1)%Z else Zfloor (r1 + r2) = (Zfloor r1 + Zfloor r2)%Z. Proof. -destruct (Zfloor_bound r1, Zfloor_bound r2) as [H1 H2]. -case Rle_dec; intro H. - now apply Zfloor_eq; rewrite plus_IZR, plus_IZR; lra. -now apply Zfloor_eq; rewrite plus_IZR; lra. + destruct (Zfloor_bound r1, Zfloor_bound r2) as [H1 H2]. + case Rle_dec; intro H. + now apply Zfloor_eq; rewrite plus_IZR, plus_IZR; lra. + now apply Zfloor_eq; rewrite plus_IZR; lra. Qed. Definition Zceil (x : R) := (- Zfloor (- x))%Z. Theorem Zceil_bound x : (IZR (Zceil x) - 1 < x <= IZR (Zceil x))%R. Proof. -now unfold Zceil; generalize (Zfloor_bound (- x)); rewrite !opp_IZR; lra. + now unfold Zceil; generalize (Zfloor_bound (- x)); rewrite !opp_IZR; lra. Qed. Theorem Zfloor_ceil_bound x : (IZR (Zfloor x) <= x <= IZR (Zceil x))%R. @@ -87,19 +87,19 @@ Proof. unfold Zceil; lia. Qed. Lemma Zceil_eq (z : Z) x : IZR z - 1 < x <= IZR z -> Zceil x = z. Proof. -intro xB; assert (H : Zfloor (- x) = (- z)%Z); [|unfold Zceil; lia]. -now apply Zfloor_eq; rewrite opp_IZR; lra. + intro xB; assert (H : Zfloor (- x) = (- z)%Z); [|unfold Zceil; lia]. + now apply Zfloor_eq; rewrite opp_IZR; lra. Qed. Lemma Zceil_le x y : x <= y -> (Zceil x <= Zceil y)%Z. Proof. -intro xLy; apply Z.opp_le_mono; unfold Zceil; rewrite !Z.opp_involutive. -now apply Zfloor_le; lra. + intro xLy; apply Z.opp_le_mono; unfold Zceil; rewrite !Z.opp_involutive. + now apply Zfloor_le; lra. Qed. Lemma Zceil_addz (z: Z) x : Zceil (x + IZR z) = (Zceil x + z)%Z. Proof. -now unfold Zceil; rewrite Ropp_plus_distr, <- opp_IZR, Zfloor_addz; lia. + now unfold Zceil; rewrite Ropp_plus_distr, <- opp_IZR, Zfloor_addz; lia. Qed. Lemma ZceilD_cond r1 r2 : @@ -107,9 +107,9 @@ Lemma ZceilD_cond r1 r2 : then Zceil (r1 + r2) = (Zceil r1 + Zceil r2 - 1)%Z else Zceil (r1 + r2) = (Zceil r1 + Zceil r2)%Z. Proof. -generalize (ZfloorD_cond (- r1) (- r2)). -now unfold Zceil; rewrite !opp_IZR; do 2 case Rle_dec; try lra; - rewrite Ropp_plus_distr; lia. + generalize (ZfloorD_cond (- r1) (- r2)). + now unfold Zceil; rewrite !opp_IZR; do 2 case Rle_dec; try lra; + rewrite Ropp_plus_distr; lia. Qed. Lemma ZfloorB_cond r1 r2 : @@ -117,7 +117,7 @@ Lemma ZfloorB_cond r1 r2 : then Zfloor (r1 - r2) = (Zfloor r1 - Zceil r2 + 1)%Z else Zfloor (r1 - r2) = (Zfloor r1 - Zceil r2)%Z. Proof. -now generalize (ZfloorD_cond r1 (- r2)); rewrite !ZfloorN, !opp_IZR. + now generalize (ZfloorD_cond r1 (- r2)); rewrite !ZfloorN, !opp_IZR. Qed. Lemma ZceilB_cond r1 r2 : @@ -125,5 +125,5 @@ Lemma ZceilB_cond r1 r2 : then Zceil (r1 - r2) = (Zceil r1 - Zfloor r2 - 1)%Z else Zceil (r1 - r2) = (Zceil r1 - Zfloor r2)%Z. Proof. -now generalize (ZceilD_cond r1 (- r2)); rewrite !ZceilN, !opp_IZR. + now generalize (ZceilD_cond r1 (- r2)); rewrite !ZceilN, !opp_IZR. Qed. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 8ea5d7027b..8f0e5852ec 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -137,10 +137,10 @@ Section Properties. Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y. Proof. - induction 1 as [x y H|x y z H H0 IH0]. - - left; assumption. - - right with y; auto. - left; auto. + induction 1 as [x y H|x y z H H0 IH0]. + - left; assumption. + - right with y; auto. + left; auto. Qed. Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. @@ -296,6 +296,7 @@ Section Properties. P z -> (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) -> forall x, clos_refl_trans_1n R x z -> P x. + Proof. intros P z H H0 x; induction 1 as [|x y z]; auto. apply H0 with y; auto. Qed. @@ -304,6 +305,7 @@ Section Properties. P z -> (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) -> forall x, clos_refl_trans R x z -> P x. + Proof. intros P z Hz IH x Hxz. apply clos_rt_rt1n_iff in Hxz. elim Hxz using rt1n_ind_right; auto. @@ -327,6 +329,7 @@ Section Properties. Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. + Proof. induction 1 as [|x y z0]. - auto. - intros; right with y; eauto. @@ -345,6 +348,7 @@ Section Properties. Lemma clos_rst_rst1n : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. + Proof. induction 1 as [x y| | |]. - constructor 2 with y; auto. constructor 1. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 2992aa53c6..6915a0115a 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -65,30 +65,30 @@ End Reflexive_Closure. (** ** Reflexive-transitive closure *) Section Reflexive_Transitive_Closure. - Variable A : Type. - Variable R : relation A. + Variable A : Type. + Variable R : relation A. - (** Definition by direct reflexive-transitive closure *) + (** Definition by direct reflexive-transitive closure *) - Inductive clos_refl_trans (x:A) : A -> Prop := - | rt_step (y:A) : R x y -> clos_refl_trans x y - | rt_refl : clos_refl_trans x x - | rt_trans (y z:A) : - clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. + Inductive clos_refl_trans (x:A) : A -> Prop := + | rt_step (y:A) : R x y -> clos_refl_trans x y + | rt_refl : clos_refl_trans x x + | rt_trans (y z:A) : + clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. - (** Alternative definition by transitive extension on the left *) + (** Alternative definition by transitive extension on the left *) - Inductive clos_refl_trans_1n (x: A) : A -> Prop := - | rt1n_refl : clos_refl_trans_1n x x - | rt1n_trans (y z:A) : - R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. + Inductive clos_refl_trans_1n (x: A) : A -> Prop := + | rt1n_refl : clos_refl_trans_1n x x + | rt1n_trans (y z:A) : + R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. - (** Alternative definition by transitive extension on the right *) + (** Alternative definition by transitive extension on the right *) - Inductive clos_refl_trans_n1 (x: A) : A -> Prop := - | rtn1_refl : clos_refl_trans_n1 x x - | rtn1_trans (y z:A) : - R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z. + Inductive clos_refl_trans_n1 (x: A) : A -> Prop := + | rtn1_refl : clos_refl_trans_n1 x x + | rtn1_trans (y z:A) : + R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z. End Reflexive_Transitive_Closure. @@ -145,14 +145,14 @@ End Union. (** ** Disjoint union of relations *) Section Disjoint_Union. -Variables A B : Type. -Variable leA : A -> A -> Prop. -Variable leB : B -> B -> Prop. - -Inductive le_AsB : A + B -> A + B -> Prop := - | le_aa (x y:A) : leA x y -> le_AsB (inl _ x) (inl _ y) - | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) - | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). + Variables A B : Type. + Variable leA : A -> A -> Prop. + Variable leB : B -> B -> Prop. + + Inductive le_AsB : A + B -> A + B -> Prop := + | le_aa (x y:A) : leA x y -> le_AsB (inl _ x) (inl _ y) + | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) + | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). End Disjoint_Union. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index d18c5e5433..ef9dfd33a0 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -72,6 +72,7 @@ Section Integers_sect. Qed. Definition nat_po : PO nat. + Proof. apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le); auto with sets arith. - apply Inhabited_intro with (x := 0). diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 71c98400a7..ad9300b575 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -96,6 +96,7 @@ Section Partial_order_facts. Qed. Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D). + Proof. red. intros x y z H' H'0. apply Strict_Rel_Transitive_with_Rel with (y := y); diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 2cc1568117..71431cca5d 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -33,157 +33,175 @@ From Stdlib Require Export Partial_Order. From Stdlib Require Export Cpo. Section The_power_set_partial_order. -Variable U : Type. - -Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) := - Definition_of_Power_set : - forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X. -#[local] -Hint Resolve Definition_of_Power_set : core. - -Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. -intro X; red. -intros x H'; elim H'. -Qed. -#[local] -Hint Resolve Empty_set_minimal : core. - -Theorem Power_set_Inhabited : - forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X). -intro X. -apply Inhabited_intro with (Empty_set U); auto with sets. -Qed. -#[local] -Hint Resolve Power_set_Inhabited : core. - -Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). -auto 6 with sets. -Qed. -#[local] -Hint Resolve Inclusion_is_an_order : core. - -Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). -elim Inclusion_is_an_order; auto with sets. -Qed. -#[local] -Hint Resolve Inclusion_is_transitive : core. - -Definition Power_set_PO : Ensemble U -> PO (Ensemble U). -intro A; try assumption. -apply Definition_of_PO with (Power_set A) (Included U); auto with sets. -Defined. -#[local] -Hint Unfold Power_set_PO : core. - -Theorem Strict_Rel_is_Strict_Included : - same_relation (Ensemble U) (Strict_Included U) - (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). -auto with sets. -Qed. -#[local] -Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. - -Lemma Strict_inclusion_is_transitive_with_inclusion : - forall x y z:Ensemble U, - Strict_Included U x y -> Included U y z -> Strict_Included U x z. -intros x y z H' H'0; try assumption. -elim Strict_Rel_is_Strict_Included. -unfold contains. -intros H'1 H'2; try assumption. -apply H'1. -apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets. -Qed. - -Lemma Strict_inclusion_is_transitive_with_inclusion_left : - forall x y z:Ensemble U, - Included U x y -> Strict_Included U y z -> Strict_Included U x z. -intros x y z H' H'0; try assumption. -elim Strict_Rel_is_Strict_Included. -unfold contains. -intros H'1 H'2; try assumption. -apply H'1. -apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets. -Qed. - -Lemma Strict_inclusion_is_transitive : - Transitive (Ensemble U) (Strict_Included U). -apply cong_transitive_same_relation with - (R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))); - auto with sets. -Qed. - -Theorem Empty_set_is_Bottom : - forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). -intro A; apply Bottom_definition; simpl; auto with sets. -Qed. -#[local] -Hint Resolve Empty_set_is_Bottom : core. - -Theorem Union_minimal : - forall a b X:Ensemble U, - Included U a X -> Included U b X -> Included U (Union U a b) X. -intros a b X H' H'0; red. -intros x H'1; elim H'1; auto with sets. -Qed. -#[local] -Hint Resolve Union_minimal : core. - -Theorem Intersection_maximal : - forall a b X:Ensemble U, - Included U X a -> Included U X b -> Included U X (Intersection U a b). -auto with sets. -Qed. - -Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b). -auto with sets. -Qed. - -Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b). -auto with sets. -Qed. - -Theorem Intersection_decreases_l : - forall a b:Ensemble U, Included U (Intersection U a b) a. -intros a b; red. -intros x H'; elim H'; auto with sets. -Qed. - -Theorem Intersection_decreases_r : - forall a b:Ensemble U, Included U (Intersection U a b) b. -intros a b; red. -intros x H'; elim H'; auto with sets. -Qed. -#[local] -Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l - Intersection_decreases_r : core. - -Theorem Union_is_Lub : - forall A a b:Ensemble U, - Included U a A -> - Included U b A -> - Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b). -intros A a b H' H'0. -apply Lub_definition; simpl. -- apply Upper_Bound_definition; simpl; auto with sets. - intros y H'1; elim H'1; auto with sets. -- intros y H'1; elim H'1; simpl; auto with sets. -Qed. - -Theorem Intersection_is_Glb : - forall A a b:Ensemble U, - Included U a A -> - Included U b A -> - Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) - (Intersection U a b). -intros A a b H' H'0. -apply Glb_definition; simpl. -- apply Lower_Bound_definition; simpl; auto with sets. - + apply Definition_of_Power_set. - generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; - auto with sets. - + intros y H'1; elim H'1; auto with sets. -- intros y H'1; elim H'1; simpl; auto with sets. -Qed. + Variable U : Type. + + Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) := + Definition_of_Power_set : + forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X. + #[local] + Hint Resolve Definition_of_Power_set : core. + + Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. + Proof. + intro X; red. + intros x H'; elim H'. + Qed. + #[local] + Hint Resolve Empty_set_minimal : core. + + Theorem Power_set_Inhabited : + forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X). + Proof. + intro X. + apply Inhabited_intro with (Empty_set U); auto with sets. + Qed. + #[local] + Hint Resolve Power_set_Inhabited : core. + + Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). + Proof. + auto 6 with sets. + Qed. + #[local] + Hint Resolve Inclusion_is_an_order : core. + + Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). + Proof. + elim Inclusion_is_an_order; auto with sets. + Qed. + #[local] + Hint Resolve Inclusion_is_transitive : core. + + Definition Power_set_PO : Ensemble U -> PO (Ensemble U). + Proof. + intro A; try assumption. + apply Definition_of_PO with (Power_set A) (Included U); auto with sets. + Defined. + #[local] + Hint Unfold Power_set_PO : core. + + Theorem Strict_Rel_is_Strict_Included : + same_relation (Ensemble U) (Strict_Included U) + (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). + Proof. + auto with sets. + Qed. + #[local] + Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. + + Lemma Strict_inclusion_is_transitive_with_inclusion : + forall x y z:Ensemble U, + Strict_Included U x y -> Included U y z -> Strict_Included U x z. + Proof. + intros x y z H' H'0; try assumption. + elim Strict_Rel_is_Strict_Included. + unfold contains. + intros H'1 H'2; try assumption. + apply H'1. + apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets. + Qed. + + Lemma Strict_inclusion_is_transitive_with_inclusion_left : + forall x y z:Ensemble U, + Included U x y -> Strict_Included U y z -> Strict_Included U x z. + Proof. + intros x y z H' H'0; try assumption. + elim Strict_Rel_is_Strict_Included. + unfold contains. + intros H'1 H'2; try assumption. + apply H'1. + apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets. + Qed. + + Lemma Strict_inclusion_is_transitive : + Transitive (Ensemble U) (Strict_Included U). + Proof. + apply cong_transitive_same_relation with + (R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))); + auto with sets. + Qed. + + Theorem Empty_set_is_Bottom : + forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). + Proof. + intro A; apply Bottom_definition; simpl; auto with sets. + Qed. + #[local] + Hint Resolve Empty_set_is_Bottom : core. + + Theorem Union_minimal : + forall a b X:Ensemble U, + Included U a X -> Included U b X -> Included U (Union U a b) X. + Proof. + intros a b X H' H'0; red. + intros x H'1; elim H'1; auto with sets. + Qed. + #[local] + Hint Resolve Union_minimal : core. + + Theorem Intersection_maximal : + forall a b X:Ensemble U, + Included U X a -> Included U X b -> Included U X (Intersection U a b). + Proof. + auto with sets. + Qed. + + Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b). + Proof. + auto with sets. + Qed. + + Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b). + Proof. + auto with sets. + Qed. + + Theorem Intersection_decreases_l : + forall a b:Ensemble U, Included U (Intersection U a b) a. + Proof. + intros a b; red. + intros x H'; elim H'; auto with sets. + Qed. + + Theorem Intersection_decreases_r : + forall a b:Ensemble U, Included U (Intersection U a b) b. + Proof. + intros a b; red. + intros x H'; elim H'; auto with sets. + Qed. + #[local] + Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l + Intersection_decreases_r : core. + + Theorem Union_is_Lub : + forall A a b:Ensemble U, + Included U a A -> + Included U b A -> + Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b). + Proof. + intros A a b H' H'0. + apply Lub_definition; simpl. + - apply Upper_Bound_definition; simpl; auto with sets. + intros y H'1; elim H'1; auto with sets. + - intros y H'1; elim H'1; simpl; auto with sets. + Qed. + + Theorem Intersection_is_Glb : + forall A a b:Ensemble U, + Included U a A -> + Included U b A -> + Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) + (Intersection U a b). + Proof. + intros A a b H' H'0. + apply Glb_definition; simpl. + - apply Lower_Bound_definition; simpl; auto with sets. + + apply Definition_of_Power_set. + generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; + auto with sets. + + intros y H'1; elim H'1; auto with sets. + - intros y H'1; elim H'1; simpl; auto with sets. + Qed. End The_power_set_partial_order. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 7b94a9d902..00039ae27b 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -37,316 +37,316 @@ From Stdlib Require Export Powerset. #[local] Ltac Tauto.intuition_solver ::= auto with sets. Section Sets_as_an_algebra. - Variable U : Type. - - Theorem Empty_set_zero : forall X:Ensemble U, Union U (Empty_set U) X = X. - Proof. - auto 6 with sets. - Qed. - - Theorem Empty_set_zero_right : forall X:Ensemble U, Union U X (Empty_set U) = X. - Proof. - auto 6 with sets. - Qed. - - Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x. - Proof. - unfold Add at 1; auto using Empty_set_zero with sets. - Qed. - - Lemma less_than_empty : - forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U. - Proof. - auto with sets. - Qed. - - Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A. - Proof. - auto with sets. - Qed. - - Theorem Union_associative : - forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C). - Proof. - auto 9 with sets. - Qed. - - Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A. - Proof. - auto 7 with sets. - Qed. - - Lemma Union_absorbs : - forall A B:Ensemble U, Included U B A -> Union U A B = A. - Proof. - auto 7 with sets. - Qed. - - Theorem Couple_as_union : - forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y. - Proof. - intros x y; apply Extensionality_Ensembles; split; red. - - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). - - intros x0 H'; elim H'; auto with sets. - Qed. - - Theorem Triple_as_union : - forall x y z:U, - Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) = - Triple U x y z. - Proof. - intros x y z; apply Extensionality_Ensembles; split; red. - - intros x0 H'; elim H'. - + intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). - + intros x1 H'0; elim H'0; auto with sets. - - intros x0 H'; elim H'; auto with sets. - Qed. - - Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. - Proof. - intros x y. - rewrite <- (Couple_as_union x y). - rewrite <- (Union_idempotent (Singleton U x)). - apply Triple_as_union. - Qed. - - Theorem Triple_as_Couple_Singleton : - forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z). - Proof. - intros x y z. - rewrite <- (Triple_as_union x y z). - rewrite <- (Couple_as_union x y); auto with sets. - Qed. - - Theorem Intersection_commutative : - forall A B:Ensemble U, Intersection U A B = Intersection U B A. - Proof. - intros A B. - apply Extensionality_Ensembles. - split; red; intros x H'; elim H'; auto with sets. - Qed. - - Theorem Distributivity : - forall A B C:Ensemble U, - Intersection U A (Union U B C) = - Union U (Intersection U A B) (Intersection U A C). - Proof. - intros A B C. - apply Extensionality_Ensembles. - split; red; intros x H'. - - elim H'. - intros x0 H'0 H'1; generalize H'0. - elim H'1; auto with sets. - - elim H'; intros x0 H'0; elim H'0; auto with sets. - Qed. - - Lemma Distributivity_l - : forall (A B C : Ensemble U), - Intersection U (Union U A B) C = - Union U (Intersection U A C) (Intersection U B C). - Proof. - intros A B C. - rewrite Intersection_commutative. - rewrite Distributivity. - f_equal; apply Intersection_commutative. - Qed. - - Theorem Distributivity' : - forall A B C:Ensemble U, - Union U A (Intersection U B C) = - Intersection U (Union U A B) (Union U A C). - Proof. - intros A B C. - apply Extensionality_Ensembles. - split; red; intros x H'. - - elim H'; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - - elim H'. - intros x0 H'0; elim H'0; auto with sets. - intros x1 H'1 H'2; try exact H'2. - generalize H'1. - elim H'2; auto with sets. - Qed. - - Theorem Union_add : - forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x). - Proof. - unfold Add; auto using Union_associative with sets. - Qed. - - Theorem Non_disjoint_union : - forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X. - Proof. - intros X x H'; unfold Add. - apply Extensionality_Ensembles; red. - split; red; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - intros t H'1; elim H'1; auto with sets. - Qed. - - Theorem Non_disjoint_union' : - forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X. - Proof. - intros X x H'; unfold Subtract. - apply Extensionality_Ensembles. - split; red; auto with sets. - - intros x0 H'0; elim H'0; auto with sets. - - intros x0 H'0; apply Setminus_intro; auto with sets. - red; intro H'1; elim H'1. - lapply (Singleton_inv U x x0); auto with sets. - intro H'4; apply H'; rewrite H'4; auto with sets. - Qed. - - Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. - Proof. - intro x; rewrite (Empty_set_zero' x); auto with sets. - Qed. - - Lemma incl_add : - forall (A B:Ensemble U) (x:U), - Included U A B -> Included U (Add U A x) (Add U B x). - Proof. - intros A B x H'; red; auto with sets. - intros x0 H'0. - lapply (Add_inv U A x x0); auto with sets. - intro H'1; elim H'1; - [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ]; - auto with sets. - Qed. - - Lemma incl_add_x : - forall (A B:Ensemble U) (x:U), - ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B. - Proof. - unfold Included. - intros A B x H' H'0 x0 H'1. - lapply (H'0 x0); auto with sets. - intro H'2; lapply (Add_inv U B x x0); auto with sets. - intro H'3; elim H'3; - [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ]. - absurd (In U A x0); auto with sets. - rewrite <- H'4; auto with sets. - Qed. - - Lemma Add_commutative : - forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x. - Proof. - intros A x y. - unfold Add. - rewrite (Union_associative A (Singleton U x) (Singleton U y)). - rewrite (Union_commutative (Singleton U x) (Singleton U y)). - rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); - auto with sets. - Qed. - - Lemma Add_commutative' : - forall (A:Ensemble U) (x y z:U), - Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y. - Proof. - intros A x y z. - rewrite (Add_commutative (Add U A x) y z). - rewrite (Add_commutative A x z); auto with sets. - Qed. - - Lemma Add_distributes : - forall (A B:Ensemble U) (x y:U), - Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y). - Proof. - intros A B x y H'; try assumption. - rewrite <- (Union_add (Add U A x) B y). - unfold Add at 4. - rewrite (Union_commutative A (Singleton U x)). - rewrite Union_associative. - rewrite (Union_absorbs A B H'). - rewrite (Union_commutative (Singleton U x) A). - auto with sets. - Qed. - - Lemma setcover_intro : - forall (U:Type) (A x y:Ensemble U), - Strict_Included U x y -> - ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) -> - covers (Ensemble U) (Power_set_PO U A) y x. - Proof. - intros; apply Definition_of_covers; auto with sets. - Qed. - - Lemma Disjoint_Intersection: - forall A s1 s2, Disjoint A s1 s2 -> Intersection A s1 s2 = Empty_set A. - Proof. - intros. apply Extensionality_Ensembles. split. - * destruct H. - intros x H1. unfold In in *. exfalso. intuition. apply (H _ H1). - * intuition. - Qed. - - Lemma Intersection_Empty_set_l: - forall A s, Intersection A (Empty_set A) s = Empty_set A. - Proof. - intros. auto with sets. - Qed. - - Lemma Intersection_Empty_set_r: - forall A s, Intersection A s (Empty_set A) = Empty_set A. - Proof. - intros. auto with sets. - Qed. - - Lemma Seminus_Empty_set_l: - forall A s, Setminus A (Empty_set A) s = Empty_set A. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. destruct H1. unfold In in *. assumption. - * intuition. - Qed. - - Lemma Seminus_Empty_set_r: - forall A s, Setminus A s (Empty_set A) = s. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. destruct H1. unfold In in *. assumption. - * intuition. - Qed. - - Lemma Setminus_Union_l: - forall A s1 s2 s3, - Setminus A (Union A s1 s2) s3 = Union A (Setminus A s1 s3) (Setminus A s2 s3). - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H. inversion H. inversion H0; intuition. - * intros x H. constructor; inversion H; inversion H0; intuition. - Qed. - - Lemma Setminus_Union_r: - forall A s1 s2 s3, - Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H. inversion H. constructor. - -- intuition. - -- contradict H1. intuition. - * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. - Qed. - - Lemma Setminus_Disjoint_noop: - forall A s1 s2, - Intersection A s1 s2 = Empty_set A -> Setminus A s1 s2 = s1. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. inversion_clear H1. intuition. - * intros x H1. constructor; intuition. contradict H. - apply Inhabited_not_empty. - exists x. intuition. - Qed. - - Lemma Setminus_Included_empty: - forall A s1 s2, - Included A s1 s2 -> Setminus A s1 s2 = Empty_set A. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. inversion_clear H1. contradiction H2. intuition. - * intuition. - Qed. + Variable U : Type. + + Theorem Empty_set_zero : forall X:Ensemble U, Union U (Empty_set U) X = X. + Proof. + auto 6 with sets. + Qed. + + Theorem Empty_set_zero_right : forall X:Ensemble U, Union U X (Empty_set U) = X. + Proof. + auto 6 with sets. + Qed. + + Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x. + Proof. + unfold Add at 1; auto using Empty_set_zero with sets. + Qed. + + Lemma less_than_empty : + forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U. + Proof. + auto with sets. + Qed. + + Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A. + Proof. + auto with sets. + Qed. + + Theorem Union_associative : + forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C). + Proof. + auto 9 with sets. + Qed. + + Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A. + Proof. + auto 7 with sets. + Qed. + + Lemma Union_absorbs : + forall A B:Ensemble U, Included U B A -> Union U A B = A. + Proof. + auto 7 with sets. + Qed. + + Theorem Couple_as_union : + forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y. + Proof. + intros x y; apply Extensionality_Ensembles; split; red. + - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). + - intros x0 H'; elim H'; auto with sets. + Qed. + + Theorem Triple_as_union : + forall x y z:U, + Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) = + Triple U x y z. + Proof. + intros x y z; apply Extensionality_Ensembles; split; red. + - intros x0 H'; elim H'. + + intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). + + intros x1 H'0; elim H'0; auto with sets. + - intros x0 H'; elim H'; auto with sets. + Qed. + + Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. + Proof. + intros x y. + rewrite <- (Couple_as_union x y). + rewrite <- (Union_idempotent (Singleton U x)). + apply Triple_as_union. + Qed. + + Theorem Triple_as_Couple_Singleton : + forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z). + Proof. + intros x y z. + rewrite <- (Triple_as_union x y z). + rewrite <- (Couple_as_union x y); auto with sets. + Qed. + + Theorem Intersection_commutative : + forall A B:Ensemble U, Intersection U A B = Intersection U B A. + Proof. + intros A B. + apply Extensionality_Ensembles. + split; red; intros x H'; elim H'; auto with sets. + Qed. + + Theorem Distributivity : + forall A B C:Ensemble U, + Intersection U A (Union U B C) = + Union U (Intersection U A B) (Intersection U A C). + Proof. + intros A B C. + apply Extensionality_Ensembles. + split; red; intros x H'. + - elim H'. + intros x0 H'0 H'1; generalize H'0. + elim H'1; auto with sets. + - elim H'; intros x0 H'0; elim H'0; auto with sets. + Qed. + + Lemma Distributivity_l + : forall (A B C : Ensemble U), + Intersection U (Union U A B) C = + Union U (Intersection U A C) (Intersection U B C). + Proof. + intros A B C. + rewrite Intersection_commutative. + rewrite Distributivity. + f_equal; apply Intersection_commutative. + Qed. + + Theorem Distributivity' : + forall A B C:Ensemble U, + Union U A (Intersection U B C) = + Intersection U (Union U A B) (Union U A C). + Proof. + intros A B C. + apply Extensionality_Ensembles. + split; red; intros x H'. + - elim H'; auto with sets. + intros x0 H'0; elim H'0; auto with sets. + - elim H'. + intros x0 H'0; elim H'0; auto with sets. + intros x1 H'1 H'2; try exact H'2. + generalize H'1. + elim H'2; auto with sets. + Qed. + + Theorem Union_add : + forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x). + Proof. + unfold Add; auto using Union_associative with sets. + Qed. + + Theorem Non_disjoint_union : + forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X. + Proof. + intros X x H'; unfold Add. + apply Extensionality_Ensembles; red. + split; red; auto with sets. + intros x0 H'0; elim H'0; auto with sets. + intros t H'1; elim H'1; auto with sets. + Qed. + + Theorem Non_disjoint_union' : + forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X. + Proof. + intros X x H'; unfold Subtract. + apply Extensionality_Ensembles. + split; red; auto with sets. + - intros x0 H'0; elim H'0; auto with sets. + - intros x0 H'0; apply Setminus_intro; auto with sets. + red; intro H'1; elim H'1. + lapply (Singleton_inv U x x0); auto with sets. + intro H'4; apply H'; rewrite H'4; auto with sets. + Qed. + + Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. + Proof. + intro x; rewrite (Empty_set_zero' x); auto with sets. + Qed. + + Lemma incl_add : + forall (A B:Ensemble U) (x:U), + Included U A B -> Included U (Add U A x) (Add U B x). + Proof. + intros A B x H'; red; auto with sets. + intros x0 H'0. + lapply (Add_inv U A x x0); auto with sets. + intro H'1; elim H'1; + [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ]; + auto with sets. + Qed. + + Lemma incl_add_x : + forall (A B:Ensemble U) (x:U), + ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B. + Proof. + unfold Included. + intros A B x H' H'0 x0 H'1. + lapply (H'0 x0); auto with sets. + intro H'2; lapply (Add_inv U B x x0); auto with sets. + intro H'3; elim H'3; + [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ]. + absurd (In U A x0); auto with sets. + rewrite <- H'4; auto with sets. + Qed. + + Lemma Add_commutative : + forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x. + Proof. + intros A x y. + unfold Add. + rewrite (Union_associative A (Singleton U x) (Singleton U y)). + rewrite (Union_commutative (Singleton U x) (Singleton U y)). + rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); + auto with sets. + Qed. + + Lemma Add_commutative' : + forall (A:Ensemble U) (x y z:U), + Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y. + Proof. + intros A x y z. + rewrite (Add_commutative (Add U A x) y z). + rewrite (Add_commutative A x z); auto with sets. + Qed. + + Lemma Add_distributes : + forall (A B:Ensemble U) (x y:U), + Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y). + Proof. + intros A B x y H'; try assumption. + rewrite <- (Union_add (Add U A x) B y). + unfold Add at 4. + rewrite (Union_commutative A (Singleton U x)). + rewrite Union_associative. + rewrite (Union_absorbs A B H'). + rewrite (Union_commutative (Singleton U x) A). + auto with sets. + Qed. + + Lemma setcover_intro : + forall (U:Type) (A x y:Ensemble U), + Strict_Included U x y -> + ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) -> + covers (Ensemble U) (Power_set_PO U A) y x. + Proof. + intros; apply Definition_of_covers; auto with sets. + Qed. + + Lemma Disjoint_Intersection: + forall A s1 s2, Disjoint A s1 s2 -> Intersection A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * destruct H. + intros x H1. unfold In in *. exfalso. intuition. apply (H _ H1). + * intuition. + Qed. + + Lemma Intersection_Empty_set_l: + forall A s, Intersection A (Empty_set A) s = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Intersection_Empty_set_r: + forall A s, Intersection A s (Empty_set A) = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Seminus_Empty_set_l: + forall A s, Setminus A (Empty_set A) s = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Seminus_Empty_set_r: + forall A s, Setminus A s (Empty_set A) = s. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Setminus_Union_l: + forall A s1 s2 s3, + Setminus A (Union A s1 s2) s3 = Union A (Setminus A s1 s3) (Setminus A s2 s3). + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. inversion H0; intuition. + * intros x H. constructor; inversion H; inversion H0; intuition. + Qed. + + Lemma Setminus_Union_r: + forall A s1 s2 s3, + Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. constructor. + -- intuition. + -- contradict H1. intuition. + * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. + Qed. + + Lemma Setminus_Disjoint_noop: + forall A s1 s2, + Intersection A s1 s2 = Empty_set A -> Setminus A s1 s2 = s1. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. intuition. + * intros x H1. constructor; intuition. contradict H. + apply Inhabited_not_empty. + exists x. intuition. + Qed. + + Lemma Setminus_Included_empty: + forall A s1 s2, + Included A s1 s2 -> Setminus A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. contradiction H2. intuition. + * intuition. + Qed. End Sets_as_an_algebra. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 35250d8f64..5b0eff78f2 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -37,22 +37,22 @@ Theorem Rsym_imp_notRsym : forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Complement U R). Proof. -unfold Symmetric, Complement. -intros U R H' x y H'0; red; intro H'1; apply H'0; auto with sets. + unfold Symmetric, Complement. + intros U R H' x y H'0; red; intro H'1; apply H'0; auto with sets. Qed. Theorem Equiv_from_preorder : forall (U:Type) (R:Relation U), Preorder U R -> Equivalence U (fun x y:U => R x y /\ R y x). Proof. -intros U R H'; elim H'; intros H'0 H'1. -apply Definition_of_equivalence. -- red in H'0; auto 10 with sets. -- red in H'1; red; auto 10 with sets. - intros x y z h; elim h; intros H'3 H'4; clear h. - intro h; elim h; intros H'5 H'6; clear h. - split; apply H'1 with y; auto 10 with sets. -- red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. + intros U R H'; elim H'; intros H'0 H'1. + apply Definition_of_equivalence. + - red in H'0; auto 10 with sets. + - red in H'1; red; auto 10 with sets. + intros x y z h; elim h; intros H'3 H'4; clear h. + intro h; elim h; intros H'5 H'6; clear h. + split; apply H'1 with y; auto 10 with sets. + - red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. Qed. #[global] Hint Resolve Equiv_from_preorder : core. @@ -61,7 +61,7 @@ Theorem Equiv_from_order : forall (U:Type) (R:Relation U), Order U R -> Equivalence U (fun x y:U => R x y /\ R y x). Proof. -intros U R H'; elim H'; auto 10 with sets. + intros U R H'; elim H'; auto 10 with sets. Qed. #[global] Hint Resolve Equiv_from_order : core. @@ -69,7 +69,7 @@ Hint Resolve Equiv_from_order : core. Theorem contains_is_preorder : forall U:Type, Preorder (Relation U) (contains U). Proof. -auto 10 with sets. + auto 10 with sets. Qed. #[global] Hint Resolve contains_is_preorder : core. @@ -77,7 +77,7 @@ Hint Resolve contains_is_preorder : core. Theorem same_relation_is_equivalence : forall U:Type, Equivalence (Relation U) (same_relation U). Proof. -unfold same_relation at 1; auto 10 with sets. + unfold same_relation at 1; auto 10 with sets. Qed. #[global] Hint Resolve same_relation_is_equivalence : core. @@ -86,7 +86,7 @@ Theorem cong_reflexive_same_relation : forall (U:Type) (R R':Relation U), same_relation U R R' -> Reflexive U R -> Reflexive U R'. Proof. -unfold same_relation; intuition. + unfold same_relation; intuition. Qed. Theorem cong_symmetric_same_relation : @@ -111,8 +111,8 @@ Theorem cong_transitive_same_relation : forall (U:Type) (R R':Relation U), same_relation U R R' -> Transitive U R -> Transitive U R'. Proof. -intros U R R' H' H'0; red. -elim H'. -intros H'1 H'2 x y z H'3 H'4; apply H'2. -apply H'0 with y; auto with sets. + intros U R R' H' H'0; red. + elim H'. + intros H'1 H'2 x y z H'3 H'4; apply H'2. + apply H'0 with y; auto with sets. Qed. diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index e9a6053694..876d3a0860 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -29,24 +29,24 @@ From Stdlib Require Export Relations_1. Section Relations_2. -Variable U : Type. -Variable R : Relation U. + Variable U : Type. + Variable R : Relation U. -Inductive Rstar (x:U) : U -> Prop := - | Rstar_0 : Rstar x x - | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z. + Inductive Rstar (x:U) : U -> Prop := + | Rstar_0 : Rstar x x + | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z. -Inductive Rstar1 (x:U) : U -> Prop := - | Rstar1_0 : Rstar1 x x - | Rstar1_1 : forall y:U, R x y -> Rstar1 x y - | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z. + Inductive Rstar1 (x:U) : U -> Prop := + | Rstar1_0 : Rstar1 x x + | Rstar1_1 : forall y:U, R x y -> Rstar1 x y + | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z. -Inductive Rplus (x:U) : U -> Prop := - | Rplus_0 : forall y:U, R x y -> Rplus x y - | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z. + Inductive Rplus (x:U) : U -> Prop := + | Rplus_0 : forall y:U, R x y -> Rplus x y + | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z. -Definition Strongly_confluent : Prop := - forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z). + Definition Strongly_confluent : Prop := + forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z). End Relations_2. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 86d37aa594..8f7970da38 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -33,100 +33,100 @@ From Stdlib Require Export Relations_2. Theorem Rstar_reflexive : forall (U:Type) (R:Relation U), Reflexive U (Rstar U R). Proof. -auto with sets. + auto with sets. Qed. Theorem Rplus_contains_R : forall (U:Type) (R:Relation U), contains U (Rplus U R) R. Proof. -auto with sets. + auto with sets. Qed. Theorem Rstar_contains_R : forall (U:Type) (R:Relation U), contains U (Rstar U R) R. Proof. -intros U R; red; intros x y H'; apply Rstar_n with y; auto with sets. + intros U R; red; intros x y H'; apply Rstar_n with y; auto with sets. Qed. Theorem Rstar_contains_Rplus : forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R). Proof. -intros U R; red. -intros x y H'; elim H'. -- generalize Rstar_contains_R; intro T; red in T; auto with sets. -- intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets. + intros U R; red. + intros x y H'; elim H'. + - generalize Rstar_contains_R; intro T; red in T; auto with sets. + - intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets. Qed. Theorem Rstar_transitive : forall (U:Type) (R:Relation U), Transitive U (Rstar U R). Proof. -intros U R; red. -intros x y z H'; elim H'; auto with sets. -intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets. + intros U R; red. + intros x y z H'; elim H'; auto with sets. + intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets. Qed. Theorem Rstar_cases : forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> x = y \/ (exists u : _, R x u /\ Rstar U R u y). Proof. -intros U R x y H'; elim H'; auto with sets. -intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets. + intros U R x y H'; elim H'; auto with sets. + intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets. Qed. Theorem Rstar_equiv_Rstar1 : forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R). Proof. -generalize Rstar_contains_R; intro T; red in T. -intros U R; unfold same_relation, contains. -split; intros x y H'; elim H'; auto with sets. -- generalize Rstar_transitive; intro T1; red in T1. - intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. -- intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. + generalize Rstar_contains_R; intro T; red in T. + intros U R; unfold same_relation, contains. + split; intros x y H'; elim H'; auto with sets. + - generalize Rstar_transitive; intro T1; red in T1. + intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. + - intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. Qed. Theorem Rsym_imp_Rstarsym : forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R). Proof. -intros U R H'; red. -intros x y H'0; elim H'0; auto with sets. -intros x0 y0 z H'1 H'2 H'3. -generalize Rstar_transitive; intro T1; red in T1. -apply T1 with y0; auto with sets. -apply Rstar_n with x0; auto with sets. + intros U R H'; red. + intros x y H'0; elim H'0; auto with sets. + intros x0 y0 z H'1 H'2 H'3. + generalize Rstar_transitive; intro T1; red in T1. + apply T1 with y0; auto with sets. + apply Rstar_n with x0; auto with sets. Qed. Theorem Sstar_contains_Rstar : forall (U:Type) (R S:Relation U), contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R). Proof. -unfold contains. -intros U R S H' x y H'0; elim H'0; auto with sets. -generalize Rstar_transitive; intro T1; red in T1. -intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets. + unfold contains. + intros U R S H' x y H'0; elim H'0; auto with sets. + generalize Rstar_transitive; intro T1; red in T1. + intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets. Qed. Theorem star_monotone : forall (U:Type) (R S:Relation U), contains U S R -> contains U (Rstar U S) (Rstar U R). Proof. -intros U R S H'. -apply Sstar_contains_Rstar; auto with sets. -generalize (Rstar_contains_R U S); auto with sets. + intros U R S H'. + apply Sstar_contains_Rstar; auto with sets. + generalize (Rstar_contains_R U S); auto with sets. Qed. Theorem RstarRplus_RRstar : forall (U:Type) (R:Relation U) (x y z:U), Rstar U R x y -> Rplus U R y z -> exists u : _, R x u /\ Rstar U R u z. Proof. -generalize Rstar_contains_Rplus; intro T; red in T. -generalize Rstar_transitive; intro T1; red in T1. -intros U R x y z H'; elim H'. -- intros x0 H'0; elim H'0. - + intros x1 y0 H'1; exists y0; auto with sets. - + intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. -- intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. - split; [ try assumption | idtac ]. - apply T1 with z0; auto with sets. + generalize Rstar_contains_Rplus; intro T; red in T. + generalize Rstar_transitive; intro T1; red in T1. + intros U R x y z H'; elim H'. + - intros x0 H'0; elim H'0. + + intros x1 y0 H'1; exists y0; auto with sets. + + intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. + - intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. + split; [ try assumption | idtac ]. + apply T1 with z0; auto with sets. Qed. Theorem Lemma1 : @@ -136,18 +136,18 @@ Theorem Lemma1 : Rstar U R x b -> forall a:U, R x a -> exists z : _, Rstar U R a z /\ R b z. Proof. -intros U R H' x b H'0; elim H'0. -- intros x0 a H'1; exists a; auto with sets. -- intros x0 y z H'1 H'2 H'3 a H'4. - red in H'. - specialize H' with (x := x0) (a := a) (b := y); lapply H'; - [ intro H'8; lapply H'8; - [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] - | clear H' ]; auto with sets. - elim H'9. - intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. - elim (H'3 t); auto with sets. - intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. - exists z1; split; [ idtac | assumption ]. - apply Rstar_n with t; auto with sets. + intros U R H' x b H'0; elim H'0. + - intros x0 a H'1; exists a; auto with sets. + - intros x0 y z H'1 H'2 H'3 a H'4. + red in H'. + specialize H' with (x := x0) (a := a) (b := y); lapply H'; + [ intro H'8; lapply H'8; + [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] + | clear H' ]; auto with sets. + elim H'9. + intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. + elim (H'3 t); auto with sets. + intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. + exists z1; split; [ idtac | assumption ]. + apply Rstar_n with t; auto with sets. Qed. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index ce09a5e708..0933a18f94 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -35,8 +35,8 @@ From Stdlib Require Export Relations_3. Theorem Rstar_imp_coherent : forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> coherent U R x y. Proof. -intros U R x y H'; red. -exists y; auto with sets. + intros U R x y H'; red. + exists y; auto with sets. Qed. #[global] Hint Resolve Rstar_imp_coherent : core. @@ -44,129 +44,129 @@ Hint Resolve Rstar_imp_coherent : core. Theorem coherent_symmetric : forall (U:Type) (R:Relation U), Symmetric U (coherent U R). Proof. -unfold coherent at 1. -intros U R; red. -intros x y H'; elim H'. -intros z H'0; exists z; tauto. + unfold coherent at 1. + intros U R; red. + intros x y H'; elim H'. + intros z H'0; exists z; tauto. Qed. Theorem Strong_confluence : forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R. Proof. -intros U R H'; red. -intro x; red; intros a b H'0. -unfold coherent at 1. -generalize b; clear b. -elim H'0; clear H'0. -- intros x0 b H'1; exists b; auto with sets. -- intros x0 y z H'1 H'2 H'3 b H'4. - generalize (Lemma1 U R); intro h; lapply h; - [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; - [ intro H'5; generalize (H'5 y); intro h1; lapply h1; - [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; - clear h h0 h1 h2 h3 - | clear h h0 h1 ] - | clear h h0 ] - | clear h ]; auto with sets. - generalize (H'3 z0); intro h; lapply h; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 - | clear h ]; auto with sets. - exists z1; split; auto with sets. - apply Rstar_n with z0; auto with sets. + intros U R H'; red. + intro x; red; intros a b H'0. + unfold coherent at 1. + generalize b; clear b. + elim H'0; clear H'0. + - intros x0 b H'1; exists b; auto with sets. + - intros x0 y z H'1 H'2 H'3 b H'4. + generalize (Lemma1 U R); intro h; lapply h; + [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; + [ intro H'5; generalize (H'5 y); intro h1; lapply h1; + [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; + clear h h0 h1 h2 h3 + | clear h h0 h1 ] + | clear h h0 ] + | clear h ]; auto with sets. + generalize (H'3 z0); intro h; lapply h; + [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 + | clear h ]; auto with sets. + exists z1; split; auto with sets. + apply Rstar_n with z0; auto with sets. Qed. Theorem Strong_confluence_direct : forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R. Proof. -intros U R H'; red. -intro x; red; intros a b H'0. -unfold coherent at 1. -generalize b; clear b. -elim H'0; clear H'0. -- intros x0 b H'1; exists b; auto with sets. -- intros x0 y z H'1 H'2 H'3 b H'4. - cut (ex (fun t:U => Rstar U R y t /\ R b t)). - + intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. - generalize (H'3 t); intro h; lapply h; - [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 - | clear h ]; auto with sets. - exists z0; split; [ assumption | idtac ]. - apply Rstar_n with t; auto with sets. - + generalize H'1; generalize y; clear H'1. - elim H'4. - * intros x1 y0 H'0; exists y0; auto with sets. - * intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. - red in H'. - generalize (H' x1 y0 y1); intro h; lapply h; - [ intro H'7; lapply H'7; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; - clear h H'7 h0 h1 - | clear h ] - | clear h ]; auto with sets. - generalize (H'5 z1); intro h; lapply h; - [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 + intros U R H'; red. + intro x; red; intros a b H'0. + unfold coherent at 1. + generalize b; clear b. + elim H'0; clear H'0. + - intros x0 b H'1; exists b; auto with sets. + - intros x0 y z H'1 H'2 H'3 b H'4. + cut (ex (fun t:U => Rstar U R y t /\ R b t)). + + intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. + generalize (H'3 t); intro h; lapply h; + [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 | clear h ]; auto with sets. - exists t; split; auto with sets. - apply Rstar_n with z1; auto with sets. + exists z0; split; [ assumption | idtac ]. + apply Rstar_n with t; auto with sets. + + generalize H'1; generalize y; clear H'1. + elim H'4. + * intros x1 y0 H'0; exists y0; auto with sets. + * intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. + red in H'. + generalize (H' x1 y0 y1); intro h; lapply h; + [ intro H'7; lapply H'7; + [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; + clear h H'7 h0 h1 + | clear h ] + | clear h ]; auto with sets. + generalize (H'5 z1); intro h; lapply h; + [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 + | clear h ]; auto with sets. + exists t; split; auto with sets. + apply Rstar_n with z1; auto with sets. Qed. Theorem Noetherian_contains_Noetherian : forall (U:Type) (R R':Relation U), Noetherian U R -> contains U R R' -> Noetherian U R'. Proof. -unfold Noetherian at 2. -intros U R R' H' H'0 x. -elim (H' x); auto with sets. + unfold Noetherian at 2. + intros U R R' H' H'0 x. + elim (H' x); auto with sets. Qed. Theorem Newman : forall (U:Type) (R:Relation U), Noetherian U R -> Locally_confluent U R -> Confluent U R. Proof. -intros U R H' H'0; red; intro x. -elim (H' x); unfold confluent. -intros x0 H'1 H'2 y z H'3 H'4. -generalize (Rstar_cases U R x0 y); intro h; lapply h; - [ intro h0; elim h0; - [ clear h h0; intro h1 - | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6; - clear h h0 h1 h2 ] - | clear h ]; auto with sets. -- elim h1; auto with sets. -- generalize (Rstar_cases U R x0 z); intro h; lapply h; - [ intro h0; elim h0; + intros U R H' H'0; red; intro x. + elim (H' x); unfold confluent. + intros x0 H'1 H'2 y z H'3 H'4. + generalize (Rstar_cases U R x0 y); intro h; lapply h; + [ intro h0; elim h0; [ clear h h0; intro h1 - | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; - clear h h0 h1 h2 ] - | clear h ]; auto with sets. - + elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. - + unfold Locally_confluent, locally_confluent, coherent in H'0. - generalize (H'0 x0 u v); intro h; lapply h; - [ intro H'9; lapply H'9; - [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; - clear h H'9 h0 h1 - | clear h ] + | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6; + clear h h0 h1 h2 ] + | clear h ]; auto with sets. + - elim h1; auto with sets. + - generalize (Rstar_cases U R x0 z); intro h; lapply h; + [ intro h0; elim h0; + [ clear h h0; intro h1 + | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; + clear h h0 h1 h2 ] | clear h ]; auto with sets. - clear H'0. - unfold coherent at 1 in H'2. - generalize (H'2 u); intro h; lapply h; - [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; + + elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. + + unfold Locally_confluent, locally_confluent, coherent in H'0. + generalize (H'0 x0 u v); intro h; lapply h; [ intro H'9; lapply H'9; - [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; - clear h h0 H'9 h1 h2 + [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; + clear h H'9 h0 h1 + | clear h ] + | clear h ]; auto with sets. + clear H'0. + unfold coherent at 1 in H'2. + generalize (H'2 u); intro h; lapply h; + [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; + [ intro H'9; lapply H'9; + [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; + clear h h0 H'9 h1 h2 + | clear h h0 ] | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. - generalize Rstar_transitive; intro T; red in T. - generalize (H'2 v); intro h; lapply h; - [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; - [ intro H'14; lapply H'14; - [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; - clear h h0 H'14 h1 h2 + | clear h ]; auto with sets. + generalize Rstar_transitive; intro T; red in T. + generalize (H'2 v); intro h; lapply h; + [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; + [ intro H'14; lapply H'14; + [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; + clear h h0 H'14 h1 h2 + | clear h h0 ] | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. - * red; (exists z1; split); auto with sets. - apply T with y1; auto with sets. - * apply T with t; auto with sets. + | clear h ]; auto with sets. + * red; (exists z1; split); auto with sets. + apply T with y1; auto with sets. + * apply T with t; auto with sets. Qed. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 525a33c493..43ff608241 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -19,200 +19,200 @@ Set Implicit Arguments. Section defs. -Variable A : Set. -Variable eqA : A -> A -> Prop. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - -Inductive uniset : Set := - Charac : (A -> bool) -> uniset. - -Definition charac (s:uniset) (a:A) : bool := let (f) := s in f a. - -Definition Emptyset := Charac (fun a:A => false). - -Definition Fullset := Charac (fun a:A => true). - -Definition Singleton (a:A) := - Charac - (fun a':A => - match eqA_dec a a' with - | left h => true - | right h => false - end). - -Definition In (s:uniset) (a:A) : Prop := charac s a = true. -#[local] -Hint Unfold In : core. - -(** uniset inclusion *) -Definition incl (s1 s2:uniset) := forall a:A, Bool.le (charac s1 a) (charac s2 a). -#[local] -Hint Unfold incl : core. - -(** uniset equality *) -Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. -#[local] -Hint Unfold seq : core. - -Lemma le_refl : forall b, Bool.le b b. -Proof. -destruct b; simpl; auto. -Qed. -#[local] -Hint Resolve le_refl : core. - -Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. -Proof. -unfold incl; intros s1 s2 E a; elim (E a); auto. -Qed. - -Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1. -Proof. -unfold incl; intros s1 s2 E a; elim (E a); auto. -Qed. - -Lemma seq_refl : forall x:uniset, seq x x. -Proof. -destruct x; unfold seq; auto. -Qed. -#[local] -Hint Resolve seq_refl : core. - -Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. -Proof. -unfold seq. -destruct x; destruct y; destruct z; simpl; intros. -rewrite H; auto. -Qed. - -Lemma seq_sym : forall x y:uniset, seq x y -> seq y x. -Proof. -unfold seq. -destruct x; destruct y; simpl; auto. -Qed. - -(** uniset union *) -Definition union (m1 m2:uniset) := - Charac (fun a:A => orb (charac m1 a) (charac m2 a)). - -Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). -Proof. -unfold seq; unfold union; simpl; auto. -Qed. -#[local] -Hint Resolve union_empty_left : core. - -Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). -Proof. -unfold seq; unfold union; simpl. -intros x a; rewrite (orb_b_false (charac x a)); auto. -Qed. -#[local] -Hint Resolve union_empty_right : core. - -Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). -Proof. -unfold seq; unfold charac; unfold union. -destruct x; destruct y; auto with bool. -Qed. -#[local] -Hint Resolve union_comm : core. - -Lemma union_ass : - forall x y z:uniset, seq (union (union x y) z) (union x (union y z)). -Proof. -unfold seq; unfold union; unfold charac. -destruct x; destruct y; destruct z; auto with bool. -Qed. -#[local] -Hint Resolve union_ass : core. - -Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). -Proof. -unfold seq; unfold union; unfold charac. -destruct x; destruct y; destruct z. -intros; elim H; auto. -Qed. -#[local] -Hint Resolve seq_left : core. - -Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). -Proof. -unfold seq; unfold union; unfold charac. -destruct x; destruct y; destruct z. -intros; elim H; auto. -Qed. -#[local] -Hint Resolve seq_right : core. - - -(** All the proofs that follow duplicate [Multiset_of_A] *) - -(** Here we should make uniset an abstract datatype, by hiding [Charac], + Variable A : Set. + Variable eqA : A -> A -> Prop. + Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + + Inductive uniset : Set := + Charac : (A -> bool) -> uniset. + + Definition charac (s:uniset) (a:A) : bool := let (f) := s in f a. + + Definition Emptyset := Charac (fun a:A => false). + + Definition Fullset := Charac (fun a:A => true). + + Definition Singleton (a:A) := + Charac + (fun a':A => + match eqA_dec a a' with + | left h => true + | right h => false + end). + + Definition In (s:uniset) (a:A) : Prop := charac s a = true. + #[local] + Hint Unfold In : core. + + (** uniset inclusion *) + Definition incl (s1 s2:uniset) := forall a:A, Bool.le (charac s1 a) (charac s2 a). + #[local] + Hint Unfold incl : core. + + (** uniset equality *) + Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. + #[local] + Hint Unfold seq : core. + + Lemma le_refl : forall b, Bool.le b b. + Proof. + destruct b; simpl; auto. + Qed. + #[local] + Hint Resolve le_refl : core. + + Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. + Proof. + unfold incl; intros s1 s2 E a; elim (E a); auto. + Qed. + + Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1. + Proof. + unfold incl; intros s1 s2 E a; elim (E a); auto. + Qed. + + Lemma seq_refl : forall x:uniset, seq x x. + Proof. + destruct x; unfold seq; auto. + Qed. + #[local] + Hint Resolve seq_refl : core. + + Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. + Proof. + unfold seq. + destruct x; destruct y; destruct z; simpl; intros. + rewrite H; auto. + Qed. + + Lemma seq_sym : forall x y:uniset, seq x y -> seq y x. + Proof. + unfold seq. + destruct x; destruct y; simpl; auto. + Qed. + + (** uniset union *) + Definition union (m1 m2:uniset) := + Charac (fun a:A => orb (charac m1 a) (charac m2 a)). + + Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). + Proof. + unfold seq; unfold union; simpl; auto. + Qed. + #[local] + Hint Resolve union_empty_left : core. + + Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). + Proof. + unfold seq; unfold union; simpl. + intros x a; rewrite (orb_b_false (charac x a)); auto. + Qed. + #[local] + Hint Resolve union_empty_right : core. + + Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). + Proof. + unfold seq; unfold charac; unfold union. + destruct x; destruct y; auto with bool. + Qed. + #[local] + Hint Resolve union_comm : core. + + Lemma union_ass : + forall x y z:uniset, seq (union (union x y) z) (union x (union y z)). + Proof. + unfold seq; unfold union; unfold charac. + destruct x; destruct y; destruct z; auto with bool. + Qed. + #[local] + Hint Resolve union_ass : core. + + Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). + Proof. + unfold seq; unfold union; unfold charac. + destruct x; destruct y; destruct z. + intros; elim H; auto. + Qed. + #[local] + Hint Resolve seq_left : core. + + Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). + Proof. + unfold seq; unfold union; unfold charac. + destruct x; destruct y; destruct z. + intros; elim H; auto. + Qed. + #[local] + Hint Resolve seq_right : core. + + + (** All the proofs that follow duplicate [Multiset_of_A] *) + + (** Here we should make uniset an abstract datatype, by hiding [Charac], [union], [charac]; all further properties are proved abstractly *) -Lemma union_rotate : - forall x y z:uniset, seq (union x (union y z)) (union z (union x y)). -Proof. -intros; apply (op_rotate uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma seq_congr : - forall x y z t:uniset, seq x y -> seq z t -> seq (union x z) (union y t). -Proof. -intros; apply (cong_congr uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma union_perm_left : - forall x y z:uniset, seq (union x (union y z)) (union y (union x z)). -Proof. -intros; apply (perm_left uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma uniset_twist1 : - forall x y z t:uniset, - seq (union x (union (union y z) t)) (union (union y (union x t)) z). -Proof. -intros; apply (twist uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma uniset_twist2 : - forall x y z t:uniset, - seq (union x (union (union y z) t)) (union (union y (union x z)) t). -Proof. -intros; apply seq_trans with (union (union x (union y z)) t). -- apply seq_sym; apply union_ass. -- apply seq_left; apply union_perm_left. -Qed. - -(** specific for treesort *) - -Lemma treesort_twist1 : - forall x y z t u:uniset, - seq u (union y z) -> - seq (union x (union u t)) (union (union y (union x t)) z). -Proof. -intros; apply seq_trans with (union x (union (union y z) t)). -- apply seq_right; apply seq_left; trivial. -- apply uniset_twist1. -Qed. - -Lemma treesort_twist2 : - forall x y z t u:uniset, - seq u (union y z) -> - seq (union x (union u t)) (union (union y (union x z)) t). -Proof. -intros; apply seq_trans with (union x (union (union y z) t)). -- apply seq_right; apply seq_left; trivial. -- apply uniset_twist2. -Qed. - - -(*i theory of minter to do similarly + Lemma union_rotate : + forall x y z:uniset, seq (union x (union y z)) (union z (union x y)). + Proof. + intros; apply (op_rotate uniset union seq); auto. + exact seq_trans. + Qed. + + Lemma seq_congr : + forall x y z t:uniset, seq x y -> seq z t -> seq (union x z) (union y t). + Proof. + intros; apply (cong_congr uniset union seq); auto. + exact seq_trans. + Qed. + + Lemma union_perm_left : + forall x y z:uniset, seq (union x (union y z)) (union y (union x z)). + Proof. + intros; apply (perm_left uniset union seq); auto. + exact seq_trans. + Qed. + + Lemma uniset_twist1 : + forall x y z t:uniset, + seq (union x (union (union y z) t)) (union (union y (union x t)) z). + Proof. + intros; apply (twist uniset union seq); auto. + exact seq_trans. + Qed. + + Lemma uniset_twist2 : + forall x y z t:uniset, + seq (union x (union (union y z) t)) (union (union y (union x z)) t). + Proof. + intros; apply seq_trans with (union (union x (union y z)) t). + - apply seq_sym; apply union_ass. + - apply seq_left; apply union_perm_left. + Qed. + + (** specific for treesort *) + + Lemma treesort_twist1 : + forall x y z t u:uniset, + seq u (union y z) -> + seq (union x (union u t)) (union (union y (union x t)) z). + Proof. + intros; apply seq_trans with (union x (union (union y z) t)). + - apply seq_right; apply seq_left; trivial. + - apply uniset_twist1. + Qed. + + Lemma treesort_twist2 : + forall x y z t u:uniset, + seq u (union y z) -> + seq (union x (union u t)) (union (union y (union x z)) t). + Proof. + intros; apply seq_trans with (union x (union (union y z) t)). + - apply seq_right; apply seq_left; trivial. + - apply uniset_twist2. + Qed. + + + (*i theory of minter to do similarly (* uniset intersection *) Definition minter := [m1,m2:uniset] (Charac [a:A](andb (charac m1 a)(charac m2 a))). diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v index 3368ddcede..1dae3399f2 100644 --- a/theories/Sorting/CPermutation.v +++ b/theories/Sorting/CPermutation.v @@ -25,76 +25,76 @@ Set Implicit Arguments. Section CPermutation. -Variable A:Type. - -(** Definition *) - -Inductive CPermutation : list A -> list A -> Prop := -| cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). - -Instance CPermutation_Permutation : Proper (CPermutation ==> (@Permutation A)) id. -Proof. intros ? ? [? ?]; apply Permutation_app_comm. Qed. - -(** Some facts about [CPermutation] *) - -Theorem CPermutation_nil : forall l, CPermutation [] l -> l = []. -Proof. -intros l HC; inversion HC as [l1 l2 Heq]; subst. -now apply app_eq_nil in Heq; destruct Heq; subst. -Qed. - -Theorem CPermutation_nil_cons : forall l a, ~ CPermutation [] (a :: l). -Proof. intros l a HC; apply CPermutation_nil in HC; inversion HC. Qed. - -Theorem CPermutation_nil_app_cons : forall l1 l2 a, - ~ CPermutation [] (l1 ++ a ::l2). -Proof. -intros l1 l2 a HC; apply CPermutation_nil in HC; destruct l1; inversion HC. -Qed. - -Lemma CPermutation_split : forall l1 l2, - CPermutation l1 l2 <-> exists n, l2 = skipn n l1 ++ firstn n l1. -Proof. -intros l1 l2; split. -- intros [l1' l2']. - exists (length l1'). - rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal. - now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r. -- now intros [n ->]; rewrite <- (firstn_skipn n) at 1. -Qed. - - -(** Equivalence relation *) - -Theorem CPermutation_refl : forall l, CPermutation l l. -Proof. -intros l; now rewrite <- (app_nil_l l) at 1; rewrite <- (app_nil_r l) at 2. -Qed. - -Instance CPermutation_refl' : Proper (Logic.eq ==> CPermutation) id. -Proof. intros ? ? ->; apply CPermutation_refl. Qed. - -Theorem CPermutation_sym : forall l l', CPermutation l l' -> CPermutation l' l. -Proof. now intros ? ? [? ?]. Qed. - -Theorem CPermutation_trans : forall l l' l'', - CPermutation l l' -> CPermutation l' l'' -> CPermutation l l''. -Proof. -intros l l' l'' HC1 HC2. -inversion HC1 as [l1 l2]; inversion HC2 as [l3 l4 Heq Heq']; subst. -clear - Heq; revert l1 l2 l4 Heq; clear; induction l3; simpl; intros. -- now subst; rewrite app_nil_r. -- destruct l2 as [| b]. - + simpl in Heq; subst. - now rewrite app_nil_r, app_comm_cons. - + inversion Heq as [[Heqb Heq']]; subst. - replace (l1 ++ b :: l2) with ((l1 ++ b :: nil) ++ l2) - by now rewrite <- app_assoc, <- app_comm_cons. - replace (l4 ++ b :: l3) with ((l4 ++ b :: nil) ++ l3) - by now rewrite <- app_assoc, <- app_comm_cons. - apply IHl3. - now rewrite 2 app_assoc, Heq'. -Qed. + Variable A:Type. + + (** Definition *) + + Inductive CPermutation : list A -> list A -> Prop := + | cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). + + Instance CPermutation_Permutation : Proper (CPermutation ==> (@Permutation A)) id. + Proof. intros ? ? [? ?]; apply Permutation_app_comm. Qed. + + (** Some facts about [CPermutation] *) + + Theorem CPermutation_nil : forall l, CPermutation [] l -> l = []. + Proof. + intros l HC; inversion HC as [l1 l2 Heq]; subst. + now apply app_eq_nil in Heq; destruct Heq; subst. + Qed. + + Theorem CPermutation_nil_cons : forall l a, ~ CPermutation [] (a :: l). + Proof. intros l a HC; apply CPermutation_nil in HC; inversion HC. Qed. + + Theorem CPermutation_nil_app_cons : forall l1 l2 a, + ~ CPermutation [] (l1 ++ a ::l2). + Proof. + intros l1 l2 a HC; apply CPermutation_nil in HC; destruct l1; inversion HC. + Qed. + + Lemma CPermutation_split : forall l1 l2, + CPermutation l1 l2 <-> exists n, l2 = skipn n l1 ++ firstn n l1. + Proof. + intros l1 l2; split. + - intros [l1' l2']. + exists (length l1'). + rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal. + now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r. + - now intros [n ->]; rewrite <- (firstn_skipn n) at 1. + Qed. + + + (** Equivalence relation *) + + Theorem CPermutation_refl : forall l, CPermutation l l. + Proof. + intros l; now rewrite <- (app_nil_l l) at 1; rewrite <- (app_nil_r l) at 2. + Qed. + + Instance CPermutation_refl' : Proper (Logic.eq ==> CPermutation) id. + Proof. intros ? ? ->; apply CPermutation_refl. Qed. + + Theorem CPermutation_sym : forall l l', CPermutation l l' -> CPermutation l' l. + Proof. now intros ? ? [? ?]. Qed. + + Theorem CPermutation_trans : forall l l' l'', + CPermutation l l' -> CPermutation l' l'' -> CPermutation l l''. + Proof. + intros l l' l'' HC1 HC2. + inversion HC1 as [l1 l2]; inversion HC2 as [l3 l4 Heq Heq']; subst. + clear - Heq; revert l1 l2 l4 Heq; clear; induction l3; simpl; intros. + - now subst; rewrite app_nil_r. + - destruct l2 as [| b]. + + simpl in Heq; subst. + now rewrite app_nil_r, app_comm_cons. + + inversion Heq as [[Heqb Heq']]; subst. + replace (l1 ++ b :: l2) with ((l1 ++ b :: nil) ++ l2) + by now rewrite <- app_assoc, <- app_comm_cons. + replace (l4 ++ b :: l3) with ((l4 ++ b :: nil) ++ l3) + by now rewrite <- app_assoc, <- app_comm_cons. + apply IHl3. + now rewrite 2 app_assoc, Heq'. + Qed. End CPermutation. @@ -115,89 +115,89 @@ Instance CPermutation_Equivalence A : Equivalence (@CPermutation A) | 10 := { Section CPermutation_properties. -Variable A B:Type. - -Implicit Types a b : A. -Implicit Types l : list A. - -(** Compatibility with others operations on lists *) - -Lemma CPermutation_app : forall l1 l2 l3, - CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3. -Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2). Qed. - -Theorem CPermutation_app_comm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). -Proof. apply cperm. Qed. - -Lemma CPermutation_app_rot : forall l1 l2 l3, - CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). -Proof. intros l1 l2 l3; now rewrite (app_assoc l2). Qed. - -Lemma CPermutation_cons_append : forall l a, - CPermutation (a :: l) (l ++ [a]). -Proof. intros l a; now rewrite <- (app_nil_l l), app_comm_cons. Qed. - -Lemma CPermutation_morph_cons : forall P : list A -> Prop, - (forall a l, P (l ++ [a]) -> P (a :: l)) -> - Proper (@CPermutation A ==> iff) P. -Proof. -enough (forall P : list A -> Prop, - (forall a l, P (l ++ [a]) -> P (a :: l)) -> - forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2) - as Himp - by now intros P HP l1 l2 HC; split; [ | symmetry in HC ]; apply Himp. -intros P HP l1 l2 [l1' l2']. -revert l1'; induction l2' using rev_ind; intros l1' HPl. -- now rewrite app_nil_r in HPl. -- rewrite app_assoc in HPl. - apply HP in HPl. - rewrite <- app_assoc, <- app_comm_cons, app_nil_l. - now apply IHl2'. -Qed. - -Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. -Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. - -Lemma CPermutation_length_1_inv : forall a l, CPermutation [a] l -> l = [a]. -Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. - -Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. -Proof. -intros; now change [a; b] with ([a] ++ [b]); change [b; a] with ([b] ++ [a]). -Qed. - -Lemma CPermutation_length_2 : forall a1 a2 b1 b2, - CPermutation [a1; a2] [b1; b2] -> - a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. -Proof. intros; now apply Permutation_length_2, CPermutation_Permutation. Qed. - -Lemma CPermutation_length_2_inv : forall a b l, - CPermutation [a; b] l -> l = [a; b] \/ l = [b; a]. -Proof. intros; now apply Permutation_length_2_inv, CPermutation_Permutation. Qed. - -Lemma CPermutation_vs_elt_inv : forall l l1 l2 a, - CPermutation l (l1 ++ a :: l2) -> - exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''. -Proof. -intros l l1 l2 a HC. -inversion HC as [l1' l2' Heq' Heq]; clear HC; subst. -enough (exists l3, (l2' ++ l3 = l1 /\ l1' = l3 ++ a :: l2) - \/ (l2' = l1 ++ a :: l3 /\ l3 ++ l1' = l2)) - as [l3 [[<- ->]|[-> <-]]]. -- exists l3, (l2 ++ l2'); rewrite app_comm_cons; intuition. -- exists (l1' ++ l1), l3; intuition. -- revert l1' l2' l2 Heq; induction l1; simpl; intros l1' l2' l2 Heq. - + destruct l2'; inversion Heq; subst. - * exists nil; intuition. - * exists l2'; intuition. - + destruct l2'; inversion Heq; subst. - * exists (a0 :: l1); intuition. - * apply IHl1 in H1 as [l3 [[<- ->]|[-> <-]]]; exists l3; intuition. -Qed. - -Lemma CPermutation_vs_cons_inv : forall l l0 a, - CPermutation l (a :: l0) -> exists l' l'', l0 = l'' ++ l' /\ l = l' ++ a :: l''. -Proof. intros; rewrite <- (app_nil_r l0); now apply CPermutation_vs_elt_inv. Qed. + Variable A B:Type. + + Implicit Types a b : A. + Implicit Types l : list A. + + (** Compatibility with others operations on lists *) + + Lemma CPermutation_app : forall l1 l2 l3, + CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3. + Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2). Qed. + + Theorem CPermutation_app_comm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). + Proof. apply cperm. Qed. + + Lemma CPermutation_app_rot : forall l1 l2 l3, + CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). + Proof. intros l1 l2 l3; now rewrite (app_assoc l2). Qed. + + Lemma CPermutation_cons_append : forall l a, + CPermutation (a :: l) (l ++ [a]). + Proof. intros l a; now rewrite <- (app_nil_l l), app_comm_cons. Qed. + + Lemma CPermutation_morph_cons : forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + Proper (@CPermutation A ==> iff) P. + Proof. + enough (forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2) + as Himp + by now intros P HP l1 l2 HC; split; [ | symmetry in HC ]; apply Himp. + intros P HP l1 l2 [l1' l2']. + revert l1'; induction l2' using rev_ind; intros l1' HPl. + - now rewrite app_nil_r in HPl. + - rewrite app_assoc in HPl. + apply HP in HPl. + rewrite <- app_assoc, <- app_comm_cons, app_nil_l. + now apply IHl2'. + Qed. + + Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. + Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. + + Lemma CPermutation_length_1_inv : forall a l, CPermutation [a] l -> l = [a]. + Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. + + Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. + Proof. + intros; now change [a; b] with ([a] ++ [b]); change [b; a] with ([b] ++ [a]). + Qed. + + Lemma CPermutation_length_2 : forall a1 a2 b1 b2, + CPermutation [a1; a2] [b1; b2] -> + a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. + Proof. intros; now apply Permutation_length_2, CPermutation_Permutation. Qed. + + Lemma CPermutation_length_2_inv : forall a b l, + CPermutation [a; b] l -> l = [a; b] \/ l = [b; a]. + Proof. intros; now apply Permutation_length_2_inv, CPermutation_Permutation. Qed. + + Lemma CPermutation_vs_elt_inv : forall l l1 l2 a, + CPermutation l (l1 ++ a :: l2) -> + exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''. + Proof. + intros l l1 l2 a HC. + inversion HC as [l1' l2' Heq' Heq]; clear HC; subst. + enough (exists l3, (l2' ++ l3 = l1 /\ l1' = l3 ++ a :: l2) + \/ (l2' = l1 ++ a :: l3 /\ l3 ++ l1' = l2)) + as [l3 [[<- ->]|[-> <-]]]. + - exists l3, (l2 ++ l2'); rewrite app_comm_cons; intuition. + - exists (l1' ++ l1), l3; intuition. + - revert l1' l2' l2 Heq; induction l1; simpl; intros l1' l2' l2 Heq. + + destruct l2'; inversion Heq; subst. + * exists nil; intuition. + * exists l2'; intuition. + + destruct l2'; inversion Heq; subst. + * exists (a0 :: l1); intuition. + * apply IHl1 in H1 as [l3 [[<- ->]|[-> <-]]]; exists l3; intuition. + Qed. + + Lemma CPermutation_vs_cons_inv : forall l l0 a, + CPermutation l (a :: l0) -> exists l' l'', l0 = l'' ++ l' /\ l = l' ++ a :: l''. + Proof. intros; rewrite <- (app_nil_r l0); now apply CPermutation_vs_elt_inv. Qed. End CPermutation_properties. @@ -207,19 +207,19 @@ End CPermutation_properties. #[global] Instance CPermutation_rev A : Proper (@CPermutation A ==> @CPermutation A) (@rev A) | 10. Proof. -intro l; induction l; intros l' HC. -- now apply CPermutation_nil in HC; subst. -- symmetry in HC. - destruct (CPermutation_vs_cons_inv HC) as [l1 [l2 [-> ->]]]. - simpl; rewrite ? rev_app_distr; simpl. - now rewrite <- app_assoc. + intro l; induction l; intros l' HC. + - now apply CPermutation_nil in HC; subst. + - symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [l1 [l2 [-> ->]]]. + simpl; rewrite ? rev_app_distr; simpl. + now rewrite <- app_assoc. Qed. #[global] Instance CPermutation_in A a : Proper (@CPermutation A ==> Basics.impl) (In a). Proof. -intros l l' HC Hin. -now apply Permutation_in with l; [ apply CPermutation_Permutation | ]. + intros l l' HC Hin. + now apply Permutation_in with l; [ apply CPermutation_Permutation | ]. Qed. #[global] Instance CPermutation_in' A : @@ -233,50 +233,50 @@ Proof. now intros ? ? [l1 l2]; rewrite 2 map_app. Qed. Lemma CPermutation_map_inv A B : forall (f : A -> B) m l, CPermutation m (map f l) -> exists l', m = map f l' /\ CPermutation l l'. Proof. -induction m as [| b m]; intros l HC. -- exists nil; split; auto. - destruct l; auto. - apply CPermutation_nil in HC; inversion HC. -- symmetry in HC. - destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. - apply map_eq_app in Heq as [l1 [l1' [-> [<- Heq]]]]. - apply map_eq_cons in Heq as [a [l1'' [-> [<- <-]]]]. - exists (a :: l1'' ++ l1); split. - + now simpl; rewrite map_app. - + now rewrite app_comm_cons. + induction m as [| b m]; intros l HC. + - exists nil; split; auto. + destruct l; auto. + apply CPermutation_nil in HC; inversion HC. + - symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. + apply map_eq_app in Heq as [l1 [l1' [-> [<- Heq]]]]. + apply map_eq_cons in Heq as [a [l1'' [-> [<- <-]]]]. + exists (a :: l1'' ++ l1); split. + + now simpl; rewrite map_app. + + now rewrite app_comm_cons. Qed. Lemma CPermutation_image A B : forall (f : A -> B) a l l', CPermutation (a :: l) (map f l') -> exists a', a = f a'. Proof. -intros f a l l' HP. -now apply CPermutation_Permutation, Permutation_image in HP. + intros f a l l' HP. + now apply CPermutation_Permutation, Permutation_image in HP. Qed. #[global] Instance CPermutation_Forall A (P : A -> Prop) : Proper (@CPermutation A ==> Basics.impl) (Forall P). Proof. -intros ? ? [? ?] HF. -now apply Forall_app in HF; apply Forall_app. + intros ? ? [? ?] HF. + now apply Forall_app in HF; apply Forall_app. Qed. #[global] Instance CPermutation_Exists A (P : A -> Prop) : Proper (@CPermutation A ==> Basics.impl) (Exists P). Proof. -intros ? ? [? ?] HE. -apply Exists_app in HE; apply Exists_app; intuition. + intros ? ? [? ?] HE. + apply Exists_app in HE; apply Exists_app; intuition. Qed. Lemma CPermutation_Forall2 A B (P : A -> B -> Prop) : forall l1 l1' l2, CPermutation l1 l1' -> Forall2 P l1 l2 -> exists l2', CPermutation l2 l2' /\ Forall2 P l1' l2'. Proof. -intros ? ? ? [? ?] HF. -apply Forall2_app_inv_l in HF as (l2' & l2'' & HF' & HF'' & ->). -exists (l2'' ++ l2'); intuition. -now apply Forall2_app. + intros ? ? ? [? ?] HF. + apply Forall2_app_inv_l in HF as (l2' & l2'' & HF' & HF'' & ->). + exists (l2'' ++ l2'); intuition. + now apply Forall2_app. Qed. diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v index d0397347d7..aa7be788e5 100644 --- a/theories/Sorting/Mergesort.v +++ b/theories/Sorting/Mergesort.v @@ -33,17 +33,17 @@ Open Scope bool_scope. Module Sort (Import X:Orders.TotalLeBool'). -Fixpoint merge l1 l2 := - let fix merge_aux l2 := - match l1, l2 with - | [], _ => l2 - | _, [] => l1 - | a1::l1', a2::l2' => - if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2' - end - in merge_aux l2. - -(** We implement mergesort using an explicit stack of pending mergings. + Fixpoint merge l1 l2 := + let fix merge_aux l2 := + match l1, l2 with + | [], _ => l2 + | _, [] => l1 + | a1::l1', a2::l2' => + if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2' + end + in merge_aux l2. + + (** We implement mergesort using an explicit stack of pending mergings. Pending merging are represented like a binary number where digits are either None (denoting 0) or Some list to merge (denoting 1). The n-th digit represents the pending list to be merged at level n, if any. @@ -87,166 +87,166 @@ Fixpoint merge l1 l2 := that lists are merged on a dichotomic basis. *) -Fixpoint merge_list_to_stack stack l := - match stack with - | [] => [Some l] - | None :: stack' => Some l :: stack' - | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l) - end. - -Fixpoint merge_stack stack := - match stack with - | [] => [] - | None :: stack' => merge_stack stack' - | Some l :: stack' => merge l (merge_stack stack') - end. - -Fixpoint iter_merge stack l := - match l with - | [] => merge_stack stack - | a::l' => iter_merge (merge_list_to_stack stack [a]) l' - end. - -Definition sort := iter_merge []. - -(** The proof of correctness *) - -#[local] Notation Sorted := (LocallySorted leb) (only parsing). - -Fixpoint SortedStack stack := - match stack with - | [] => True - | None :: stack' => SortedStack stack' - | Some l :: stack' => Sorted l /\ SortedStack stack' - end. - -#[local] Ltac invert H := inversion H; subst; clear H. - -Fixpoint flatten_stack (stack : list (option (list t))) := - match stack with - | [] => [] - | None :: stack' => flatten_stack stack' - | Some l :: stack' => l ++ flatten_stack stack' - end. - -Theorem Sorted_merge : forall l1 l2, - Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2). -Proof. - induction l1; induction l2; intros; simpl; auto. - destruct (a <=? a0) eqn:Heq1. - - invert H. - + simpl. constructor; trivial; rewrite Heq1; constructor. - + assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto). - clear H0 H3 IHl1; simpl in *. - destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor. - - assert (a0 <=? a) by - (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')). - invert H0. - + constructor; trivial. - + assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1. - clear IHl2; simpl in *. - destruct (a <=? b); constructor; auto. -Qed. - -Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2). -Proof. - induction l1; simpl merge; intro. - - assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l) - as -> by (destruct l; trivial). (* Technical lemma *) - apply Permutation_refl. - - induction l2. - + rewrite app_nil_r. apply Permutation_refl. - + destruct (a <=? a0). - * constructor; apply IHl1. - * apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2. -Qed. - -Theorem Sorted_merge_list_to_stack : forall stack l, - SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l). -Proof. - induction stack as [|[|]]; intros; simpl. - - auto. - - apply IHstack. - + destruct H as (_,H1). fold SortedStack in H1. auto. - + apply Sorted_merge; auto; destruct H; auto. - - auto. -Qed. - -Theorem Permuted_merge_list_to_stack : forall stack l, - Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)). -Proof. - induction stack as [|[]]; simpl; intros. - - reflexivity. - - rewrite app_assoc. - etransitivity. - + apply Permutation_app_tail. + Fixpoint merge_list_to_stack stack l := + match stack with + | [] => [Some l] + | None :: stack' => Some l :: stack' + | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l) + end. + + Fixpoint merge_stack stack := + match stack with + | [] => [] + | None :: stack' => merge_stack stack' + | Some l :: stack' => merge l (merge_stack stack') + end. + + Fixpoint iter_merge stack l := + match l with + | [] => merge_stack stack + | a::l' => iter_merge (merge_list_to_stack stack [a]) l' + end. + + Definition sort := iter_merge []. + + (** The proof of correctness *) + + #[local] Notation Sorted := (LocallySorted leb) (only parsing). + + Fixpoint SortedStack stack := + match stack with + | [] => True + | None :: stack' => SortedStack stack' + | Some l :: stack' => Sorted l /\ SortedStack stack' + end. + + #[local] Ltac invert H := inversion H; subst; clear H. + + Fixpoint flatten_stack (stack : list (option (list t))) := + match stack with + | [] => [] + | None :: stack' => flatten_stack stack' + | Some l :: stack' => l ++ flatten_stack stack' + end. + + Theorem Sorted_merge : forall l1 l2, + Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2). + Proof. + induction l1; induction l2; intros; simpl; auto. + destruct (a <=? a0) eqn:Heq1. + - invert H. + + simpl. constructor; trivial; rewrite Heq1; constructor. + + assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto). + clear H0 H3 IHl1; simpl in *. + destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor. + - assert (a0 <=? a) by + (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')). + invert H0. + + constructor; trivial. + + assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1. + clear IHl2; simpl in *. + destruct (a <=? b); constructor; auto. + Qed. + + Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2). + Proof. + induction l1; simpl merge; intro. + - assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l) + as -> by (destruct l; trivial). (* Technical lemma *) + apply Permutation_refl. + - induction l2. + + rewrite app_nil_r. apply Permutation_refl. + + destruct (a <=? a0). + * constructor; apply IHl1. + * apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2. + Qed. + + Theorem Sorted_merge_list_to_stack : forall stack l, + SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l). + Proof. + induction stack as [|[|]]; intros; simpl. + - auto. + - apply IHstack. + + destruct H as (_,H1). fold SortedStack in H1. auto. + + apply Sorted_merge; auto; destruct H; auto. + - auto. + Qed. + + Theorem Permuted_merge_list_to_stack : forall stack l, + Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)). + Proof. + induction stack as [|[]]; simpl; intros. + - reflexivity. + - rewrite app_assoc. etransitivity. - * apply Permutation_app_comm. - * apply Permuted_merge. - + apply IHstack. - - reflexivity. -Qed. - -Theorem Sorted_merge_stack : forall stack, - SortedStack stack -> Sorted (merge_stack stack). -Proof. -induction stack as [|[|]]; simpl; intros. -- constructor; auto. -- apply Sorted_merge; tauto. -- auto. -Qed. - -Theorem Permuted_merge_stack : forall stack, - Permutation (flatten_stack stack) (merge_stack stack). -Proof. -induction stack as [|[]]; simpl. -- trivial. -- transitivity (l ++ merge_stack stack). - + apply Permutation_app_head; trivial. - + apply Permuted_merge. -- assumption. -Qed. - -Theorem Sorted_iter_merge : forall stack l, - SortedStack stack -> Sorted (iter_merge stack l). -Proof. - intros stack l H; induction l in stack, H |- *; simpl. - - auto using Sorted_merge_stack. - - assert (Sorted [a]) by constructor. - auto using Sorted_merge_list_to_stack. -Qed. - -Theorem Permuted_iter_merge : forall l stack, - Permutation (flatten_stack stack ++ l) (iter_merge stack l). -Proof. - induction l; simpl; intros. - - rewrite app_nil_r. apply Permuted_merge_stack. - - change (a::l) with ([a]++l). - rewrite app_assoc. - etransitivity. - + apply Permutation_app_tail. + + apply Permutation_app_tail. + etransitivity. + * apply Permutation_app_comm. + * apply Permuted_merge. + + apply IHstack. + - reflexivity. + Qed. + + Theorem Sorted_merge_stack : forall stack, + SortedStack stack -> Sorted (merge_stack stack). + Proof. + induction stack as [|[|]]; simpl; intros. + - constructor; auto. + - apply Sorted_merge; tauto. + - auto. + Qed. + + Theorem Permuted_merge_stack : forall stack, + Permutation (flatten_stack stack) (merge_stack stack). + Proof. + induction stack as [|[]]; simpl. + - trivial. + - transitivity (l ++ merge_stack stack). + + apply Permutation_app_head; trivial. + + apply Permuted_merge. + - assumption. + Qed. + + Theorem Sorted_iter_merge : forall stack l, + SortedStack stack -> Sorted (iter_merge stack l). + Proof. + intros stack l H; induction l in stack, H |- *; simpl. + - auto using Sorted_merge_stack. + - assert (Sorted [a]) by constructor. + auto using Sorted_merge_list_to_stack. + Qed. + + Theorem Permuted_iter_merge : forall l stack, + Permutation (flatten_stack stack ++ l) (iter_merge stack l). + Proof. + induction l; simpl; intros. + - rewrite app_nil_r. apply Permuted_merge_stack. + - change (a::l) with ([a]++l). + rewrite app_assoc. etransitivity. - * apply Permutation_app_comm. - * apply Permuted_merge_list_to_stack. - + apply IHl. -Qed. - -Theorem LocallySorted_sort : forall l, Sorted (sort l). -Proof. -intro; apply Sorted_iter_merge. constructor. -Qed. - -Corollary Sorted_sort : forall l, Sorted.Sorted leb (sort l). -Proof. intro; eapply Sorted_LocallySorted_iff, LocallySorted_sort; auto. Qed. - -Theorem Permuted_sort : forall l, Permutation l (sort l). -Proof. -intro; apply (Permuted_iter_merge l []). -Qed. - -Corollary StronglySorted_sort : forall l, - Transitive leb -> StronglySorted leb (sort l). -Proof. auto using Sorted_StronglySorted, Sorted_sort. Qed. + + apply Permutation_app_tail. + etransitivity. + * apply Permutation_app_comm. + * apply Permuted_merge_list_to_stack. + + apply IHl. + Qed. + + Theorem LocallySorted_sort : forall l, Sorted (sort l). + Proof. + intro; apply Sorted_iter_merge. constructor. + Qed. + + Corollary Sorted_sort : forall l, Sorted.Sorted leb (sort l). + Proof. intro; eapply Sorted_LocallySorted_iff, LocallySorted_sort; auto. Qed. + + Theorem Permuted_sort : forall l, Permutation l (sort l). + Proof. + intro; apply (Permuted_iter_merge l []). + Qed. + + Corollary StronglySorted_sort : forall l, + Transitive leb -> StronglySorted leb (sort l). + Proof. auto using Sorted_StronglySorted, Sorted_sort. Qed. End Sort. diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 6fbec13752..1bb7d7acd6 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -32,453 +32,453 @@ Set Implicit Arguments. Section Permut. -(** * From lists to multisets *) - -Variable A : Type. -Variable eqA : relation A. -Hypothesis eqA_equiv : Equivalence eqA. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - -Let emptyBag := EmptyBag A. -Let singletonBag := SingletonBag _ eqA_dec. - -(** contents of a list *) - -Fixpoint list_contents (l:list A) : multiset A := - match l with - | [] => emptyBag - | a :: l => munion (singletonBag a) (list_contents l) - end. - -Lemma list_contents_app : - forall l m:list A, - meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)). -Proof. - simple induction l; simpl; auto with datatypes. - intros. - apply meq_trans with - (munion (singletonBag a) (munion (list_contents l0) (list_contents m))); - auto with datatypes. -Qed. - -(** * [permutation]: definition and basic properties *) - -Definition permutation (l m:list A) := meq (list_contents l) (list_contents m). - -Lemma permut_refl : forall l:list A, permutation l l. -Proof. - unfold permutation; auto with datatypes. -Qed. - -Lemma permut_sym : - forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1. -Proof. - unfold permutation, meq; intros; symmetry; trivial. -Qed. - -Lemma permut_trans : - forall l m n:list A, permutation l m -> permutation m n -> permutation l n. -Proof. - unfold permutation; intros. - apply meq_trans with (list_contents m); auto with datatypes. -Qed. - -Lemma permut_cons_eq : - forall l m:list A, - permutation l m -> forall a a', eqA a a' -> permutation (a :: l) (a' :: m). -Proof. - unfold permutation; simpl; intros. - apply meq_trans with (munion (singletonBag a') (list_contents l)). - - apply meq_left, meq_singleton; auto. - - auto with datatypes. -Qed. - -Lemma permut_cons : - forall l m:list A, - permutation l m -> forall a:A, permutation (a :: l) (a :: m). -Proof. - unfold permutation; simpl; auto with datatypes. -Qed. - -Lemma permut_app : - forall l l' m m':list A, - permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m'). -Proof. - unfold permutation; intros. - apply meq_trans with (munion (list_contents l) (list_contents m)); - auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m')); - auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m)); - auto using permut_cons, list_contents_app with datatypes. -Qed. - -Lemma permut_add_inside_eq : - forall a a' l1 l2 l3 l4, eqA a a' -> - permutation (l1 ++ l2) (l3 ++ l4) -> - permutation (l1 ++ a :: l2) (l3 ++ a' :: l4). -Proof. - unfold permutation, meq in *; intros. - specialize H0 with a0. - repeat rewrite list_contents_app in *; simpl in *. - destruct (eqA_dec a a0) as [Ha|Ha]; rewrite H in Ha; - decide (eqA_dec a' a0) with Ha; simpl; auto with arith. - do 2 rewrite <- plus_n_Sm; f_equal; auto. -Qed. - -Lemma permut_add_inside : - forall a l1 l2 l3 l4, - permutation (l1 ++ l2) (l3 ++ l4) -> - permutation (l1 ++ a :: l2) (l3 ++ a :: l4). -Proof. - unfold permutation, meq in *; intros. - generalize (H a0); clear H. - do 4 rewrite list_contents_app. - simpl. - destruct (eqA_dec a a0); simpl; auto with arith. - do 2 rewrite <- plus_n_Sm; f_equal; auto. -Qed. - -Lemma permut_add_cons_inside_eq : - forall a a' l l1 l2, eqA a a' -> - permutation l (l1 ++ l2) -> - permutation (a :: l) (l1 ++ a' :: l2). -Proof. - intros; - replace (a :: l) with ([] ++ a :: l); trivial; - apply permut_add_inside_eq; trivial. -Qed. - -Lemma permut_add_cons_inside : - forall a l l1 l2, - permutation l (l1 ++ l2) -> - permutation (a :: l) (l1 ++ a :: l2). -Proof. - intros; + (** * From lists to multisets *) + + Variable A : Type. + Variable eqA : relation A. + Hypothesis eqA_equiv : Equivalence eqA. + Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + + Let emptyBag := EmptyBag A. + Let singletonBag := SingletonBag _ eqA_dec. + + (** contents of a list *) + + Fixpoint list_contents (l:list A) : multiset A := + match l with + | [] => emptyBag + | a :: l => munion (singletonBag a) (list_contents l) + end. + + Lemma list_contents_app : + forall l m:list A, + meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)). + Proof. + simple induction l; simpl; auto with datatypes. + intros. + apply meq_trans with + (munion (singletonBag a) (munion (list_contents l0) (list_contents m))); + auto with datatypes. + Qed. + + (** * [permutation]: definition and basic properties *) + + Definition permutation (l m:list A) := meq (list_contents l) (list_contents m). + + Lemma permut_refl : forall l:list A, permutation l l. + Proof. + unfold permutation; auto with datatypes. + Qed. + + Lemma permut_sym : + forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1. + Proof. + unfold permutation, meq; intros; symmetry; trivial. + Qed. + + Lemma permut_trans : + forall l m n:list A, permutation l m -> permutation m n -> permutation l n. + Proof. + unfold permutation; intros. + apply meq_trans with (list_contents m); auto with datatypes. + Qed. + + Lemma permut_cons_eq : + forall l m:list A, + permutation l m -> forall a a', eqA a a' -> permutation (a :: l) (a' :: m). + Proof. + unfold permutation; simpl; intros. + apply meq_trans with (munion (singletonBag a') (list_contents l)). + - apply meq_left, meq_singleton; auto. + - auto with datatypes. + Qed. + + Lemma permut_cons : + forall l m:list A, + permutation l m -> forall a:A, permutation (a :: l) (a :: m). + Proof. + unfold permutation; simpl; auto with datatypes. + Qed. + + Lemma permut_app : + forall l l' m m':list A, + permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m'). + Proof. + unfold permutation; intros. + apply meq_trans with (munion (list_contents l) (list_contents m)); + auto using permut_cons, list_contents_app with datatypes. + apply meq_trans with (munion (list_contents l') (list_contents m')); + auto using permut_cons, list_contents_app with datatypes. + apply meq_trans with (munion (list_contents l') (list_contents m)); + auto using permut_cons, list_contents_app with datatypes. + Qed. + + Lemma permut_add_inside_eq : + forall a a' l1 l2 l3 l4, eqA a a' -> + permutation (l1 ++ l2) (l3 ++ l4) -> + permutation (l1 ++ a :: l2) (l3 ++ a' :: l4). + Proof. + unfold permutation, meq in *; intros. + specialize H0 with a0. + repeat rewrite list_contents_app in *; simpl in *. + destruct (eqA_dec a a0) as [Ha|Ha]; rewrite H in Ha; + decide (eqA_dec a' a0) with Ha; simpl; auto with arith. + do 2 rewrite <- plus_n_Sm; f_equal; auto. + Qed. + + Lemma permut_add_inside : + forall a l1 l2 l3 l4, + permutation (l1 ++ l2) (l3 ++ l4) -> + permutation (l1 ++ a :: l2) (l3 ++ a :: l4). + Proof. + unfold permutation, meq in *; intros. + generalize (H a0); clear H. + do 4 rewrite list_contents_app. + simpl. + destruct (eqA_dec a a0); simpl; auto with arith. + do 2 rewrite <- plus_n_Sm; f_equal; auto. + Qed. + + Lemma permut_add_cons_inside_eq : + forall a a' l l1 l2, eqA a a' -> + permutation l (l1 ++ l2) -> + permutation (a :: l) (l1 ++ a' :: l2). + Proof. + intros; replace (a :: l) with ([] ++ a :: l); trivial; - apply permut_add_inside; trivial. -Qed. - -Lemma permut_middle : - forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m). -Proof. - intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl. -Qed. - -Lemma permut_sym_app : - forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). -Proof. - intros l1 l2; - unfold permutation, meq; - intro a; do 2 rewrite list_contents_app; simpl; - auto with arith. -Qed. - -Lemma permut_rev : - forall l, permutation l (rev l). -Proof. - induction l. - - simpl; trivial using permut_refl. - - simpl. - apply permut_add_cons_inside. - rewrite app_nil_r. trivial. -Qed. - -(** * Some inversion results. *) -Lemma permut_conv_inv : - forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2. -Proof. - intros e l1 l2; unfold permutation, meq; simpl; intros H a; - generalize (H a); lia. -Qed. - -Lemma permut_app_inv1 : - forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2. -Proof. - intros l l1 l2; unfold permutation, meq; simpl; - intros H a; generalize (H a); clear H. - do 2 rewrite list_contents_app. - simpl. - lia. -Qed. - -(** we can use [multiplicity] to define [InA] and [NoDupA]. *) - -Fact if_eqA_then : forall a a' (B:Type)(b b':B), - eqA a a' -> (if eqA_dec a a' then b else b') = b. -Proof. - intros. destruct eqA_dec as [_|NEQ]; auto. - contradict NEQ; auto. -Qed. - -Lemma permut_app_inv2 : - forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2. -Proof. - intros l l1 l2; unfold permutation, meq; simpl; - intros H a; generalize (H a); clear H. - do 2 rewrite list_contents_app. - simpl. - lia. -Qed. - -Lemma permut_remove_hd_eq : - forall l l1 l2 a b, eqA a b -> - permutation (a :: l) (l1 ++ b :: l2) -> permutation l (l1 ++ l2). -Proof. - unfold permutation, meq; simpl; intros l l1 l2 a b Heq H a0. - specialize H with a0. - rewrite list_contents_app in *. simpl in *. - destruct (eqA_dec a _) as [Ha|Ha]; rewrite Heq in Ha; revert H; - decide (eqA_dec b a0) with Ha; lia. -Qed. - -Lemma permut_remove_hd : - forall l l1 l2 a, - permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2). -Proof. - pose proof (Equivalence_Reflexive (R := eqA)); - eauto using permut_remove_hd_eq. -Qed. - -Fact if_eqA_else : forall a a' (B:Type)(b b':B), - ~eqA a a' -> (if eqA_dec a a' then b else b') = b'. -Proof. - intros. decide (eqA_dec a a') with H; auto. -Qed. - -Fact if_eqA_refl : forall a (B:Type)(b b':B), - (if eqA_dec a a then b else b') = b. -Proof. - intros; apply (decide_left (eqA_dec a a)); auto with *. -Qed. - -(** PL: Inutilisable dans un rewrite sans un change prealable. *) - -#[global] Instance if_eqA (B:Type)(b b':B) : - Proper (eqA==>eqA==>@eq _) (fun x y => if eqA_dec x y then b else b'). -Proof. - intros x x' Hxx' y y' Hyy'. - intros; destruct (eqA_dec x y) as [H|H]; - destruct (eqA_dec x' y') as [H'|H']; auto. - - contradict H'; transitivity x; auto with *; transitivity y; auto with *. - - contradict H; transitivity x'; auto with *; transitivity y'; auto with *. -Qed. - -Fact if_eqA_rewrite_l : forall a1 a1' a2 (B:Type)(b b':B), - eqA a1 a1' -> (if eqA_dec a1 a2 then b else b') = - (if eqA_dec a1' a2 then b else b'). -Proof. - intros; destruct (eqA_dec a1 a2) as [A1|A1]; - destruct (eqA_dec a1' a2) as [A1'|A1']; auto. - - contradict A1'; transitivity a1; eauto with *. - - contradict A1; transitivity a1'; eauto with *. -Qed. - -Fact if_eqA_rewrite_r : forall a1 a2 a2' (B:Type)(b b':B), - eqA a2 a2' -> (if eqA_dec a1 a2 then b else b') = - (if eqA_dec a1 a2' then b else b'). -Proof. - intros; destruct (eqA_dec a1 a2) as [A2|A2]; - destruct (eqA_dec a1 a2') as [A2'|A2']; auto. - - contradict A2'; transitivity a2; eauto with *. - - contradict A2; transitivity a2'; eauto with *. -Qed. - - -#[global] Instance multiplicity_eqA (l:list A) : - Proper (eqA==>@eq _) (multiplicity (list_contents l)). -Proof. - intros x x' Hxx'. - induction l as [|y l Hl]; simpl; auto. - rewrite (@if_eqA_rewrite_r y x x'); auto. -Qed. - -Lemma multiplicity_InA : - forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a. -Proof. - induction l. - - simpl. - split; inversion 1. - - simpl. - intros a'; split; intros H. - + inversion_clear H. - * apply (decide_left (eqA_dec a a')); auto with *. - * destruct (eqA_dec a a'); auto with *. simpl; rewrite <- IHl; auto. - + destruct (eqA_dec a a'); auto with *. right. rewrite IHl; auto. -Qed. - -Lemma multiplicity_InA_O : - forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0. -Proof. - intros l a; rewrite multiplicity_InA; - destruct (multiplicity (list_contents l) a); auto with arith. - destruct 1; auto with arith. -Qed. - -Lemma multiplicity_InA_S : - forall l a, InA eqA a l -> multiplicity (list_contents l) a >= 1. -Proof. - intros l a; rewrite multiplicity_InA; auto with arith. -Qed. - -Lemma multiplicity_NoDupA : forall l, - NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1). -Proof. - induction l. - - simpl. - split; auto with arith. - - split; simpl. - + inversion_clear 1. - rewrite IHl in H1. - intros; destruct (eqA_dec a a0) as [EQ|NEQ]; simpl; auto with *. - rewrite <- EQ. - rewrite multiplicity_InA_O; auto. - + intros; constructor. - * rewrite multiplicity_InA. - specialize (H a). - rewrite if_eqA_refl in H. - clear IHl; lia. - * rewrite IHl; intros. - specialize (H a0). lia. -Qed. - -(** Permutation is compatible with InA. *) -Lemma permut_InA_InA : - forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2. -Proof. - intros l1 l2 e. - do 2 rewrite multiplicity_InA. - unfold permutation, meq. - intros H;rewrite H; auto. -Qed. - -Lemma permut_cons_InA : - forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2. -Proof. - intros; apply (permut_InA_InA (e:=e) H); auto with *. -Qed. - -(** Permutation of an empty list. *) -Lemma permut_nil : - forall l, permutation l [] -> l = []. -Proof. - intro l; destruct l as [ | e l ]; trivial. - assert (InA eqA e (e::l)) by (auto with * ). - intro Abs; generalize (permut_InA_InA Abs H). - inversion 1. -Qed. - -(** Permutation for short lists. *) - -Lemma permut_length_1: - forall a b, permutation [a] [b] -> eqA a b. -Proof. - intros a b; unfold permutation, meq. - intro P; specialize (P b); simpl in *. - rewrite if_eqA_refl in *. - destruct (eqA_dec a b); simpl; auto; discriminate. -Qed. - -Lemma permut_length_2 : - forall a1 b1 a2 b2, permutation [a1; b1] [a2; b2] -> - (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1). -Proof. - intros a1 b1 a2 b2 P. - assert (H:=permut_cons_InA P). - inversion_clear H. - - left; split; auto. - apply permut_length_1. - red; red; intros. - specialize (P a). simpl in *. - rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. lia. - - right. - inversion_clear H0; [|inversion H]. - split; auto. - apply permut_length_1. - red; red; intros. - specialize (P a); simpl in *. - rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. lia. -Qed. - -(** Permutation is compatible with length. *) -Lemma permut_length : - forall l1 l2, permutation l1 l2 -> length l1 = length l2. -Proof. - induction l1; intros l2 H. - - rewrite (permut_nil (permut_sym H)); auto. - - assert (H0:=permut_cons_InA H). - destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). - subst l2. - rewrite length_app. - simpl; rewrite <- plus_n_Sm; f_equal. - rewrite <- length_app. - apply IHl1. - apply permut_remove_hd with b. - apply permut_trans with (a::l1); auto. - revert H1; unfold permutation, meq; simpl. - intros; f_equal; auto. - rewrite (@if_eqA_rewrite_l a b a0); auto. -Qed. - -Lemma NoDupA_equivlistA_permut : - forall l l', NoDupA eqA l -> NoDupA eqA l' -> - equivlistA eqA l l' -> permutation l l'. -Proof. - intros. - red; unfold meq; intros. - rewrite multiplicity_NoDupA in H, H0. - generalize (H a) (H0 a) (H1 a); clear H H0 H1. - do 2 rewrite multiplicity_InA. - destruct 3; lia. -Qed. - -End Permut. - -Section Permut_map. - -Variables A B : Type. - -Variable eqA : relation A. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. -Hypothesis eqA_equiv : Equivalence eqA. - -Variable eqB : B->B->Prop. -Hypothesis eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. -Hypothesis eqB_trans : Transitive eqB. - -(** Permutation is compatible with map. *) - -Lemma permut_map : - forall f, - (Proper (eqA==>eqB) f) -> - forall l1 l2, permutation _ eqA_dec l1 l2 -> - permutation _ eqB_dec (map f l1) (map f l2). -Proof. - intros f; induction l1. - - intros l2 P; rewrite (permut_nil eqA_equiv (permut_sym P)); apply permut_refl. - - intros l2 P. + apply permut_add_inside_eq; trivial. + Qed. + + Lemma permut_add_cons_inside : + forall a l l1 l2, + permutation l (l1 ++ l2) -> + permutation (a :: l) (l1 ++ a :: l2). + Proof. + intros; + replace (a :: l) with ([] ++ a :: l); trivial; + apply permut_add_inside; trivial. + Qed. + + Lemma permut_middle : + forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m). + Proof. + intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl. + Qed. + + Lemma permut_sym_app : + forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). + Proof. + intros l1 l2; + unfold permutation, meq; + intro a; do 2 rewrite list_contents_app; simpl; + auto with arith. + Qed. + + Lemma permut_rev : + forall l, permutation l (rev l). + Proof. + induction l. + - simpl; trivial using permut_refl. + - simpl. + apply permut_add_cons_inside. + rewrite app_nil_r. trivial. + Qed. + + (** * Some inversion results. *) + Lemma permut_conv_inv : + forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2. + Proof. + intros e l1 l2; unfold permutation, meq; simpl; intros H a; + generalize (H a); lia. + Qed. + + Lemma permut_app_inv1 : + forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2. + Proof. + intros l l1 l2; unfold permutation, meq; simpl; + intros H a; generalize (H a); clear H. + do 2 rewrite list_contents_app. simpl. - assert (H0:=permut_cons_InA eqA_equiv P). - destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). - subst l2. - rewrite map_app. + lia. + Qed. + + (** we can use [multiplicity] to define [InA] and [NoDupA]. *) + + Fact if_eqA_then : forall a a' (B:Type)(b b':B), + eqA a a' -> (if eqA_dec a a' then b else b') = b. + Proof. + intros. destruct eqA_dec as [_|NEQ]; auto. + contradict NEQ; auto. + Qed. + + Lemma permut_app_inv2 : + forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2. + Proof. + intros l l1 l2; unfold permutation, meq; simpl; + intros H a; generalize (H a); clear H. + do 2 rewrite list_contents_app. simpl. - apply permut_trans with (f b :: map f l1). - + revert H1; unfold permutation, meq; simpl. - intros; f_equal; auto. - destruct (eqB_dec (f b) a0) as [H2|H2]; - destruct (eqB_dec (f a) a0) as [H3|H3]; auto. - * destruct H3; transitivity (f b); auto with *. - * destruct H2; transitivity (f a); auto with *. - + apply permut_add_cons_inside. - rewrite <- map_app. - apply IHl1; auto. - apply permut_remove_hd with b; trivial. + lia. + Qed. + + Lemma permut_remove_hd_eq : + forall l l1 l2 a b, eqA a b -> + permutation (a :: l) (l1 ++ b :: l2) -> permutation l (l1 ++ l2). + Proof. + unfold permutation, meq; simpl; intros l l1 l2 a b Heq H a0. + specialize H with a0. + rewrite list_contents_app in *. simpl in *. + destruct (eqA_dec a _) as [Ha|Ha]; rewrite Heq in Ha; revert H; + decide (eqA_dec b a0) with Ha; lia. + Qed. + + Lemma permut_remove_hd : + forall l l1 l2 a, + permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2). + Proof. + pose proof (Equivalence_Reflexive (R := eqA)); + eauto using permut_remove_hd_eq. + Qed. + + Fact if_eqA_else : forall a a' (B:Type)(b b':B), + ~eqA a a' -> (if eqA_dec a a' then b else b') = b'. + Proof. + intros. decide (eqA_dec a a') with H; auto. + Qed. + + Fact if_eqA_refl : forall a (B:Type)(b b':B), + (if eqA_dec a a then b else b') = b. + Proof. + intros; apply (decide_left (eqA_dec a a)); auto with *. + Qed. + + (** PL: Inutilisable dans un rewrite sans un change prealable. *) + + #[global] Instance if_eqA (B:Type)(b b':B) : + Proper (eqA==>eqA==>@eq _) (fun x y => if eqA_dec x y then b else b'). + Proof. + intros x x' Hxx' y y' Hyy'. + intros; destruct (eqA_dec x y) as [H|H]; + destruct (eqA_dec x' y') as [H'|H']; auto. + - contradict H'; transitivity x; auto with *; transitivity y; auto with *. + - contradict H; transitivity x'; auto with *; transitivity y'; auto with *. + Qed. + + Fact if_eqA_rewrite_l : forall a1 a1' a2 (B:Type)(b b':B), + eqA a1 a1' -> (if eqA_dec a1 a2 then b else b') = + (if eqA_dec a1' a2 then b else b'). + Proof. + intros; destruct (eqA_dec a1 a2) as [A1|A1]; + destruct (eqA_dec a1' a2) as [A1'|A1']; auto. + - contradict A1'; transitivity a1; eauto with *. + - contradict A1; transitivity a1'; eauto with *. + Qed. + + Fact if_eqA_rewrite_r : forall a1 a2 a2' (B:Type)(b b':B), + eqA a2 a2' -> (if eqA_dec a1 a2 then b else b') = + (if eqA_dec a1 a2' then b else b'). + Proof. + intros; destruct (eqA_dec a1 a2) as [A2|A2]; + destruct (eqA_dec a1 a2') as [A2'|A2']; auto. + - contradict A2'; transitivity a2; eauto with *. + - contradict A2; transitivity a2'; eauto with *. + Qed. + + + #[global] Instance multiplicity_eqA (l:list A) : + Proper (eqA==>@eq _) (multiplicity (list_contents l)). + Proof. + intros x x' Hxx'. + induction l as [|y l Hl]; simpl; auto. + rewrite (@if_eqA_rewrite_r y x x'); auto. + Qed. + + Lemma multiplicity_InA : + forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a. + Proof. + induction l. + - simpl. + split; inversion 1. + - simpl. + intros a'; split; intros H. + + inversion_clear H. + * apply (decide_left (eqA_dec a a')); auto with *. + * destruct (eqA_dec a a'); auto with *. simpl; rewrite <- IHl; auto. + + destruct (eqA_dec a a'); auto with *. right. rewrite IHl; auto. + Qed. + + Lemma multiplicity_InA_O : + forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0. + Proof. + intros l a; rewrite multiplicity_InA; + destruct (multiplicity (list_contents l) a); auto with arith. + destruct 1; auto with arith. + Qed. + + Lemma multiplicity_InA_S : + forall l a, InA eqA a l -> multiplicity (list_contents l) a >= 1. + Proof. + intros l a; rewrite multiplicity_InA; auto with arith. + Qed. + + Lemma multiplicity_NoDupA : forall l, + NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1). + Proof. + induction l. + - simpl. + split; auto with arith. + - split; simpl. + + inversion_clear 1. + rewrite IHl in H1. + intros; destruct (eqA_dec a a0) as [EQ|NEQ]; simpl; auto with *. + rewrite <- EQ. + rewrite multiplicity_InA_O; auto. + + intros; constructor. + * rewrite multiplicity_InA. + specialize (H a). + rewrite if_eqA_refl in H. + clear IHl; lia. + * rewrite IHl; intros. + specialize (H a0). lia. + Qed. + + (** Permutation is compatible with InA. *) + Lemma permut_InA_InA : + forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2. + Proof. + intros l1 l2 e. + do 2 rewrite multiplicity_InA. + unfold permutation, meq. + intros H;rewrite H; auto. + Qed. + + Lemma permut_cons_InA : + forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2. + Proof. + intros; apply (permut_InA_InA (e:=e) H); auto with *. + Qed. + + (** Permutation of an empty list. *) + Lemma permut_nil : + forall l, permutation l [] -> l = []. + Proof. + intro l; destruct l as [ | e l ]; trivial. + assert (InA eqA e (e::l)) by (auto with * ). + intro Abs; generalize (permut_InA_InA Abs H). + inversion 1. + Qed. + + (** Permutation for short lists. *) + + Lemma permut_length_1: + forall a b, permutation [a] [b] -> eqA a b. + Proof. + intros a b; unfold permutation, meq. + intro P; specialize (P b); simpl in *. + rewrite if_eqA_refl in *. + destruct (eqA_dec a b); simpl; auto; discriminate. + Qed. + + Lemma permut_length_2 : + forall a1 b1 a2 b2, permutation [a1; b1] [a2; b2] -> + (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1). + Proof. + intros a1 b1 a2 b2 P. + assert (H:=permut_cons_InA P). + inversion_clear H. + - left; split; auto. + apply permut_length_1. + red; red; intros. + specialize (P a). simpl in *. + rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. lia. + - right. + inversion_clear H0; [|inversion H]. + split; auto. + apply permut_length_1. + red; red; intros. + specialize (P a); simpl in *. + rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. lia. + Qed. + + (** Permutation is compatible with length. *) + Lemma permut_length : + forall l1 l2, permutation l1 l2 -> length l1 = length l2. + Proof. + induction l1; intros l2 H. + - rewrite (permut_nil (permut_sym H)); auto. + - assert (H0:=permut_cons_InA H). + destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). + subst l2. + rewrite length_app. + simpl; rewrite <- plus_n_Sm; f_equal. + rewrite <- length_app. + apply IHl1. + apply permut_remove_hd with b. apply permut_trans with (a::l1); auto. revert H1; unfold permutation, meq; simpl. intros; f_equal; auto. - rewrite (@if_eqA_rewrite_l _ _ eqA_equiv eqA_dec a b a0); auto. -Qed. + rewrite (@if_eqA_rewrite_l a b a0); auto. + Qed. + + Lemma NoDupA_equivlistA_permut : + forall l l', NoDupA eqA l -> NoDupA eqA l' -> + equivlistA eqA l l' -> permutation l l'. + Proof. + intros. + red; unfold meq; intros. + rewrite multiplicity_NoDupA in H, H0. + generalize (H a) (H0 a) (H1 a); clear H H0 H1. + do 2 rewrite multiplicity_InA. + destruct 3; lia. + Qed. + +End Permut. + +Section Permut_map. + + Variables A B : Type. + + Variable eqA : relation A. + Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + Hypothesis eqA_equiv : Equivalence eqA. + + Variable eqB : B->B->Prop. + Hypothesis eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. + Hypothesis eqB_trans : Transitive eqB. + + (** Permutation is compatible with map. *) + + Lemma permut_map : + forall f, + (Proper (eqA==>eqB) f) -> + forall l1 l2, permutation _ eqA_dec l1 l2 -> + permutation _ eqB_dec (map f l1) (map f l2). + Proof. + intros f; induction l1. + - intros l2 P; rewrite (permut_nil eqA_equiv (permut_sym P)); apply permut_refl. + - intros l2 P. + simpl. + assert (H0:=permut_cons_InA eqA_equiv P). + destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). + subst l2. + rewrite map_app. + simpl. + apply permut_trans with (f b :: map f l1). + + revert H1; unfold permutation, meq; simpl. + intros; f_equal; auto. + destruct (eqB_dec (f b) a0) as [H2|H2]; + destruct (eqB_dec (f a) a0) as [H3|H3]; auto. + * destruct H3; transitivity (f b); auto with *. + * destruct H2; transitivity (f a); auto with *. + + apply permut_add_cons_inside. + rewrite <- map_app. + apply IHl1; auto. + apply permut_remove_hd with b; trivial. + apply permut_trans with (a::l1); auto. + revert H1; unfold permutation, meq; simpl. + intros; f_equal; auto. + rewrite (@if_eqA_rewrite_l _ _ eqA_equiv eqA_dec a b a0); auto. + Qed. End Permut_map. @@ -486,56 +486,56 @@ From Stdlib Require Import Permutation. Section Permut_permut. -Variable A : Type. - -Variable eqA : relation A. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. -Hypothesis eqA_equiv : Equivalence eqA. - -Lemma Permutation_impl_permutation : forall l l', - Permutation l l' -> permutation _ eqA_dec l l'. -Proof. - induction 1. - - apply permut_refl. - - apply permut_cons; auto using Equivalence_Reflexive. - - change (x :: y :: l) with ([x] ++ y :: l); - apply permut_add_cons_inside; simpl; - apply permut_cons_eq; - pose proof (Equivalence_Reflexive (R := eqA)); - auto using permut_refl. - - apply permut_trans with l'; trivial. -Qed. - -Lemma permut_eqA : forall l l', Forall2 eqA l l' -> permutation _ eqA_dec l l'. -Proof. - induction 1. - - apply permut_refl. - - apply permut_cons_eq; trivial. -Qed. - -Lemma permutation_Permutation : forall l l', - permutation _ eqA_dec l l' <-> - exists l'', Permutation l l'' /\ Forall2 eqA l'' l'. -Proof. - split; intro H. - - (* -> *) - induction l in l', H |- *. - + exists []; apply permut_sym, permut_nil in H as ->; auto using Forall2. - + pose proof H as H'. - apply permut_cons_InA, InA_split in H - as (l1 & y & l2 & Heq & ->); trivial. - apply permut_remove_hd_eq, IHl in H' - as (l'' & IHP & IHA); clear IHl; trivial. - apply Forall2_app_inv_r in IHA as (l1'' & l2'' & Hl1 & Hl2 & ->). - exists (l1'' ++ a :: l2''); split. - * apply Permutation_cons_app; trivial. - * apply Forall2_app, Forall2_cons; trivial. - - (* <- *) - destruct H as (l'' & H & Heq). - apply permut_trans with l''. - + apply Permutation_impl_permutation; trivial. - + apply permut_eqA; trivial. -Qed. + Variable A : Type. + + Variable eqA : relation A. + Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + Hypothesis eqA_equiv : Equivalence eqA. + + Lemma Permutation_impl_permutation : forall l l', + Permutation l l' -> permutation _ eqA_dec l l'. + Proof. + induction 1. + - apply permut_refl. + - apply permut_cons; auto using Equivalence_Reflexive. + - change (x :: y :: l) with ([x] ++ y :: l); + apply permut_add_cons_inside; simpl; + apply permut_cons_eq; + pose proof (Equivalence_Reflexive (R := eqA)); + auto using permut_refl. + - apply permut_trans with l'; trivial. + Qed. + + Lemma permut_eqA : forall l l', Forall2 eqA l l' -> permutation _ eqA_dec l l'. + Proof. + induction 1. + - apply permut_refl. + - apply permut_cons_eq; trivial. + Qed. + + Lemma permutation_Permutation : forall l l', + permutation _ eqA_dec l l' <-> + exists l'', Permutation l l'' /\ Forall2 eqA l'' l'. + Proof. + split; intro H. + - (* -> *) + induction l in l', H |- *. + + exists []; apply permut_sym, permut_nil in H as ->; auto using Forall2. + + pose proof H as H'. + apply permut_cons_InA, InA_split in H + as (l1 & y & l2 & Heq & ->); trivial. + apply permut_remove_hd_eq, IHl in H' + as (l'' & IHP & IHA); clear IHl; trivial. + apply Forall2_app_inv_r in IHA as (l1'' & l2'' & Hl1 & Hl2 & ->). + exists (l1'' ++ a :: l2''); split. + * apply Permutation_cons_app; trivial. + * apply Forall2_app, Forall2_cons; trivial. + - (* <- *) + destruct H as (l'' & H & Heq). + apply permut_trans with l''. + + apply Permutation_impl_permutation; trivial. + + apply permut_eqA; trivial. + Qed. End Permut_permut. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 5d560c2c52..1e0ef218c1 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -22,57 +22,57 @@ Set Implicit Arguments. Section Permutation. -Variable A:Type. - -Inductive Permutation : list A -> list A -> Prop := -| perm_nil: Permutation [] [] -| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l') -| perm_swap x y l : Permutation (y::x::l) (x::y::l) -| perm_trans l l' l'' : - Permutation l l' -> Permutation l' l'' -> Permutation l l''. - -#[local] Hint Constructors Permutation : core. - -(** Some facts about [Permutation] *) - -Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = []. -Proof. - intros l HF. - remember (@nil A) as m in HF. - induction HF; discriminate || auto. -Qed. - -Theorem Permutation_nil_cons : forall (l : list A) (x : A), - ~ Permutation nil (x::l). -Proof. - intros l x HF. - apply Permutation_nil in HF; discriminate. -Qed. - -(** Permutation over lists is a equivalence relation *) - -Theorem Permutation_refl : forall l : list A, Permutation l l. -Proof. - induction l; constructor. exact IHl. -Qed. - -Instance Permutation_refl' : Proper (Logic.eq ==> Permutation) id. -Proof. - intros x y Heq; rewrite Heq; apply Permutation_refl. -Qed. - -Theorem Permutation_sym : forall l l' : list A, - Permutation l l' -> Permutation l' l. -Proof. - intros l l' Hperm; induction Hperm; auto. - apply perm_trans with (l':=l'); assumption. -Qed. - -Theorem Permutation_trans : forall l l' l'' : list A, - Permutation l l' -> Permutation l' l'' -> Permutation l l''. -Proof. - exact perm_trans. -Qed. + Variable A:Type. + + Inductive Permutation : list A -> list A -> Prop := + | perm_nil: Permutation [] [] + | perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l') + | perm_swap x y l : Permutation (y::x::l) (x::y::l) + | perm_trans l l' l'' : + Permutation l l' -> Permutation l' l'' -> Permutation l l''. + + #[local] Hint Constructors Permutation : core. + + (** Some facts about [Permutation] *) + + Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = []. + Proof. + intros l HF. + remember (@nil A) as m in HF. + induction HF; discriminate || auto. + Qed. + + Theorem Permutation_nil_cons : forall (l : list A) (x : A), + ~ Permutation nil (x::l). + Proof. + intros l x HF. + apply Permutation_nil in HF; discriminate. + Qed. + + (** Permutation over lists is a equivalence relation *) + + Theorem Permutation_refl : forall l : list A, Permutation l l. + Proof. + induction l; constructor. exact IHl. + Qed. + + Instance Permutation_refl' : Proper (Logic.eq ==> Permutation) id. + Proof. + intros x y Heq; rewrite Heq; apply Permutation_refl. + Qed. + + Theorem Permutation_sym : forall l l' : list A, + Permutation l l' -> Permutation l' l. + Proof. + intros l l' Hperm; induction Hperm; auto. + apply perm_trans with (l':=l'); assumption. + Qed. + + Theorem Permutation_trans : forall l l' l'' : list A, + Permutation l l' -> Permutation l' l'' -> Permutation l l''. + Proof. + exact perm_trans. + Qed. End Permutation. @@ -116,581 +116,581 @@ Qed. Section Permutation_properties. -Variable A B:Type. - -Implicit Types a : A. -Implicit Types l m : list A. - -(** Compatibility with others operations on lists *) - -Theorem Permutation_in : forall (l l' : list A) (x : A), - Permutation l l' -> In x l -> In x l'. -Proof. - intros l l' x Hperm; induction Hperm; simpl; tauto. -Qed. - -#[global] Instance Permutation_in' : - Proper (Logic.eq ==> @Permutation A ==> iff) (@In A). -Proof. - repeat red; intros; subst; eauto using Permutation_in. -Qed. - -Lemma Permutation_app_tail : forall (l l' tl : list A), - Permutation l l' -> Permutation (l++tl) (l'++tl). -Proof. - intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto. - eapply Permutation_trans with (l':=l'++tl); trivial. -Qed. - -Lemma Permutation_app_head : forall (l tl tl' : list A), - Permutation tl tl' -> Permutation (l++tl) (l++tl'). -Proof. - intros l tl tl' Hperm; induction l; - [trivial | repeat rewrite <- app_comm_cons; constructor; assumption]. -Qed. - -Theorem Permutation_app : forall (l m l' m' : list A), - Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m'). -Proof. - intros l m l' m' Hpermll' Hpermmm'; - induction Hpermll' as [|x l l'|x y l|l l' l'']; - repeat rewrite <- app_comm_cons; auto. - - apply Permutation_trans with (l' := (x :: y :: l ++ m)); - [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial. - - apply Permutation_trans with (l' := (l' ++ m')); try assumption. - apply Permutation_app_tail; assumption. -Qed. - -#[export] Instance Permutation_app' : - Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A). -Proof. - repeat intro; now apply Permutation_app. -Qed. - -Lemma Permutation_add_inside : forall a (l l' tl tl' : list A), - Permutation l l' -> Permutation tl tl' -> - Permutation (l ++ a :: tl) (l' ++ a :: tl'). -Proof. - intros; apply Permutation_app; auto. -Qed. - -Lemma Permutation_cons_append : forall (l : list A) x, - Permutation (x :: l) (l ++ x :: nil). -Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed. -#[local] Hint Resolve Permutation_cons_append : core. - -Theorem Permutation_app_comm : forall (l l' : list A), - Permutation (l ++ l') (l' ++ l). -Proof. - induction l as [|x l]; simpl; intro l'. - - rewrite app_nil_r; trivial. - - rewrite IHl. + Variable A B:Type. + + Implicit Types a : A. + Implicit Types l m : list A. + + (** Compatibility with others operations on lists *) + + Theorem Permutation_in : forall (l l' : list A) (x : A), + Permutation l l' -> In x l -> In x l'. + Proof. + intros l l' x Hperm; induction Hperm; simpl; tauto. + Qed. + + #[global] Instance Permutation_in' : + Proper (Logic.eq ==> @Permutation A ==> iff) (@In A). + Proof. + repeat red; intros; subst; eauto using Permutation_in. + Qed. + + Lemma Permutation_app_tail : forall (l l' tl : list A), + Permutation l l' -> Permutation (l++tl) (l'++tl). + Proof. + intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto. + eapply Permutation_trans with (l':=l'++tl); trivial. + Qed. + + Lemma Permutation_app_head : forall (l tl tl' : list A), + Permutation tl tl' -> Permutation (l++tl) (l++tl'). + Proof. + intros l tl tl' Hperm; induction l; + [trivial | repeat rewrite <- app_comm_cons; constructor; assumption]. + Qed. + + Theorem Permutation_app : forall (l m l' m' : list A), + Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m'). + Proof. + intros l m l' m' Hpermll' Hpermmm'; + induction Hpermll' as [|x l l'|x y l|l l' l'']; + repeat rewrite <- app_comm_cons; auto. + - apply Permutation_trans with (l' := (x :: y :: l ++ m)); + [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial. + - apply Permutation_trans with (l' := (l' ++ m')); try assumption. + apply Permutation_app_tail; assumption. + Qed. + + #[export] Instance Permutation_app' : + Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A). + Proof. + repeat intro; now apply Permutation_app. + Qed. + + Lemma Permutation_add_inside : forall a (l l' tl tl' : list A), + Permutation l l' -> Permutation tl tl' -> + Permutation (l ++ a :: tl) (l' ++ a :: tl'). + Proof. + intros; apply Permutation_app; auto. + Qed. + + Lemma Permutation_cons_append : forall (l : list A) x, + Permutation (x :: l) (l ++ x :: nil). + Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed. + #[local] Hint Resolve Permutation_cons_append : core. + + Theorem Permutation_app_comm : forall (l l' : list A), + Permutation (l ++ l') (l' ++ l). + Proof. + induction l as [|x l]; simpl; intro l'. + - rewrite app_nil_r; trivial. + - rewrite IHl. + rewrite app_comm_cons, Permutation_cons_append. + now rewrite <- app_assoc. + Qed. + #[local] Hint Resolve Permutation_app_comm : core. + + Lemma Permutation_app_rot : forall l1 l2 l3: list A, + Permutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). + Proof. + intros l1 l2 l3; now rewrite (app_assoc l2). + Qed. + #[local] Hint Resolve Permutation_app_rot : core. + + Lemma Permutation_app_swap_app : forall l1 l2 l3: list A, + Permutation (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3). + Proof. + intros. + rewrite 2 app_assoc. + apply Permutation_app_tail, Permutation_app_comm. + Qed. + #[local] Hint Resolve Permutation_app_swap_app : core. + + Lemma Permutation_app_middle : forall l l1 l2 l3 l4, + Permutation (l1 ++ l2) (l3 ++ l4) -> + Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4). + Proof. + intros l l1 l2 l3 l4 HP. + now rewrite Permutation_app_swap_app, HP, Permutation_app_swap_app. + Qed. + + Theorem Permutation_cons_app : forall (l l1 l2:list A) a, + Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). + Proof. + intros l l1 l2 a H. rewrite H. rewrite app_comm_cons, Permutation_cons_append. now rewrite <- app_assoc. -Qed. -#[local] Hint Resolve Permutation_app_comm : core. - -Lemma Permutation_app_rot : forall l1 l2 l3: list A, - Permutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). -Proof. - intros l1 l2 l3; now rewrite (app_assoc l2). -Qed. -#[local] Hint Resolve Permutation_app_rot : core. - -Lemma Permutation_app_swap_app : forall l1 l2 l3: list A, - Permutation (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3). -Proof. - intros. - rewrite 2 app_assoc. - apply Permutation_app_tail, Permutation_app_comm. -Qed. -#[local] Hint Resolve Permutation_app_swap_app : core. - -Lemma Permutation_app_middle : forall l l1 l2 l3 l4, - Permutation (l1 ++ l2) (l3 ++ l4) -> - Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4). -Proof. - intros l l1 l2 l3 l4 HP. - now rewrite Permutation_app_swap_app, HP, Permutation_app_swap_app. -Qed. - -Theorem Permutation_cons_app : forall (l l1 l2:list A) a, - Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). -Proof. - intros l l1 l2 a H. rewrite H. - rewrite app_comm_cons, Permutation_cons_append. - now rewrite <- app_assoc. -Qed. -#[local] Hint Resolve Permutation_cons_app : core. - -Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'. -Proof. - induction 1; simpl; trivial. - rewrite perm_swap. now apply perm_skip. -Qed. - -Theorem Permutation_middle : forall (l1 l2:list A) a, - Permutation (a :: l1 ++ l2) (l1 ++ a :: l2). -Proof. - auto. -Qed. -#[local] Hint Resolve Permutation_middle : core. - -Lemma Permutation_middle2 : forall l1 l2 l3 a b, - Permutation (a :: b :: l1 ++ l2 ++ l3) (l1 ++ a :: l2 ++ b :: l3). -Proof. - intros l1 l2 l3 a b. - apply Permutation_cons_app. - rewrite 2 app_assoc. - now apply Permutation_cons_app. -Qed. -#[local] Hint Resolve Permutation_middle2 : core. - -Lemma Permutation_elt : forall l1 l2 l1' l2' (a:A), - Permutation (l1 ++ l2) (l1' ++ l2') -> - Permutation (l1 ++ a :: l2) (l1' ++ a :: l2'). -Proof. - intros l1 l2 l1' l2' a HP. - transitivity (a :: l1 ++ l2); auto. -Qed. - -Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). -Proof. - induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. -Qed. - -#[global] Instance Permutation_rev' : - Proper (@Permutation A ==> @Permutation A) (@rev A). -Proof. - repeat intro; now rewrite <- 2 Permutation_rev. -Qed. - -Theorem Permutation_length : forall (l l' : list A), - Permutation l l' -> length l = length l'. -Proof. - intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l'). -Qed. - -#[global] Instance Permutation_length' : - Proper (@Permutation A ==> Logic.eq) (@length A) | 10. -Proof. - exact Permutation_length. -Qed. - -#[global] Instance Permutation_Forall (P : A -> Prop) : - Proper ((@Permutation A) ==> Basics.impl) (Forall P). -Proof. - intros l1 l2 HP. - induction HP; intro HF; auto. - - inversion_clear HF; auto. - - inversion_clear HF as [ | ? ? HF1 HF2]. - inversion_clear HF2; auto. -Qed. - -#[global] Instance Permutation_Exists (P : A -> Prop) : - Proper ((@Permutation A) ==> Basics.impl) (Exists P). -Proof. - intros l1 l2 HP. - induction HP; intro HF; auto. - - inversion_clear HF; auto. - - inversion_clear HF as [ | ? ? HF1 ]; auto. - inversion_clear HF1; auto. -Qed. - -Lemma Permutation_Forall2 (P : A -> B -> Prop) : - forall l1 l1' (l2 : list B), Permutation l1 l1' -> Forall2 P l1 l2 -> - exists l2' : list B, Permutation l2 l2' /\ Forall2 P l1' l2'. -Proof. - intros l1 l1' l2 HP. - revert l2; induction HP; intros l2 HF; inversion HF as [ | ? b ? ? HF1 HF2 ]; subst. - - now exists nil. - - apply IHHP in HF2 as [l2' [HP2 HF2]]. - exists (b :: l2'); auto. - - inversion_clear HF2 as [ | ? b' ? l2' HF3 HF4 ]. - exists (b' :: b :: l2'); auto. - - apply Permutation_nil in HP1; subst. - apply Permutation_nil in HP2; subst. - now exists nil. - - apply IHHP1 in HF as [l2' [HP2' HF2']]. - apply IHHP2 in HF2' as [l2'' [HP2'' HF2'']]. - exists l2''; split; auto. - now transitivity l2'. -Qed. - -Theorem Permutation_ind_bis : - forall P : list A -> list A -> Prop, - P [] [] -> - (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) -> - (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) -> - (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> - forall l l', Permutation l l' -> P l l'. -Proof. - intros P Hnil Hskip Hswap Htrans. - induction 1; auto. - - apply Htrans with (x::y::l); auto. - + apply Hswap; auto. - induction l; auto. - + apply Hskip; auto. - apply Hskip; auto. - induction l; auto. - - eauto. -Qed. - -Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), - ~ Permutation nil (l++x::l'). -Proof. - intros l l' x HF. - apply Permutation_nil in HF. destruct l; discriminate. -Qed. - -Ltac InvAdd := repeat (match goal with - | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst - end). - -Ltac finish_basic_perms H := - try constructor; try rewrite perm_swap; try constructor; trivial; - (rewrite <- H; now apply Permutation_Add) || - (rewrite H; symmetry; now apply Permutation_Add). - -Theorem Permutation_Add_inv a l1 l2 : - Permutation l1 l2 -> forall l1' l2', Add a l1' l1 -> Add a l2' l2 -> - Permutation l1' l2'. -Proof. - revert l1 l2. refine (Permutation_ind_bis _ _ _ _ _). - - (* nil *) - inversion_clear 1. - - (* skip *) - intros x l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE. - constructor. now apply IH. - - (* swap *) - intros x y l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE. - rewrite perm_swap; do 2 constructor. now apply IH. - - (* trans *) - intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2. - assert (Ha : In a l). { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. } - destruct (Add_inv _ _ Ha) as (l',AD). - transitivity l'; auto. -Qed. - -Theorem Permutation_app_inv (l1 l2 l3 l4:list A) a : - Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4). -Proof. - intros. eapply Permutation_Add_inv; eauto using Add_app. -Qed. - -Theorem Permutation_cons_inv l l' a : - Permutation (a::l) (a::l') -> Permutation l l'. -Proof. - intro. eapply Permutation_Add_inv; eauto using Add_head. -Qed. - -Theorem Permutation_cons_app_inv l l1 l2 a : - Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). -Proof. - intro. eapply Permutation_Add_inv; eauto using Add_head, Add_app. -Qed. - -Theorem Permutation_app_inv_l : forall l l1 l2, - Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. -Proof. - induction l; simpl; auto. - intros. - apply IHl. - apply Permutation_cons_inv with a; auto. -Qed. - -Theorem Permutation_app_inv_r l l1 l2 : - Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. -Proof. - rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l. -Qed. - -Lemma Permutation_app_inv_m l l1 l2 l3 l4 : - Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4) -> - Permutation (l1 ++ l2) (l3 ++ l4). -Proof. - intros HP. - apply (Permutation_app_inv_l l). - transitivity (l1 ++ l ++ l2); auto. - transitivity (l3 ++ l ++ l4); auto. -Qed. - -Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a]. -Proof. - intros a l H; remember [a] as m in H. - induction H; try (injection Heqm as [= -> ->]); - discriminate || auto. - apply Permutation_nil in H as ->; trivial. -Qed. - -Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b. -Proof. - intros a b H. - apply Permutation_length_1_inv in H; injection H as [= ->]; trivial. -Qed. - -Lemma Permutation_length_2_inv : - forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1]. -Proof. - intros a1 a2 l H; remember [a1;a2] as m in H. - revert a1 a2 Heqm. - induction H; intros; try (injection Heqm as [= ? ?]; subst); - discriminate || (try tauto). - - apply Permutation_length_1_inv in H as ->; left; auto. - - apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as []; - auto. -Qed. - -Lemma Permutation_length_2 : - forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] -> - a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. -Proof. - intros a1 b1 a2 b2 H. - apply Permutation_length_2_inv in H as [H|H]; injection H as [= -> ->]; auto. -Qed. - -Lemma Permutation_vs_elt_inv : forall l l1 l2 a, - Permutation l (l1 ++ a :: l2) -> exists l' l'', l = l' ++ a :: l''. -Proof. - intros l l1 l2 a HP. - symmetry in HP. - apply (Permutation_in a), in_split in HP; trivial. - apply in_elt. -Qed. - -Lemma Permutation_vs_cons_inv : forall l l1 a, - Permutation l (a :: l1) -> exists l' l'', l = l' ++ a :: l''. -Proof. - intros l l1 a HP. - rewrite <- (app_nil_l (a :: l1)) in HP. - apply (Permutation_vs_elt_inv _ _ _ HP). -Qed. - -Lemma Permutation_vs_cons_cons_inv : forall l l' a b, - Permutation l (a :: b :: l') -> - exists l1 l2 l3, l = l1 ++ a :: l2 ++ b :: l3 \/ l = l1 ++ b :: l2 ++ a :: l3. -Proof. - intros l l' a b HP. - destruct (Permutation_vs_cons_inv HP) as [l1 [l2]]; subst. - symmetry in HP. - apply Permutation_cons_app_inv in HP. - apply (Permutation_in b), in_app_or in HP; [|now apply in_eq]. - destruct HP as [(l3 & l4 & ->)%in_split | (l3 & l4 & ->)%in_split]. - - exists l3, l4, l2; right. - now rewrite <-app_assoc; simpl. - - now exists l1, l3, l4; left. -Qed. - -Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' -> - (forall x:A, In x l <-> In x l') -> Permutation l l'. -Proof. - intros N. revert l'. induction N as [|a l Hal Hl IH]. - - destruct l'; simpl; auto. - intros Hl' H. exfalso. rewrite (H a); auto. - - intros l' Hl' H. - assert (Ha : In a l') by (apply H; simpl; auto). - destruct (Add_inv _ _ Ha) as (l'' & AD). - rewrite <- (Permutation_Add AD). - apply perm_skip. - apply IH; clear IH. - * now apply (NoDup_Add AD). - * split. - + apply incl_Add_inv with a l'; trivial. intro. apply H. - + intro Hx. - assert (Hx' : In x (a::l)). - { apply H. rewrite (Add_in AD). now right. } - destruct Hx'; simpl; trivial. subst. - rewrite (NoDup_Add AD) in Hl'. tauto. -Qed. - -Lemma NoDup_Permutation_bis l l' : NoDup l -> - length l' <= length l -> incl l l' -> Permutation l l'. -Proof. - intros. apply NoDup_Permutation; auto. - - now apply NoDup_incl_NoDup with l. - - split; auto. - apply NoDup_length_incl; trivial. -Qed. - -Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'. -Proof. - induction 1; auto. - - inversion_clear 1; constructor; eauto using Permutation_in. - - inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *. - constructor. - + simpl; intuition. - + constructor; intuition. -Qed. - -#[global] Instance Permutation_NoDup' : - Proper (@Permutation A ==> iff) (@NoDup A). -Proof. - repeat red; eauto using Permutation_NoDup. -Qed. - -Lemma Permutation_repeat x n l : - Permutation l (repeat x n) -> l = repeat x n. -Proof. - revert n; induction l as [|y l IHl] ; simpl; intros n HP; auto. - - now apply Permutation_nil in HP; inversion HP. - - assert (y = x) as Heq by (now apply repeat_spec with n, (Permutation_in _ HP); left); subst. - destruct n; simpl; simpl in HP. - + symmetry in HP; apply Permutation_nil in HP; inversion HP. - + f_equal; apply IHl. - now apply Permutation_cons_inv with x. -Qed. - -Lemma Permutation_incl_cons_inv_r (l1 l2 : list A) a : incl l1 (a :: l2) -> - exists n l3, Permutation l1 (repeat a n ++ l3) /\ incl l3 l2. -Proof. - induction l1 as [|b l1 IH]. - - intros _. now exists 0, nil. - - intros [Hb Hincl] %incl_cons_inv. - destruct (IH Hincl) as [n [l3 [Hl1 Hl3l2]]]. - destruct Hb. - + subst b. exists (S n), l3. eauto. - + exists n, (b :: l3). eauto using incl_cons. -Qed. - -Lemma Permutation_pigeonhole l1 l2 : incl l1 l2 -> length l2 < length l1 -> - exists a l3, Permutation l1 (a :: a :: l3). -Proof. - induction l2 as [|a l2 IH] in l1 |- *. - - intros -> %incl_l_nil [] %PeanoNat.Nat.nlt_0_r. - - intros [[|[|n]] [l4 [Hl1 Hl4]]] %Permutation_incl_cons_inv_r Hlen. - + apply IH. - * unfold incl. eauto using Permutation_in. - * eauto using PeanoNat.Nat.lt_trans. - + assert (Hl2l4 : length l2 < length l4). - { rewrite (Permutation_length Hl1) in Hlen. - now apply PeanoNat.Nat.succ_lt_mono. } - destruct (IH l4 Hl4 Hl2l4) as [b [l3 Hl4l3]]. - exists b, (a :: l3). - apply (Permutation_trans Hl1). - now apply (Permutation_cons_app (b :: b :: nil)). - + now exists a, (repeat a n ++ l4). -Qed. - -Lemma Permutation_pigeonhole_rel (R : B -> A -> Prop) (l1 : list B) l2 : - Forall (fun b => Exists (R b) l2) l1 -> - length l2 < length l1 -> - exists b b' (l3 : list B), Permutation l1 (b :: b' :: l3) /\ exists a, In a l2 /\ R b a /\ R b' a. -Proof. - intros [l2' [Hl2'l1 Hl2'l2]]%Forall_Exists_exists_Forall2. - intros Hl2l2'. rewrite (Forall2_length Hl2'l1) in Hl2l2'. - destruct (Permutation_pigeonhole Hl2'l2 Hl2l2') as [a [l3 Hl2']]. - destruct (Permutation_Forall2 Hl2' (Forall2_flip Hl2'l1)) as [l1' [Hl1l1' Hl1']]. - destruct (Forall2_app_inv_l [a; a] l3 Hl1') as [lbb' [l1'' [Ha [? ?]]]]. - assert (Hlbb' := Forall2_length Ha). - destruct lbb' as [|b lb']; [easy|]. - apply Forall2_cons_iff in Ha as [Hba Ha]. - destruct lb' as [|b' l]; [easy|]. - apply Forall2_cons_iff in Ha as [Hb'a Ha]. - inversion Ha. subst. exists b, b', l1''. - split; [easy|]. exists a. - split; eauto using Permutation_in, in_eq. -Qed. - -Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - -Lemma Permutation_count_occ l1 l2 : - Permutation l1 l2 <-> forall x, count_occ eq_dec l1 x = count_occ eq_dec l2 x. -Proof. - split. - - induction 1 as [ | y l1 l2 HP IHP | y z l | l1 l2 l3 HP1 IHP1 HP2 IHP2 ]; - cbn; intros a; auto. - + now rewrite IHP. - + destruct (eq_dec y a); destruct (eq_dec z a); auto. - + now rewrite IHP1, IHP2. - - revert l2; induction l1 as [|y l1 IHl1]; cbn; intros l2 Hocc. - + replace l2 with (@nil A); auto. - symmetry; apply (count_occ_inv_nil eq_dec); intuition. - + assert (exists l2' l2'', l2 = l2' ++ y :: l2'') as [l2' [l2'' ->]]. - { specialize (Hocc y). - destruct (eq_dec y y); intuition. - apply in_split, (count_occ_In eq_dec). - rewrite <- Hocc; apply Nat.lt_0_succ. } - apply Permutation_cons_app, IHl1. - intros z; specialize (Hocc z); destruct (eq_dec y z) as [Heq | Hneq]. - * rewrite (count_occ_elt_eq _ _ _ Heq) in Hocc. - now injection Hocc. - * now rewrite (count_occ_elt_neq _ _ _ Hneq) in Hocc. -Qed. - -End Permutation_properties. - -Section Permutation_map. - -Variable A B : Type. -Variable f : A -> B. - -Lemma Permutation_map l l' : - Permutation l l' -> Permutation (map f l) (map f l'). -Proof. - induction 1; simpl; eauto. -Qed. - -#[global] Instance Permutation_map' : - Proper (@Permutation A ==> @Permutation B) (map f). -Proof. - exact Permutation_map. -Qed. - -Lemma Permutation_map_inv : forall l1 l2, - Permutation l1 (map f l2) -> exists l3, l1 = map f l3 /\ Permutation l2 l3. -Proof. - induction l1; intros l2 HP. - - exists nil; split; auto. - apply Permutation_nil in HP. - destruct l2; auto. - inversion HP. - - symmetry in HP. - destruct (Permutation_vs_cons_inv HP) as [l3 [l4 Heq]]. - destruct (map_eq_app _ _ _ _ Heq) as [l1' [l2' [Heq1 [Heq2 Heq3]]]]; subst. - destruct (map_eq_cons _ _ Heq3) as [b [l1'' [Heq1' [Heq2' Heq3']]]]; subst. - rewrite map_app in HP; simpl in HP. + Qed. + #[local] Hint Resolve Permutation_cons_app : core. + + Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'. + Proof. + induction 1; simpl; trivial. + rewrite perm_swap. now apply perm_skip. + Qed. + + Theorem Permutation_middle : forall (l1 l2:list A) a, + Permutation (a :: l1 ++ l2) (l1 ++ a :: l2). + Proof. + auto. + Qed. + #[local] Hint Resolve Permutation_middle : core. + + Lemma Permutation_middle2 : forall l1 l2 l3 a b, + Permutation (a :: b :: l1 ++ l2 ++ l3) (l1 ++ a :: l2 ++ b :: l3). + Proof. + intros l1 l2 l3 a b. + apply Permutation_cons_app. + rewrite 2 app_assoc. + now apply Permutation_cons_app. + Qed. + #[local] Hint Resolve Permutation_middle2 : core. + + Lemma Permutation_elt : forall l1 l2 l1' l2' (a:A), + Permutation (l1 ++ l2) (l1' ++ l2') -> + Permutation (l1 ++ a :: l2) (l1' ++ a :: l2'). + Proof. + intros l1 l2 l1' l2' a HP. + transitivity (a :: l1 ++ l2); auto. + Qed. + + Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). + Proof. + induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. + Qed. + + #[global] Instance Permutation_rev' : + Proper (@Permutation A ==> @Permutation A) (@rev A). + Proof. + repeat intro; now rewrite <- 2 Permutation_rev. + Qed. + + Theorem Permutation_length : forall (l l' : list A), + Permutation l l' -> length l = length l'. + Proof. + intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l'). + Qed. + + #[global] Instance Permutation_length' : + Proper (@Permutation A ==> Logic.eq) (@length A) | 10. + Proof. + exact Permutation_length. + Qed. + + #[global] Instance Permutation_Forall (P : A -> Prop) : + Proper ((@Permutation A) ==> Basics.impl) (Forall P). + Proof. + intros l1 l2 HP. + induction HP; intro HF; auto. + - inversion_clear HF; auto. + - inversion_clear HF as [ | ? ? HF1 HF2]. + inversion_clear HF2; auto. + Qed. + + #[global] Instance Permutation_Exists (P : A -> Prop) : + Proper ((@Permutation A) ==> Basics.impl) (Exists P). + Proof. + intros l1 l2 HP. + induction HP; intro HF; auto. + - inversion_clear HF; auto. + - inversion_clear HF as [ | ? ? HF1 ]; auto. + inversion_clear HF1; auto. + Qed. + + Lemma Permutation_Forall2 (P : A -> B -> Prop) : + forall l1 l1' (l2 : list B), Permutation l1 l1' -> Forall2 P l1 l2 -> + exists l2' : list B, Permutation l2 l2' /\ Forall2 P l1' l2'. + Proof. + intros l1 l1' l2 HP. + revert l2; induction HP; intros l2 HF; inversion HF as [ | ? b ? ? HF1 HF2 ]; subst. + - now exists nil. + - apply IHHP in HF2 as [l2' [HP2 HF2]]. + exists (b :: l2'); auto. + - inversion_clear HF2 as [ | ? b' ? l2' HF3 HF4 ]. + exists (b' :: b :: l2'); auto. + - apply Permutation_nil in HP1; subst. + apply Permutation_nil in HP2; subst. + now exists nil. + - apply IHHP1 in HF as [l2' [HP2' HF2']]. + apply IHHP2 in HF2' as [l2'' [HP2'' HF2'']]. + exists l2''; split; auto. + now transitivity l2'. + Qed. + + Theorem Permutation_ind_bis : + forall P : list A -> list A -> Prop, + P [] [] -> + (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) -> + (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) -> + (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> + forall l l', Permutation l l' -> P l l'. + Proof. + intros P Hnil Hskip Hswap Htrans. + induction 1; auto. + - apply Htrans with (x::y::l); auto. + + apply Hswap; auto. + induction l; auto. + + apply Hskip; auto. + apply Hskip; auto. + induction l; auto. + - eauto. + Qed. + + Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), + ~ Permutation nil (l++x::l'). + Proof. + intros l l' x HF. + apply Permutation_nil in HF. destruct l; discriminate. + Qed. + + Ltac InvAdd := repeat (match goal with + | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst + end). + + Ltac finish_basic_perms H := + try constructor; try rewrite perm_swap; try constructor; trivial; + (rewrite <- H; now apply Permutation_Add) || + (rewrite H; symmetry; now apply Permutation_Add). + + Theorem Permutation_Add_inv a l1 l2 : + Permutation l1 l2 -> forall l1' l2', Add a l1' l1 -> Add a l2' l2 -> + Permutation l1' l2'. + Proof. + revert l1 l2. refine (Permutation_ind_bis _ _ _ _ _). + - (* nil *) + inversion_clear 1. + - (* skip *) + intros x l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE. + constructor. now apply IH. + - (* swap *) + intros x y l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE. + rewrite perm_swap; do 2 constructor. now apply IH. + - (* trans *) + intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2. + assert (Ha : In a l). { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. } + destruct (Add_inv _ _ Ha) as (l',AD). + transitivity l'; auto. + Qed. + + Theorem Permutation_app_inv (l1 l2 l3 l4:list A) a : + Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4). + Proof. + intros. eapply Permutation_Add_inv; eauto using Add_app. + Qed. + + Theorem Permutation_cons_inv l l' a : + Permutation (a::l) (a::l') -> Permutation l l'. + Proof. + intro. eapply Permutation_Add_inv; eauto using Add_head. + Qed. + + Theorem Permutation_cons_app_inv l l1 l2 a : + Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). + Proof. + intro. eapply Permutation_Add_inv; eauto using Add_head, Add_app. + Qed. + + Theorem Permutation_app_inv_l : forall l l1 l2, + Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. + Proof. + induction l; simpl; auto. + intros. + apply IHl. + apply Permutation_cons_inv with a; auto. + Qed. + + Theorem Permutation_app_inv_r l l1 l2 : + Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. + Proof. + rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l. + Qed. + + Lemma Permutation_app_inv_m l l1 l2 l3 l4 : + Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4) -> + Permutation (l1 ++ l2) (l3 ++ l4). + Proof. + intros HP. + apply (Permutation_app_inv_l l). + transitivity (l1 ++ l ++ l2); auto. + transitivity (l3 ++ l ++ l4); auto. + Qed. + + Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a]. + Proof. + intros a l H; remember [a] as m in H. + induction H; try (injection Heqm as [= -> ->]); + discriminate || auto. + apply Permutation_nil in H as ->; trivial. + Qed. + + Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b. + Proof. + intros a b H. + apply Permutation_length_1_inv in H; injection H as [= ->]; trivial. + Qed. + + Lemma Permutation_length_2_inv : + forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1]. + Proof. + intros a1 a2 l H; remember [a1;a2] as m in H. + revert a1 a2 Heqm. + induction H; intros; try (injection Heqm as [= ? ?]; subst); + discriminate || (try tauto). + - apply Permutation_length_1_inv in H as ->; left; auto. + - apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as []; + auto. + Qed. + + Lemma Permutation_length_2 : + forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] -> + a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. + Proof. + intros a1 b1 a2 b2 H. + apply Permutation_length_2_inv in H as [H|H]; injection H as [= -> ->]; auto. + Qed. + + Lemma Permutation_vs_elt_inv : forall l l1 l2 a, + Permutation l (l1 ++ a :: l2) -> exists l' l'', l = l' ++ a :: l''. + Proof. + intros l l1 l2 a HP. + symmetry in HP. + apply (Permutation_in a), in_split in HP; trivial. + apply in_elt. + Qed. + + Lemma Permutation_vs_cons_inv : forall l l1 a, + Permutation l (a :: l1) -> exists l' l'', l = l' ++ a :: l''. + Proof. + intros l l1 a HP. + rewrite <- (app_nil_l (a :: l1)) in HP. + apply (Permutation_vs_elt_inv _ _ _ HP). + Qed. + + Lemma Permutation_vs_cons_cons_inv : forall l l' a b, + Permutation l (a :: b :: l') -> + exists l1 l2 l3, l = l1 ++ a :: l2 ++ b :: l3 \/ l = l1 ++ b :: l2 ++ a :: l3. + Proof. + intros l l' a b HP. + destruct (Permutation_vs_cons_inv HP) as [l1 [l2]]; subst. symmetry in HP. apply Permutation_cons_app_inv in HP. - rewrite <- map_app in HP. - destruct (IHl1 _ HP) as [l3 [Heq1'' Heq2'']]; subst. - exists (b :: l3); split; auto. - symmetry in Heq2''; symmetry; apply (Permutation_cons_app _ _ _ Heq2''). -Qed. + apply (Permutation_in b), in_app_or in HP; [|now apply in_eq]. + destruct HP as [(l3 & l4 & ->)%in_split | (l3 & l4 & ->)%in_split]. + - exists l3, l4, l2; right. + now rewrite <-app_assoc; simpl. + - now exists l1, l3, l4; left. + Qed. + + Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' -> + (forall x:A, In x l <-> In x l') -> Permutation l l'. + Proof. + intros N. revert l'. induction N as [|a l Hal Hl IH]. + - destruct l'; simpl; auto. + intros Hl' H. exfalso. rewrite (H a); auto. + - intros l' Hl' H. + assert (Ha : In a l') by (apply H; simpl; auto). + destruct (Add_inv _ _ Ha) as (l'' & AD). + rewrite <- (Permutation_Add AD). + apply perm_skip. + apply IH; clear IH. + * now apply (NoDup_Add AD). + * split. + + apply incl_Add_inv with a l'; trivial. intro. apply H. + + intro Hx. + assert (Hx' : In x (a::l)). + { apply H. rewrite (Add_in AD). now right. } + destruct Hx'; simpl; trivial. subst. + rewrite (NoDup_Add AD) in Hl'. tauto. + Qed. + + Lemma NoDup_Permutation_bis l l' : NoDup l -> + length l' <= length l -> incl l l' -> Permutation l l'. + Proof. + intros. apply NoDup_Permutation; auto. + - now apply NoDup_incl_NoDup with l. + - split; auto. + apply NoDup_length_incl; trivial. + Qed. + + Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'. + Proof. + induction 1; auto. + - inversion_clear 1; constructor; eauto using Permutation_in. + - inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *. + constructor. + + simpl; intuition. + + constructor; intuition. + Qed. + + #[global] Instance Permutation_NoDup' : + Proper (@Permutation A ==> iff) (@NoDup A). + Proof. + repeat red; eauto using Permutation_NoDup. + Qed. + + Lemma Permutation_repeat x n l : + Permutation l (repeat x n) -> l = repeat x n. + Proof. + revert n; induction l as [|y l IHl] ; simpl; intros n HP; auto. + - now apply Permutation_nil in HP; inversion HP. + - assert (y = x) as Heq by (now apply repeat_spec with n, (Permutation_in _ HP); left); subst. + destruct n; simpl; simpl in HP. + + symmetry in HP; apply Permutation_nil in HP; inversion HP. + + f_equal; apply IHl. + now apply Permutation_cons_inv with x. + Qed. + + Lemma Permutation_incl_cons_inv_r (l1 l2 : list A) a : incl l1 (a :: l2) -> + exists n l3, Permutation l1 (repeat a n ++ l3) /\ incl l3 l2. + Proof. + induction l1 as [|b l1 IH]. + - intros _. now exists 0, nil. + - intros [Hb Hincl] %incl_cons_inv. + destruct (IH Hincl) as [n [l3 [Hl1 Hl3l2]]]. + destruct Hb. + + subst b. exists (S n), l3. eauto. + + exists n, (b :: l3). eauto using incl_cons. + Qed. + + Lemma Permutation_pigeonhole l1 l2 : incl l1 l2 -> length l2 < length l1 -> + exists a l3, Permutation l1 (a :: a :: l3). + Proof. + induction l2 as [|a l2 IH] in l1 |- *. + - intros -> %incl_l_nil [] %PeanoNat.Nat.nlt_0_r. + - intros [[|[|n]] [l4 [Hl1 Hl4]]] %Permutation_incl_cons_inv_r Hlen. + + apply IH. + * unfold incl. eauto using Permutation_in. + * eauto using PeanoNat.Nat.lt_trans. + + assert (Hl2l4 : length l2 < length l4). + { rewrite (Permutation_length Hl1) in Hlen. + now apply PeanoNat.Nat.succ_lt_mono. } + destruct (IH l4 Hl4 Hl2l4) as [b [l3 Hl4l3]]. + exists b, (a :: l3). + apply (Permutation_trans Hl1). + now apply (Permutation_cons_app (b :: b :: nil)). + + now exists a, (repeat a n ++ l4). + Qed. + + Lemma Permutation_pigeonhole_rel (R : B -> A -> Prop) (l1 : list B) l2 : + Forall (fun b => Exists (R b) l2) l1 -> + length l2 < length l1 -> + exists b b' (l3 : list B), Permutation l1 (b :: b' :: l3) /\ exists a, In a l2 /\ R b a /\ R b' a. + Proof. + intros [l2' [Hl2'l1 Hl2'l2]]%Forall_Exists_exists_Forall2. + intros Hl2l2'. rewrite (Forall2_length Hl2'l1) in Hl2l2'. + destruct (Permutation_pigeonhole Hl2'l2 Hl2l2') as [a [l3 Hl2']]. + destruct (Permutation_Forall2 Hl2' (Forall2_flip Hl2'l1)) as [l1' [Hl1l1' Hl1']]. + destruct (Forall2_app_inv_l [a; a] l3 Hl1') as [lbb' [l1'' [Ha [? ?]]]]. + assert (Hlbb' := Forall2_length Ha). + destruct lbb' as [|b lb']; [easy|]. + apply Forall2_cons_iff in Ha as [Hba Ha]. + destruct lb' as [|b' l]; [easy|]. + apply Forall2_cons_iff in Ha as [Hb'a Ha]. + inversion Ha. subst. exists b, b', l1''. + split; [easy|]. exists a. + split; eauto using Permutation_in, in_eq. + Qed. + + Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. + + Lemma Permutation_count_occ l1 l2 : + Permutation l1 l2 <-> forall x, count_occ eq_dec l1 x = count_occ eq_dec l2 x. + Proof. + split. + - induction 1 as [ | y l1 l2 HP IHP | y z l | l1 l2 l3 HP1 IHP1 HP2 IHP2 ]; + cbn; intros a; auto. + + now rewrite IHP. + + destruct (eq_dec y a); destruct (eq_dec z a); auto. + + now rewrite IHP1, IHP2. + - revert l2; induction l1 as [|y l1 IHl1]; cbn; intros l2 Hocc. + + replace l2 with (@nil A); auto. + symmetry; apply (count_occ_inv_nil eq_dec); intuition. + + assert (exists l2' l2'', l2 = l2' ++ y :: l2'') as [l2' [l2'' ->]]. + { specialize (Hocc y). + destruct (eq_dec y y); intuition. + apply in_split, (count_occ_In eq_dec). + rewrite <- Hocc; apply Nat.lt_0_succ. } + apply Permutation_cons_app, IHl1. + intros z; specialize (Hocc z); destruct (eq_dec y z) as [Heq | Hneq]. + * rewrite (count_occ_elt_eq _ _ _ Heq) in Hocc. + now injection Hocc. + * now rewrite (count_occ_elt_neq _ _ _ Hneq) in Hocc. + Qed. -Lemma Permutation_image : forall a l l', - Permutation (a :: l) (map f l') -> exists a', a = f a'. -Proof. - intros a l l' HP. - destruct (Permutation_map_inv _ HP) as [l'' [Heq _]]. - destruct l'' as [ | a' l'']; inversion_clear Heq. - now exists a'. -Qed. +End Permutation_properties. -Lemma Permutation_elt_map_inv: forall l1 l2 l3 l4 a, - Permutation (l1 ++ a :: l2) (l3 ++ map f l4) -> (forall b, a <> f b) -> - exists l1' l2', l3 = l1' ++ a :: l2'. -Proof. - intros l1 l2 l3 l4 a HP Hf. - apply (Permutation_in a), in_app_or in HP; [| now apply in_elt]. - destruct HP as [HP%in_split | (x & Heq & ?)%in_map_iff]; trivial; subst. - now contradiction (Hf x). -Qed. +Section Permutation_map. -#[global] Instance Permutation_flat_map (g : A -> list B) : - Proper ((@Permutation A) ==> (@Permutation B)) (flat_map g). -Proof. - intros l1; induction l1; intros l2 HP. - - now apply Permutation_nil in HP; subst. - - symmetry in HP. - destruct (Permutation_vs_cons_inv HP) as [l' [l'']]; subst. - symmetry in HP. - apply Permutation_cons_app_inv in HP. - rewrite flat_map_app; simpl. - rewrite <- (app_nil_l _). - apply Permutation_app_middle; simpl. - rewrite <- flat_map_app. - apply (IHl1 _ HP). -Qed. + Variable A B : Type. + Variable f : A -> B. + + Lemma Permutation_map l l' : + Permutation l l' -> Permutation (map f l) (map f l'). + Proof. + induction 1; simpl; eauto. + Qed. + + #[global] Instance Permutation_map' : + Proper (@Permutation A ==> @Permutation B) (map f). + Proof. + exact Permutation_map. + Qed. + + Lemma Permutation_map_inv : forall l1 l2, + Permutation l1 (map f l2) -> exists l3, l1 = map f l3 /\ Permutation l2 l3. + Proof. + induction l1; intros l2 HP. + - exists nil; split; auto. + apply Permutation_nil in HP. + destruct l2; auto. + inversion HP. + - symmetry in HP. + destruct (Permutation_vs_cons_inv HP) as [l3 [l4 Heq]]. + destruct (map_eq_app _ _ _ _ Heq) as [l1' [l2' [Heq1 [Heq2 Heq3]]]]; subst. + destruct (map_eq_cons _ _ Heq3) as [b [l1'' [Heq1' [Heq2' Heq3']]]]; subst. + rewrite map_app in HP; simpl in HP. + symmetry in HP. + apply Permutation_cons_app_inv in HP. + rewrite <- map_app in HP. + destruct (IHl1 _ HP) as [l3 [Heq1'' Heq2'']]; subst. + exists (b :: l3); split; auto. + symmetry in Heq2''; symmetry; apply (Permutation_cons_app _ _ _ Heq2''). + Qed. + + Lemma Permutation_image : forall a l l', + Permutation (a :: l) (map f l') -> exists a', a = f a'. + Proof. + intros a l l' HP. + destruct (Permutation_map_inv _ HP) as [l'' [Heq _]]. + destruct l'' as [ | a' l'']; inversion_clear Heq. + now exists a'. + Qed. + + Lemma Permutation_elt_map_inv: forall l1 l2 l3 l4 a, + Permutation (l1 ++ a :: l2) (l3 ++ map f l4) -> (forall b, a <> f b) -> + exists l1' l2', l3 = l1' ++ a :: l2'. + Proof. + intros l1 l2 l3 l4 a HP Hf. + apply (Permutation_in a), in_app_or in HP; [| now apply in_elt]. + destruct HP as [HP%in_split | (x & Heq & ?)%in_map_iff]; trivial; subst. + now contradiction (Hf x). + Qed. + + #[global] Instance Permutation_flat_map (g : A -> list B) : + Proper ((@Permutation A) ==> (@Permutation B)) (flat_map g). + Proof. + intros l1; induction l1; intros l2 HP. + - now apply Permutation_nil in HP; subst. + - symmetry in HP. + destruct (Permutation_vs_cons_inv HP) as [l' [l'']]; subst. + symmetry in HP. + apply Permutation_cons_app_inv in HP. + rewrite flat_map_app; simpl. + rewrite <- (app_nil_l _). + apply Permutation_app_middle; simpl. + rewrite <- flat_map_app. + apply (IHl1 _ HP). + Qed. End Permutation_map. @@ -708,39 +708,39 @@ Qed. #[local] Definition adapt_injective f : Injective f -> Injective (adapt f). Proof. - unfold adapt. intros Hf x y EQ. - destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT']. - - now apply eq_add_S, Hf. - - apply Nat.lt_eq_cases in LE. - destruct LE as [LT|EQ']; [|now apply Hf in EQ']. - unfold lt in LT. rewrite EQ in LT. - rewrite (Nat.lt_succ_pred _ _ LT') in LT. - elim (proj1 (Nat.lt_nge _ _) LT' LT). - - apply Nat.lt_eq_cases in LE'. - destruct LE' as [LT'|EQ']; [|now apply Hf in EQ']. - unfold lt in LT'. rewrite <- EQ in LT'. - rewrite (Nat.lt_succ_pred _ _ LT) in LT'. - elim (proj1 (Nat.lt_nge _ _) LT LT'). - - apply eq_add_S, Hf. - now rewrite <- (Nat.lt_succ_pred _ _ LT), <- (Nat.lt_succ_pred _ _ LT'), EQ. + unfold adapt. intros Hf x y EQ. + destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT']. + - now apply eq_add_S, Hf. + - apply Nat.lt_eq_cases in LE. + destruct LE as [LT|EQ']; [|now apply Hf in EQ']. + unfold lt in LT. rewrite EQ in LT. + rewrite (Nat.lt_succ_pred _ _ LT') in LT. + elim (proj1 (Nat.lt_nge _ _) LT' LT). + - apply Nat.lt_eq_cases in LE'. + destruct LE' as [LT'|EQ']; [|now apply Hf in EQ']. + unfold lt in LT'. rewrite <- EQ in LT'. + rewrite (Nat.lt_succ_pred _ _ LT) in LT'. + elim (proj1 (Nat.lt_nge _ _) LT LT'). + - apply eq_add_S, Hf. + now rewrite <- (Nat.lt_succ_pred _ _ LT), <- (Nat.lt_succ_pred _ _ LT'), EQ. Defined. #[local] Definition adapt_ok A (a : A) l1 l2 f : Injective f -> length l1 = f 0 -> forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n). Proof. - unfold adapt. intros Hf E n. - destruct le_lt_dec as [LE|LT]. - - apply Nat.lt_eq_cases in LE. - destruct LE as [LT|EQ]; [|now apply Hf in EQ]. - rewrite <- E in LT. - rewrite 2 nth_error_app1; auto. - - rewrite <- (Nat.lt_succ_pred _ _ LT) at 1. - rewrite <- E, <- (Nat.lt_succ_pred _ _ LT) in LT. - rewrite 2 nth_error_app2. - + rewrite Nat.sub_succ_l; [ reflexivity | ]. - apply Nat.lt_succ_r; assumption. - + apply Nat.lt_succ_r; assumption. - + apply Nat.lt_le_incl; assumption. + unfold adapt. intros Hf E n. + destruct le_lt_dec as [LE|LT]. + - apply Nat.lt_eq_cases in LE. + destruct LE as [LT|EQ]; [|now apply Hf in EQ]. + rewrite <- E in LT. + rewrite 2 nth_error_app1; auto. + - rewrite <- (Nat.lt_succ_pred _ _ LT) at 1. + rewrite <- E, <- (Nat.lt_succ_pred _ _ LT) in LT. + rewrite 2 nth_error_app2. + + rewrite Nat.sub_succ_l; [ reflexivity | ]. + apply Nat.lt_succ_r; assumption. + + apply Nat.lt_succ_r; assumption. + + apply Nat.lt_le_incl; assumption. Defined. Lemma Permutation_nth_error A (l l' : list A) : @@ -749,41 +749,41 @@ Lemma Permutation_nth_error A (l l' : list A) : exists f:nat->nat, Injective f /\ forall n, nth_error l' n = nth_error l (f n)). Proof. - split. - { intros P. - split; [now apply Permutation_length|]. - induction P. - - exists (fun n => n). - split; try red; auto. - - destruct IHP as (f & Hf & Hf'). - exists (fun n => match n with O => O | S n => S (f n) end). - split; try red. - * intros [|y] [|z]; simpl; now auto. - * intros [|n]; simpl; auto. - - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end). - split; try red. - * intros [|[|z]] [|[|t]]; simpl; now auto. - * intros [|[|n]]; simpl; auto. - - destruct IHP1 as (f & Hf & Hf'). - destruct IHP2 as (g & Hg & Hg'). - exists (fun n => f (g n)). - split; try red. - * auto. - * intros n. rewrite <- Hf'; auto. } - { revert l. induction l'. - - intros [|l] (E & _); now auto. - - intros l (E & f & Hf & Hf'). - simpl in E. - assert (Ha : nth_error l (f 0) = Some a) - by (symmetry; apply (Hf' 0)). - destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1). - rewrite L12. rewrite <- Permutation_middle. constructor. - apply IHl'; split; [|exists (adapt f); split]. - * revert E. rewrite L12, !length_app. simpl. - rewrite <- plus_n_Sm. now injection 1. - * now apply adapt_injective. - * intro n. rewrite <- (adapt_ok a), <- L12; auto. - apply (Hf' (S n)). } + split. + { intros P. + split; [now apply Permutation_length|]. + induction P. + - exists (fun n => n). + split; try red; auto. + - destruct IHP as (f & Hf & Hf'). + exists (fun n => match n with O => O | S n => S (f n) end). + split; try red. + * intros [|y] [|z]; simpl; now auto. + * intros [|n]; simpl; auto. + - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end). + split; try red. + * intros [|[|z]] [|[|t]]; simpl; now auto. + * intros [|[|n]]; simpl; auto. + - destruct IHP1 as (f & Hf & Hf'). + destruct IHP2 as (g & Hg & Hg'). + exists (fun n => f (g n)). + split; try red. + * auto. + * intros n. rewrite <- Hf'; auto. } + { revert l. induction l'. + - intros [|l] (E & _); now auto. + - intros l (E & f & Hf & Hf'). + simpl in E. + assert (Ha : nth_error l (f 0) = Some a) + by (symmetry; apply (Hf' 0)). + destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1). + rewrite L12. rewrite <- Permutation_middle. constructor. + apply IHl'; split; [|exists (adapt f); split]. + * revert E. rewrite L12, !length_app. simpl. + rewrite <- plus_n_Sm. now injection 1. + * now apply adapt_injective. + * intro n. rewrite <- (adapt_ok a), <- L12; auto. + apply (Hf' (S n)). } Qed. Lemma nat_bijection_Permutation n f : @@ -791,13 +791,13 @@ Lemma nat_bijection_Permutation n f : Injective f -> let l := seq 0 n in Permutation (map f l) l. Proof. - intros Hf BD. - apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup. - * now rewrite length_map. - * intros x. rewrite in_map_iff. intros (y & <- & Hy'). - rewrite in_seq in *. simpl in *. - destruct Hy' as (_,Hy'). - split; [ apply Nat.le_0_l | auto ]. + intros Hf BD. + apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup. + * now rewrite length_map. + * intros x. rewrite in_map_iff. intros (y & <- & Hy'). + rewrite in_seq in *. simpl in *. + destruct Hy' as (_,Hy'). + split; [ apply Nat.le_0_l | auto ]. Qed. #[global] @@ -820,66 +820,66 @@ Qed. Section Permutation_transp. -Variable A:Type. - -(** Permutation definition based on transpositions for induction with fixed length *) -Inductive Permutation_transp : list A -> list A -> Prop := -| perm_t_refl : forall l, Permutation_transp l l -| perm_t_swap : forall x y l1 l2, Permutation_transp (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2) -| perm_t_trans l l' l'' : - Permutation_transp l l' -> Permutation_transp l' l'' -> Permutation_transp l l''. - -Instance Permutation_transp_sym : Symmetric Permutation_transp. -Proof. - intros l1 l2 HP; induction HP; subst; try (now constructor). - now apply (perm_t_trans IHHP2). -Qed. - -#[global] Instance Permutation_transp_equiv : Equivalence Permutation_transp | 100. -Proof. - split. - - intros l; apply perm_t_refl. - - apply Permutation_transp_sym. - - intros l1 l2 l3 ;apply perm_t_trans. -Qed. - -Lemma Permutation_transp_cons : forall (x : A) l1 l2, - Permutation_transp l1 l2 -> Permutation_transp (x :: l1) (x :: l2). -Proof. - intros x l1 l2 HP. - induction HP. - - reflexivity. - - rewrite 2 app_comm_cons. - apply perm_t_swap. - - now transitivity (x :: l'). -Qed. - -Lemma Permutation_Permutation_transp : forall l1 l2 : list A, - Permutation l1 l2 <-> Permutation_transp l1 l2. -Proof. - intros l1 l2; split; intros HP; induction HP; intuition auto. - - solve_relation. - - now apply Permutation_transp_cons. - - rewrite <- (app_nil_l (y :: _)). - rewrite <- (app_nil_l (x :: y :: _)). - apply perm_t_swap. - - now transitivity l'. - - apply Permutation_app_head. - apply perm_swap. - - now transitivity l'. -Qed. - -Lemma Permutation_ind_transp : forall P : list A -> list A -> Prop, - (forall l, P l l) -> - (forall x y l1 l2, P (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2)) -> - (forall l l' l'', - Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> - forall l1 l2, Permutation l1 l2 -> P l1 l2. -Proof. - intros P Hr Ht Htr l1 l2 HP; apply Permutation_Permutation_transp in HP. - revert Hr Ht Htr; induction HP; intros Hr Ht Htr; auto. - apply (Htr _ l'); intuition; now apply Permutation_Permutation_transp. -Qed. + Variable A:Type. + + (** Permutation definition based on transpositions for induction with fixed length *) + Inductive Permutation_transp : list A -> list A -> Prop := + | perm_t_refl : forall l, Permutation_transp l l + | perm_t_swap : forall x y l1 l2, Permutation_transp (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2) + | perm_t_trans l l' l'' : + Permutation_transp l l' -> Permutation_transp l' l'' -> Permutation_transp l l''. + + Instance Permutation_transp_sym : Symmetric Permutation_transp. + Proof. + intros l1 l2 HP; induction HP; subst; try (now constructor). + now apply (perm_t_trans IHHP2). + Qed. + + #[global] Instance Permutation_transp_equiv : Equivalence Permutation_transp | 100. + Proof. + split. + - intros l; apply perm_t_refl. + - apply Permutation_transp_sym. + - intros l1 l2 l3 ;apply perm_t_trans. + Qed. + + Lemma Permutation_transp_cons : forall (x : A) l1 l2, + Permutation_transp l1 l2 -> Permutation_transp (x :: l1) (x :: l2). + Proof. + intros x l1 l2 HP. + induction HP. + - reflexivity. + - rewrite 2 app_comm_cons. + apply perm_t_swap. + - now transitivity (x :: l'). + Qed. + + Lemma Permutation_Permutation_transp : forall l1 l2 : list A, + Permutation l1 l2 <-> Permutation_transp l1 l2. + Proof. + intros l1 l2; split; intros HP; induction HP; intuition auto. + - solve_relation. + - now apply Permutation_transp_cons. + - rewrite <- (app_nil_l (y :: _)). + rewrite <- (app_nil_l (x :: y :: _)). + apply perm_t_swap. + - now transitivity l'. + - apply Permutation_app_head. + apply perm_swap. + - now transitivity l'. + Qed. + + Lemma Permutation_ind_transp : forall P : list A -> list A -> Prop, + (forall l, P l l) -> + (forall x y l1 l2, P (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2)) -> + (forall l l' l'', + Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> + forall l1 l2, Permutation l1 l2 -> P l1 l2. + Proof. + intros P Hr Ht Htr l1 l2 HP; apply Permutation_Permutation_transp in HP. + revert Hr Ht Htr; induction HP; intros Hr Ht Htr; auto. + apply (Htr _ l'); intuition; now apply Permutation_Permutation_transp. + Qed. End Permutation_transp. diff --git a/theories/Sorting/SetoidList.v b/theories/Sorting/SetoidList.v index 32acc0c542..e9a25d6b0d 100644 --- a/theories/Sorting/SetoidList.v +++ b/theories/Sorting/SetoidList.v @@ -21,390 +21,390 @@ Unset Strict Implicit. found in [Sorting]. *) Section Type_with_equality. -Variable A : Type. -Variable eqA : A -> A -> Prop. + Variable A : Type. + Variable eqA : A -> A -> Prop. -(** Being in a list modulo an equality relation over type [A]. *) + (** Being in a list modulo an equality relation over type [A]. *) -Inductive InA (x : A) : list A -> Prop := - | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) - | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). + Inductive InA (x : A) : list A -> Prop := + | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) + | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). -#[local] -Hint Constructors InA : core. + #[local] + Hint Constructors InA : core. -(** TODO: it would be nice to have a generic definition instead + (** TODO: it would be nice to have a generic definition instead of the previous one. Having [InA = Exists eqA] raises too many compatibility issues. For now, we only state the equivalence: *) -Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. -Proof. split; induction 1; auto. Qed. + Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. + Proof. split; induction 1; auto. Qed. -Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. -Proof. - intuition. invlist InA; auto. -Qed. + Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. + Proof. + intuition. invlist InA; auto. + Qed. -Lemma InA_nil : forall x, InA x nil <-> False. -Proof. - intuition. invlist InA. -Qed. + Lemma InA_nil : forall x, InA x nil <-> False. + Proof. + intuition. invlist InA. + Qed. -(** An alternative definition of [InA]. *) + (** An alternative definition of [InA]. *) -Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. -Proof. - intros; rewrite InA_altdef, Exists_exists; firstorder. -Qed. + Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. + Proof. + intros; rewrite InA_altdef, Exists_exists; firstorder. + Qed. -(** A list without redundancy modulo the equality over [A]. *) + (** A list without redundancy modulo the equality over [A]. *) -Inductive NoDupA : list A -> Prop := - | NoDupA_nil : NoDupA nil - | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). + Inductive NoDupA : list A -> Prop := + | NoDupA_nil : NoDupA nil + | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). -#[local] -Hint Constructors NoDupA : core. + #[local] + Hint Constructors NoDupA : core. -(** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) + (** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) -Lemma NoDupA_altdef : forall l, - NoDupA l <-> ForallOrdPairs (complement eqA) l. -Proof. - split; induction 1 as [|a l H rest]; constructor; auto. - - rewrite Forall_forall. intros b Hb. - intro Eq; elim H. rewrite InA_alt. exists b; auto. - - rewrite InA_alt; intros (a' & Haa' & Ha'). - rewrite Forall_forall in H. exact (H a' Ha' Haa'). -Qed. + Lemma NoDupA_altdef : forall l, + NoDupA l <-> ForallOrdPairs (complement eqA) l. + Proof. + split; induction 1 as [|a l H rest]; constructor; auto. + - rewrite Forall_forall. intros b Hb. + intro Eq; elim H. rewrite InA_alt. exists b; auto. + - rewrite InA_alt; intros (a' & Haa' & Ha'). + rewrite Forall_forall in H. exact (H a' Ha' Haa'). + Qed. -(** lists with same elements modulo [eqA] *) + (** lists with same elements modulo [eqA] *) -Definition inclA l l' := forall x, InA x l -> InA x l'. -Definition equivlistA l l' := forall x, InA x l <-> InA x l'. + Definition inclA l l' := forall x, InA x l -> InA x l'. + Definition equivlistA l l' := forall x, InA x l <-> InA x l'. -Lemma incl_nil l : inclA nil l. -Proof. intros a H. inversion H. Qed. -#[local] -Hint Resolve incl_nil : list. + Lemma incl_nil l : inclA nil l. + Proof. intros a H. inversion H. Qed. + #[local] + Hint Resolve incl_nil : list. -(** lists with same elements modulo [eqA] at the same place *) + (** lists with same elements modulo [eqA] at the same place *) -Inductive eqlistA : list A -> list A -> Prop := - | eqlistA_nil : eqlistA nil nil - | eqlistA_cons : forall x x' l l', - eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). + Inductive eqlistA : list A -> list A -> Prop := + | eqlistA_nil : eqlistA nil nil + | eqlistA_cons : forall x x' l l', + eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). -#[local] -Hint Constructors eqlistA : core. + #[local] + Hint Constructors eqlistA : core. -(** We could also have written [eqlistA = Forall2 eqA]. *) + (** We could also have written [eqlistA = Forall2 eqA]. *) -Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'. -Proof. split; induction 1; auto. Qed. + Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'. + Proof. split; induction 1; auto. Qed. -(** Results concerning lists modulo [eqA] *) + (** Results concerning lists modulo [eqA] *) -Hypothesis eqA_equiv : Equivalence eqA. -Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). -Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). -Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). + Hypothesis eqA_equiv : Equivalence eqA. + Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). + Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). + Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). -#[local] -Hint Resolve eqarefl eqatrans : core. -#[local] -Hint Immediate eqasym : core. + #[local] + Hint Resolve eqarefl eqatrans : core. + #[local] + Hint Immediate eqasym : core. -Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. + Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. -(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *) + (** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *) -#[global] Instance equivlist_equiv : Equivalence equivlistA. -Proof. - firstorder. -Qed. + #[global] Instance equivlist_equiv : Equivalence equivlistA. + Proof. + firstorder. + Qed. -#[global] Instance eqlistA_equiv : Equivalence eqlistA. -Proof. - constructor; red. - - intros x; induction x; auto. - - induction 1; auto. - - intros x y z H; revert z; induction H; auto. - inversion 1; subst; auto. invlist eqlistA; eauto with *. -Qed. -(** Moreover, [eqlistA] implies [equivlistA]. A reverse result + #[global] Instance eqlistA_equiv : Equivalence eqlistA. + Proof. + constructor; red. + - intros x; induction x; auto. + - induction 1; auto. + - intros x y z H; revert z; induction H; auto. + inversion 1; subst; auto. invlist eqlistA; eauto with *. + Qed. + (** Moreover, [eqlistA] implies [equivlistA]. A reverse result will be proved later for sorted list without duplicates. *) -#[global] Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. -Proof. - intros x x' H. induction H as [|? ? ? ? H ? IHeqlistA]. - - intuition auto with relations. - - red; intros x0. - rewrite 2 InA_cons. - rewrite (IHeqlistA x0), H; intuition. -Qed. + #[global] Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. + Proof. + intros x x' H. induction H as [|? ? ? ? H ? IHeqlistA]. + - intuition auto with relations. + - red; intros x0. + rewrite 2 InA_cons. + rewrite (IHeqlistA x0), H; intuition. + Qed. -(** InA is compatible with eqA (for its first arg) and with + (** InA is compatible with eqA (for its first arg) and with equivlistA (and hence eqlistA) for its second arg *) -#[global] Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA. -Proof. - intros x x' Hxx' l l' Hll'. rewrite (Hll' x). - rewrite 2 InA_alt; firstorder. -Qed. - -(** For compatibility, an immediate consequence of [InA_compat] *) - -Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. -Proof. - intros l x y H H'. rewrite <- H. auto. -Qed. -#[local] -Hint Immediate InA_eqA : core. - -Lemma In_InA : forall l x, In x l -> InA x l. -Proof. - intros l; induction l; simpl; intuition. - subst; auto. -Qed. -#[local] -Hint Resolve In_InA : core. - -Lemma InA_split : forall l x, InA x l -> - exists l1 y l2, eqA x y /\ l = l1++y::l2. -Proof. -intros l; induction l as [|a l IHl]; intros x H; inv. -- exists (@nil A); exists a; exists l; auto. -- match goal with H' : InA x l |- _ => rename H' into H0 end. - destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). - exists (a::l1); exists y; exists l2; auto. - split; simpl; f_equal; auto. -Qed. - -Lemma InA_app : forall l1 l2 x, - InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. -Proof. - intros l1; induction l1 as [|a l1 IHl1]; simpl in *; intuition. - inv; auto. - match goal with H0' : InA _ (l1 ++ _) |- _ => rename H0' into H0 end. - elim (IHl1 _ _ H0); auto. -Qed. - -Lemma InA_app_iff : forall l1 l2 x, - InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2. -Proof. - split. - - apply InA_app. - - destruct 1 as [H|H]; generalize H; do 2 rewrite InA_alt. - + destruct 1 as (y,(H1,H2)); exists y; split; auto. - apply in_or_app; auto. - + destruct 1 as (y,(H1,H2)); exists y; split; auto. - apply in_or_app; auto. -Qed. - -Lemma InA_rev : forall p m, - InA p (rev m) <-> InA p m. -Proof. - intros; do 2 rewrite InA_alt. - split; intros (y,H); exists y; intuition. - - rewrite In_rev; auto. - - rewrite <- In_rev; auto. -Qed. - -(** Some more facts about InA *) - -Lemma InA_singleton x y : InA x (y::nil) <-> eqA x y. -Proof. - rewrite InA_cons, InA_nil; tauto. -Qed. - -Lemma InA_double_head x y l : - InA x (y :: y :: l) <-> InA x (y :: l). -Proof. - rewrite !InA_cons; tauto. -Qed. - -Lemma InA_permute_heads x y z l : - InA x (y :: z :: l) <-> InA x (z :: y :: l). -Proof. - rewrite !InA_cons; tauto. -Qed. - -Lemma InA_app_idem x l : InA x (l ++ l) <-> InA x l. -Proof. - rewrite InA_app_iff; tauto. -Qed. - -Section NoDupA. - -Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> - (forall x, InA x l -> InA x l' -> False) -> - NoDupA (l++l'). -Proof. -intros l; induction l as [|a l IHl]; simpl; auto; intros l' H H0 H1. -inv. -constructor. -- rewrite InA_alt; intros (y,(H4,H5)). - destruct (in_app_or _ _ _ H5). - + match goal with H2' : ~ InA a l |- _ => rename H2' into H2 end. - elim H2. - rewrite InA_alt. - exists y; auto. - + apply (H1 a). - * auto. - * rewrite InA_alt. - exists y; auto. -- apply IHl; auto. - intros x ? ?. - apply (H1 x); auto. -Qed. - -Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). -Proof. -intros l; induction l. -- simpl; auto. -- simpl; intros. - inv. - apply NoDupA_app; auto. - + constructor; auto. - intro; inv. - + intros x. - rewrite InA_alt. - intros (x1,(H2,H3)). - intro; inv. - match goal with H0 : ~ InA _ _ |- _ => destruct H0 end. - match goal with H4 : eqA x ?x' |- InA ?x' _ => rewrite <- H4, H2 end. - apply In_InA. - rewrite In_rev; auto. -Qed. - -Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). -Proof. - intros l; induction l; simpl in *; intros; inv; auto. - constructor; eauto. - match goal with H0 : ~ InA _ _ |- _ => contradict H0 end. - rewrite InA_app_iff in *. - rewrite InA_cons. - intuition. -Qed. - -Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). -Proof. - intros l; induction l as [|a l IHl]; simpl in *; intros l' x H; inv; auto. - constructor; eauto. - - match goal with H1 : NoDupA (l ++ x :: l') |- _ => assert (H2:=IHl _ _ H1) end. - inv. - rewrite InA_cons. - red; destruct 1. - + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => apply H0 end. - rewrite InA_app_iff in *; rewrite InA_cons; auto. - + auto. - - constructor. - + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => contradict H0 end. - rewrite InA_app_iff in *; rewrite InA_cons; intuition. - + eapply NoDupA_split; eauto. -Qed. - -Lemma NoDupA_singleton x : NoDupA (x::nil). -Proof. - repeat constructor. inversion 1. -Qed. - -End NoDupA. - -Section EquivlistA. - -#[global] Instance equivlistA_cons_proper: - Proper (eqA ==> equivlistA ==> equivlistA) (@cons A). -Proof. - intros ? ? E1 ? ? E2 ?; now rewrite !InA_cons, E1, E2. -Qed. - -#[global] Instance equivlistA_app_proper: - Proper (equivlistA ==> equivlistA ==> equivlistA) (@app A). -Proof. - intros ? ? E1 ? ? E2 ?. now rewrite !InA_app_iff, E1, E2. -Qed. - -Lemma equivlistA_cons_nil x l : ~ equivlistA (x :: l) nil. -Proof. - intros E. now eapply InA_nil, E, InA_cons_hd. -Qed. - -Lemma equivlistA_nil_eq l : equivlistA l nil -> l = nil. -Proof. - destruct l. - - trivial. - - intros H. now apply equivlistA_cons_nil in H. -Qed. - -Lemma equivlistA_double_head x l : equivlistA (x :: x :: l) (x :: l). -Proof. - intro. apply InA_double_head. -Qed. - -Lemma equivlistA_permute_heads x y l : - equivlistA (x :: y :: l) (y :: x :: l). -Proof. - intro. apply InA_permute_heads. -Qed. - -Lemma equivlistA_app_idem l : equivlistA (l ++ l) l. -Proof. - intro. apply InA_app_idem. -Qed. - -Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y -> - NoDupA (x::l) -> NoDupA (l1++y::l2) -> - equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). -Proof. - intros H H0 H1 H2; intro a. - generalize (H2 a). - rewrite !InA_app_iff, !InA_cons. - inv. - assert (SW:=NoDupA_swap H1). inv. - rewrite InA_app_iff in *. - split; intros. - - match goal with H3 : ~ InA x l |- _ => - assert (~eqA a x) by (contradict H3; rewrite <- H3; auto) - end. - assert (~eqA a y) by (rewrite <- H; auto). - tauto. - - assert (OR : eqA a x \/ InA a l) by intuition. - destruct OR as [EQN|INA]; auto. - match goal with H0 : ~ (InA y l1 \/ InA y l2) |- _ => elim H0 end. - rewrite <-H,<-EQN; auto. -Qed. - -End EquivlistA. - -Section Fold. - -Variable B:Type. -Variable eqB:B->B->Prop. -Variable st:Equivalence eqB. -Variable f:A->B->B. -Variable i:B. -Variable Comp:Proper (eqA==>eqB==>eqB) f. - -Lemma fold_right_eqlistA : - forall s s', eqlistA s s' -> - eqB (fold_right f i s) (fold_right f i s'). -Proof. -induction 1; simpl; auto with relations. -apply Comp; auto. -Qed. - -(** Fold with restricted [transpose] hypothesis. *) - -Section Fold_With_Restriction. -Variable R : A -> A -> Prop. -Hypothesis R_sym : Symmetric R. -Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. - - -(* + #[global] Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA. + Proof. + intros x x' Hxx' l l' Hll'. rewrite (Hll' x). + rewrite 2 InA_alt; firstorder. + Qed. + + (** For compatibility, an immediate consequence of [InA_compat] *) + + Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. + Proof. + intros l x y H H'. rewrite <- H. auto. + Qed. + #[local] + Hint Immediate InA_eqA : core. + + Lemma In_InA : forall l x, In x l -> InA x l. + Proof. + intros l; induction l; simpl; intuition. + subst; auto. + Qed. + #[local] + Hint Resolve In_InA : core. + + Lemma InA_split : forall l x, InA x l -> + exists l1 y l2, eqA x y /\ l = l1++y::l2. + Proof. + intros l; induction l as [|a l IHl]; intros x H; inv. + - exists (@nil A); exists a; exists l; auto. + - match goal with H' : InA x l |- _ => rename H' into H0 end. + destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). + exists (a::l1); exists y; exists l2; auto. + split; simpl; f_equal; auto. + Qed. + + Lemma InA_app : forall l1 l2 x, + InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. + Proof. + intros l1; induction l1 as [|a l1 IHl1]; simpl in *; intuition. + inv; auto. + match goal with H0' : InA _ (l1 ++ _) |- _ => rename H0' into H0 end. + elim (IHl1 _ _ H0); auto. + Qed. + + Lemma InA_app_iff : forall l1 l2 x, + InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2. + Proof. + split. + - apply InA_app. + - destruct 1 as [H|H]; generalize H; do 2 rewrite InA_alt. + + destruct 1 as (y,(H1,H2)); exists y; split; auto. + apply in_or_app; auto. + + destruct 1 as (y,(H1,H2)); exists y; split; auto. + apply in_or_app; auto. + Qed. + + Lemma InA_rev : forall p m, + InA p (rev m) <-> InA p m. + Proof. + intros; do 2 rewrite InA_alt. + split; intros (y,H); exists y; intuition. + - rewrite In_rev; auto. + - rewrite <- In_rev; auto. + Qed. + + (** Some more facts about InA *) + + Lemma InA_singleton x y : InA x (y::nil) <-> eqA x y. + Proof. + rewrite InA_cons, InA_nil; tauto. + Qed. + + Lemma InA_double_head x y l : + InA x (y :: y :: l) <-> InA x (y :: l). + Proof. + rewrite !InA_cons; tauto. + Qed. + + Lemma InA_permute_heads x y z l : + InA x (y :: z :: l) <-> InA x (z :: y :: l). + Proof. + rewrite !InA_cons; tauto. + Qed. + + Lemma InA_app_idem x l : InA x (l ++ l) <-> InA x l. + Proof. + rewrite InA_app_iff; tauto. + Qed. + + Section NoDupA. + + Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> + (forall x, InA x l -> InA x l' -> False) -> + NoDupA (l++l'). + Proof. + intros l; induction l as [|a l IHl]; simpl; auto; intros l' H H0 H1. + inv. + constructor. + - rewrite InA_alt; intros (y,(H4,H5)). + destruct (in_app_or _ _ _ H5). + + match goal with H2' : ~ InA a l |- _ => rename H2' into H2 end. + elim H2. + rewrite InA_alt. + exists y; auto. + + apply (H1 a). + * auto. + * rewrite InA_alt. + exists y; auto. + - apply IHl; auto. + intros x ? ?. + apply (H1 x); auto. + Qed. + + Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). + Proof. + intros l; induction l. + - simpl; auto. + - simpl; intros. + inv. + apply NoDupA_app; auto. + + constructor; auto. + intro; inv. + + intros x. + rewrite InA_alt. + intros (x1,(H2,H3)). + intro; inv. + match goal with H0 : ~ InA _ _ |- _ => destruct H0 end. + match goal with H4 : eqA x ?x' |- InA ?x' _ => rewrite <- H4, H2 end. + apply In_InA. + rewrite In_rev; auto. + Qed. + + Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). + Proof. + intros l; induction l; simpl in *; intros; inv; auto. + constructor; eauto. + match goal with H0 : ~ InA _ _ |- _ => contradict H0 end. + rewrite InA_app_iff in *. + rewrite InA_cons. + intuition. + Qed. + + Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). + Proof. + intros l; induction l as [|a l IHl]; simpl in *; intros l' x H; inv; auto. + constructor; eauto. + - match goal with H1 : NoDupA (l ++ x :: l') |- _ => assert (H2:=IHl _ _ H1) end. + inv. + rewrite InA_cons. + red; destruct 1. + + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => apply H0 end. + rewrite InA_app_iff in *; rewrite InA_cons; auto. + + auto. + - constructor. + + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => contradict H0 end. + rewrite InA_app_iff in *; rewrite InA_cons; intuition. + + eapply NoDupA_split; eauto. + Qed. + + Lemma NoDupA_singleton x : NoDupA (x::nil). + Proof. + repeat constructor. inversion 1. + Qed. + + End NoDupA. + + Section EquivlistA. + + #[global] Instance equivlistA_cons_proper: + Proper (eqA ==> equivlistA ==> equivlistA) (@cons A). + Proof. + intros ? ? E1 ? ? E2 ?; now rewrite !InA_cons, E1, E2. + Qed. + + #[global] Instance equivlistA_app_proper: + Proper (equivlistA ==> equivlistA ==> equivlistA) (@app A). + Proof. + intros ? ? E1 ? ? E2 ?. now rewrite !InA_app_iff, E1, E2. + Qed. + + Lemma equivlistA_cons_nil x l : ~ equivlistA (x :: l) nil. + Proof. + intros E. now eapply InA_nil, E, InA_cons_hd. + Qed. + + Lemma equivlistA_nil_eq l : equivlistA l nil -> l = nil. + Proof. + destruct l. + - trivial. + - intros H. now apply equivlistA_cons_nil in H. + Qed. + + Lemma equivlistA_double_head x l : equivlistA (x :: x :: l) (x :: l). + Proof. + intro. apply InA_double_head. + Qed. + + Lemma equivlistA_permute_heads x y l : + equivlistA (x :: y :: l) (y :: x :: l). + Proof. + intro. apply InA_permute_heads. + Qed. + + Lemma equivlistA_app_idem l : equivlistA (l ++ l) l. + Proof. + intro. apply InA_app_idem. + Qed. + + Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y -> + NoDupA (x::l) -> NoDupA (l1++y::l2) -> + equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). + Proof. + intros H H0 H1 H2; intro a. + generalize (H2 a). + rewrite !InA_app_iff, !InA_cons. + inv. + assert (SW:=NoDupA_swap H1). inv. + rewrite InA_app_iff in *. + split; intros. + - match goal with H3 : ~ InA x l |- _ => + assert (~eqA a x) by (contradict H3; rewrite <- H3; auto) + end. + assert (~eqA a y) by (rewrite <- H; auto). + tauto. + - assert (OR : eqA a x \/ InA a l) by intuition. + destruct OR as [EQN|INA]; auto. + match goal with H0 : ~ (InA y l1 \/ InA y l2) |- _ => elim H0 end. + rewrite <-H,<-EQN; auto. + Qed. + + End EquivlistA. + + Section Fold. + + Variable B:Type. + Variable eqB:B->B->Prop. + Variable st:Equivalence eqB. + Variable f:A->B->B. + Variable i:B. + Variable Comp:Proper (eqA==>eqB==>eqB) f. + + Lemma fold_right_eqlistA : + forall s s', eqlistA s s' -> + eqB (fold_right f i s) (fold_right f i s'). + Proof. + induction 1; simpl; auto with relations. + apply Comp; auto. + Qed. + + (** Fold with restricted [transpose] hypothesis. *) + + Section Fold_With_Restriction. + Variable R : A -> A -> Prop. + Hypothesis R_sym : Symmetric R. + Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. + + + (* (** [ForallOrdPairs R] is compatible with [equivlistA] over the lists without duplicates, as long as the relation [R] @@ -448,594 +448,594 @@ Qed. *) -(** Compatibility of [ForallOrdPairs] with respect to [inclA]. *) - -Lemma ForallOrdPairs_inclA : forall l l', - NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. -Proof. -intros l l'. induction l' as [|x l' IH]. -- constructor. -- intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. - rewrite Forall_forall; intros y Hy. - assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto). - apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx'). - assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto). - apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy'). - rewrite Hxx', Hyy'. - destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto. - absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto. -Qed. - - -(** Two-argument functions that allow to reorder their arguments. *) -Definition transpose (f : A -> B -> B) := - forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). - -(** A version of transpose with restriction on where it should hold *) -Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := - forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). - -Variable TraR :transpose_restr R f. - -Lemma fold_right_commutes_restr : - forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). -Proof. -intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x H. -- reflexivity. -- transitivity (f a (f x (fold_right f i (s1++s2)))). - + apply Comp; auto. - apply IHs1. - invlist ForallOrdPairs; auto. - + apply TraR. - invlist ForallOrdPairs; auto. - match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- R a x => - rewrite Forall_forall in H0; apply H0 - end. - apply in_or_app; simpl; auto. -Qed. - -Lemma fold_right_equivlistA_restr : - forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). -Proof. - intros s; induction s as [|x l Hrec]. - - intros s'; destruct s' as [|a s']; simpl. - + intros; reflexivity. - + unfold equivlistA; intros H H0 H1 H2. - destruct (H2 a). - assert (InA a nil) by auto; inv. - - intros s' N N' F E; simpl in *. - assert (InA x s') as H by (rewrite <- (E x); auto). - destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). - subst s'. - transitivity (f x (fold_right f i (s1++s2))). - + apply Comp; auto. - apply Hrec; auto. - * inv; auto. - * eapply NoDupA_split; eauto. - * invlist ForallOrdPairs; auto. - * eapply equivlistA_NoDupA_split; eauto. - + transitivity (f y (fold_right f i (s1++s2))). - * apply Comp; auto. reflexivity. - * symmetry; apply fold_right_commutes_restr. - apply ForallOrdPairs_inclA with (x::l); auto. - red; intros; rewrite E; auto. -Qed. - -Lemma fold_right_add_restr : - forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. - intros s' s x **; apply (@fold_right_equivlistA_restr s' (x::s)); auto. -Qed. - -End Fold_With_Restriction. - -(** we now state similar results, but without restriction on transpose. *) - -Variable Tra :transpose f. - -Lemma fold_right_commutes : forall s1 s2 x, - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). -Proof. -intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x. -- reflexivity. -- transitivity (f a (f x (fold_right f i (s1++s2)))); auto. - apply Comp; auto. -Qed. - -Lemma fold_right_equivlistA : - forall s s', NoDupA s -> NoDupA s' -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). -Proof. -intros; apply (fold_right_equivlistA_restr (R:=fun _ _ => True)); - repeat red; auto. -apply ForallPairs_ForallOrdPairs; try red; auto. -Qed. - -Lemma fold_right_add : - forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. - intros s' s x **; apply (@fold_right_equivlistA s' (x::s)); auto. -Qed. - -End Fold. - - -Section Fold2. - -Variable B:Type. -Variable eqB:B->B->Prop. -Variable st:Equivalence eqB. -Variable f:A->B->B. -Variable Comp:Proper (eqA==>eqB==>eqB) f. - - -Lemma fold_right_eqlistA2 : - forall s s' (i j:B) (heqij: eqB i j) (heqss': eqlistA s s'), - eqB (fold_right f i s) (fold_right f j s'). -Proof. - intros s. - induction s as [|a s IHs];intros s' i j heqij heqss'. - - inversion heqss'. - subst. - simpl. - assumption. - - inversion heqss'. - subst. - simpl. - apply Comp. - + assumption. - + apply IHs;assumption. -Qed. - -Section Fold2_With_Restriction. - -Variable R : A -> A -> Prop. -Hypothesis R_sym : Symmetric R. -Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. - -(** Two-argument functions that allow to reorder their arguments. *) -Definition transpose2 (f : A -> B -> B) := - forall (x y : A) (z z': B), eqB z z' -> eqB (f x (f y z)) (f y (f x z')). - -(** A version of transpose with restriction on where it should hold *) -Definition transpose_restr2 (R : A -> A -> Prop)(f : A -> B -> B) := - forall (x y : A) (z z': B), R x y -> eqB z z' -> eqB (f x (f y z)) (f y (f x z')). - -Variable TraR :transpose_restr2 R f. - -Lemma fold_right_commutes_restr2 : - forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) -> - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))). -Proof. -intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x i j heqij ?. -- apply Comp. - + destruct eqA_equiv. apply Equivalence_Reflexive. - + eapply fold_right_eqlistA2. - * assumption. - * reflexivity. -- transitivity (f a (f x (fold_right f j (s1++s2)))). - + apply Comp; auto. - eapply IHs1. - * assumption. - * invlist ForallOrdPairs; auto. - + apply TraR. - * invlist ForallOrdPairs; auto. - match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- _ => - rewrite Forall_forall in H0; apply H0 + (** Compatibility of [ForallOrdPairs] with respect to [inclA]. *) + + Lemma ForallOrdPairs_inclA : forall l l', + NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. + Proof. + intros l l'. induction l' as [|x l' IH]. + - constructor. + - intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. + rewrite Forall_forall; intros y Hy. + assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto). + apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx'). + assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto). + apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy'). + rewrite Hxx', Hyy'. + destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto. + absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto. + Qed. + + + (** Two-argument functions that allow to reorder their arguments. *) + Definition transpose (f : A -> B -> B) := + forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). + + (** A version of transpose with restriction on where it should hold *) + Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := + forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). + + Variable TraR :transpose_restr R f. + + Lemma fold_right_commutes_restr : + forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). + Proof. + intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x H. + - reflexivity. + - transitivity (f a (f x (fold_right f i (s1++s2)))). + + apply Comp; auto. + apply IHs1. + invlist ForallOrdPairs; auto. + + apply TraR. + invlist ForallOrdPairs; auto. + match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- R a x => + rewrite Forall_forall in H0; apply H0 + end. + apply in_or_app; simpl; auto. + Qed. + + Lemma fold_right_equivlistA_restr : + forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). + Proof. + intros s; induction s as [|x l Hrec]. + - intros s'; destruct s' as [|a s']; simpl. + + intros; reflexivity. + + unfold equivlistA; intros H H0 H1 H2. + destruct (H2 a). + assert (InA a nil) by auto; inv. + - intros s' N N' F E; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). + destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). + subst s'. + transitivity (f x (fold_right f i (s1++s2))). + + apply Comp; auto. + apply Hrec; auto. + * inv; auto. + * eapply NoDupA_split; eauto. + * invlist ForallOrdPairs; auto. + * eapply equivlistA_NoDupA_split; eauto. + + transitivity (f y (fold_right f i (s1++s2))). + * apply Comp; auto. reflexivity. + * symmetry; apply fold_right_commutes_restr. + apply ForallOrdPairs_inclA with (x::l); auto. + red; intros; rewrite E; auto. + Qed. + + Lemma fold_right_add_restr : + forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). + Proof. + intros s' s x **; apply (@fold_right_equivlistA_restr s' (x::s)); auto. + Qed. + + End Fold_With_Restriction. + + (** we now state similar results, but without restriction on transpose. *) + + Variable Tra :transpose f. + + Lemma fold_right_commutes : forall s1 s2 x, + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). + Proof. + intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x. + - reflexivity. + - transitivity (f a (f x (fold_right f i (s1++s2)))); auto. + apply Comp; auto. + Qed. + + Lemma fold_right_equivlistA : + forall s s', NoDupA s -> NoDupA s' -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). + Proof. + intros; apply (fold_right_equivlistA_restr (R:=fun _ _ => True)); + repeat red; auto. + apply ForallPairs_ForallOrdPairs; try red; auto. + Qed. + + Lemma fold_right_add : + forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). + Proof. + intros s' s x **; apply (@fold_right_equivlistA s' (x::s)); auto. + Qed. + + End Fold. + + + Section Fold2. + + Variable B:Type. + Variable eqB:B->B->Prop. + Variable st:Equivalence eqB. + Variable f:A->B->B. + Variable Comp:Proper (eqA==>eqB==>eqB) f. + + + Lemma fold_right_eqlistA2 : + forall s s' (i j:B) (heqij: eqB i j) (heqss': eqlistA s s'), + eqB (fold_right f i s) (fold_right f j s'). + Proof. + intros s. + induction s as [|a s IHs];intros s' i j heqij heqss'. + - inversion heqss'. + subst. + simpl. + assumption. + - inversion heqss'. + subst. + simpl. + apply Comp. + + assumption. + + apply IHs;assumption. + Qed. + + Section Fold2_With_Restriction. + + Variable R : A -> A -> Prop. + Hypothesis R_sym : Symmetric R. + Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. + + (** Two-argument functions that allow to reorder their arguments. *) + Definition transpose2 (f : A -> B -> B) := + forall (x y : A) (z z': B), eqB z z' -> eqB (f x (f y z)) (f y (f x z')). + + (** A version of transpose with restriction on where it should hold *) + Definition transpose_restr2 (R : A -> A -> Prop)(f : A -> B -> B) := + forall (x y : A) (z z': B), R x y -> eqB z z' -> eqB (f x (f y z)) (f y (f x z')). + + Variable TraR :transpose_restr2 R f. + + Lemma fold_right_commutes_restr2 : + forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) -> + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))). + Proof. + intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x i j heqij ?. + - apply Comp. + + destruct eqA_equiv. apply Equivalence_Reflexive. + + eapply fold_right_eqlistA2. + * assumption. + * reflexivity. + - transitivity (f a (f x (fold_right f j (s1++s2)))). + + apply Comp; auto. + eapply IHs1. + * assumption. + * invlist ForallOrdPairs; auto. + + apply TraR. + * invlist ForallOrdPairs; auto. + match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- _ => + rewrite Forall_forall in H0; apply H0 + end. + apply in_or_app; simpl; auto. + * reflexivity. + Qed. + + Lemma fold_right_equivlistA_restr2 : + forall s s' i j, + NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> + equivlistA s s' -> eqB i j -> + eqB (fold_right f i s) (fold_right f j s'). + Proof. + intros s; induction s as [|x l Hrec]. + { intros s'; destruct s' as [|a s']; simpl. + - intros. assumption. + - unfold equivlistA; intros ? ? H H0 H1 H2 **. + destruct (H2 a). + assert (InA a nil) by auto; inv. + } + intros s' i j N N' F E eqij; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). + destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). + subst s'. + transitivity (f x (fold_right f j (s1++s2))). + - apply Comp; auto. + apply Hrec; auto. + + inv; auto. + + eapply NoDupA_split; eauto. + + invlist ForallOrdPairs; auto. + + eapply equivlistA_NoDupA_split; eauto. + - transitivity (f y (fold_right f i (s1++s2))). + + apply Comp; auto. + symmetry. + apply fold_right_eqlistA2. + * assumption. + * reflexivity. + + symmetry. + apply fold_right_commutes_restr2. + * symmetry. + assumption. + * apply ForallOrdPairs_inclA with (x::l); auto. + red; intros; rewrite E; auto. + Qed. + + Lemma fold_right_add_restr2 : + forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). + Proof. + intros s' s i j x **; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. + Qed. + + End Fold2_With_Restriction. + + Variable Tra :transpose2 f. + + Lemma fold_right_commutes2 : forall s1 s2 i x x', + eqA x x' -> + eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))). + Proof. + intros s1; induction s1 as [|a s1 IHs1];simpl;intros s2 i x x' H. + - apply Comp;auto. + reflexivity. + - transitivity (f a (f x' (fold_right f i (s1++s2)))); auto. + + apply Comp;auto. + + apply Tra. + reflexivity. + Qed. + + Lemma fold_right_equivlistA2 : + forall s s' i j, NoDupA s -> NoDupA s' -> eqB i j -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). + Proof. + red in Tra. + intros; apply (fold_right_equivlistA_restr2 (R:=fun _ _ => True)); + repeat red; auto. + apply ForallPairs_ForallOrdPairs; try red; auto. + Qed. + + Lemma fold_right_add2 : + forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). + Proof. + intros s' s i j x **. + replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto. + eapply fold_right_equivlistA2;auto. + Qed. + + End Fold2. + + Section Remove. + + Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. + + Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. + Proof. + intros x l; induction l as [|a l IHl]. + - right; auto. + intro; inv. + - destruct (eqA_dec x a). + + left; auto. + + destruct IHl. + * left; auto. + * right; intro; inv; contradiction. + Defined. + + Fixpoint removeA (x : A) (l : list A) : list A := + match l with + | nil => nil + | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) end. - apply in_or_app; simpl; auto. - * reflexivity. -Qed. - -Lemma fold_right_equivlistA_restr2 : - forall s s' i j, - NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> - equivlistA s s' -> eqB i j -> - eqB (fold_right f i s) (fold_right f j s'). -Proof. - intros s; induction s as [|x l Hrec]. - { intros s'; destruct s' as [|a s']; simpl. - - intros. assumption. - - unfold equivlistA; intros ? ? H H0 H1 H2 **. - destruct (H2 a). - assert (InA a nil) by auto; inv. - } - intros s' i j N N' F E eqij; simpl in *. - assert (InA x s') as H by (rewrite <- (E x); auto). - destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). - subst s'. - transitivity (f x (fold_right f j (s1++s2))). - - apply Comp; auto. - apply Hrec; auto. - + inv; auto. - + eapply NoDupA_split; eauto. - + invlist ForallOrdPairs; auto. - + eapply equivlistA_NoDupA_split; eauto. - - transitivity (f y (fold_right f i (s1++s2))). - + apply Comp; auto. - symmetry. - apply fold_right_eqlistA2. - * assumption. - * reflexivity. - + symmetry. - apply fold_right_commutes_restr2. - * symmetry. - assumption. - * apply ForallOrdPairs_inclA with (x::l); auto. - red; intros; rewrite E; auto. -Qed. - -Lemma fold_right_add_restr2 : - forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). -Proof. - intros s' s i j x **; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. -Qed. - -End Fold2_With_Restriction. - -Variable Tra :transpose2 f. - -Lemma fold_right_commutes2 : forall s1 s2 i x x', - eqA x x' -> - eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))). -Proof. - intros s1; induction s1 as [|a s1 IHs1];simpl;intros s2 i x x' H. -- apply Comp;auto. - reflexivity. -- transitivity (f a (f x' (fold_right f i (s1++s2)))); auto. - + apply Comp;auto. - + apply Tra. - reflexivity. -Qed. - -Lemma fold_right_equivlistA2 : - forall s s' i j, NoDupA s -> NoDupA s' -> eqB i j -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). -Proof. -red in Tra. -intros; apply (fold_right_equivlistA_restr2 (R:=fun _ _ => True)); -repeat red; auto. -apply ForallPairs_ForallOrdPairs; try red; auto. -Qed. - -Lemma fold_right_add2 : - forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). -Proof. - intros s' s i j x **. - replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto. - eapply fold_right_equivlistA2;auto. -Qed. - -End Fold2. - -Section Remove. - -Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. - -Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. -Proof. -intros x l; induction l as [|a l IHl]. -- right; auto. - intro; inv. -- destruct (eqA_dec x a). - + left; auto. - + destruct IHl. - * left; auto. - * right; intro; inv; contradiction. -Defined. - -Fixpoint removeA (x : A) (l : list A) : list A := - match l with - | nil => nil - | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) - end. - -Lemma removeA_filter : forall x l, - removeA x l = filter (fun y => if eqA_dec x y then false else true) l. -Proof. -intros x l; induction l as [|a l IHl]; simpl; auto. -destruct (eqA_dec x a); auto. -rewrite IHl; auto. -Qed. - -Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. -Proof. -intros l; induction l as [|a l IHl]; simpl; auto. -- intros x y; split. - + intro; inv. - + destruct 1; inv. -- intros x y. - destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. - + rewrite IHl; split; destruct 1; split; auto. - inv; auto. - match goal with H0 : ~ eqA x y |- _ => destruct H0 end; transitivity a; auto. - + split. - * intro; inv. - -- split; auto. - contradict Hnot. - transitivity y; auto. - -- match goal with H0 : InA y (removeA x l) |- _ => - rewrite (IHl x y) in H0; destruct H0; auto - end. - * destruct 1; inv; auto. - right; rewrite IHl; auto. -Qed. - -Lemma removeA_NoDupA : - forall s x, NoDupA s -> NoDupA (removeA x s). -Proof. -intros s; induction s as [|a s IHs]; simpl; intros x ?. -- auto. -- inv. - destruct (eqA_dec x a); simpl; auto. - constructor; auto. - rewrite removeA_InA. - intuition. -Qed. - -Lemma removeA_equivlistA : forall l l' x, - ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). -Proof. -unfold equivlistA; intros l l' x H H0 x0. -rewrite removeA_InA. -split; intros H1. -- rewrite <- H0; split; auto. - contradict H. - apply InA_eqA with x0; auto. -- rewrite <- (H0 x0) in H1. - destruct H1. - inv; auto. - match goal with H2 : ~ eqA x x0 |- _ => elim H2; auto end. -Qed. - -End Remove. - - - -(** Results concerning lists modulo [eqA] and [ltA] *) - -Variable ltA : A -> A -> Prop. -Hypothesis ltA_strorder : StrictOrder ltA. -Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. - -Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). - -#[local] -Hint Resolve sotrans : core. - -Notation InfA:=(lelistA ltA). -Notation SortA:=(sort ltA). - -#[local] -Hint Constructors lelistA sort : core. - -Lemma InfA_ltA : - forall l x y, ltA x y -> InfA y l -> InfA x l. -Proof. - intros l; destruct l; constructor. inv; eauto. -Qed. - -#[global] Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. -Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) - intros x x' Hxx' l l' Hll'. - inversion_clear Hll'. - - intuition. - - split; intro; inv; constructor. - + match goal with H : eqA _ _ |- _ => rewrite <- Hxx', <- H; auto end. - + match goal with H : eqA _ _ |- _ => rewrite Hxx', H; auto end. -Qed. - -(** For compatibility, can be deduced from [InfA_compat] *) -Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. -Proof using eqA_equiv ltA_compat. - intros H; now rewrite H. -Qed. -#[local] -Hint Immediate InfA_ltA InfA_eqA : core. -Lemma SortA_InfA_InA : - forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. -Proof. - intros l; induction l as [|a l IHl]. - - intros x a **. inv. - - intros x a0 **. inv. - + setoid_replace x with a; auto. - + eauto. -Qed. - -Lemma In_InfA : - forall l x, (forall y, In y l -> ltA x y) -> InfA x l. -Proof. - intros l; induction l; simpl; intros; constructor; auto. -Qed. - -Lemma InA_InfA : - forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. -Proof. - intros l; induction l; simpl; intros; constructor; auto. -Qed. - -(* In fact, this may be used as an alternative definition for InfA: *) - -Lemma InfA_alt : - forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). -Proof. -split. -- intros; eapply SortA_InfA_InA; eauto. -- apply InA_InfA. -Qed. - -Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). -Proof. - intros l1; induction l1; simpl; auto. - intros; inv; auto. -Qed. - -Lemma SortA_app : - forall l1 l2, SortA l1 -> SortA l2 -> - (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> - SortA (l1 ++ l2). -Proof. - intros l1; induction l1; intros l2; simpl in *; intuition. - inv. - constructor; auto. - apply InfA_app; auto. - destruct l2; auto. -Qed. - -Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. -Proof. - intros l; induction l as [|x l' H]; auto. - intros H0. - inv. - constructor; auto. - intro. - apply (StrictOrder_Irreflexive x). - eapply SortA_InfA_InA; eauto. -Qed. - - -(** Some results about [eqlistA] *) - -Section EqlistA. - -Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. -Proof. -induction 1; auto; simpl; congruence. -Qed. - -#[global] Instance app_eqlistA_compat : - Proper (eqlistA==>eqlistA==>eqlistA) (@app A). -Proof. - repeat red; induction 1; simpl; auto. -Qed. - -(** For compatibility, can be deduced from app_eqlistA_compat **) -Lemma eqlistA_app : forall l1 l1' l2 l2', - eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). -Proof. -intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity. -Qed. - -Lemma eqlistA_rev_app : forall l1 l1', - eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> - eqlistA ((rev l1)++l2) ((rev l1')++l2'). -Proof. -induction 1; auto. -simpl; intros. -do 2 rewrite <- app_assoc; simpl; auto. -Qed. - -#[global] Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). -Proof. -repeat red. intros x y ?. -rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). -apply eqlistA_rev_app; auto. -Qed. - -Lemma eqlistA_rev : forall l1 l1', - eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). -Proof. -apply rev_eqlistA_compat. -Qed. - -Lemma SortA_equivlistA_eqlistA : forall l l', - SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. -Proof. -intros l; induction l as [|a l IHl]; intros l'; destruct l' as [|a0 l']; simpl; intros H H0 H1; auto. -- destruct (H1 a0); assert (InA a0 nil) by auto; inv. -- destruct (H1 a); assert (InA a nil) by auto; inv. -- inv. - assert (forall y, InA y l -> ltA a y) by - (intros; eapply (SortA_InfA_InA (l:=l)); eauto). - assert (forall y, InA y l' -> ltA a0 y) by - (intros; eapply (SortA_InfA_InA (l:=l')); eauto). - do 2 match goal with H : InfA _ _ |- _ => clear H end. - assert (eqA a a0). - + destruct (H1 a). - destruct (H1 a0). - assert (InA a (a0::l')) by auto. inv; auto. - assert (InA a0 (a::l)) by auto. inv; auto. - elim (StrictOrder_Irreflexive a); eauto. - + constructor; auto. - apply IHl; auto. - intros x; split; intros. - * destruct (H1 x). - assert (InA x (a0::l')) by auto. inv; auto. - match goal with H3 : eqA a a0, H4 : InA x l, H9 : eqA x a0 |- InA x l' => - rewrite H9,<-H3 in H4 - end. - elim (StrictOrder_Irreflexive a); eauto. - * destruct (H1 x). - assert (InA x (a::l)) by auto. inv; auto. - match goal with H3 : eqA a a0, H4 : InA x l', H9 : eqA x a |- InA x l => - rewrite H9,H3 in H4 - end. - elim (StrictOrder_Irreflexive a0); eauto. -Qed. - -End EqlistA. - -(** A few things about [filter] *) - -Section Filter. - -Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). -Proof. -intros f l; induction l as [|a l IHl]; simpl; auto. -intros; inv; auto. -destruct (f a); auto. -constructor; auto. -apply In_InfA; auto. -intros y H. -rewrite filter_In in H; destruct H. -eapply SortA_InfA_InA; eauto. -Qed. -Arguments eq {A} x _. - -Lemma filter_InA : forall f, Proper (eqA==>eq) f -> - forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. -Proof. -(* Unset Mangle Names. *) -clear sotrans ltA ltA_strorder ltA_compat. -intros f H l x; do 2 rewrite InA_alt; intuition; - match goal with Hex' : exists _, _ |- _ => rename Hex' into Hex end. -- destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. -- destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; intuition. - rewrite (H _ _ H0); auto. -- destruct Hex as (y,(H0,H1)); exists y; rewrite filter_In; intuition. - rewrite <- (H _ _ H0); auto. -Qed. - -Lemma filter_split : - forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> - forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. -Proof. -intros f H l; induction l as [|a l IHl]; simpl; intros H0; auto. -inv. -match goal with H1' : SortA l, H2' : InfA a l |- _ => rename H1' into H1, H2' into H2 end. -rewrite IHl at 1; auto. -case_eq (f a); simpl; intros; auto. -assert (forall e, In e l -> f e = false) as H3. { - intros e H3. - assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). - case_eq (f e); simpl; intros; auto. - elim (StrictOrder_Irreflexive e). - transitivity a; auto. -} -replace (List.filter f l) with (@nil A); auto. -generalize H3; clear; induction l as [|a l IHl]; simpl; auto. -case_eq (f a); auto; intros H H3. -rewrite H3 in H; auto; try discriminate. -Qed. - -End Filter. + Lemma removeA_filter : forall x l, + removeA x l = filter (fun y => if eqA_dec x y then false else true) l. + Proof. + intros x l; induction l as [|a l IHl]; simpl; auto. + destruct (eqA_dec x a); auto. + rewrite IHl; auto. + Qed. + + Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. + Proof. + intros l; induction l as [|a l IHl]; simpl; auto. + - intros x y; split. + + intro; inv. + + destruct 1; inv. + - intros x y. + destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. + + rewrite IHl; split; destruct 1; split; auto. + inv; auto. + match goal with H0 : ~ eqA x y |- _ => destruct H0 end; transitivity a; auto. + + split. + * intro; inv. + -- split; auto. + contradict Hnot. + transitivity y; auto. + -- match goal with H0 : InA y (removeA x l) |- _ => + rewrite (IHl x y) in H0; destruct H0; auto + end. + * destruct 1; inv; auto. + right; rewrite IHl; auto. + Qed. + + Lemma removeA_NoDupA : + forall s x, NoDupA s -> NoDupA (removeA x s). + Proof. + intros s; induction s as [|a s IHs]; simpl; intros x ?. + - auto. + - inv. + destruct (eqA_dec x a); simpl; auto. + constructor; auto. + rewrite removeA_InA. + intuition. + Qed. + + Lemma removeA_equivlistA : forall l l' x, + ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). + Proof. + unfold equivlistA; intros l l' x H H0 x0. + rewrite removeA_InA. + split; intros H1. + - rewrite <- H0; split; auto. + contradict H. + apply InA_eqA with x0; auto. + - rewrite <- (H0 x0) in H1. + destruct H1. + inv; auto. + match goal with H2 : ~ eqA x x0 |- _ => elim H2; auto end. + Qed. + + End Remove. + + + + (** Results concerning lists modulo [eqA] and [ltA] *) + + Variable ltA : A -> A -> Prop. + Hypothesis ltA_strorder : StrictOrder ltA. + Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. + + Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). + + #[local] + Hint Resolve sotrans : core. + + Notation InfA:=(lelistA ltA). + Notation SortA:=(sort ltA). + + #[local] + Hint Constructors lelistA sort : core. + + Lemma InfA_ltA : + forall l x y, ltA x y -> InfA y l -> InfA x l. + Proof. + intros l; destruct l; constructor. inv; eauto. + Qed. + + #[global] Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. + Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) + intros x x' Hxx' l l' Hll'. + inversion_clear Hll'. + - intuition. + - split; intro; inv; constructor. + + match goal with H : eqA _ _ |- _ => rewrite <- Hxx', <- H; auto end. + + match goal with H : eqA _ _ |- _ => rewrite Hxx', H; auto end. + Qed. + + (** For compatibility, can be deduced from [InfA_compat] *) + Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. + Proof using eqA_equiv ltA_compat. + intros H; now rewrite H. + Qed. + #[local] + Hint Immediate InfA_ltA InfA_eqA : core. + + Lemma SortA_InfA_InA : + forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. + Proof. + intros l; induction l as [|a l IHl]. + - intros x a **. inv. + - intros x a0 **. inv. + + setoid_replace x with a; auto. + + eauto. + Qed. + + Lemma In_InfA : + forall l x, (forall y, In y l -> ltA x y) -> InfA x l. + Proof. + intros l; induction l; simpl; intros; constructor; auto. + Qed. + + Lemma InA_InfA : + forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. + Proof. + intros l; induction l; simpl; intros; constructor; auto. + Qed. + + (* In fact, this may be used as an alternative definition for InfA: *) + + Lemma InfA_alt : + forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). + Proof. + split. + - intros; eapply SortA_InfA_InA; eauto. + - apply InA_InfA. + Qed. + + Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). + Proof. + intros l1; induction l1; simpl; auto. + intros; inv; auto. + Qed. + + Lemma SortA_app : + forall l1 l2, SortA l1 -> SortA l2 -> + (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> + SortA (l1 ++ l2). + Proof. + intros l1; induction l1; intros l2; simpl in *; intuition. + inv. + constructor; auto. + apply InfA_app; auto. + destruct l2; auto. + Qed. + + Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. + Proof. + intros l; induction l as [|x l' H]; auto. + intros H0. + inv. + constructor; auto. + intro. + apply (StrictOrder_Irreflexive x). + eapply SortA_InfA_InA; eauto. + Qed. + + + (** Some results about [eqlistA] *) + + Section EqlistA. + + Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. + Proof. + induction 1; auto; simpl; congruence. + Qed. + + #[global] Instance app_eqlistA_compat : + Proper (eqlistA==>eqlistA==>eqlistA) (@app A). + Proof. + repeat red; induction 1; simpl; auto. + Qed. + + (** For compatibility, can be deduced from app_eqlistA_compat **) + Lemma eqlistA_app : forall l1 l1' l2 l2', + eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). + Proof. + intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity. + Qed. + + Lemma eqlistA_rev_app : forall l1 l1', + eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> + eqlistA ((rev l1)++l2) ((rev l1')++l2'). + Proof. + induction 1; auto. + simpl; intros. + do 2 rewrite <- app_assoc; simpl; auto. + Qed. + + #[global] Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). + Proof. + repeat red. intros x y ?. + rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). + apply eqlistA_rev_app; auto. + Qed. + + Lemma eqlistA_rev : forall l1 l1', + eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). + Proof. + apply rev_eqlistA_compat. + Qed. + + Lemma SortA_equivlistA_eqlistA : forall l l', + SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. + Proof. + intros l; induction l as [|a l IHl]; intros l'; destruct l' as [|a0 l']; simpl; intros H H0 H1; auto. + - destruct (H1 a0); assert (InA a0 nil) by auto; inv. + - destruct (H1 a); assert (InA a nil) by auto; inv. + - inv. + assert (forall y, InA y l -> ltA a y) by + (intros; eapply (SortA_InfA_InA (l:=l)); eauto). + assert (forall y, InA y l' -> ltA a0 y) by + (intros; eapply (SortA_InfA_InA (l:=l')); eauto). + do 2 match goal with H : InfA _ _ |- _ => clear H end. + assert (eqA a a0). + + destruct (H1 a). + destruct (H1 a0). + assert (InA a (a0::l')) by auto. inv; auto. + assert (InA a0 (a::l)) by auto. inv; auto. + elim (StrictOrder_Irreflexive a); eauto. + + constructor; auto. + apply IHl; auto. + intros x; split; intros. + * destruct (H1 x). + assert (InA x (a0::l')) by auto. inv; auto. + match goal with H3 : eqA a a0, H4 : InA x l, H9 : eqA x a0 |- InA x l' => + rewrite H9,<-H3 in H4 + end. + elim (StrictOrder_Irreflexive a); eauto. + * destruct (H1 x). + assert (InA x (a::l)) by auto. inv; auto. + match goal with H3 : eqA a a0, H4 : InA x l', H9 : eqA x a |- InA x l => + rewrite H9,H3 in H4 + end. + elim (StrictOrder_Irreflexive a0); eauto. + Qed. + + End EqlistA. + + (** A few things about [filter] *) + + Section Filter. + + Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). + Proof. + intros f l; induction l as [|a l IHl]; simpl; auto. + intros; inv; auto. + destruct (f a); auto. + constructor; auto. + apply In_InfA; auto. + intros y H. + rewrite filter_In in H; destruct H. + eapply SortA_InfA_InA; eauto. + Qed. + Arguments eq {A} x _. + + Lemma filter_InA : forall f, Proper (eqA==>eq) f -> + forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. + Proof. + (* Unset Mangle Names. *) + clear sotrans ltA ltA_strorder ltA_compat. + intros f H l x; do 2 rewrite InA_alt; intuition; + match goal with Hex' : exists _, _ |- _ => rename Hex' into Hex end. + - destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. + - destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; intuition. + rewrite (H _ _ H0); auto. + - destruct Hex as (y,(H0,H1)); exists y; rewrite filter_In; intuition. + rewrite <- (H _ _ H0); auto. + Qed. + + Lemma filter_split : + forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> + forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. + Proof. + intros f H l; induction l as [|a l IHl]; simpl; intros H0; auto. + inv. + match goal with H1' : SortA l, H2' : InfA a l |- _ => rename H1' into H1, H2' into H2 end. + rewrite IHl at 1; auto. + case_eq (f a); simpl; intros; auto. + assert (forall e, In e l -> f e = false) as H3. { + intros e H3. + assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). + case_eq (f e); simpl; intros; auto. + elim (StrictOrder_Irreflexive e). + transitivity a; auto. + } + replace (List.filter f l) with (@nil A); auto. + generalize H3; clear; induction l as [|a l IHl]; simpl; auto. + case_eq (f a); auto; intros H H3. + rewrite H3 in H; auto; try discriminate. + Qed. + + End Filter. End Type_with_equality. #[global] @@ -1046,52 +1046,52 @@ Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _. Section Find. -Variable A B : Type. -Variable eqA : A -> A -> Prop. -Hypothesis eqA_equiv : Equivalence eqA. -Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. - -Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := - match l with - | nil => None - | (a,b)::l => if f a then Some b else findA f l - end. - -Lemma findA_NoDupA : - forall l a b, - NoDupA (fun p p' => eqA (fst p) (fst p')) l -> - (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <-> - findA (fun a' => if eqA_dec a a' then true else false) l = Some b). -Proof. -set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). -set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). -intros l; induction l as [|a l IHl]; intros a0 b H; simpl. -- split; intros H0; try discriminate. - invlist InA. -- destruct a as (a',b'); rename a0 into a. - invlist NoDupA. - split; intros. - + invlist InA. - * match goal with H2 : eqke (a, b) (a', b') |- _ => compute in H2; destruct H2 end. - subst b'. - destruct (eqA_dec a a'); intuition. - * destruct (eqA_dec a a') as [HeqA|]; simpl. - -- match goal with H0 : ~ InA eqk (a', b') l |- _ => contradict H0 end. - match goal with H2 : InA eqke (a, b) l |- _ => revert HeqA H2; clear - eqA_equiv end. - induction l. - ++ intros; invlist InA. - ++ intros; invlist InA; auto. - match goal with |- InA eqk _ (?p :: _) => destruct p as [a0 b0] end. - match goal with H : eqke (a, b) (a0, b0) |- _ => compute in H; destruct H end. - subst b. - left; auto. - compute. - transitivity a; auto. symmetry; auto. - -- rewrite <- IHl; auto. - + destruct (eqA_dec a a'); simpl in *. - * left; split; simpl; congruence. - * right. rewrite IHl; auto. -Qed. + Variable A B : Type. + Variable eqA : A -> A -> Prop. + Hypothesis eqA_equiv : Equivalence eqA. + Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. + + Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := + match l with + | nil => None + | (a,b)::l => if f a then Some b else findA f l + end. + + Lemma findA_NoDupA : + forall l a b, + NoDupA (fun p p' => eqA (fst p) (fst p')) l -> + (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <-> + findA (fun a' => if eqA_dec a a' then true else false) l = Some b). + Proof. + set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). + set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). + intros l; induction l as [|a l IHl]; intros a0 b H; simpl. + - split; intros H0; try discriminate. + invlist InA. + - destruct a as (a',b'); rename a0 into a. + invlist NoDupA. + split; intros. + + invlist InA. + * match goal with H2 : eqke (a, b) (a', b') |- _ => compute in H2; destruct H2 end. + subst b'. + destruct (eqA_dec a a'); intuition. + * destruct (eqA_dec a a') as [HeqA|]; simpl. + -- match goal with H0 : ~ InA eqk (a', b') l |- _ => contradict H0 end. + match goal with H2 : InA eqke (a, b) l |- _ => revert HeqA H2; clear - eqA_equiv end. + induction l. + ++ intros; invlist InA. + ++ intros; invlist InA; auto. + match goal with |- InA eqk _ (?p :: _) => destruct p as [a0 b0] end. + match goal with H : eqke (a, b) (a0, b0) |- _ => compute in H; destruct H end. + subst b. + left; auto. + compute. + transitivity a; auto. symmetry; auto. + -- rewrite <- IHl; auto. + + destruct (eqA_dec a a'); simpl in *. + * left; split; simpl; congruence. + * right. rewrite IHl; auto. + Qed. End Find. diff --git a/theories/Sorting/SetoidPermutation.v b/theories/Sorting/SetoidPermutation.v index 7f7266fc68..2bb816747f 100644 --- a/theories/Sorting/SetoidPermutation.v +++ b/theories/Sorting/SetoidPermutation.v @@ -21,186 +21,186 @@ Unset Strict Implicit. (** Contribution by Robbert Krebbers (Nijmegen University). *) Section Permutation. -Context {A : Type} (eqA : relation A) (e : Equivalence eqA). - -Inductive PermutationA : list A -> list A -> Prop := - | permA_nil: PermutationA nil nil - | permA_skip x₁ x₂ l₁ l₂ : - eqA x₁ x₂ -> PermutationA l₁ l₂ -> PermutationA (x₁ :: l₁) (x₂ :: l₂) - | permA_swap x y l : PermutationA (y :: x :: l) (x :: y :: l) - | permA_trans l₁ l₂ l₃ : - PermutationA l₁ l₂ -> PermutationA l₂ l₃ -> PermutationA l₁ l₃. -#[local] Hint Constructors PermutationA : core. - -#[global] Instance: Equivalence PermutationA. -Proof. - constructor. - - intro l. induction l; intuition. - - intros l₁ l₂. induction 1; eauto. apply permA_skip; intuition. - - exact permA_trans. -Qed. - -#[global] Instance PermutationA_cons : - Proper (eqA ==> PermutationA ==> PermutationA) (@cons A). -Proof. - repeat intro. now apply permA_skip. -Qed. - -Lemma PermutationA_app_head l₁ l₂ l : - PermutationA l₁ l₂ -> PermutationA (l ++ l₁) (l ++ l₂). -Proof. - induction l; trivial; intros. apply permA_skip; intuition. -Qed. - -#[global] Instance PermutationA_app : - Proper (PermutationA ==> PermutationA ==> PermutationA) (@app A). -Proof. - intros l₁ l₂ Pl k₁ k₂ Pk. - induction Pl. - - easy. - - now apply permA_skip. - - etransitivity. - * rewrite <-!app_comm_cons. now apply permA_swap. - * rewrite !app_comm_cons. now apply PermutationA_app_head. - - do 2 (etransitivity; try eassumption). - apply PermutationA_app_head. now symmetry. -Qed. - -Lemma PermutationA_app_tail l₁ l₂ l : - PermutationA l₁ l₂ -> PermutationA (l₁ ++ l) (l₂ ++ l). -Proof. - intros E. now rewrite E. -Qed. - -Lemma PermutationA_cons_append l x : - PermutationA (x :: l) (l ++ x :: nil). -Proof. - induction l. - - easy. - - simpl. rewrite <-IHl. intuition. -Qed. - -Lemma PermutationA_app_comm l₁ l₂ : - PermutationA (l₁ ++ l₂) (l₂ ++ l₁). -Proof. - induction l₁. - - now rewrite app_nil_r. - - rewrite <-app_comm_cons, IHl₁, app_comm_cons. - now rewrite PermutationA_cons_append, <-app_assoc. -Qed. - -Lemma PermutationA_cons_app l l₁ l₂ x : - PermutationA l (l₁ ++ l₂) -> PermutationA (x :: l) (l₁ ++ x :: l₂). -Proof. - intros E. rewrite E. - now rewrite app_comm_cons, (PermutationA_cons_append l₁ x), <- app_assoc. -Qed. - -Lemma PermutationA_middle l₁ l₂ x : - PermutationA (x :: l₁ ++ l₂) (l₁ ++ x :: l₂). -Proof. - now apply PermutationA_cons_app. -Qed. - -Lemma PermutationA_equivlistA l₁ l₂ : - PermutationA l₁ l₂ -> equivlistA eqA l₁ l₂. -Proof. - induction 1. - - reflexivity. - - now apply equivlistA_cons_proper. - - now apply equivlistA_permute_heads. - - etransitivity; eassumption. -Qed. - -Lemma NoDupA_equivlistA_PermutationA l₁ l₂ : - NoDupA eqA l₁ -> NoDupA eqA l₂ -> - equivlistA eqA l₁ l₂ -> PermutationA l₁ l₂. -Proof. - intros Pl₁. revert l₂. induction Pl₁ as [|x l₁ E1]. - - intros l₂ _ H₂. symmetry in H₂. now rewrite (equivlistA_nil_eq eqA). - - intros l₂ Pl₂ E2. - destruct (@InA_split _ eqA l₂ x) as [l₂h [y [l₂t [E3 ?]]]]. - { rewrite <-E2. intuition. } - subst. transitivity (y :: l₁); [intuition |]. - apply PermutationA_cons_app, IHPl₁. - + now apply NoDupA_split with y. - + apply equivlistA_NoDupA_split with x y; intuition. -Qed. - -Lemma Permutation_eqlistA_commute l₁ l₂ l₃ : - eqlistA eqA l₁ l₂ -> Permutation l₂ l₃ -> - exists l₂', Permutation l₁ l₂' /\ eqlistA eqA l₂' l₃. -Proof. - intros E P. revert l₁ E. - induction P; intros. - - inversion_clear E. now exists nil. - - inversion_clear E. - destruct (IHP l0) as (l0',(P',E')); trivial. clear IHP. - exists (x0::l0'). split; auto. - - inversion_clear E. inversion_clear H0. - exists (x1::x0::l1). now repeat constructor. - - clear P1 P2. - destruct (IHP1 _ E) as (l₁',(P₁,E₁)). - destruct (IHP2 _ E₁) as (l₂',(P₂,E₂)). - exists l₂'. split; trivial. econstructor; eauto. -Qed. - -Lemma PermutationA_decompose l₁ l₂ : - PermutationA l₁ l₂ -> - exists l, Permutation l₁ l /\ eqlistA eqA l l₂. -Proof. - induction 1. - - now exists nil. - - destruct IHPermutationA as (l,(P,E)). exists (x₁::l); auto. - - exists (x::y::l). split. - + constructor. - + reflexivity. - - destruct IHPermutationA1 as (l₁',(P,E)). - destruct IHPermutationA2 as (l₂',(P',E')). - destruct (@Permutation_eqlistA_commute l₁' l₂ l₂') as (l₁'',(P'',E'')); - trivial. - exists l₁''. split. - + now transitivity l₁'. - + now transitivity l₂'. -Qed. - -Lemma Permutation_PermutationA l₁ l₂ : - Permutation l₁ l₂ -> PermutationA l₁ l₂. -Proof. - induction 1. - - constructor. - - now constructor. - - apply permA_swap. - - econstructor; eauto. -Qed. - -Lemma eqlistA_PermutationA l₁ l₂ : - eqlistA eqA l₁ l₂ -> PermutationA l₁ l₂. -Proof. - induction 1; now constructor. -Qed. - -Lemma NoDupA_equivlistA_decompose l1 l2 : - NoDupA eqA l1 -> NoDupA eqA l2 -> equivlistA eqA l1 l2 -> - exists l, Permutation l1 l /\ eqlistA eqA l l2. -Proof. - intros. apply PermutationA_decompose. - now apply NoDupA_equivlistA_PermutationA. -Qed. - -Lemma PermutationA_preserves_NoDupA l₁ l₂ : - PermutationA l₁ l₂ -> NoDupA eqA l₁ -> NoDupA eqA l₂. -Proof. - induction 1; trivial. - - inversion_clear 1; constructor; auto. - apply PermutationA_equivlistA in H0. contradict H2. - now rewrite H, H0. - - inversion_clear 1. inversion_clear H1. constructor. - + contradict H. inversion_clear H; trivial. - elim H0. now constructor. - + constructor; trivial. - contradict H0. now apply InA_cons_tl. - - eauto. -Qed. + Context {A : Type} (eqA : relation A) (e : Equivalence eqA). + + Inductive PermutationA : list A -> list A -> Prop := + | permA_nil: PermutationA nil nil + | permA_skip x₁ x₂ l₁ l₂ : + eqA x₁ x₂ -> PermutationA l₁ l₂ -> PermutationA (x₁ :: l₁) (x₂ :: l₂) + | permA_swap x y l : PermutationA (y :: x :: l) (x :: y :: l) + | permA_trans l₁ l₂ l₃ : + PermutationA l₁ l₂ -> PermutationA l₂ l₃ -> PermutationA l₁ l₃. + #[local] Hint Constructors PermutationA : core. + + #[global] Instance: Equivalence PermutationA. + Proof. + constructor. + - intro l. induction l; intuition. + - intros l₁ l₂. induction 1; eauto. apply permA_skip; intuition. + - exact permA_trans. + Qed. + + #[global] Instance PermutationA_cons : + Proper (eqA ==> PermutationA ==> PermutationA) (@cons A). + Proof. + repeat intro. now apply permA_skip. + Qed. + + Lemma PermutationA_app_head l₁ l₂ l : + PermutationA l₁ l₂ -> PermutationA (l ++ l₁) (l ++ l₂). + Proof. + induction l; trivial; intros. apply permA_skip; intuition. + Qed. + + #[global] Instance PermutationA_app : + Proper (PermutationA ==> PermutationA ==> PermutationA) (@app A). + Proof. + intros l₁ l₂ Pl k₁ k₂ Pk. + induction Pl. + - easy. + - now apply permA_skip. + - etransitivity. + * rewrite <-!app_comm_cons. now apply permA_swap. + * rewrite !app_comm_cons. now apply PermutationA_app_head. + - do 2 (etransitivity; try eassumption). + apply PermutationA_app_head. now symmetry. + Qed. + + Lemma PermutationA_app_tail l₁ l₂ l : + PermutationA l₁ l₂ -> PermutationA (l₁ ++ l) (l₂ ++ l). + Proof. + intros E. now rewrite E. + Qed. + + Lemma PermutationA_cons_append l x : + PermutationA (x :: l) (l ++ x :: nil). + Proof. + induction l. + - easy. + - simpl. rewrite <-IHl. intuition. + Qed. + + Lemma PermutationA_app_comm l₁ l₂ : + PermutationA (l₁ ++ l₂) (l₂ ++ l₁). + Proof. + induction l₁. + - now rewrite app_nil_r. + - rewrite <-app_comm_cons, IHl₁, app_comm_cons. + now rewrite PermutationA_cons_append, <-app_assoc. + Qed. + + Lemma PermutationA_cons_app l l₁ l₂ x : + PermutationA l (l₁ ++ l₂) -> PermutationA (x :: l) (l₁ ++ x :: l₂). + Proof. + intros E. rewrite E. + now rewrite app_comm_cons, (PermutationA_cons_append l₁ x), <- app_assoc. + Qed. + + Lemma PermutationA_middle l₁ l₂ x : + PermutationA (x :: l₁ ++ l₂) (l₁ ++ x :: l₂). + Proof. + now apply PermutationA_cons_app. + Qed. + + Lemma PermutationA_equivlistA l₁ l₂ : + PermutationA l₁ l₂ -> equivlistA eqA l₁ l₂. + Proof. + induction 1. + - reflexivity. + - now apply equivlistA_cons_proper. + - now apply equivlistA_permute_heads. + - etransitivity; eassumption. + Qed. + + Lemma NoDupA_equivlistA_PermutationA l₁ l₂ : + NoDupA eqA l₁ -> NoDupA eqA l₂ -> + equivlistA eqA l₁ l₂ -> PermutationA l₁ l₂. + Proof. + intros Pl₁. revert l₂. induction Pl₁ as [|x l₁ E1]. + - intros l₂ _ H₂. symmetry in H₂. now rewrite (equivlistA_nil_eq eqA). + - intros l₂ Pl₂ E2. + destruct (@InA_split _ eqA l₂ x) as [l₂h [y [l₂t [E3 ?]]]]. + { rewrite <-E2. intuition. } + subst. transitivity (y :: l₁); [intuition |]. + apply PermutationA_cons_app, IHPl₁. + + now apply NoDupA_split with y. + + apply equivlistA_NoDupA_split with x y; intuition. + Qed. + + Lemma Permutation_eqlistA_commute l₁ l₂ l₃ : + eqlistA eqA l₁ l₂ -> Permutation l₂ l₃ -> + exists l₂', Permutation l₁ l₂' /\ eqlistA eqA l₂' l₃. + Proof. + intros E P. revert l₁ E. + induction P; intros. + - inversion_clear E. now exists nil. + - inversion_clear E. + destruct (IHP l0) as (l0',(P',E')); trivial. clear IHP. + exists (x0::l0'). split; auto. + - inversion_clear E. inversion_clear H0. + exists (x1::x0::l1). now repeat constructor. + - clear P1 P2. + destruct (IHP1 _ E) as (l₁',(P₁,E₁)). + destruct (IHP2 _ E₁) as (l₂',(P₂,E₂)). + exists l₂'. split; trivial. econstructor; eauto. + Qed. + + Lemma PermutationA_decompose l₁ l₂ : + PermutationA l₁ l₂ -> + exists l, Permutation l₁ l /\ eqlistA eqA l l₂. + Proof. + induction 1. + - now exists nil. + - destruct IHPermutationA as (l,(P,E)). exists (x₁::l); auto. + - exists (x::y::l). split. + + constructor. + + reflexivity. + - destruct IHPermutationA1 as (l₁',(P,E)). + destruct IHPermutationA2 as (l₂',(P',E')). + destruct (@Permutation_eqlistA_commute l₁' l₂ l₂') as (l₁'',(P'',E'')); + trivial. + exists l₁''. split. + + now transitivity l₁'. + + now transitivity l₂'. + Qed. + + Lemma Permutation_PermutationA l₁ l₂ : + Permutation l₁ l₂ -> PermutationA l₁ l₂. + Proof. + induction 1. + - constructor. + - now constructor. + - apply permA_swap. + - econstructor; eauto. + Qed. + + Lemma eqlistA_PermutationA l₁ l₂ : + eqlistA eqA l₁ l₂ -> PermutationA l₁ l₂. + Proof. + induction 1; now constructor. + Qed. + + Lemma NoDupA_equivlistA_decompose l1 l2 : + NoDupA eqA l1 -> NoDupA eqA l2 -> equivlistA eqA l1 l2 -> + exists l, Permutation l1 l /\ eqlistA eqA l l2. + Proof. + intros. apply PermutationA_decompose. + now apply NoDupA_equivlistA_PermutationA. + Qed. + + Lemma PermutationA_preserves_NoDupA l₁ l₂ : + PermutationA l₁ l₂ -> NoDupA eqA l₁ -> NoDupA eqA l₂. + Proof. + induction 1; trivial. + - inversion_clear 1; constructor; auto. + apply PermutationA_equivlistA in H0. contradict H2. + now rewrite H, H0. + - inversion_clear 1. inversion_clear H1. constructor. + + contradict H. inversion_clear H; trivial. + elim H0. now constructor. + + constructor; trivial. + contradict H0. now apply InA_cons_tl. + - eauto. + Qed. End Permutation. diff --git a/theories/Streams/StreamMemo.v b/theories/Streams/StreamMemo.v index 83745154c6..d9d5ca0178 100644 --- a/theories/Streams/StreamMemo.v +++ b/theories/Streams/StreamMemo.v @@ -18,54 +18,54 @@ From Stdlib Require Import Streams. Section MemoFunction. -Variable A: Type. -Variable f: nat -> A. - -CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)). - -Definition memo_list := memo_make 0. - -Fixpoint memo_get (n:nat) (l:Stream A) : A := - match n with - | O => hd l - | S n1 => memo_get n1 (tl l) - end. - -Theorem memo_get_correct: forall n, memo_get n memo_list = f n. -Proof. -assert (F1: forall n m, memo_get n (memo_make m) = f (n + m)). -{ induction n as [| n Hrec]; try (intros m; reflexivity). - intros m; simpl; rewrite Hrec. - rewrite plus_n_Sm; auto. } -intros n; transitivity (f (n + 0)); try exact (F1 n 0). -rewrite <- plus_n_O; auto. -Qed. - -(** Building with possible sharing using a iterator [g] : + Variable A: Type. + Variable f: nat -> A. + + CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)). + + Definition memo_list := memo_make 0. + + Fixpoint memo_get (n:nat) (l:Stream A) : A := + match n with + | O => hd l + | S n1 => memo_get n1 (tl l) + end. + + Theorem memo_get_correct: forall n, memo_get n memo_list = f n. + Proof. + assert (F1: forall n m, memo_get n (memo_make m) = f (n + m)). + { induction n as [| n Hrec]; try (intros m; reflexivity). + intros m; simpl; rewrite Hrec. + rewrite plus_n_Sm; auto. } + intros n; transitivity (f (n + 0)); try exact (F1 n 0). + rewrite <- plus_n_O; auto. + Qed. + + (** Building with possible sharing using a iterator [g] : We now suppose in addition that [f n] is in fact the [n]-th iterate of a function [g]. *) -Variable g: A -> A. + Variable g: A -> A. -Hypothesis Hg_correct: forall n, f (S n) = g (f n). + Hypothesis Hg_correct: forall n, f (S n) = g (f n). -CoFixpoint imemo_make (fn:A) : Stream A := - let fn1 := g fn in - Cons fn1 (imemo_make fn1). + CoFixpoint imemo_make (fn:A) : Stream A := + let fn1 := g fn in + Cons fn1 (imemo_make fn1). -Definition imemo_list := let f0 := f 0 in - Cons f0 (imemo_make f0). + Definition imemo_list := let f0 := f 0 in + Cons f0 (imemo_make f0). -Theorem imemo_get_correct: forall n, memo_get n imemo_list = f n. -Proof. -assert (F1: forall n m, memo_get n (imemo_make (f m)) = f (S (n + m))). -{ induction n as [| n Hrec]; try (intros m; exact (eq_sym (Hg_correct m))). - simpl; intros m; rewrite <- Hg_correct, Hrec, <- plus_n_Sm; auto. } -destruct n as [| n]; try reflexivity. -unfold imemo_list; simpl; rewrite F1. -rewrite <- plus_n_O; auto. -Qed. + Theorem imemo_get_correct: forall n, memo_get n imemo_list = f n. + Proof. + assert (F1: forall n m, memo_get n (imemo_make (f m)) = f (S (n + m))). + { induction n as [| n Hrec]; try (intros m; exact (eq_sym (Hg_correct m))). + simpl; intros m; rewrite <- Hg_correct, Hrec, <- plus_n_Sm; auto. } + destruct n as [| n]; try reflexivity. + unfold imemo_list; simpl; rewrite F1. + rewrite <- plus_n_O; auto. + Qed. End MemoFunction. @@ -80,88 +80,88 @@ Arguments memo_val : clear implicits. Section DependentMemoFunction. -Variable A: nat -> Type. -Variable f: forall n, A n. - -Notation memo_val := (memo_val A). - -Fixpoint is_eq (n m : nat) : {n = m} + {True} := - match n, m return {n = m} + {True} with - | 0, 0 =>left True (eq_refl 0) - | 0, S m1 => right (0 = S m1) I - | S n1, 0 => right (S n1 = 0) I - | S n1, S m1 => - match is_eq n1 m1 with - | left H => left True (f_equal S H) - | right _ => right (S n1 = S m1) I - end - end. - -Definition memo_get_val n (v: memo_val): A n := -match v with -| memo_mval m x => - match is_eq n m with - | left H => - match H in (eq _ y) return (A y -> A n) with - | eq_refl => fun v1 : A n => v1 - end - | right _ => fun _ : A m => f n - end x -end. + Variable A: nat -> Type. + Variable f: forall n, A n. -Let mf n := memo_mval n (f n). + Notation memo_val := (memo_val A). -Definition dmemo_list := memo_list _ mf. - -Definition dmemo_get n l := memo_get_val n (memo_get _ n l). - -Theorem dmemo_get_correct: forall n, dmemo_get n dmemo_list = f n. -Proof. -intros n; unfold dmemo_get, dmemo_list. -rewrite (memo_get_correct memo_val mf n); simpl. -case (is_eq n n); simpl; auto; intros e. -assert (e = eq_refl n). -- apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - + left; auto. - + right; intros HH; discriminate HH. - + right; intros HH; discriminate HH. - + case (Hx y). - * intros HH; left; case HH; auto. - * intros HH; right; intros HH1; case HH. - injection HH1; auto. -- rewrite H; auto. -Qed. - -(** Finally, a version with both dependency and iterator *) - -Variable g: forall n, A n -> A (S n). - -Hypothesis Hg_correct: forall n, f (S n) = g n (f n). - -Let mg v := match v with - memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. - -Definition dimemo_list := imemo_list _ mf mg. + Fixpoint is_eq (n m : nat) : {n = m} + {True} := + match n, m return {n = m} + {True} with + | 0, 0 =>left True (eq_refl 0) + | 0, S m1 => right (0 = S m1) I + | S n1, 0 => right (S n1 = 0) I + | S n1, S m1 => + match is_eq n1 m1 with + | left H => left True (f_equal S H) + | right _ => right (S n1 = S m1) I + end + end. + + Definition memo_get_val n (v: memo_val): A n := + match v with + | memo_mval m x => + match is_eq n m with + | left H => + match H in (eq _ y) return (A y -> A n) with + | eq_refl => fun v1 : A n => v1 + end + | right _ => fun _ : A m => f n + end x + end. -Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. -Proof. -intros n; unfold dmemo_get, dimemo_list. -rewrite (imemo_get_correct memo_val mf mg); simpl. -- case (is_eq n n); simpl; auto; intros e. - assert (e = eq_refl n). - + apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - * left; auto. - * right; intros HH; discriminate HH. - * right; intros HH; discriminate HH. - * case (Hx y). - -- intros HH; left; case HH; auto. - -- intros HH; right; intros HH1; case HH. - injection HH1; auto. - + rewrite H; auto. -- intros n1; unfold mf; rewrite Hg_correct; auto. -Qed. + Let mf n := memo_mval n (f n). + + Definition dmemo_list := memo_list _ mf. + + Definition dmemo_get n l := memo_get_val n (memo_get _ n l). + + Theorem dmemo_get_correct: forall n, dmemo_get n dmemo_list = f n. + Proof. + intros n; unfold dmemo_get, dmemo_list. + rewrite (memo_get_correct memo_val mf n); simpl. + case (is_eq n n); simpl; auto; intros e. + assert (e = eq_refl n). + - apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + + left; auto. + + right; intros HH; discriminate HH. + + right; intros HH; discriminate HH. + + case (Hx y). + * intros HH; left; case HH; auto. + * intros HH; right; intros HH1; case HH. + injection HH1; auto. + - rewrite H; auto. + Qed. + + (** Finally, a version with both dependency and iterator *) + + Variable g: forall n, A n -> A (S n). + + Hypothesis Hg_correct: forall n, f (S n) = g n (f n). + + Let mg v := match v with + memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. + + Definition dimemo_list := imemo_list _ mf mg. + + Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. + Proof. + intros n; unfold dmemo_get, dimemo_list. + rewrite (imemo_get_correct memo_val mf mg); simpl. + - case (is_eq n n); simpl; auto; intros e. + assert (e = eq_refl n). + + apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + * left; auto. + * right; intros HH; discriminate HH. + * right; intros HH; discriminate HH. + * case (Hx y). + -- intros HH; left; case HH; auto. + -- intros HH; right; intros HH1; case HH. + injection HH1; auto. + + rewrite H; auto. + - intros n1; unfold mf; rewrite Hg_correct; auto. + Qed. End DependentMemoFunction. diff --git a/theories/Streams/Streams.v b/theories/Streams/Streams.v index 09c357fdd8..df8a8ec55a 100644 --- a/theories/Streams/Streams.v +++ b/theories/Streams/Streams.v @@ -16,234 +16,242 @@ CoInductive Stream (A : Type) := Cons : A -> Stream A -> Stream A. Section Streams. - Variable A : Type. - - Notation Stream := (Stream A). - - -Definition hd (x:Stream) := match x with - | Cons a _ => a - end. - -Definition tl (x:Stream) := match x with - | Cons _ s => s - end. - - -Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream := - match n with - | O => s - | S m => Str_nth_tl m (tl s) - end. - -Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s). - - -Lemma unfold_Stream : - forall x:Stream, x = match x with - | Cons a s => Cons a s - end. -Proof. - intro x. - case x. - trivial. -Qed. - -Lemma tl_nth_tl : - forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s). -Proof. - simple induction n; simpl; auto. -Qed. -#[local] -Hint Resolve tl_nth_tl: datatypes. - -Lemma Str_nth_tl_plus : - forall (n m:nat) (s:Stream), - Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s. -simple induction n; simpl; intros; auto with datatypes. -rewrite <- H. -rewrite tl_nth_tl; trivial with datatypes. -Qed. - -Lemma Str_nth_plus : - forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s. -intros; unfold Str_nth; rewrite Str_nth_tl_plus; - trivial with datatypes. -Qed. - -(** Extensional Equality between two streams *) - -CoInductive EqSt (s1 s2: Stream) : Prop := - eqst : - hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. - -(** A coinduction principle *) - -Ltac coinduction proof := - cofix proof; intros; constructor; - [ clear proof | try (apply proof; clear proof) ]. - - -(** Extensional equality is an equivalence relation *) - -Theorem EqSt_reflex : forall s:Stream, EqSt s s. -coinduction EqSt_reflex. -reflexivity. -Qed. - -Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1. -coinduction Eq_sym. -+ case H; intros; symmetry ; assumption. -+ case H; intros; assumption. -Qed. - - -Theorem trans_EqSt : - forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3. -coinduction Eq_trans. -- transitivity (hd s2). - + case H; intros; assumption. - + case H0; intros; assumption. -- apply (Eq_trans (tl s1) (tl s2) (tl s3)). - + case H; trivial with datatypes. - + case H0; trivial with datatypes. -Qed. - -(** The definition given is equivalent to require the elements at each + Variable A : Type. + + Notation Stream := (Stream A). + + + Definition hd (x:Stream) := match x with + | Cons a _ => a + end. + + Definition tl (x:Stream) := match x with + | Cons _ s => s + end. + + + Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream := + match n with + | O => s + | S m => Str_nth_tl m (tl s) + end. + + Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s). + + + Lemma unfold_Stream : + forall x:Stream, x = match x with + | Cons a s => Cons a s + end. + Proof. + intro x. + case x. + trivial. + Qed. + + Lemma tl_nth_tl : + forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s). + Proof. + simple induction n; simpl; auto. + Qed. + #[local] + Hint Resolve tl_nth_tl: datatypes. + + Lemma Str_nth_tl_plus : + forall (n m:nat) (s:Stream), + Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s. + Proof. + simple induction n; simpl; intros; auto with datatypes. + rewrite <- H. + rewrite tl_nth_tl; trivial with datatypes. + Qed. + + Lemma Str_nth_plus : + forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s. + Proof. + intros; unfold Str_nth; rewrite Str_nth_tl_plus; + trivial with datatypes. + Qed. + + (** Extensional Equality between two streams *) + + CoInductive EqSt (s1 s2: Stream) : Prop := + eqst : + hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. + + (** A coinduction principle *) + + Ltac coinduction proof := + cofix proof; intros; constructor; + [ clear proof | try (apply proof; clear proof) ]. + + + (** Extensional equality is an equivalence relation *) + + Theorem EqSt_reflex : forall s:Stream, EqSt s s. + Proof. + coinduction EqSt_reflex. + reflexivity. + Qed. + + Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1. + Proof. + coinduction Eq_sym. + + case H; intros; symmetry ; assumption. + + case H; intros; assumption. + Qed. + + + Theorem trans_EqSt : + forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3. + Proof. + coinduction Eq_trans. + - transitivity (hd s2). + + case H; intros; assumption. + + case H0; intros; assumption. + - apply (Eq_trans (tl s1) (tl s2) (tl s3)). + + case H; trivial with datatypes. + + case H0; trivial with datatypes. + Qed. + + (** The definition given is equivalent to require the elements at each position to be equal *) -Theorem eqst_ntheq : - forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2. -unfold Str_nth; simple induction n. -- intros s1 s2 H; case H; trivial with datatypes. -- intros m hypind. - simpl. - intros s1 s2 H. - apply hypind. - case H; trivial with datatypes. -Qed. - -Theorem ntheq_eqst : - forall s1 s2:Stream, - (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2. -coinduction Equiv2. -- apply (H 0). -- intros n; apply (H (S n)). -Qed. - -Section Stream_Properties. - -Variable P : Stream -> Prop. - -(*i + Theorem eqst_ntheq : + forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2. + Proof. + unfold Str_nth; simple induction n. + - intros s1 s2 H; case H; trivial with datatypes. + - intros m hypind. + simpl. + intros s1 s2 H. + apply hypind. + case H; trivial with datatypes. + Qed. + + Theorem ntheq_eqst : + forall s1 s2:Stream, + (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2. + Proof. + coinduction Equiv2. + - apply (H 0). + - intros n; apply (H (S n)). + Qed. + + Section Stream_Properties. + + Variable P : Stream -> Prop. + + (*i Inductive Exists : Stream -> Prop := | Here : forall x:Stream, P x -> Exists x | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x. i*) -Inductive Exists ( x: Stream ) : Prop := - | Here : P x -> Exists x - | Further : Exists (tl x) -> Exists x. + Inductive Exists ( x: Stream ) : Prop := + | Here : P x -> Exists x + | Further : Exists (tl x) -> Exists x. -CoInductive ForAll (x: Stream) : Prop := - HereAndFurther : P x -> ForAll (tl x) -> ForAll x. + CoInductive ForAll (x: Stream) : Prop := + HereAndFurther : P x -> ForAll (tl x) -> ForAll x. -Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x). -Proof. -induction m. -- tauto. -- intros x [_ H]. - simpl. - apply IHm. - assumption. -Qed. + Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x). + Proof. + induction m. + - tauto. + - intros x [_ H]. + simpl. + apply IHm. + assumption. + Qed. -Section Co_Induction_ForAll. -Variable Inv : Stream -> Prop. -Hypothesis InvThenP : forall x:Stream, Inv x -> P x. -Hypothesis InvIsStable : forall x:Stream, Inv x -> Inv (tl x). + Section Co_Induction_ForAll. + Variable Inv : Stream -> Prop. + Hypothesis InvThenP : forall x:Stream, Inv x -> P x. + Hypothesis InvIsStable : forall x:Stream, Inv x -> Inv (tl x). -Theorem ForAll_coind : forall x:Stream, Inv x -> ForAll x. -coinduction ForAll_coind; auto. -Qed. -End Co_Induction_ForAll. + Theorem ForAll_coind : forall x:Stream, Inv x -> ForAll x. + Proof. + coinduction ForAll_coind; auto. + Qed. + End Co_Induction_ForAll. -End Stream_Properties. + End Stream_Properties. End Streams. Section Map. -Variables A B : Type. -Variable f : A -> B. -CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)). - -Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s). -Proof. -induction n. -- reflexivity. -- simpl. - intros s. - apply IHn. -Qed. - -Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s). -Proof. -intros n s. -unfold Str_nth. -rewrite Str_nth_tl_map. -reflexivity. -Qed. - -Lemma ForAll_map : forall (P:Stream B -> Prop) (S:Stream A), ForAll (fun s => P -(map s)) S <-> ForAll P (map S). -Proof. -intros P S. -split; generalize S; clear S; cofix ForAll_map; intros S; constructor; -destruct H as [H0 H]; firstorder. -Qed. - -Lemma Exists_map : forall (P:Stream B -> Prop) (S:Stream A), Exists (fun s => P -(map s)) S -> Exists P (map S). -Proof. -intros P S H. -(induction H;[left|right]); firstorder. -Defined. + Variables A B : Type. + Variable f : A -> B. + CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)). + + Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s). + Proof. + induction n. + - reflexivity. + - simpl. + intros s. + apply IHn. + Qed. + + Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s). + Proof. + intros n s. + unfold Str_nth. + rewrite Str_nth_tl_map. + reflexivity. + Qed. + + Lemma ForAll_map : forall (P:Stream B -> Prop) (S:Stream A), ForAll (fun s => P + (map s)) S <-> ForAll P (map S). + Proof. + intros P S. + split; generalize S; clear S; cofix ForAll_map; intros S; constructor; + destruct H as [H0 H]; firstorder. + Qed. + + Lemma Exists_map : forall (P:Stream B -> Prop) (S:Stream A), Exists (fun s => P + (map s)) S -> Exists P (map S). + Proof. + intros P S H. + (induction H;[left|right]); firstorder. + Defined. End Map. Section Constant_Stream. -Variable A : Type. -Variable a : A. -CoFixpoint const : Stream A := Cons a const. + Variable A : Type. + Variable a : A. + CoFixpoint const : Stream A := Cons a const. End Constant_Stream. Section Zip. -Variable A B C : Type. -Variable f: A -> B -> C. - -CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C := -Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)). - -Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), - Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). -Proof. -induction n. -- reflexivity. -- intros [x xs] [y ys]. - unfold Str_nth in *. - simpl in *. - apply IHn. -Qed. - -Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a - b)= f (Str_nth n a) (Str_nth n b). -Proof. -intros. -unfold Str_nth. -rewrite Str_nth_tl_zipWith. -reflexivity. -Qed. + Variable A B C : Type. + Variable f: A -> B -> C. + + CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C := + Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)). + + Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), + Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). + Proof. + induction n. + - reflexivity. + - intros [x xs] [y ys]. + unfold Str_nth in *. + simpl in *. + apply IHn. + Qed. + + Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a + b)= f (Str_nth n a) (Str_nth n b). + Proof. + intros. + unfold Str_nth. + rewrite Str_nth_tl_zipWith. + reflexivity. + Qed. End Zip. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 0077dd4c2f..d96f7271ec 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -59,9 +59,9 @@ Infix "=?" := eqb : char_scope. Lemma eqb_spec (a b : ascii) : reflect (a = b) (a =? b)%char. Proof. - destruct a, b; simpl. - do 8 (case Bool.eqb_spec; [ intros -> | constructor; now intros [= ] ]). - now constructor. + destruct a, b; simpl. + do 8 (case Bool.eqb_spec; [ intros -> | constructor; now intros [= ] ]). + now constructor. Qed. #[local] Ltac t_eqb := @@ -136,10 +136,10 @@ Qed. Theorem N_ascii_embedding : forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n. Proof. -intro n; destruct n as [|p]. -- reflexivity. -- do 8 (destruct p as [p|p|]; [ | | intros; vm_compute; reflexivity ]); - intro H; vm_compute in H; destruct p; discriminate. + intro n; destruct n as [|p]. + - reflexivity. + - do 8 (destruct p as [p|p|]; [ | | intros; vm_compute; reflexivity ]); + intro H; vm_compute in H; destruct p; discriminate. Qed. Theorem N_ascii_bounded : @@ -157,13 +157,13 @@ Qed. Theorem nat_ascii_embedding : forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n. Proof. - intros. unfold nat_of_ascii, ascii_of_nat. - rewrite N_ascii_embedding. - - apply Nat2N.id. - - unfold N.lt. - change 256%N with (N.of_nat 256). - rewrite <- Nat2N.inj_compare. - now apply Nat.compare_lt_iff. + intros. unfold nat_of_ascii, ascii_of_nat. + rewrite N_ascii_embedding. + - apply Nat2N.id. + - unfold N.lt. + change 256%N with (N.of_nat 256). + rewrite <- Nat2N.inj_compare. + now apply Nat.compare_lt_iff. Qed. Theorem nat_ascii_bounded : diff --git a/theories/Strings/String.v b/theories/Strings/String.v index ceeb2a3c76..d674066f2a 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -40,7 +40,7 @@ Register String as core.string.string. Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}. Proof. - decide equality; apply ascii_dec. + decide equality; apply ascii_dec. Defined. #[local] Open Scope lazy_bool_scope. @@ -56,10 +56,10 @@ Infix "=?" := eqb : string_scope. Lemma eqb_spec s1 s2 : Bool.reflect (s1 = s2) (s1 =? s2)%string. Proof. - revert s2. induction s1 as [|? s1 IHs1]; - intro s2; destruct s2; try (constructor; easy); simpl. - case Ascii.eqb_spec; simpl; [intros -> | constructor; now intros [= ]]. - case IHs1; [intros ->; now constructor | constructor; now intros [= ]]. + revert s2. induction s1 as [|? s1 IHs1]; + intro s2; destruct s2; try (constructor; easy); simpl. + case Ascii.eqb_spec; simpl; [intros -> | constructor; now intros [= ]]. + case IHs1; [intros ->; now constructor | constructor; now intros [= ]]. Qed. #[local] Ltac t_eqb := @@ -178,20 +178,20 @@ Fixpoint get (n : nat) (s : string) {struct s} : option ascii := Theorem get_correct : forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2. Proof. -intros s1; elim s1; simpl. -- intros s2; case s2; simpl; split; auto. - + intros H; generalize (H O); intros H1; inversion H1. - + intros; discriminate. -- intros a s1' Rec s2; case s2 as [|? s]; simpl; split; auto. - + intros H; generalize (H O); intros H1; inversion H1. - + intros; discriminate. - + intros H; generalize (H O); simpl; intros H1; inversion H1. - case (Rec s). - intros H0; rewrite H0; auto. - intros n; exact (H (S n)). - + intros [= H1 H2]. - rewrite H2; trivial. - rewrite H1; auto. + intros s1; elim s1; simpl. + - intros s2; case s2; simpl; split; auto. + + intros H; generalize (H O); intros H1; inversion H1. + + intros; discriminate. + - intros a s1' Rec s2; case s2 as [|? s]; simpl; split; auto. + + intros H; generalize (H O); intros H1; inversion H1. + + intros; discriminate. + + intros H; generalize (H O); simpl; intros H1; inversion H1. + case (Rec s). + intros H0; rewrite H0; auto. + intros n; exact (H (S n)). + + intros [= H1 H2]. + rewrite H2; trivial. + rewrite H1; auto. Qed. (** The first elements of [s1 ++ s2] are the ones of [s1] *) @@ -200,11 +200,11 @@ Theorem append_correct1 : forall (s1 s2 : string) (n : nat), n < length s1 -> get n s1 = get n (s1 ++ s2). Proof. -intros s1; elim s1; simpl; auto. -- intros s2 n H; inversion H. -- intros a s1' Rec s2 n; case n; simpl; auto. - intros n0 H; apply Rec; auto. - apply Nat.succ_lt_mono; auto. + intros s1; elim s1; simpl; auto. + - intros s2 n H; inversion H. + - intros a s1' Rec s2 n; case n; simpl; auto. + intros n0 H; apply Rec; auto. + apply Nat.succ_lt_mono; auto. Qed. (** The last elements of [s1 ++ s2] are the ones of [s2] *) @@ -213,12 +213,12 @@ Theorem append_correct2 : forall (s1 s2 : string) (n : nat), get n s2 = get (n + length s1) (s1 ++ s2). Proof. -intros s1; elim s1; simpl; auto. -- intros s2 n; rewrite Nat.add_comm; simpl; auto. -- intros a s1' Rec s2 n; case n; simpl; auto. - intros. - (replace (n0 + S (length s1')) - with (S n0 + length s1') by now rewrite Nat.add_succ_r); auto. + intros s1; elim s1; simpl; auto. + - intros s2 n; rewrite Nat.add_comm; simpl; auto. + - intros a s1' Rec s2 n; case n; simpl; auto. + intros. + (replace (n0 + S (length s1')) + with (S n0 + length s1') by now rewrite Nat.add_succ_r); auto. Qed. (** *** Substrings *) @@ -242,16 +242,16 @@ Theorem substring_correct1 : forall (s : string) (n m p : nat), p < m -> get p (substring n m s) = get (p + n) s. Proof. -intros s; elim s; simpl; auto. -- intros n; case n; simpl; auto. - intros m; case m; simpl; auto. -- intros a s' Rec; intros n; case n; simpl; auto. - + intros m; case m; simpl; auto. - * intros p H; inversion H. - * intros m' p; case p; simpl; auto. - intros n0 H; apply Rec; simpl; auto. - apply <- Nat.succ_lt_mono; auto. - + intros n' m p H; rewrite Nat.add_succ_r; auto. + intros s; elim s; simpl; auto. + - intros n; case n; simpl; auto. + intros m; case m; simpl; auto. + - intros a s' Rec; intros n; case n; simpl; auto. + + intros m; case m; simpl; auto. + * intros p H; inversion H. + * intros m' p; case p; simpl; auto. + intros n0 H; apply Rec; simpl; auto. + apply <- Nat.succ_lt_mono; auto. + + intros n' m p H; rewrite Nat.add_succ_r; auto. Qed. (** The substring has at most [m] elements *) @@ -259,15 +259,15 @@ Qed. Theorem substring_correct2 : forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None. Proof. -intros s; elim s; simpl; auto. -- intros n; case n; simpl; auto. - intros m; case m; simpl; auto. -- intros a s' Rec; intros n; case n; simpl; auto. - intros m; case m; simpl; auto. - intros m' p; case p; simpl; auto. - + intros H; inversion H. - + intros n0 H; apply Rec; simpl; auto. - apply <- Nat.succ_le_mono; auto. + intros s; elim s; simpl; auto. + - intros n; case n; simpl; auto. + intros m; case m; simpl; auto. + - intros a s' Rec; intros n; case n; simpl; auto. + intros m; case m; simpl; auto. + intros m' p; case p; simpl; auto. + + intros H; inversion H. + + intros n0 H; apply Rec; simpl; auto. + apply <- Nat.succ_le_mono; auto. Qed. (** *** Concatenating lists of strings *) @@ -307,16 +307,16 @@ Theorem prefix_correct : forall s1 s2 : string, prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1. Proof. -intros s1; elim s1; simpl; auto. -- intros s2; case s2; simpl; split; auto. -- intros a s1' Rec s2; case s2; simpl; auto. - + split; intros; discriminate. - + intros b s2'; case (ascii_dec a b); simpl; auto. - * intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto. - -- rewrite e; rewrite H1; auto. - -- apply H2; injection H3; auto. - * intros n; split; intros H; try discriminate. - case n; injection H; auto. + intros s1; elim s1; simpl; auto. + - intros s2; case s2; simpl; split; auto. + - intros a s1' Rec s2; case s2; simpl; auto. + + split; intros; discriminate. + + intros b s2'; case (ascii_dec a b); simpl; auto. + * intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto. + -- rewrite e; rewrite H1; auto. + -- apply H2; injection H3; auto. + * intros n; split; intros H; try discriminate. + case n; injection H; auto. Qed. (** Test if, starting at position [n], [s1] occurs in [s2]; if @@ -353,29 +353,29 @@ Theorem index_correct1 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> substring m (length s1) s2 = s1. Proof. -intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; - auto. -- intros n; case n; simpl; auto. - + intros m s1; case s1; simpl; auto. - * intros [= <-]; auto. - * intros; discriminate. - + intros; discriminate. -- intros b s2' Rec n m s1. - case n; simpl; auto. - + generalize (prefix_correct s1 (String b s2')); - case (prefix s1 (String b s2')). - * intros H0 [= <-]; auto. - case H0; simpl; auto. - * case m; simpl; auto. - -- case (index O s1 s2'); intros; discriminate. - -- intros m'; generalize (Rec O m' s1); case (index O s1 s2'); auto. - ++ intros x H H0 H1; apply H; injection H1; auto. - ++ intros; discriminate. - + intros n'; case m; simpl; auto. - * case (index n' s1 s2'); intros; discriminate. - * intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. - -- intros x H H1; apply H; injection H1; auto. - -- intros; discriminate. + intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; + auto. + - intros n; case n; simpl; auto. + + intros m s1; case s1; simpl; auto. + * intros [= <-]; auto. + * intros; discriminate. + + intros; discriminate. + - intros b s2' Rec n m s1. + case n; simpl; auto. + + generalize (prefix_correct s1 (String b s2')); + case (prefix s1 (String b s2')). + * intros H0 [= <-]; auto. + case H0; simpl; auto. + * case m; simpl; auto. + -- case (index O s1 s2'); intros; discriminate. + -- intros m'; generalize (Rec O m' s1); case (index O s1 s2'); auto. + ++ intros x H H0 H1; apply H; injection H1; auto. + ++ intros; discriminate. + + intros n'; case m; simpl; auto. + * case (index n' s1 s2'); intros; discriminate. + * intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. + -- intros x H H1; apply H; injection H1; auto. + -- intros; discriminate. Qed. (** If the result of [index] is [Some m], @@ -386,42 +386,42 @@ Theorem index_correct2 : index n s1 s2 = Some m -> forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1. Proof. -intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; - auto. -- intros n; case n; simpl; auto. - + intros m s1; case s1; simpl; auto. - * intros [= <-]. - intros p H0 H2; inversion H2. - * intros; discriminate. - + intros; discriminate. -- intros b s2' Rec n m s1. - case n; simpl; auto. - + generalize (prefix_correct s1 (String b s2')); - case (prefix s1 (String b s2')). - * intros H0 [= <-]; auto. - intros p H2 H3; inversion H3. - * case m; simpl; auto. - -- case (index 0 s1 s2'); intros; discriminate. - -- intros m'; generalize (Rec O m' s1); case (index 0 s1 s2'); auto. - ++ intros x H H0 H1 p; try case p; simpl; auto. - ** intros H2 H3; red; intros H4; case H0. - intros H5 H6; absurd (false = true); auto with bool. - ** { intros n0 H2 H3; apply H; auto. - - injection H1; auto. - - apply Nat.le_0_l. - - apply <- Nat.succ_lt_mono; auto. - } - ++ intros; discriminate. - + intros n'; case m; simpl; auto. - * case (index n' s1 s2'); intros; discriminate. - * intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. - -- intros x H H0 p; case p; simpl; auto. - ++ intros H1; inversion H1; auto. - ++ intros n0 H1 H2; apply H; auto. - ** injection H0; auto. - ** apply <- Nat.succ_le_mono; auto. - ** apply <- Nat.succ_lt_mono; auto. - -- intros; discriminate. + intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; + auto. + - intros n; case n; simpl; auto. + + intros m s1; case s1; simpl; auto. + * intros [= <-]. + intros p H0 H2; inversion H2. + * intros; discriminate. + + intros; discriminate. + - intros b s2' Rec n m s1. + case n; simpl; auto. + + generalize (prefix_correct s1 (String b s2')); + case (prefix s1 (String b s2')). + * intros H0 [= <-]; auto. + intros p H2 H3; inversion H3. + * case m; simpl; auto. + -- case (index 0 s1 s2'); intros; discriminate. + -- intros m'; generalize (Rec O m' s1); case (index 0 s1 s2'); auto. + ++ intros x H H0 H1 p; try case p; simpl; auto. + ** intros H2 H3; red; intros H4; case H0. + intros H5 H6; absurd (false = true); auto with bool. + ** { intros n0 H2 H3; apply H; auto. + - injection H1; auto. + - apply Nat.le_0_l. + - apply <- Nat.succ_lt_mono; auto. + } + ++ intros; discriminate. + + intros n'; case m; simpl; auto. + * case (index n' s1 s2'); intros; discriminate. + * intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. + -- intros x H H0 p; case p; simpl; auto. + ++ intros H1; inversion H1; auto. + ++ intros n0 H1 H2; apply H; auto. + ** injection H0; auto. + ** apply <- Nat.succ_le_mono; auto. + ** apply <- Nat.succ_lt_mono; auto. + -- intros; discriminate. Qed. (** If the result of [index] is [None], [s1] does not occur in [s2] @@ -432,35 +432,35 @@ Theorem index_correct3 : index n s1 s2 = None -> s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1. Proof. -intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; - auto. -- intros n; case n; simpl; auto. - + intros m s1; case s1; simpl; auto. - case m; intros; red; intros; discriminate. - + intros n' m; case m; auto. - intros s1; case s1; simpl; auto. -- intros b s2' Rec n m s1. - case n; simpl; auto. - + generalize (prefix_correct s1 (String b s2')); - case (prefix s1 (String b s2')). - * intros; discriminate. - * case m; simpl; auto with bool. - -- case s1; simpl; auto. - intros a s H H0 H1 H2; red; intros H3; case H. - intros H4 H5; absurd (false = true); auto with bool. - -- case s1; simpl; auto. - intros a s n0 H H0 H1 H2; - change (substring n0 (length (String a s)) s2' <> String a s); - apply (Rec O); auto. - ++ generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros; - discriminate. - ++ apply Nat.le_0_l. - + intros n'; case m; simpl; auto. - * intros H H0 H1; inversion H1. - * intros n0 H H0 H1; apply (Rec n'); auto. - -- generalize H; case (index n' s1 s2'); simpl; auto; intros; - discriminate. - -- apply Nat.succ_le_mono; auto. + intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; + auto. + - intros n; case n; simpl; auto. + + intros m s1; case s1; simpl; auto. + case m; intros; red; intros; discriminate. + + intros n' m; case m; auto. + intros s1; case s1; simpl; auto. + - intros b s2' Rec n m s1. + case n; simpl; auto. + + generalize (prefix_correct s1 (String b s2')); + case (prefix s1 (String b s2')). + * intros; discriminate. + * case m; simpl; auto with bool. + -- case s1; simpl; auto. + intros a s H H0 H1 H2; red; intros H3; case H. + intros H4 H5; absurd (false = true); auto with bool. + -- case s1; simpl; auto. + intros a s n0 H H0 H1 H2; + change (substring n0 (length (String a s)) s2' <> String a s); + apply (Rec O); auto. + ++ generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros; + discriminate. + ++ apply Nat.le_0_l. + + intros n'; case m; simpl; auto. + * intros H H0 H1; inversion H1. + * intros n0 H H0 H1; apply (Rec n'); auto. + -- generalize H; case (index n' s1 s2'); simpl; auto; intros; + discriminate. + -- apply Nat.succ_le_mono; auto. Qed. (* Back to normal for prefix *) @@ -473,16 +473,16 @@ Theorem index_correct4 : forall (n : nat) (s : string), index n EmptyString s = None -> length s < n. Proof. -intros n s; generalize n; clear n; elim s; simpl; auto. -- intros n; case n; simpl; auto. - + intros; discriminate. - + intros; apply Nat.lt_0_succ. -- intros a s' H n; case n; simpl; auto. - + intros; discriminate. - + intros n'; generalize (H n'); case (index n' EmptyString s'); simpl; - auto. - * intros; discriminate. - * intros H0 H1. apply -> Nat.succ_lt_mono; auto. + intros n s; generalize n; clear n; elim s; simpl; auto. + - intros n; case n; simpl; auto. + + intros; discriminate. + + intros; apply Nat.lt_0_succ. + - intros a s' H n; case n; simpl; auto. + + intros; discriminate. + + intros n'; generalize (H n'); case (index n' EmptyString s'); simpl; + auto. + * intros; discriminate. + * intros H0 H1. apply -> Nat.succ_lt_mono; auto. Qed. (** Same as [index] but with no optional type, we return [0] when it diff --git a/theories/Structures/BoolOrder.v b/theories/Structures/BoolOrder.v index 4a61f73286..e67677a1b3 100644 --- a/theories/Structures/BoolOrder.v +++ b/theories/Structures/BoolOrder.v @@ -71,17 +71,17 @@ Proof. destr_bool; intuition. Qed. #[global] Instance le_preorder : PreOrder Bool.le. Proof. -split. -- intros b; apply le_refl. -- intros b1 b2 b3; apply le_trans. + split. + - intros b; apply le_refl. + - intros b1 b2 b3; apply le_trans. Qed. #[global] Instance lt_strorder : StrictOrder Bool.lt. Proof. -split. -- intros b; apply lt_irrefl. -- intros b1 b2 b3; apply lt_trans. + split. + - intros b; apply lt_irrefl. + - intros b1 b2 b3; apply lt_trans. Qed. (* Module structure *) diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 4d7f2b4231..5546abe330 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -28,137 +28,137 @@ Module Type DecidableType := Equalities.DecidableTypeOrig. (** * Additional notions about keys and datas used in FMap *) Module KeyDecidableType(D:DecidableType). - Import D. - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := - eq (fst p) (fst p') /\ (snd p) = (snd p'). - - #[local] + Import D. + + Section Elt. + Variable elt : Type. + Notation key:=t. + + Definition eqk (p p':key*elt) := eq (fst p) (fst p'). + Definition eqke (p p':key*elt) := + eq (fst p) (fst p') /\ (snd p) = (snd p'). + + #[local] + Hint Unfold eqk eqke : core. + #[local] + Hint Extern 2 (eqke ?a ?b) => split : core. + + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* eqk, eqke are equalities *) + + Lemma eqk_refl : forall e, eqk e e. + Proof. auto. Qed. + + Lemma eqke_refl : forall e, eqke e e. + Proof. auto. Qed. + + Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. + Proof. auto. Qed. + + Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. + Proof. unfold eqke; intuition. Qed. + + Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. + Proof. eauto. Qed. + + Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. + Proof. + unfold eqke; intuition; [ eauto | congruence ]. + Qed. + + #[local] + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + #[local] + Hint Immediate eqk_sym eqke_sym : core. + + #[global] Instance eqk_equiv : Equivalence eqk. + Proof. split; eauto. Qed. + + #[global] Instance eqke_equiv : Equivalence eqke. + Proof. split; eauto. Qed. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + #[local] + Hint Resolve InA_eqke_eqk : core. + + Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. + Proof. + intros p q m **; apply InA_eqA with p; auto using eqk_equiv. + Qed. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + + #[local] + Hint Unfold MapsTo In : core. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + intros k l; split; intros [y H]. + - exists y; auto. + - induction H as [a l eq|a l H IH]. + + destruct a as [k' y']. + exists y'; auto. + + destruct IH as [e H0]. + exists e; auto. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto. + destruct H1; simpl in *; intuition. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. + Qed. + + End Elt. + + #[global] Hint Unfold eqk eqke : core. - #[local] + #[global] Hint Extern 2 (eqke ?a ?b) => split : core. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* eqk, eqke are equalities *) - - Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. - - Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. - - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto | congruence ]. - Qed. - - #[local] + #[global] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - #[local] + #[global] Hint Immediate eqk_sym eqke_sym : core. - - #[global] Instance eqk_equiv : Equivalence eqk. - Proof. split; eauto. Qed. - - #[global] Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto. Qed. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke; induction 1; intuition. - Qed. - #[local] + #[global] Hint Resolve InA_eqke_eqk : core. - - Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. - Proof. - intros p q m **; apply InA_eqA with p; auto using eqk_equiv. - Qed. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - - #[local] + #[global] Hint Unfold MapsTo In : core. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - intros k l; split; intros [y H]. - - exists y; auto. - - induction H as [a l eq|a l H IH]. - + destruct a as [k' y']. - exists y'; auto. - + destruct IH as [e H0]. - exists e; auto. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1 as [? H0]. - inversion_clear H0 as [? ? H1|]; eauto. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - End Elt. - - #[global] - Hint Unfold eqk eqke : core. - #[global] - Hint Extern 2 (eqke ?a ?b) => split : core. - #[global] - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - #[global] - Hint Immediate eqk_sym eqke_sym : core. - #[global] - Hint Resolve InA_eqke_eqk : core. - #[global] - Hint Unfold MapsTo In : core. - #[global] - Hint Resolve In_inv_2 In_inv_3 : core. + #[global] + Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 473496485e..26cdda83cf 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -16,172 +16,172 @@ Set Implicit Arguments. Module KeyDecidableType(D:DecidableType). - #[local] Open Scope signature_scope. - #[local] Notation key := D.t. + #[local] Open Scope signature_scope. + #[local] Notation key := D.t. - Definition eqk {elt} : relation (key*elt) := D.eq @@1. - Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. + Definition eqk {elt} : relation (key*elt) := D.eq @@1. + Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. - #[global] - Hint Unfold eqk eqke : core. + #[global] + Hint Unfold eqk eqke : core. - (** eqk, eqke are equalities *) + (** eqk, eqke are equalities *) -#[global] - Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _. + #[global] + Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _. -#[global] - Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _. + #[global] + Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _. - (** eqke is stricter than eqk *) + (** eqke is stricter than eqk *) -#[global] - Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt). - Proof. firstorder. Qed. - - (** Alternative definitions of eqke and eqk *) - - Lemma eqke_def {elt} k k' (e e':elt) : - eqke (k,e) (k',e') = (D.eq k k' /\ e = e'). - Proof. reflexivity. Defined. - - Lemma eqke_def' {elt} (p q:key*elt) : - eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q). - Proof. reflexivity. Defined. - - Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'. - Proof. now destruct 1. Qed. - - Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'. - Proof. now destruct 1. Qed. - - Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'. - Proof. reflexivity. Defined. - - Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q). - Proof. reflexivity. Qed. - - Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. - Proof. trivial. Qed. - - #[global] - Hint Resolve eqke_1 eqke_2 eqk_1 : core. - - (* Additional facts *) - - Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) : - InA eqke p m -> InA eqk p m. - Proof. - induction 1; firstorder. - Qed. - #[global] - Hint Resolve InA_eqke_eqk : core. - - Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : - InA eqk p m -> exists q, eqk p q /\ InA eqke q m. - Proof. - induction 1; firstorder auto with crelations. - Qed. - - Lemma InA_eqk {elt} p q (m:list (key*elt)) : - eqk p q -> InA eqk p m -> InA eqk q m. - Proof. - now intros <-. - Qed. - - Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). - Definition In {elt} k m := exists e:elt, MapsTo k e m. - - #[global] - Hint Unfold MapsTo In : core. - - (* Alternative formulations for [In k l] *) - - Lemma In_alt {elt} k (l:list (key*elt)) : - In k l <-> exists e, InA eqk (k,e) l. - Proof. - unfold In, MapsTo. - split; intros (e,H). - - exists e; auto. - - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)). - compute in E. exists e'. now rewrite E. - Qed. - - Lemma In_alt' {elt} (l:list (key*elt)) k e : - In k l <-> InA eqk (k,e) l. - Proof. - rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute. - Qed. - - Lemma In_alt2 {elt} k (l:list (key*elt)) : - In k l <-> Exists (fun p => D.eq k (fst p)) l. - Proof. - unfold In, MapsTo. - setoid_rewrite Exists_exists; setoid_rewrite InA_alt. - firstorder. - exists (snd x), x; auto. - Qed. - - Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False. - Proof. - rewrite In_alt2; apply Exists_nil. - Qed. - - Lemma In_cons {elt} k p (l:list (key*elt)) : - In k (p::l) <-> D.eq k (fst p) \/ In k l. - Proof. - rewrite !In_alt2, Exists_cons; intuition. - Qed. - -#[global] - Instance MapsTo_compat {elt} : - Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt). - Proof. - intros x x' Hx e e' He l l' Hl. unfold MapsTo. - rewrite Hx, He, Hl; intuition. - Qed. - -#[global] - Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt). - Proof. - intros x x' Hx l l' Hl. rewrite !In_alt. - setoid_rewrite Hl. setoid_rewrite Hx. intuition. - Qed. - - Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e : - D.eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. now intros <-. Qed. - - Lemma In_eq {elt} (l:list (key*elt)) x y : - D.eq x y -> In x l -> In y l. - Proof. now intros <-. Qed. - - Lemma In_inv {elt} k k' e (l:list (key*elt)) : - In k ((k',e) :: l) -> D.eq k k' \/ In k l. - Proof. - intros (e',H). red in H. rewrite InA_cons, eqke_def in H. - intuition. right. now exists e'. - Qed. - - Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) : - InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l. - Proof. - rewrite InA_cons, eqk_def. intuition. - Qed. - - Lemma In_inv_3 {elt} x x' (l:list (key*elt)) : - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1. - eauto with *. - Qed. - - #[global] - Hint Extern 2 (eqke ?a ?b) => split : core. - #[global] - Hint Resolve InA_eqke_eqk : core. - #[global] - Hint Resolve In_inv_2 In_inv_3 : core. + #[global] + Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt). + Proof. firstorder. Qed. + + (** Alternative definitions of eqke and eqk *) + + Lemma eqke_def {elt} k k' (e e':elt) : + eqke (k,e) (k',e') = (D.eq k k' /\ e = e'). + Proof. reflexivity. Defined. + + Lemma eqke_def' {elt} (p q:key*elt) : + eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q). + Proof. reflexivity. Defined. + + Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'. + Proof. now destruct 1. Qed. + + Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'. + Proof. now destruct 1. Qed. + + Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'. + Proof. reflexivity. Defined. + + Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q). + Proof. reflexivity. Qed. + + Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. + Proof. trivial. Qed. + + #[global] + Hint Resolve eqke_1 eqke_2 eqk_1 : core. + + (* Additional facts *) + + Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) : + InA eqke p m -> InA eqk p m. + Proof. + induction 1; firstorder. + Qed. + #[global] + Hint Resolve InA_eqke_eqk : core. + + Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : + InA eqk p m -> exists q, eqk p q /\ InA eqke q m. + Proof. + induction 1; firstorder auto with crelations. + Qed. + + Lemma InA_eqk {elt} p q (m:list (key*elt)) : + eqk p q -> InA eqk p m -> InA eqk q m. + Proof. + now intros <-. + Qed. + + Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). + Definition In {elt} k m := exists e:elt, MapsTo k e m. + + #[global] + Hint Unfold MapsTo In : core. + + (* Alternative formulations for [In k l] *) + + Lemma In_alt {elt} k (l:list (key*elt)) : + In k l <-> exists e, InA eqk (k,e) l. + Proof. + unfold In, MapsTo. + split; intros (e,H). + - exists e; auto. + - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)). + compute in E. exists e'. now rewrite E. + Qed. + + Lemma In_alt' {elt} (l:list (key*elt)) k e : + In k l <-> InA eqk (k,e) l. + Proof. + rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute. + Qed. + + Lemma In_alt2 {elt} k (l:list (key*elt)) : + In k l <-> Exists (fun p => D.eq k (fst p)) l. + Proof. + unfold In, MapsTo. + setoid_rewrite Exists_exists; setoid_rewrite InA_alt. + firstorder. + exists (snd x), x; auto. + Qed. + + Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False. + Proof. + rewrite In_alt2; apply Exists_nil. + Qed. + + Lemma In_cons {elt} k p (l:list (key*elt)) : + In k (p::l) <-> D.eq k (fst p) \/ In k l. + Proof. + rewrite !In_alt2, Exists_cons; intuition. + Qed. + + #[global] + Instance MapsTo_compat {elt} : + Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt). + Proof. + intros x x' Hx e e' He l l' Hl. unfold MapsTo. + rewrite Hx, He, Hl; intuition. + Qed. + + #[global] + Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt). + Proof. + intros x x' Hx l l' Hl. rewrite !In_alt. + setoid_rewrite Hl. setoid_rewrite Hx. intuition. + Qed. + + Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e : + D.eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. now intros <-. Qed. + + Lemma In_eq {elt} (l:list (key*elt)) x y : + D.eq x y -> In x l -> In y l. + Proof. now intros <-. Qed. + + Lemma In_inv {elt} k k' e (l:list (key*elt)) : + In k ((k',e) :: l) -> D.eq k k' \/ In k l. + Proof. + intros (e',H). red in H. rewrite InA_cons, eqke_def in H. + intuition. right. now exists e'. + Qed. + + Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) : + InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l. + Proof. + rewrite InA_cons, eqk_def. intuition. + Qed. + + Lemma In_inv_3 {elt} x x' (l:list (key*elt)) : + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1. + eauto with *. + Qed. + + #[global] + Hint Extern 2 (eqke ?a ?b) => split : core. + #[global] + Hint Resolve InA_eqke_eqk : core. + #[global] + Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. @@ -193,47 +193,47 @@ End KeyDecidableType. Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. - Definition t := (D1.t * D2.t)%type. + Definition t := (D1.t * D2.t)%type. - Definition eq := (D1.eq * D2.eq)%signature. + Definition eq := (D1.eq * D2.eq)%signature. -#[global] - Instance eq_equiv : Equivalence eq := _. + #[global] + Instance eq_equiv : Equivalence eq := _. - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl. - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - compute; intuition. - Defined. + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl. + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + compute; intuition. + Defined. End PairDecidableType. (** Similarly for pairs of UsualDecidableType *) Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. - Definition t := (D1.t * D2.t)%type. - Definition eq := @eq t. -#[global] - Instance eq_equiv : Equivalence eq := _. - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - unfold eq, D1.eq, D2.eq in *; simpl; - (left; f_equal; auto; fail) || - (right; intros [=]; auto). - Defined. + Definition t := (D1.t * D2.t)%type. + Definition eq := @eq t. + #[global] + Instance eq_equiv : Equivalence eq := _. + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + unfold eq, D1.eq, D2.eq in *; simpl; + (left; f_equal; auto; fail) || + (right; intros [=]; auto). + Defined. End PairUsualDecidableType. (** And also for pairs of UsualDecidableTypeFull *) Module PairUsualDecidableTypeFull (D1 D2:UsualDecidableTypeFull) - <: UsualDecidableTypeFull. + <: UsualDecidableTypeFull. - Module M := PairUsualDecidableType D1 D2. - Include Backport_DT (M). - Include HasEqDec2Bool. + Module M := PairUsualDecidableType D1 D2. + Include Backport_DT (M). + Include HasEqDec2Bool. End PairUsualDecidableTypeFull. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index 83540b790f..45013f902a 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -65,8 +65,8 @@ Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. Proof. - intros x y; elim (compare x y); intro H; [ right | left | right ]; auto with ordered_type. - assert (~ eq y x); auto with ordered_type. + intros x y; elim (compare x y); intro H; [ right | left | right ]; auto with ordered_type. + assert (~ eq y x); auto with ordered_type. Defined. End MOT_to_OT. @@ -78,445 +78,446 @@ End MOT_to_OT. Module OrderedTypeFacts (Import O: OrderedType). -#[global] - Instance eq_equiv : Equivalence eq. - Proof. split; [ exact eq_refl | exact eq_sym | exact eq_trans ]. Qed. + #[global] + Instance eq_equiv : Equivalence eq. + Proof. split; [ exact eq_refl | exact eq_sym | exact eq_trans ]. Qed. - Lemma lt_antirefl : forall x, ~ lt x x. - Proof. - intros x; intro; absurd (eq x x); auto with ordered_type. - Qed. + Lemma lt_antirefl : forall x, ~ lt x x. + Proof. + intros x; intro; absurd (eq x x); auto with ordered_type. + Qed. -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. + + Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. + Proof. + intros x y z H ?; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + - elim (lt_not_eq H); apply eq_trans with z; auto with ordered_type. + - elim (lt_not_eq (lt_trans Hlt H)); auto with ordered_type. + Qed. + + Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. + Proof. + intros x y z H H0; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + - elim (lt_not_eq H0); apply eq_trans with x; auto with ordered_type. + - elim (lt_not_eq (lt_trans H0 Hlt)); auto with ordered_type. + Qed. - Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. - intros x y z H ?; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - - elim (lt_not_eq H); apply eq_trans with z; auto with ordered_type. - - elim (lt_not_eq (lt_trans Hlt H)); auto with ordered_type. - Qed. + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros x x' Hx y y' Hy H. + apply eq_lt with x; auto with ordered_type. + apply lt_eq with y; auto. + Qed. + + Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. + Proof. intros x y; destruct (compare x y); auto. Qed. + + Module TO. + Definition t := t. + Definition eq := eq. + Definition lt := lt. + Definition le x y := lt x y \/ eq x y. + End TO. + Module IsTO. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y. + Proof. reflexivity. Qed. + End IsTO. + Module OrderTac := !MakeOrderTac TO IsTO. + Ltac order := OrderTac.order. + + Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. + Lemma eq_le x y z : eq x y -> ~lt y z -> ~lt x z. Proof. order. Qed. + Lemma neq_eq x y z : ~eq x y -> eq y z -> ~eq x z. Proof. order. Qed. + Lemma eq_neq x y z : eq x y -> ~eq y z -> ~eq x z. Proof. order. Qed. + Lemma le_lt_trans x y z : ~lt y x -> lt y z -> lt x z. Proof. order. Qed. + Lemma lt_le_trans x y z : lt x y -> ~lt z y -> lt x z. Proof. order. Qed. + Lemma le_neq x y : ~lt x y -> ~eq x y -> lt y x. Proof. order. Qed. + Lemma le_trans x y z : ~lt y x -> ~lt z y -> ~lt z x. Proof. order. Qed. + Lemma le_antisym x y : ~lt y x -> ~lt x y -> eq x y. Proof. order. Qed. + Lemma neq_sym x y : ~eq x y -> ~eq y x. Proof. order. Qed. + Lemma lt_le x y : lt x y -> ~lt y x. Proof. order. Qed. + Lemma gt_not_eq x y : lt y x -> ~ eq x y. Proof. order. Qed. + Lemma eq_not_lt x y : eq x y -> ~ lt x y. Proof. order. Qed. + Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. + Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. + + #[global] + Hint Resolve gt_not_eq eq_not_lt : ordered_type. + #[global] + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. + #[global] + Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. + + Lemma elim_compare_eq : + forall x y : t, + eq x y -> exists H : eq x y, compare x y = EQ H. + Proof. + intros x y H; case (compare x y); intros H'; try (exfalso; order). + exists H'; auto. + Qed. + + Lemma elim_compare_lt : + forall x y : t, + lt x y -> exists H : lt x y, compare x y = LT H. + Proof. + intros x y H; case (compare x y); intros H'; try (exfalso; order). + exists H'; auto. + Qed. + + Lemma elim_compare_gt : + forall x y : t, + lt y x -> exists H : lt y x, compare x y = GT H. + Proof. + intros x y H; case (compare x y); intros H'; try (exfalso; order). + exists H'; auto. + Qed. + + Ltac elim_comp := + match goal with + | |- ?e => match e with + | context ctx [ compare ?a ?b ] => + let H := fresh in + (destruct (compare a b) as [H|H|H]; try order) + end + end. + + Ltac elim_comp_eq x y := + elim (elim_compare_eq (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Ltac elim_comp_lt x y := + elim (elim_compare_lt (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Ltac elim_comp_gt x y := + elim (elim_compare_gt (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + (** For compatibility reasons *) + Definition eq_dec := eq_dec. + + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. + Proof. + intros x y; elim (compare x y); [ left | right | right ]; auto with ordered_type. + Defined. + + Definition eqb x y : bool := if eq_dec x y then true else false. + + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. + Proof. + unfold eqb; intros x y; destruct (eq_dec x y); elim_comp; auto. + Qed. + + (* Specialization of results about lists modulo. *) + + Section ForNotations. + + Notation In:=(InA eq). + Notation Inf:=(lelistA lt). + Notation Sort:=(sort lt). + Notation NoDup:=(NoDupA eq). + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. exact (InA_eqA eq_equiv). Qed. + + Lemma ListIn_In : forall l x, List.In x l -> In x l. + Proof. exact (In_InA eq_equiv). Qed. + + Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. + Proof. exact (InfA_ltA lt_strorder). Qed. + + Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. + Proof. exact (InfA_eqA eq_equiv lt_compat). Qed. + + Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. + Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. + + Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. + Proof. exact (@In_InfA t lt). Qed. + + Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. + Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. + + Lemma Inf_alt : + forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). + Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. + + Lemma Sort_NoDup : forall l, Sort l -> NoDup l. + Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. - Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. - Proof. - intros x y z H H0; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - - elim (lt_not_eq H0); apply eq_trans with x; auto with ordered_type. - - elim (lt_not_eq (lt_trans H0 Hlt)); auto with ordered_type. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - apply proper_sym_impl_iff_2; auto with *. - intros x x' Hx y y' Hy H. - apply eq_lt with x; auto with ordered_type. - apply lt_eq with y; auto. - Qed. - - Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. - Proof. intros x y; destruct (compare x y); auto. Qed. - - Module TO. - Definition t := t. - Definition eq := eq. - Definition lt := lt. - Definition le x y := lt x y \/ eq x y. - End TO. - Module IsTO. - Definition eq_equiv := eq_equiv. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition lt_total := lt_total. - Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y. - Proof. reflexivity. Qed. - End IsTO. - Module OrderTac := !MakeOrderTac TO IsTO. - Ltac order := OrderTac.order. - - Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. - Lemma eq_le x y z : eq x y -> ~lt y z -> ~lt x z. Proof. order. Qed. - Lemma neq_eq x y z : ~eq x y -> eq y z -> ~eq x z. Proof. order. Qed. - Lemma eq_neq x y z : eq x y -> ~eq y z -> ~eq x z. Proof. order. Qed. - Lemma le_lt_trans x y z : ~lt y x -> lt y z -> lt x z. Proof. order. Qed. - Lemma lt_le_trans x y z : lt x y -> ~lt z y -> lt x z. Proof. order. Qed. - Lemma le_neq x y : ~lt x y -> ~eq x y -> lt y x. Proof. order. Qed. - Lemma le_trans x y z : ~lt y x -> ~lt z y -> ~lt z x. Proof. order. Qed. - Lemma le_antisym x y : ~lt y x -> ~lt x y -> eq x y. Proof. order. Qed. - Lemma neq_sym x y : ~eq x y -> ~eq y x. Proof. order. Qed. - Lemma lt_le x y : lt x y -> ~lt y x. Proof. order. Qed. - Lemma gt_not_eq x y : lt y x -> ~ eq x y. Proof. order. Qed. - Lemma eq_not_lt x y : eq x y -> ~ lt x y. Proof. order. Qed. - Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. - Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. + End ForNotations. #[global] - Hint Resolve gt_not_eq eq_not_lt : ordered_type. - #[global] - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. + Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. #[global] - Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. - - Lemma elim_compare_eq : - forall x y : t, - eq x y -> exists H : eq x y, compare x y = EQ H. - Proof. - intros x y H; case (compare x y); intros H'; try (exfalso; order). - exists H'; auto. - Qed. - - Lemma elim_compare_lt : - forall x y : t, - lt x y -> exists H : lt x y, compare x y = LT H. - Proof. - intros x y H; case (compare x y); intros H'; try (exfalso; order). - exists H'; auto. - Qed. - - Lemma elim_compare_gt : - forall x y : t, - lt y x -> exists H : lt y x, compare x y = GT H. - Proof. - intros x y H; case (compare x y); intros H'; try (exfalso; order). - exists H'; auto. - Qed. - - Ltac elim_comp := - match goal with - | |- ?e => match e with - | context ctx [ compare ?a ?b ] => - let H := fresh in - (destruct (compare a b) as [H|H|H]; try order) - end - end. - - Ltac elim_comp_eq x y := - elim (elim_compare_eq (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_lt x y := - elim (elim_compare_lt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_gt x y := - elim (elim_compare_gt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - (** For compatibility reasons *) - Definition eq_dec := eq_dec. - - Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. - Proof. - intros x y; elim (compare x y); [ left | right | right ]; auto with ordered_type. - Defined. - - Definition eqb x y : bool := if eq_dec x y then true else false. - - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. - Proof. - unfold eqb; intros x y; destruct (eq_dec x y); elim_comp; auto. - Qed. - -(* Specialization of results about lists modulo. *) - -Section ForNotations. - -Notation In:=(InA eq). -Notation Inf:=(lelistA lt). -Notation Sort:=(sort lt). -Notation NoDup:=(NoDupA eq). - -Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. -Proof. exact (InA_eqA eq_equiv). Qed. - -Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA eq_equiv). Qed. - -Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA lt_strorder). Qed. - -Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA eq_equiv lt_compat). Qed. - -Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. -Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. - -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. -Proof. exact (@In_InfA t lt). Qed. - -Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. -Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. - -Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). -Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. - -Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. - -End ForNotations. - -#[global] -Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. -#[global] -Hint Immediate In_eq Inf_lt : ordered_type. + Hint Immediate In_eq Inf_lt : ordered_type. End OrderedTypeFacts. Module KeyOrderedType(O:OrderedType). - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := - eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - - #[local] - Hint Unfold eqk eqke ltk : ordered_type. - #[local] - Hint Extern 2 (eqke ?a ?b) => split : ordered_type. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* ltk ignore the second components *) + Import O. + Module MO:=OrderedTypeFacts(O). + Import MO. - Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). - Proof. auto. Qed. + Section Elt. + Variable elt : Type. + Notation key:=t. - Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. - Proof. auto. Qed. - #[local] - Hint Immediate ltk_right_r ltk_right_l : ordered_type. + Definition eqk (p p':key*elt) := eq (fst p) (fst p'). + Definition eqke (p p':key*elt) := + eq (fst p) (fst p') /\ (snd p) = (snd p'). + Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - (* eqk, eqke are equalities, ltk is a strict order *) + #[local] + Hint Unfold eqk eqke ltk : ordered_type. + #[local] + Hint Extern 2 (eqke ?a ?b) => split : ordered_type. - Lemma eqk_refl : forall e, eqk e e. - Proof. auto with ordered_type. Qed. + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* ltk ignore the second components *) + + Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). + Proof. auto. Qed. + + Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. + Proof. auto. Qed. + #[local] + Hint Immediate ltk_right_r ltk_right_l : ordered_type. - Lemma eqke_refl : forall e, eqke e e. - Proof. auto with ordered_type. Qed. + (* eqk, eqke are equalities, ltk is a strict order *) + + Lemma eqk_refl : forall e, eqk e e. + Proof. auto with ordered_type. Qed. + + Lemma eqke_refl : forall e, eqke e e. + Proof. auto with ordered_type. Qed. + + Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. + Proof. auto with ordered_type. Qed. + + Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. + Proof. unfold eqke; intuition auto with relations. Qed. + + Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. + Proof. eauto with ordered_type. Qed. + + Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. + Proof. + unfold eqke; intuition; [ eauto with ordered_type | congruence ]. + Qed. + + Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. + Proof. eauto with ordered_type. Qed. + + Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. + Proof. unfold eqk, ltk; auto with ordered_type. Qed. + + Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. + Proof. + unfold eqke, ltk; intuition; simpl in *; subst. + match goal with H : lt _ _, H1 : eq _ _ |- _ => exact (lt_not_eq H H1) end. + Qed. + + #[local] + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + #[local] + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + #[local] + Hint Immediate eqk_sym eqke_sym : ordered_type. + + #[global] Instance eqk_equiv : Equivalence eqk. + Proof. constructor; eauto with ordered_type. Qed. + + #[global] Instance eqke_equiv : Equivalence eqke. + Proof. split; eauto with ordered_type. Qed. + + #[global] Instance ltk_strorder : StrictOrder ltk. + Proof. constructor; eauto with ordered_type. intros x; apply (irreflexivity (x:=fst x)). Qed. + + #[global] Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. + Proof. + intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + Qed. + + #[global] Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. + Proof. + intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + Qed. + + (* Additional facts *) + + Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. + Proof. + unfold eqk, ltk; simpl; auto with ordered_type. + Qed. + + Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. + Proof. eauto with ordered_type. Qed. + + Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. + Proof. + intros (k,e) (k',e') (k'',e''). + unfold ltk, eqk; simpl; eauto with ordered_type. + Qed. + #[local] + Hint Resolve eqk_not_ltk : ordered_type. + #[local] + Hint Immediate ltk_eqk eqk_ltk : ordered_type. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + #[local] + Hint Resolve InA_eqke_eqk : ordered_type. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + Notation Sort := (sort ltk). + Notation Inf := (lelistA ltk). + + #[local] + Hint Unfold MapsTo In : ordered_type. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + intros k l; split; intros [y H]. + - exists y; auto with ordered_type. + - induction H as [a l eq|a l H IH]. + + destruct a as [k' y']. + exists y'; auto with ordered_type. + + destruct IH as [e H0]. + exists e; auto with ordered_type. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + Qed. + + Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. + Proof. exact (InfA_eqA eqk_equiv ltk_compat). Qed. + + Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. + Proof. exact (InfA_ltA ltk_strorder). Qed. + + #[local] + Hint Immediate Inf_eq : ordered_type. + #[local] + Hint Resolve Inf_lt : ordered_type. + + Lemma Sort_Inf_In : + forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Proof. + exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compat). + Qed. + + Lemma Sort_Inf_NotIn : + forall l k e, Sort l -> Inf (k,e) l -> ~In k l. + Proof. + intros l k e H H0; red; intros H1. + destruct H1 as [e' H2]. + elim (@ltk_not_eqk (k,e) (k,e')). + - eapply Sort_Inf_In; eauto with ordered_type. + - red; simpl; auto with ordered_type. + Qed. + + Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. + Proof. + exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compat). + Qed. + + Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. + Proof. + inversion 1; intros; eapply Sort_Inf_In; eauto. + Qed. + + Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> + ltk e e' \/ eqk e e'. + Proof. + intros l; inversion_clear 2; auto with ordered_type. + left; apply Sort_In_cons_1 with l; auto. + Qed. + + Lemma Sort_In_cons_3 : + forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. + Proof. + inversion_clear 1 as [|? ? H0 H1]; red; intros H H2. + destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto with ordered_type. + destruct H1; simpl in *; intuition. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. + Qed. + + End Elt. - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto with ordered_type. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition auto with relations. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto with ordered_type. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto with ordered_type | congruence ]. - Qed. - - Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto with ordered_type. Qed. - - Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto with ordered_type. Qed. - - Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. - Proof. - unfold eqke, ltk; intuition; simpl in *; subst. - match goal with H : lt _ _, H1 : eq _ _ |- _ => exact (lt_not_eq H H1) end. - Qed. - - #[local] + #[global] + Hint Unfold eqk eqke ltk : ordered_type. + #[global] + Hint Extern 2 (eqke ?a ?b) => split : ordered_type. + #[global] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. - #[local] + #[global] Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. - #[local] + #[global] Hint Immediate eqk_sym eqke_sym : ordered_type. - - #[global] Instance eqk_equiv : Equivalence eqk. - Proof. constructor; eauto with ordered_type. Qed. - - #[global] Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto with ordered_type. Qed. - - #[global] Instance ltk_strorder : StrictOrder ltk. - Proof. constructor; eauto with ordered_type. intros x; apply (irreflexivity (x:=fst x)). Qed. - - #[global] Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. - Proof. - intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. - Qed. - - #[global] Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. - Proof. - intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. - Qed. - - (* Additional facts *) - - Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. - Proof. - unfold eqk, ltk; simpl; auto with ordered_type. - Qed. - - Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. - Proof. eauto with ordered_type. Qed. - - Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. - Proof. - intros (k,e) (k',e') (k'',e''). - unfold ltk, eqk; simpl; eauto with ordered_type. - Qed. - #[local] + #[global] Hint Resolve eqk_not_ltk : ordered_type. - #[local] + #[global] Hint Immediate ltk_eqk eqk_ltk : ordered_type. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke; induction 1; intuition. - Qed. - #[local] + #[global] Hint Resolve InA_eqke_eqk : ordered_type. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - Notation Sort := (sort ltk). - Notation Inf := (lelistA ltk). - - #[local] + #[global] Hint Unfold MapsTo In : ordered_type. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - intros k l; split; intros [y H]. - - exists y; auto with ordered_type. - - induction H as [a l eq|a l H IH]. - + destruct a as [k' y']. - exists y'; auto with ordered_type. - + destruct IH as [e H0]. - exists e; auto with ordered_type. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_eqA eqk_equiv ltk_compat). Qed. - - Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_ltA ltk_strorder). Qed. - - #[local] + #[global] Hint Immediate Inf_eq : ordered_type. - #[local] + #[global] Hint Resolve Inf_lt : ordered_type. - - Lemma Sort_Inf_In : - forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. - exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compat). - Qed. - - Lemma Sort_Inf_NotIn : - forall l k e, Sort l -> Inf (k,e) l -> ~In k l. - Proof. - intros l k e H H0; red; intros H1. - destruct H1 as [e' H2]. - elim (@ltk_not_eqk (k,e) (k,e')). - - eapply Sort_Inf_In; eauto with ordered_type. - - red; simpl; auto with ordered_type. - Qed. - - Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. - Proof. - exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compat). - Qed. - - Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. - Proof. - inversion 1; intros; eapply Sort_Inf_In; eauto. - Qed. - - Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> - ltk e e' \/ eqk e e'. - Proof. - intros l; inversion_clear 2; auto with ordered_type. - left; apply Sort_In_cons_1 with l; auto. - Qed. - - Lemma Sort_In_cons_3 : - forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. - Proof. - inversion_clear 1 as [|? ? H0 H1]; red; intros H H2. - destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1 as [? H0]. - inversion_clear H0 as [? ? H1|]; eauto with ordered_type. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - End Elt. - - #[global] - Hint Unfold eqk eqke ltk : ordered_type. - #[global] - Hint Extern 2 (eqke ?a ?b) => split : ordered_type. - #[global] - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. - #[global] - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. - #[global] - Hint Immediate eqk_sym eqke_sym : ordered_type. - #[global] - Hint Resolve eqk_not_ltk : ordered_type. - #[global] - Hint Immediate ltk_eqk eqk_ltk : ordered_type. - #[global] - Hint Resolve InA_eqke_eqk : ordered_type. - #[global] - Hint Unfold MapsTo In : ordered_type. - #[global] - Hint Immediate Inf_eq : ordered_type. - #[global] - Hint Resolve Inf_lt : ordered_type. - #[global] - Hint Resolve Sort_Inf_NotIn : ordered_type. - #[global] - Hint Resolve In_inv_2 In_inv_3 : ordered_type. + #[global] + Hint Resolve Sort_Inf_NotIn : ordered_type. + #[global] + Hint Resolve In_inv_2 In_inv_3 : ordered_type. End KeyOrderedType. diff --git a/theories/Structures/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v index b80fd28cf7..cab63f24a5 100644 --- a/theories/Structures/OrderedTypeAlt.v +++ b/theories/Structures/OrderedTypeAlt.v @@ -18,103 +18,103 @@ whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] Module Type OrderedTypeAlt. - Parameter t : Type. + Parameter t : Type. - Parameter compare : t -> t -> comparison. + Parameter compare : t -> t -> comparison. - Infix "?=" := compare (at level 70, no associativity). + Infix "?=" := compare (at level 70, no associativity). - Parameter compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Parameter compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Parameter compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. End OrderedTypeAlt. (** From this new presentation to the original one. *) Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. - Import O. - - Definition t := t. - - Definition eq x y := (x?=y) = Eq. - Definition lt x y := (x?=y) = Lt. - - Lemma eq_refl : forall x, eq x x. - Proof. - intro x. - unfold eq. - assert (H:=compare_sym x x). - destruct (x ?= x); simpl in *; try discriminate; auto. - Qed. - - Lemma eq_sym : forall x y, eq x y -> eq y x. - Proof. - unfold eq; intros. - rewrite compare_sym. - rewrite H; simpl; auto. - Qed. - - Definition eq_trans := (compare_trans Eq). - - Definition lt_trans := (compare_trans Lt). - - Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. - Proof. - unfold eq, lt; intros. - rewrite H; discriminate. - Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros. - case_eq (x ?= y); intros. - - apply EQ; auto. - - apply LT; auto. - - apply GT; red. - rewrite compare_sym; rewrite H; auto. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq. - case (x ?= y); [ left | right | right ]; auto; discriminate. - Defined. + Import O. + + Definition t := t. + + Definition eq x y := (x?=y) = Eq. + Definition lt x y := (x?=y) = Lt. + + Lemma eq_refl : forall x, eq x x. + Proof. + intro x. + unfold eq. + assert (H:=compare_sym x x). + destruct (x ?= x); simpl in *; try discriminate; auto. + Qed. + + Lemma eq_sym : forall x y, eq x y -> eq y x. + Proof. + unfold eq; intros. + rewrite compare_sym. + rewrite H; simpl; auto. + Qed. + + Definition eq_trans := (compare_trans Eq). + + Definition lt_trans := (compare_trans Lt). + + Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. + Proof. + unfold eq, lt; intros. + rewrite H; discriminate. + Qed. + + Definition compare : forall x y, Compare lt eq x y. + Proof. + intros. + case_eq (x ?= y); intros. + - apply EQ; auto. + - apply LT; auto. + - apply GT; red. + rewrite compare_sym; rewrite H; auto. + Defined. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. End OrderedType_from_Alt. (** From the original presentation to this alternative one. *) Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Definition t := t. - - Definition compare x y := match compare x y with - | LT _ => Lt - | EQ _ => Eq - | GT _ => Gt - end. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Proof. - intros x y; unfold compare. - destruct O.compare; elim_comp; simpl; auto. - Qed. - - Lemma compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct c; unfold compare; - do 2 (destruct O.compare; intros; try discriminate); - elim_comp; auto. - Qed. + Import O. + Module MO:=OrderedTypeFacts(O). + Import MO. + + Definition t := t. + + Definition compare x y := match compare x y with + | LT _ => Lt + | EQ _ => Eq + | GT _ => Gt + end. + + Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Proof. + intros x y; unfold compare. + destruct O.compare; elim_comp; simpl; auto. + Qed. + + Lemma compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Proof. + intros c x y z. + destruct c; unfold compare; + do 2 (destruct O.compare; intros; try discriminate); + elim_comp; auto. + Qed. End OrderedType_to_Alt. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index 2fb3149dac..50602546e8 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -20,16 +20,16 @@ From Stdlib Require Import NArith Ndec. the equality is the usual one of Coq. *) Module Type UsualOrderedType. - Parameter Inline t : Type. - Definition eq := @eq t. - Parameter Inline lt : t -> t -> Prop. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Parameter compare : forall x y : t, Compare lt eq x y. - Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. + Parameter Inline t : Type. + Definition eq := @eq t. + Parameter Inline lt : t -> t -> Prop. + Definition eq_refl := @eq_refl t. + Definition eq_sym := @eq_sym t. + Definition eq_trans := @eq_trans t. + Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Parameter compare : forall x y : t, Compare lt eq x y. + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. End UsualOrderedType. (** a [UsualOrderedType] is in particular an [OrderedType]. *) @@ -117,15 +117,15 @@ Module Positive_as_OT <: UsualOrderedType. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Proof. - intros x y H. contradict H. rewrite H. apply Pos.lt_irrefl. + intros x y H. contradict H. rewrite H. apply Pos.lt_irrefl. Qed. Definition compare x y : Compare lt eq x y. Proof. - case_eq (x ?= y); intros H. - - apply EQ. now apply Pos.compare_eq. - - apply LT; assumption. - - apply GT. now apply Pos.gt_lt. + case_eq (x ?= y); intros H. + - apply EQ. now apply Pos.compare_eq. + - apply LT; assumption. + - apply GT. now apply Pos.gt_lt. Defined. Definition eq_dec := Pos.eq_dec. @@ -148,10 +148,10 @@ Module N_as_OT <: UsualOrderedType. Definition compare x y : Compare lt eq x y. Proof. - case_eq (x ?= y)%N; intro. - - apply EQ. now apply N.compare_eq. - - apply LT. assumption. - - apply GT. now apply N.gt_lt. + case_eq (x ?= y)%N; intro. + - apply EQ. now apply N.compare_eq. + - apply LT. assumption. + - apply GT. now apply N.gt_lt. Defined. Definition eq_dec := N.eq_dec. @@ -163,65 +163,66 @@ End N_as_OT. over their cartesian product, using the lexicographic order. *) Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. - Module MO1:=OrderedTypeFacts(O1). - Module MO2:=OrderedTypeFacts(O2). - - Definition t := prod O1.t O2.t. - - Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). - - Definition lt x y := - O1.lt (fst x) (fst y) \/ - (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). - - Lemma eq_refl : forall x : t, eq x x. - Proof. - intros (x1,x2); red; simpl; auto with ordered_type. - Qed. - - Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl; intuition auto with relations. - Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. - - left; eauto with ordered_type. - - left; eapply MO1.lt_eq; eauto. - - left; eapply MO1.eq_lt; eauto. - - right; split; eauto with ordered_type. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition. - - apply (O1.lt_not_eq H0 H1). - - apply (O2.lt_not_eq H3 H2). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - intros (x1,x2) (y1,y2). - destruct (O1.compare x1 y1). - - apply LT; unfold lt; auto. - - destruct (O2.compare x2 y2). - + apply LT; unfold lt; auto. - + apply EQ; unfold eq; auto. - + apply GT; unfold lt; auto with ordered_type. - - apply GT; unfold lt; auto. - Defined. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - - auto using lt_not_eq. - - assert (~ eq y x); auto using lt_not_eq, eq_sym. - Defined. + Module MO1:=OrderedTypeFacts(O1). + Module MO2:=OrderedTypeFacts(O2). + + Definition t := prod O1.t O2.t. + + Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). + + Definition lt x y := + O1.lt (fst x) (fst y) \/ + (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). + + Lemma eq_refl : forall x : t, eq x x. + Proof. + intros (x1,x2); red; simpl; auto with ordered_type. + Qed. + + Lemma eq_sym : forall x y : t, eq x y -> eq y x. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl; intuition auto with relations. + Qed. + + Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + Proof. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type. + Qed. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Proof. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. + - left; eauto with ordered_type. + - left; eapply MO1.lt_eq; eauto. + - left; eapply MO1.eq_lt; eauto. + - right; split; eauto with ordered_type. + Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Proof. + intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition. + - apply (O1.lt_not_eq H0 H1). + - apply (O2.lt_not_eq H3 H2). + Qed. + + Definition compare : forall x y : t, Compare lt eq x y. + Proof. + intros (x1,x2) (y1,y2). + destruct (O1.compare x1 y1). + - apply LT; unfold lt; auto. + - destruct (O2.compare x2 y2). + + apply LT; unfold lt; auto. + + apply EQ; unfold eq; auto. + + apply GT; unfold lt; auto with ordered_type. + - apply GT; unfold lt; auto. + Defined. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + - auto using lt_not_eq. + - assert (~ eq y x); auto using lt_not_eq, eq_sym. + Defined. End PairOrderedType. @@ -253,65 +254,65 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. Lemma bits_lt_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. Proof. - induction x. - - induction y; destruct z; simpl; eauto; intuition. - - induction y; destruct z; simpl; eauto; intuition. - - induction y; destruct z; simpl; eauto; intuition. + induction x. + - induction y; destruct z; simpl; eauto; intuition. + - induction y; destruct z; simpl; eauto; intuition. + - induction y; destruct z; simpl; eauto; intuition. Qed. Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof. - exact bits_lt_trans. + exact bits_lt_trans. Qed. Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. Proof. - induction x; simpl; auto. + induction x; simpl; auto. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Proof. - intros; intro. - rewrite <- H0 in H; clear H0 y. - unfold lt in H. - exact (bits_lt_antirefl x H). + intros; intro. + rewrite <- H0 in H; clear H0 y. + unfold lt in H. + exact (bits_lt_antirefl x H). Qed. Definition compare : forall x y : t, Compare lt eq x y. Proof. - induction x; destruct y. - + (* I I *) - destruct (IHx y) as [l|e|g]. - * apply LT; auto. - * apply EQ; rewrite e; red; auto. - * apply GT; auto. - + (* I O *) - apply GT; simpl; auto. - + (* I H *) - apply GT; simpl; auto. - + (* O I *) - apply LT; simpl; auto. - + (* O O *) - destruct (IHx y) as [l|e|g]. - * apply LT; auto. - * apply EQ; rewrite e; red; auto. - * apply GT; auto. - + (* O H *) - apply LT; simpl; auto. - + (* H I *) - apply LT; simpl; auto. - + (* H O *) - apply GT; simpl; auto. - + (* H H *) - apply EQ; red; auto. + induction x; destruct y. + + (* I I *) + destruct (IHx y) as [l|e|g]. + * apply LT; auto. + * apply EQ; rewrite e; red; auto. + * apply GT; auto. + + (* I O *) + apply GT; simpl; auto. + + (* I H *) + apply GT; simpl; auto. + + (* O I *) + apply LT; simpl; auto. + + (* O O *) + destruct (IHx y) as [l|e|g]. + * apply LT; auto. + * apply EQ; rewrite e; red; auto. + * apply GT; auto. + + (* O H *) + apply LT; simpl; auto. + + (* H I *) + apply LT; simpl; auto. + + (* H O *) + apply GT; simpl; auto. + + (* H H *) + apply EQ; red; auto. Qed. Lemma eq_dec (x y: positive): {x = y} + {x <> y}. Proof. - intros. case_eq (x ?= y); intros. - - left. now apply Pos.compare_eq. - - right. intro. subst y. now rewrite (Pos.compare_refl x) in *. - - right. intro. subst y. now rewrite (Pos.compare_refl x) in *. + intros. case_eq (x ?= y); intros. + - left. now apply Pos.compare_eq. + - right. intro. subst y. now rewrite (Pos.compare_refl x) in *. + - right. intro. subst y. now rewrite (Pos.compare_refl x) in *. Qed. End PositiveOrderedTypeBits. diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v index c342d92d1c..fde7764219 100644 --- a/theories/Structures/OrdersAlt.v +++ b/theories/Structures/OrdersAlt.v @@ -27,16 +27,16 @@ Module Type OrderedTypeOrig := OrderedType.OrderedType. Module Type OrderedTypeAlt. - Parameter t : Type. + Parameter t : Type. - Parameter compare : t -> t -> comparison. + Parameter compare : t -> t -> comparison. - Infix "?=" := compare (at level 70, no associativity). + Infix "?=" := compare (at level 70, no associativity). - Parameter compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Parameter compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Parameter compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. End OrderedTypeAlt. @@ -44,45 +44,45 @@ End OrderedTypeAlt. Module Update_OT (O:OrderedTypeOrig) <: OrderedType. - Include Update_DT O. (* Provides : t eq eq_equiv eq_dec *) - - Definition lt := O.lt. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros x Hx. apply (O.lt_not_eq Hx); auto with *. - - exact O.lt_trans. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - intros x x' Hx y y' Hy H. - assert (H0 : lt x' y). { - destruct (O.compare x' y) as [H'|H'|H']; auto. - - elim (O.lt_not_eq H). transitivity x'; auto with *. - - elim (O.lt_not_eq (O.lt_trans H H')); auto. - } - destruct (O.compare x' y') as [H'|H'|H']; auto. - - elim (O.lt_not_eq H). - transitivity x'; auto with *. transitivity y'; auto with *. - - elim (O.lt_not_eq (O.lt_trans H' H0)); auto with *. - Qed. - - Definition compare x y := - match O.compare x y with - | EQ _ => Eq - | LT _ => Lt - | GT _ => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros; unfold compare; destruct O.compare; auto. - Qed. + Include Update_DT O. (* Provides : t eq eq_equiv eq_dec *) + + Definition lt := O.lt. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - intros x Hx. apply (O.lt_not_eq Hx); auto with *. + - exact O.lt_trans. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros x x' Hx y y' Hy H. + assert (H0 : lt x' y). { + destruct (O.compare x' y) as [H'|H'|H']; auto. + - elim (O.lt_not_eq H). transitivity x'; auto with *. + - elim (O.lt_not_eq (O.lt_trans H H')); auto. + } + destruct (O.compare x' y') as [H'|H'|H']; auto. + - elim (O.lt_not_eq H). + transitivity x'; auto with *. transitivity y'; auto with *. + - elim (O.lt_not_eq (O.lt_trans H' H0)); auto with *. + Qed. + + Definition compare x y := + match O.compare x y with + | EQ _ => Eq + | LT _ => Lt + | GT _ => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros; unfold compare; destruct O.compare; auto. + Qed. End Update_OT. @@ -90,23 +90,23 @@ End Update_OT. Module Backport_OT (O:OrderedType) <: OrderedTypeOrig. - Include Backport_DT O. (* Provides : t eq eq_refl eq_sym eq_trans eq_dec *) + Include Backport_DT O. (* Provides : t eq eq_refl eq_sym eq_trans eq_dec *) - Definition lt := O.lt. + Definition lt := O.lt. - Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. - Proof. - intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto. - Qed. + Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. + Proof. + intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto. + Qed. - Lemma lt_trans : Transitive lt. - Proof. apply O.lt_strorder. Qed. + Lemma lt_trans : Transitive lt. + Proof. apply O.lt_strorder. Qed. - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros x y; destruct (CompSpec2Type (O.compare_spec x y)); - [apply EQ|apply LT|apply GT]; auto. - Defined. + Definition compare : forall x y, Compare lt eq x y. + Proof. + intros x y; destruct (CompSpec2Type (O.compare_spec x y)); + [apply EQ|apply LT|apply GT]; auto. + Defined. End Backport_OT. @@ -115,78 +115,78 @@ End Backport_OT. Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType. - Definition t := t. - - Definition eq x y := (x?=y) = Eq. - Definition lt x y := (x?=y) = Lt. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. - split; red. - - (* refl *) - unfold eq; intros x. - assert (H:=compare_sym x x). - destruct (x ?= x); simpl in *; auto; discriminate. - - (* sym *) - unfold eq; intros x y H. - rewrite compare_sym, H; simpl; auto. - - (* trans *) - apply compare_trans. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; repeat red; unfold lt; try apply compare_trans. - intros x H. - assert (eq x x) by reflexivity. - unfold eq in *; congruence. - Qed. - - Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. - unfold lt, eq; intros x y z Hxy Hyz. - destruct (compare x z) eqn:Hxz; auto. - - rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. - rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. - - rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. - rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. - Qed. - - Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. - Proof. - unfold lt, eq; intros x y z Hxy Hyz. - destruct (compare x z) eqn:Hxz; auto. - - rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. - rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. - - rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. - rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - repeat red; intros. - eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto. - Qed. - - Definition compare := O.compare. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt, compare; intros. - destruct (O.compare x y) eqn:H; auto. - apply CompGt. - rewrite compare_sym, H; auto. - Qed. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq. - case (x ?= y); [ left | right | right ]; auto; discriminate. - Defined. + Definition t := t. + + Definition eq x y := (x?=y) = Eq. + Definition lt x y := (x?=y) = Lt. + + #[global] + Instance eq_equiv : Equivalence eq. + Proof. + split; red. + - (* refl *) + unfold eq; intros x. + assert (H:=compare_sym x x). + destruct (x ?= x); simpl in *; auto; discriminate. + - (* sym *) + unfold eq; intros x y H. + rewrite compare_sym, H; simpl; auto. + - (* trans *) + apply compare_trans. + Qed. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split; repeat red; unfold lt; try apply compare_trans. + intros x H. + assert (eq x x) by reflexivity. + unfold eq in *; congruence. + Qed. + + Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. + Proof. + unfold lt, eq; intros x y z Hxy Hyz. + destruct (compare x z) eqn:Hxz; auto. + - rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. + rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. + - rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. + rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. + Qed. + + Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. + Proof. + unfold lt, eq; intros x y z Hxy Hyz. + destruct (compare x z) eqn:Hxz; auto. + - rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. + rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. + - rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. + rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + repeat red; intros. + eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto. + Qed. + + Definition compare := O.compare. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + unfold eq, lt, compare; intros. + destruct (O.compare x y) eqn:H; auto. + apply CompGt. + rewrite compare_sym, H; auto. + Qed. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. End OT_from_Alt. @@ -194,55 +194,55 @@ End OT_from_Alt. Module OT_to_Alt (Import O:OrderedType) <: OrderedTypeAlt. - Definition t := t. - Definition compare := compare. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Proof. - intros x y; unfold compare. - destruct (compare_spec x y) as [U|U|U]; - destruct (compare_spec y x) as [V|V|V]; auto. - - rewrite U in V. elim (StrictOrder_Irreflexive y); auto. - - rewrite U in V. elim (StrictOrder_Irreflexive y); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive y); auto. - Qed. - - Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y. - Proof. - unfold compare. - intros x y; destruct (compare_spec x y); intuition; - try discriminate. - - rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. - - rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. - Qed. - - Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y. - Proof. - unfold compare. - intros x y; destruct (compare_spec x y); intuition; - try discriminate. - - rewrite H in H0. elim (StrictOrder_Irreflexive y); auto. - - rewrite H in H0. elim (StrictOrder_Irreflexive x); auto. - Qed. - - Lemma compare_Gt : forall x y, compare x y = Gt <-> lt y x. - Proof. - intros x y. rewrite compare_sym, CompOpp_iff. apply compare_Lt. - Qed. - - Lemma compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct c; unfold compare; - rewrite ?compare_Eq, ?compare_Lt, ?compare_Gt; - transitivity y; auto. - Qed. + Definition t := t. + Definition compare := compare. + + Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Proof. + intros x y; unfold compare. + destruct (compare_spec x y) as [U|U|U]; + destruct (compare_spec y x) as [V|V|V]; auto. + - rewrite U in V. elim (StrictOrder_Irreflexive y); auto. + - rewrite U in V. elim (StrictOrder_Irreflexive y); auto. + - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + - rewrite V in U. elim (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y. + Proof. + unfold compare. + intros x y; destruct (compare_spec x y); intuition; + try discriminate. + - rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. + - rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y. + Proof. + unfold compare. + intros x y; destruct (compare_spec x y); intuition; + try discriminate. + - rewrite H in H0. elim (StrictOrder_Irreflexive y); auto. + - rewrite H in H0. elim (StrictOrder_Irreflexive x); auto. + Qed. + + Lemma compare_Gt : forall x y, compare x y = Gt <-> lt y x. + Proof. + intros x y. rewrite compare_sym, CompOpp_iff. apply compare_Lt. + Qed. + + Lemma compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Proof. + intros c x y z. + destruct c; unfold compare; + rewrite ?compare_Eq, ?compare_Lt, ?compare_Gt; + transitivity y; auto. + Qed. End OT_to_Alt. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index 8b0da97c47..b8d43a0bc8 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -46,48 +46,48 @@ Module Z_as_DT <: UsualDecidableType := Z_as_OT. over their cartesian product, using the lexicographic order. *) Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. - Include PairDecidableType O1 O2. - - Definition lt := - (relation_disjunction (O1.lt @@1) (O1.eq * O2.lt))%signature. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - (* irreflexive *) - intros (x1,x2); compute. destruct 1. - + apply (StrictOrder_Irreflexive x1); auto. - + apply (StrictOrder_Irreflexive x2); intuition. - - (* transitive *) - intros (x1,x2) (y1,y2) (z1,z2). compute. intuition. - + left; etransitivity; eauto. - + left. setoid_replace z1 with y1; auto with relations. - + left; setoid_replace x1 with y1; auto with relations. - + right; split; etransitivity; eauto. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - compute. - intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2). - rewrite X1,X2,Y1,Y2; intuition. - Qed. - - Definition compare x y := - match O1.compare (fst x) (fst y) with - | Eq => O2.compare (snd x) (snd y) - | Lt => Lt - | Gt => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros (x1,x2) (y1,y2); unfold compare; simpl. - destruct (O1.compare_spec x1 y1); try (constructor; compute; auto). - destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations. - Qed. + Include PairDecidableType O1 O2. + + Definition lt := + (relation_disjunction (O1.lt @@1) (O1.eq * O2.lt))%signature. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split. + - (* irreflexive *) + intros (x1,x2); compute. destruct 1. + + apply (StrictOrder_Irreflexive x1); auto. + + apply (StrictOrder_Irreflexive x2); intuition. + - (* transitive *) + intros (x1,x2) (y1,y2) (z1,z2). compute. intuition. + + left; etransitivity; eauto. + + left. setoid_replace z1 with y1; auto with relations. + + left; setoid_replace x1 with y1; auto with relations. + + right; split; etransitivity; eauto. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + compute. + intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2). + rewrite X1,X2,Y1,Y2; intuition. + Qed. + + Definition compare x y := + match O1.compare (fst x) (fst y) with + | Eq => O2.compare (snd x) (snd y) + | Lt => Lt + | Gt => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros (x1,x2) (y1,y2); unfold compare; simpl. + destruct (O1.compare_spec x1 y1); try (constructor; compute; auto). + destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations. + Qed. End PairOrderedType. @@ -99,153 +99,153 @@ End PairOrderedType. #[local] Open Scope positive. Module PositiveOrderedTypeBits <: UsualOrderedType. - Definition t:=positive. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := Pos.eqb. - Definition eqb_eq := Pos.eqb_eq. - Include HasEqBool2Dec. - - Fixpoint bits_lt (p q:positive) : Prop := - match p, q with - | xH, xI _ => True - | xH, _ => False - | xO p, xO q => bits_lt p q - | xO _, _ => True - | xI p, xI q => bits_lt p q - | xI _, _ => False - end. - - Definition lt:=bits_lt. - - Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. - Proof. - induction x; simpl; auto. - Qed. - - Lemma bits_lt_trans : - forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. - Proof. - induction x; destruct y,z; simpl; eauto; intuition. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; [ exact bits_lt_antirefl | exact bits_lt_trans ]. - Qed. - - Fixpoint compare x y := - match x, y with - | x~1, y~1 => compare x y - | _~1, _ => Gt - | x~0, y~0 => compare x y - | _~0, _ => Lt - | 1, _~1 => Lt - | 1, 1 => Eq - | 1, _~0 => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt. - induction x; destruct y; try constructor; simpl; auto. - - destruct (IHx y); subst; auto. - - destruct (IHx y); subst; auto. - Qed. + Definition t:=positive. + Include HasUsualEq <+ UsualIsEq. + Definition eqb := Pos.eqb. + Definition eqb_eq := Pos.eqb_eq. + Include HasEqBool2Dec. + + Fixpoint bits_lt (p q:positive) : Prop := + match p, q with + | xH, xI _ => True + | xH, _ => False + | xO p, xO q => bits_lt p q + | xO _, _ => True + | xI p, xI q => bits_lt p q + | xI _, _ => False + end. + + Definition lt:=bits_lt. + + Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. + Proof. + induction x; simpl; auto. + Qed. + + Lemma bits_lt_trans : + forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. + Proof. + induction x; destruct y,z; simpl; eauto; intuition. + Qed. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. + Qed. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split; [ exact bits_lt_antirefl | exact bits_lt_trans ]. + Qed. + + Fixpoint compare x y := + match x, y with + | x~1, y~1 => compare x y + | _~1, _ => Gt + | x~0, y~0 => compare x y + | _~0, _ => Lt + | 1, _~1 => Lt + | 1, 1 => Eq + | 1, _~0 => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + unfold eq, lt. + induction x; destruct y; try constructor; simpl; auto. + - destruct (IHx y); subst; auto. + - destruct (IHx y); subst; auto. + Qed. End PositiveOrderedTypeBits. Module Ascii_as_OT <: UsualOrderedType. - Definition t := ascii. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := Ascii.eqb. - Definition eqb_eq := Ascii.eqb_eq. - Include HasEqBool2Dec. - - Definition compare (a b : ascii) := N_as_OT.compare (N_of_ascii a) (N_of_ascii b). - Definition lt (a b : ascii) := N_as_OT.lt (N_of_ascii a) (N_of_ascii b). - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; unfold lt; [ intro | intros ??? ]; eapply N_as_OT.lt_strorder. - Qed. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros x y; unfold eq, lt, compare. - destruct (N_as_OT.compare_spec (N_of_ascii x) (N_of_ascii y)) as [H|H|H]; constructor; try assumption. - now rewrite <- (ascii_N_embedding x), <- (ascii_N_embedding y), H. - Qed. + Definition t := ascii. + Include HasUsualEq <+ UsualIsEq. + Definition eqb := Ascii.eqb. + Definition eqb_eq := Ascii.eqb_eq. + Include HasEqBool2Dec. + + Definition compare (a b : ascii) := N_as_OT.compare (N_of_ascii a) (N_of_ascii b). + Definition lt (a b : ascii) := N_as_OT.lt (N_of_ascii a) (N_of_ascii b). + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. + Qed. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split; unfold lt; [ intro | intros ??? ]; eapply N_as_OT.lt_strorder. + Qed. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros x y; unfold eq, lt, compare. + destruct (N_as_OT.compare_spec (N_of_ascii x) (N_of_ascii y)) as [H|H|H]; constructor; try assumption. + now rewrite <- (ascii_N_embedding x), <- (ascii_N_embedding y), H. + Qed. End Ascii_as_OT. (** [String] is an ordered type with respect to the usual lexical order. *) Module String_as_OT <: UsualOrderedType. - Definition t := string. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := String.eqb. - Definition eqb_eq := String.eqb_eq. - Include HasEqBool2Dec. - - Fixpoint compare (a b : string) - := match a, b with - | EmptyString, EmptyString => Eq - | EmptyString, _ => Lt - | String _ _, EmptyString => Gt - | String a_head a_tail, String b_head b_tail => - match Ascii_as_OT.compare a_head b_head with - | Lt => Lt - | Gt => Gt - | Eq => compare a_tail b_tail - end - end. - - Definition lt (a b : string) := compare a b = Lt. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt. - induction x as [|x xs IHxs], y as [|y ys]; cbn [compare]; try constructor; cbn [compare]; try reflexivity. - specialize (IHxs ys). - destruct (Ascii_as_OT.compare x y) eqn:H; [ destruct IHxs; constructor | constructor | constructor ]; cbn [compare]. - all: destruct (Ascii_as_OT.compare_spec y x), (Ascii_as_OT.compare_spec x y); cbv [Ascii_as_OT.eq] in *; try congruence; subst. - all: exfalso; eapply irreflexivity; (idtac + etransitivity); eassumption. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; unfold lt; [ intro x | intros x y z ]; unfold complement. - { induction x as [|x xs IHxs]; cbn [compare]; [ congruence | ]. - destruct (Ascii_as_OT.compare x x) eqn:H; try congruence. - exfalso; eapply irreflexivity; eassumption. } - { revert x y z. - induction x as [|x xs IHxs], y as [|y ys], z as [|z zs]; cbn [compare]; try congruence. - specialize (IHxs ys zs). - destruct (Ascii_as_OT.compare x y) eqn:Hxy, (Ascii_as_OT.compare y z) eqn:Hyz, (Ascii_as_OT.compare x z) eqn:Hxz; - try intuition (congruence || eauto). - all: destruct (Ascii_as_OT.compare_spec x y), (Ascii_as_OT.compare_spec y z), (Ascii_as_OT.compare_spec x z); - try discriminate. - all: unfold Ascii_as_OT.eq in *; subst. - all: exfalso; eapply irreflexivity; (idtac + etransitivity); (idtac + etransitivity); eassumption. } - Qed. + Definition t := string. + Include HasUsualEq <+ UsualIsEq. + Definition eqb := String.eqb. + Definition eqb_eq := String.eqb_eq. + Include HasEqBool2Dec. + + Fixpoint compare (a b : string) + := match a, b with + | EmptyString, EmptyString => Eq + | EmptyString, _ => Lt + | String _ _, EmptyString => Gt + | String a_head a_tail, String b_head b_tail => + match Ascii_as_OT.compare a_head b_head with + | Lt => Lt + | Gt => Gt + | Eq => compare a_tail b_tail + end + end. + + Definition lt (a b : string) := compare a b = Lt. + + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. + Qed. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + unfold eq, lt. + induction x as [|x xs IHxs], y as [|y ys]; cbn [compare]; try constructor; cbn [compare]; try reflexivity. + specialize (IHxs ys). + destruct (Ascii_as_OT.compare x y) eqn:H; [ destruct IHxs; constructor | constructor | constructor ]; cbn [compare]. + all: destruct (Ascii_as_OT.compare_spec y x), (Ascii_as_OT.compare_spec x y); cbv [Ascii_as_OT.eq] in *; try congruence; subst. + all: exfalso; eapply irreflexivity; (idtac + etransitivity); eassumption. + Qed. + + #[global] + Instance lt_strorder : StrictOrder lt. + Proof. + split; unfold lt; [ intro x | intros x y z ]; unfold complement. + { induction x as [|x xs IHxs]; cbn [compare]; [ congruence | ]. + destruct (Ascii_as_OT.compare x x) eqn:H; try congruence. + exfalso; eapply irreflexivity; eassumption. } + { revert x y z. + induction x as [|x xs IHxs], y as [|y ys], z as [|z zs]; cbn [compare]; try congruence. + specialize (IHxs ys zs). + destruct (Ascii_as_OT.compare x y) eqn:Hxy, (Ascii_as_OT.compare y z) eqn:Hyz, (Ascii_as_OT.compare x z) eqn:Hxz; + try intuition (congruence || eauto). + all: destruct (Ascii_as_OT.compare_spec x y), (Ascii_as_OT.compare_spec y z), (Ascii_as_OT.compare_spec x z); + try discriminate. + all: unfold Ascii_as_OT.eq in *; subst. + all: exfalso; eapply irreflexivity; (idtac + etransitivity); (idtac + etransitivity); eassumption. } + Qed. End String_as_OT. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 1db277676b..9fb4ada6f8 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -18,60 +18,60 @@ Unset Strict Implicit. Module Type CompareFacts (Import O:DecStrOrder'). - #[local] Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_eq_iff x y : (x ?= y) = Eq <-> x==y. - Proof. - case compare_spec; intro H; split; try easy; intro EQ; - contradict H; rewrite EQ; apply irreflexivity. - Qed. - - Lemma compare_eq x y : (x ?= y) = Eq -> x==y. - Proof. - apply compare_eq_iff. - Qed. - - Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x y Lt <-> ~(x Gt <-> ~(yeq==>Logic.eq) compare. - Proof. - intros x x' Hxx' y y' Hyy'. - case (compare_spec x' y'); autorewrite with order; now rewrite Hxx', Hyy'. - Qed. - - Lemma compare_refl x : (x ?= x) = Eq. - Proof. - case compare_spec; intros; trivial; now elim irreflexivity with x. - Qed. - - Lemma compare_antisym x y : (y ?= x) = CompOpp (x ?= y). - Proof. - case (compare_spec x y); simpl; autorewrite with order; - trivial; now symmetry. - Qed. + #[local] Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_eq_iff x y : (x ?= y) = Eq <-> x==y. + Proof. + case compare_spec; intro H; split; try easy; intro EQ; + contradict H; rewrite EQ; apply irreflexivity. + Qed. + + Lemma compare_eq x y : (x ?= y) = Eq -> x==y. + Proof. + apply compare_eq_iff. + Qed. + + Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x y Lt <-> ~(x Gt <-> ~(yeq==>Logic.eq) compare. + Proof. + intros x x' Hxx' y y' Hyy'. + case (compare_spec x' y'); autorewrite with order; now rewrite Hxx', Hyy'. + Qed. + + Lemma compare_refl x : (x ?= x) = Eq. + Proof. + case compare_spec; intros; trivial; now elim irreflexivity with x. + Qed. + + Lemma compare_antisym x y : (y ?= x) = CompOpp (x ?= y). + Proof. + case (compare_spec x y); simpl; autorewrite with order; + trivial; now symmetry. + Qed. End CompareFacts. @@ -80,52 +80,52 @@ End CompareFacts. Module OrderedTypeFullFacts (Import O:OrderedTypeFull'). - Module OrderTac := OTF_to_OrderTac O. - Ltac order := OrderTac.order. - Ltac iorder := intuition order. + Module OrderTac := OTF_to_OrderTac O. + Ltac order := OrderTac.order. + Ltac iorder := intuition order. -#[global] - Instance le_compat : Proper (eq==>eq==>iff) le. - Proof. repeat red; iorder. Qed. + #[global] + Instance le_compat : Proper (eq==>eq==>iff) le. + Proof. repeat red; iorder. Qed. -#[global] - Instance le_preorder : PreOrder le. - Proof. split; red; order. Qed. + #[global] + Instance le_preorder : PreOrder le. + Proof. split; red; order. Qed. -#[global] - Instance le_order : PartialOrder eq le. - Proof. compute; iorder. Qed. + #[global] + Instance le_order : PartialOrder eq le. + Proof. compute; iorder. Qed. -#[global] - Instance le_antisym : Antisymmetric _ eq le. - Proof. apply partial_order_antisym; auto with *. Qed. + #[global] + Instance le_antisym : Antisymmetric _ eq le. + Proof. apply partial_order_antisym; auto with *. Qed. - Lemma le_not_gt_iff : forall x y, x<=y <-> ~y ~y ~y<=x. - Proof. iorder. Qed. + Lemma lt_not_ge_iff : forall x y, x ~y<=x. + Proof. iorder. Qed. - Lemma le_or_gt : forall x y, x<=y \/ y x<=y /\ y<=x. - Proof. iorder. Qed. + Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x. + Proof. iorder. Qed. - Include CompareFacts O. + Include CompareFacts O. - Lemma compare_le_iff x y : compare x y <> Gt <-> x<=y. - Proof. - rewrite le_not_gt_iff. apply compare_ngt_iff. - Qed. + Lemma compare_le_iff x y : compare x y <> Gt <-> x<=y. + Proof. + rewrite le_not_gt_iff. apply compare_ngt_iff. + Qed. - Lemma compare_ge_iff x y : compare x y <> Lt <-> y<=x. - Proof. - rewrite le_not_gt_iff. apply compare_nlt_iff. - Qed. + Lemma compare_ge_iff x y : compare x y <> Lt <-> y<=x. + Proof. + rewrite le_not_gt_iff. apply compare_nlt_iff. + Qed. End OrderedTypeFullFacts. @@ -134,71 +134,71 @@ End OrderedTypeFullFacts. Module OrderedTypeFacts (Import O: OrderedType'). - Module OrderTac := OT_to_OrderTac O. - Ltac order := OrderTac.order. + Module OrderTac := OT_to_OrderTac O. + Ltac order := OrderTac.order. - Declare Scope order. - Notation "x <= y" := (~lt y x) : order. - Infix "?=" := compare (at level 70, no associativity) : order. + Declare Scope order. + Notation "x <= y" := (~lt y x) : order. + Infix "?=" := compare (at level 70, no associativity) : order. - #[local] Open Scope order. + #[local] Open Scope order. - Tactic Notation "elim_compare" constr(x) constr(y) := - destruct (compare_spec x y). + Tactic Notation "elim_compare" constr(x) constr(y) := + destruct (compare_spec x y). - Tactic Notation "elim_compare" constr(x) constr(y) "as" ident(h) := - destruct (compare_spec x y) as [h|h|h]. + Tactic Notation "elim_compare" constr(x) constr(y) "as" ident(h) := + destruct (compare_spec x y) as [h|h|h]. - (** The following lemmas are either re-phrasing of [eq_equiv] and + (** The following lemmas are either re-phrasing of [eq_equiv] and [lt_strorder] or immediately provable by [order]. Interest: compatibility, test of order, etc *) - Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x. + Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x. - Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y. + Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y. - Definition eq_trans (x y z:t) : x==y -> y==z -> x==z := - Equivalence_Transitive x y z. + Definition eq_trans (x y z:t) : x==y -> y==z -> x==z := + Equivalence_Transitive x y z. - Definition lt_trans (x y z:t) : x y x y x b | _ => b' end). - Proof. - destruct eq_dec; elim_compare x y; auto; order. - Qed. + Lemma if_eq_dec x y (B:Type)(b b':B) : + (if eq_dec x y then b else b') = + (match compare x y with Eq => b | _ => b' end). + Proof. + destruct eq_dec; elim_compare x y; auto; order. + Qed. - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with Eq => true | _ => false end. - Proof. - unfold eqb; intros; apply if_eq_dec. - Qed. + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with Eq => true | _ => false end. + Proof. + unfold eqb; intros; apply if_eq_dec. + Qed. -#[global] - Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb. - Proof. - intros x x' Hxx' y y' Hyy'. - rewrite 2 eqb_alt, Hxx', Hyy'; auto. - Qed. + #[global] + Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb. + Proof. + intros x x' Hxx' y y' Hyy'. + rewrite 2 eqb_alt, Hxx', Hyy'; auto. + Qed. End OrderedTypeFacts. @@ -243,32 +243,32 @@ End OrderedTypeTest. Module OrderedTypeRev (O:OrderedTypeFull) <: OrderedTypeFull. -Definition t := O.t. -Definition eq := O.eq. -#[global] -Program Instance eq_equiv : Equivalence eq. -Definition eq_dec := O.eq_dec. + Definition t := O.t. + Definition eq := O.eq. + #[global] + Program Instance eq_equiv : Equivalence eq. + Definition eq_dec := O.eq_dec. -Definition lt := flip O.lt. -Definition le := flip O.le. + Definition lt := flip O.lt. + Definition le := flip O.le. -#[global] -Instance lt_strorder: StrictOrder lt. -Proof. unfold lt; auto with *. Qed. -#[global] -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. unfold lt; auto with *. Qed. + #[global] + Instance lt_strorder: StrictOrder lt. + Proof. unfold lt; auto with *. Qed. + #[global] + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. unfold lt; auto with *. Qed. -Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. -Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition auto with relations. Qed. + Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. + Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition auto with relations. Qed. -Definition compare := flip O.compare. + Definition compare := flip O.compare. -Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). -Proof. -intros x y; unfold compare, eq, lt, flip. -destruct (O.compare_spec y x); auto with relations. -Qed. + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros x y; unfold compare, eq, lt, flip. + destruct (O.compare_spec y x); auto with relations. + Qed. End OrderedTypeRev. @@ -283,184 +283,184 @@ Unset Implicit Arguments. *) Module Type CompareBasedOrder (Import E:EqLtLe')(Import C:HasCmp E). - Include CmpNotation E C. - Include IsEq E. - Axiom compare_eq_iff : forall x y, (x ?= y) = Eq <-> x == y. - Axiom compare_lt_iff : forall x y, (x ?= y) = Lt <-> x < y. - Axiom compare_le_iff : forall x y, (x ?= y) <> Gt <-> x <= y. - Axiom compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y). + Include CmpNotation E C. + Include IsEq E. + Axiom compare_eq_iff : forall x y, (x ?= y) = Eq <-> x == y. + Axiom compare_lt_iff : forall x y, (x ?= y) = Lt <-> x < y. + Axiom compare_le_iff : forall x y, (x ?= y) <> Gt <-> x <= y. + Axiom compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y). End CompareBasedOrder. Module Type CompareBasedOrderFacts - (Import E:EqLtLe') - (Import C:HasCmp E) - (Import O:CompareBasedOrder E C). - - Lemma compare_spec x y : CompareSpec (x==y) (x x==y. - Proof. - apply compare_eq_iff. - Qed. - - Lemma compare_refl x : (x ?= x) = Eq. - Proof. - now apply compare_eq_iff. - Qed. - - Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y Lt <-> y<=x. - Proof. - now rewrite <- compare_le_iff, compare_antisym, CompOpp_iff. - Qed. - - Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y Lt <-> ~(x ~(x<=y). - Proof. - rewrite <- compare_le_iff. - destruct compare; split; easy || now destruct 1. - Qed. - - Lemma compare_nge_iff x y : (x ?= y) = Lt <-> ~(y<=x). - Proof. - now rewrite <- compare_nle_iff, compare_antisym, CompOpp_iff. - Qed. - - Lemma lt_irrefl x : ~ (x n < m \/ n==m. - Proof. - rewrite <- compare_lt_iff, <- compare_le_iff, <- compare_eq_iff. - destruct (n ?= m); now intuition. - Qed. + (Import E:EqLtLe') + (Import C:HasCmp E) + (Import O:CompareBasedOrder E C). + + Lemma compare_spec x y : CompareSpec (x==y) (x x==y. + Proof. + apply compare_eq_iff. + Qed. + + Lemma compare_refl x : (x ?= x) = Eq. + Proof. + now apply compare_eq_iff. + Qed. + + Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y Lt <-> y<=x. + Proof. + now rewrite <- compare_le_iff, compare_antisym, CompOpp_iff. + Qed. + + Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y Lt <-> ~(x ~(x<=y). + Proof. + rewrite <- compare_le_iff. + destruct compare; split; easy || now destruct 1. + Qed. + + Lemma compare_nge_iff x y : (x ?= y) = Lt <-> ~(y<=x). + Proof. + now rewrite <- compare_nle_iff, compare_antisym, CompOpp_iff. + Qed. + + Lemma lt_irrefl x : ~ (x n < m \/ n==m. + Proof. + rewrite <- compare_lt_iff, <- compare_le_iff, <- compare_eq_iff. + destruct (n ?= m); now intuition. + Qed. End CompareBasedOrderFacts. (** Basic facts about boolean comparisons *) Module Type BoolOrderFacts - (Import E:EqLtLe') - (Import C:HasCmp E) - (Import F:HasBoolOrdFuns' E) - (Import O:CompareBasedOrder E C) - (Import S:BoolOrdSpecs E F). + (Import E:EqLtLe') + (Import C:HasCmp E) + (Import F:HasBoolOrdFuns' E) + (Import O:CompareBasedOrder E C) + (Import S:BoolOrdSpecs E F). -Include CompareBasedOrderFacts E C O. + Include CompareBasedOrderFacts E C O. -(** Nota : apart from [eqb_compare] below, facts about [eqb] + (** Nota : apart from [eqb_compare] below, facts about [eqb] are in BoolEqualityFacts *) -(** Alternate specifications based on [BoolSpec] and [reflect] *) - -Lemma leb_spec0 x y : reflect (x<=y) (x<=?y). -Proof. - apply iff_reflect. symmetry. apply leb_le. -Defined. - -Lemma leb_spec x y : BoolSpec (x<=y) (y ~ (x <= y). -Proof. -now rewrite <- not_true_iff_false, leb_le. -Qed. - -Lemma leb_gt x y : (x <=? y) = false <-> y < x. -Proof. -now rewrite leb_nle, <- compare_lt_iff, compare_nge_iff. -Qed. - -Lemma ltb_nlt x y : (x ~ (x < y). -Proof. -now rewrite <- not_true_iff_false, ltb_lt. -Qed. - -Lemma ltb_ge x y : (x y <= x. -Proof. -now rewrite ltb_nlt, <- compare_le_iff, compare_ngt_iff. -Qed. - -(** Basic equality laws for boolean tests *) - -Lemma leb_refl x : (x <=? x) = true. -Proof. -apply leb_le. apply lt_eq_cases. now right. -Qed. - -Lemma leb_antisym x y : (y <=? x) = negb (x true | _ => false end. -Proof. -apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff. -now destruct compare. -Qed. - -Lemma ltb_compare x y : - (x true | _ => false end. -Proof. -apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff. -now destruct compare. -Qed. - -Lemma leb_compare x y : - (x <=? y) = match compare x y with Gt => false | _ => true end. -Proof. -apply eq_true_iff_eq. rewrite leb_le, <- compare_le_iff. -now destruct compare. -Qed. + (** Alternate specifications based on [BoolSpec] and [reflect] *) + + Lemma leb_spec0 x y : reflect (x<=y) (x<=?y). + Proof. + apply iff_reflect. symmetry. apply leb_le. + Defined. + + Lemma leb_spec x y : BoolSpec (x<=y) (y ~ (x <= y). + Proof. + now rewrite <- not_true_iff_false, leb_le. + Qed. + + Lemma leb_gt x y : (x <=? y) = false <-> y < x. + Proof. + now rewrite leb_nle, <- compare_lt_iff, compare_nge_iff. + Qed. + + Lemma ltb_nlt x y : (x ~ (x < y). + Proof. + now rewrite <- not_true_iff_false, ltb_lt. + Qed. + + Lemma ltb_ge x y : (x y <= x. + Proof. + now rewrite ltb_nlt, <- compare_le_iff, compare_ngt_iff. + Qed. + + (** Basic equality laws for boolean tests *) + + Lemma leb_refl x : (x <=? x) = true. + Proof. + apply leb_le. apply lt_eq_cases. now right. + Qed. + + Lemma leb_antisym x y : (y <=? x) = negb (x true | _ => false end. + Proof. + apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff. + now destruct compare. + Qed. + + Lemma ltb_compare x y : + (x true | _ => false end. + Proof. + apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff. + now destruct compare. + Qed. + + Lemma leb_compare x y : + (x <=? y) = match compare x y with Gt => false | _ => true end. + Proof. + apply eq_true_iff_eq. rewrite leb_le, <- compare_le_iff. + now destruct compare. + Qed. End BoolOrderFacts. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index bd15af00e1..0a5cb756f3 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -17,43 +17,43 @@ Unset Strict Implicit. Module OrderedTypeLists (O:OrderedType). -#[local] Notation In:=(InA O.eq). -#[local] Notation Inf:=(lelistA O.lt). -#[local] Notation Sort:=(sort O.lt). -#[local] Notation NoDup:=(NoDupA O.eq). + #[local] Notation In:=(InA O.eq). + #[local] Notation Inf:=(lelistA O.lt). + #[local] Notation Sort:=(sort O.lt). + #[local] Notation NoDup:=(NoDupA O.eq). -Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. -Proof. intros. rewrite <- H; auto. Qed. + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. intros. rewrite <- H; auto. Qed. -Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA O.eq_equiv). Qed. + Lemma ListIn_In : forall l x, List.In x l -> In x l. + Proof. exact (In_InA O.eq_equiv). Qed. -Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA O.lt_strorder). Qed. + Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l. + Proof. exact (InfA_ltA O.lt_strorder). Qed. -Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed. + Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l. + Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed. -Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x. -Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed. + Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x. + Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed. -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l. -Proof. exact (@In_InfA O.t O.lt). Qed. + Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l. + Proof. exact (@In_InfA O.t O.lt). Qed. -Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l. -Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed. + Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l. + Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed. -Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)). -Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. + Lemma Inf_alt : + forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)). + Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. -Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. + Lemma Sort_NoDup : forall l, Sort l -> NoDup l. + Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. -#[global] -Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. -#[global] -Hint Immediate In_eq Inf_lt : core. + #[global] + Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. + #[global] + Hint Immediate In_eq Inf_lt : core. End OrderedTypeLists. @@ -61,109 +61,109 @@ End OrderedTypeLists. (** * Results about keys and data as manipulated in the future MMaps. *) Module KeyOrderedType(O:OrderedType). - Include KeyDecidableType(O). (* provides eqk, eqke *) - - #[local] Notation key:=O.t. - #[local] Open Scope signature_scope. - - Definition ltk {elt} : relation (key*elt) := O.lt @@1. - - #[global] - Hint Unfold ltk : core. - - (* ltk is a strict order *) - -#[global] - Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _. - -#[global] - Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt). - Proof. unfold eqk, ltk; auto with *. Qed. - -#[global] - Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt). - Proof. eapply subrelation_proper; eauto with *. Qed. - - (* Additional facts *) - -#[global] - Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). - Proof. apply pair_compat. Qed. - - Section Elt. - Variable elt : Type. - Implicit Type p q : key*elt. - Implicit Type l m : list (key*elt). - - Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q. - Proof. - intros LT EQ; rewrite EQ in LT. - elim (StrictOrder_Irreflexive _ LT). - Qed. - - Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q. - Proof. - intros LT EQ; rewrite EQ in LT. - elim (StrictOrder_Irreflexive _ LT). - Qed. - - Notation Sort := (sort ltk). - Notation Inf := (lelistA ltk). - - Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l. - Proof. now intros <-. Qed. - - Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. - Proof. apply InfA_ltA; auto with *. Qed. - - #[local] - Hint Immediate Inf_eq : core. - #[local] - Hint Resolve Inf_lt : core. - - Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. apply SortA_InfA_InA; auto with *. Qed. - - Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l -> ~In k l. - Proof. - intros; red; intros. - destruct H1 as [e' H2]. - elim (@ltk_not_eqk (k,e) (k,e')). - - eapply Sort_Inf_In; eauto. - - repeat red; reflexivity. - Qed. - - Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l. - Proof. apply SortA_NoDupA; auto with *. Qed. - - Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q. - Proof. - intros; invlist sort; eapply Sort_Inf_In; eauto. - Qed. - - Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) -> - ltk p q \/ eqk p q. - Proof. - intros; invlist InA; auto with relations. - left; apply Sort_In_cons_1 with l; auto with relations. - Qed. - - Lemma Sort_In_cons_3 x l k e : - Sort ((k,e)::l) -> In x l -> ~O.eq x k. - Proof. - intros; invlist sort; red; intros. - eapply Sort_Inf_NotIn; eauto using In_eq. - Qed. - - End Elt. - - #[global] - Hint Resolve ltk_not_eqk ltk_not_eqke : core. - #[global] - Hint Immediate Inf_eq : core. - #[global] - Hint Resolve Inf_lt : core. - #[global] - Hint Resolve Sort_Inf_NotIn : core. + Include KeyDecidableType(O). (* provides eqk, eqke *) + + #[local] Notation key:=O.t. + #[local] Open Scope signature_scope. + + Definition ltk {elt} : relation (key*elt) := O.lt @@1. + + #[global] + Hint Unfold ltk : core. + + (* ltk is a strict order *) + + #[global] + Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _. + + #[global] + Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt). + Proof. unfold eqk, ltk; auto with *. Qed. + + #[global] + Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt). + Proof. eapply subrelation_proper; eauto with *. Qed. + + (* Additional facts *) + + #[global] + Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). + Proof. apply pair_compat. Qed. + + Section Elt. + Variable elt : Type. + Implicit Type p q : key*elt. + Implicit Type l m : list (key*elt). + + Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q. + Proof. + intros LT EQ; rewrite EQ in LT. + elim (StrictOrder_Irreflexive _ LT). + Qed. + + Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q. + Proof. + intros LT EQ; rewrite EQ in LT. + elim (StrictOrder_Irreflexive _ LT). + Qed. + + Notation Sort := (sort ltk). + Notation Inf := (lelistA ltk). + + Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l. + Proof. now intros <-. Qed. + + Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. + Proof. apply InfA_ltA; auto with *. Qed. + + #[local] + Hint Immediate Inf_eq : core. + #[local] + Hint Resolve Inf_lt : core. + + Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Proof. apply SortA_InfA_InA; auto with *. Qed. + + Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l -> ~In k l. + Proof. + intros; red; intros. + destruct H1 as [e' H2]. + elim (@ltk_not_eqk (k,e) (k,e')). + - eapply Sort_Inf_In; eauto. + - repeat red; reflexivity. + Qed. + + Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l. + Proof. apply SortA_NoDupA; auto with *. Qed. + + Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q. + Proof. + intros; invlist sort; eapply Sort_Inf_In; eauto. + Qed. + + Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) -> + ltk p q \/ eqk p q. + Proof. + intros; invlist InA; auto with relations. + left; apply Sort_In_cons_1 with l; auto with relations. + Qed. + + Lemma Sort_In_cons_3 x l k e : + Sort ((k,e)::l) -> In x l -> ~O.eq x k. + Proof. + intros; invlist sort; red; intros. + eapply Sort_Inf_NotIn; eauto using In_eq. + Qed. + + End Elt. + + #[global] + Hint Resolve ltk_not_eqk ltk_not_eqke : core. + #[global] + Hint Immediate Inf_eq : core. + #[global] + Hint Resolve Inf_lt : core. + #[global] + Hint Resolve Sort_Inf_NotIn : core. End KeyOrderedType. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index be3059f711..ddf50ce334 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -61,89 +61,89 @@ Module Type IsTotalOrder (O:EqLtLe) := (** ** Properties that will be used by the [order] tactic *) Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O). -Include EqLtLeNotation O. + Include EqLtLeNotation O. -(** Reflexivity rules *) + (** Reflexivity rules *) -Lemma eq_refl : forall x, x==x. -Proof. reflexivity. Qed. + Lemma eq_refl : forall x, x==x. + Proof. reflexivity. Qed. -Lemma le_refl : forall x, x<=x. -Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. + Lemma le_refl : forall x, x<=x. + Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. -Lemma lt_irrefl : forall x, ~ x y==x. -Proof. auto with *. Qed. + Lemma eq_sym : forall x y, x==y -> y==x. + Proof. auto with *. Qed. -Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y. -Proof. - intros x y; rewrite 2 P.le_lteq. intuition auto with relations. - elim (StrictOrder_Irreflexive x); transitivity y; auto. -Qed. + Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y. + Proof. + intros x y; rewrite 2 P.le_lteq. intuition auto with relations. + elim (StrictOrder_Irreflexive x); transitivity y; auto. + Qed. -Lemma neq_sym : forall x y, ~x==y -> ~y==x. -Proof. auto using eq_sym. Qed. + Lemma neq_sym : forall x y, ~x==y -> ~y==x. + Proof. auto using eq_sym. Qed. -(** Transitivity rules : first, a generic formulation, then instances*) + (** Transitivity rules : first, a generic formulation, then instances*) -Ltac subst_eqns := - match goal with - | H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns - | _ => idtac - end. + Ltac subst_eqns := + match goal with + | H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns + | _ => idtac + end. + + Definition interp_ord o := + match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end. + #[local] Notation "#" := interp_ord. + + Lemma trans o o' x y z : #o x y -> #o' y z -> #(o+o') x z. + Proof. + destruct o, o'; simpl; + rewrite ?P.le_lteq; intuition auto; + subst_eqns; pose proof (StrictOrder_Transitive x y z); eauto with *. + Qed. + + Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. + Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z. + Definition lt_trans x y z : x y x y x y<=z -> x y x y==z -> x y<=z -> x<=z := @trans OEQ OLE x y z. + Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z. + + Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z. + Proof. eauto using eq_trans, eq_sym. Qed. + + Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z. + Proof. eauto using eq_trans, eq_sym. Qed. + + (** (double) negation rules *) -Definition interp_ord o := - match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end. -#[local] Notation "#" := interp_ord. - -Lemma trans o o' x y z : #o x y -> #o' y z -> #(o+o') x z. -Proof. -destruct o, o'; simpl; -rewrite ?P.le_lteq; intuition auto; -subst_eqns; pose proof (StrictOrder_Transitive x y z); eauto with *. -Qed. - -Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. -Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z. -Definition lt_trans x y z : x y x y x y<=z -> x y x y==z -> x y<=z -> x<=z := @trans OEQ OLE x y z. -Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z. - -Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z. -Proof. eauto using eq_trans, eq_sym. Qed. - -Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z. -Proof. eauto using eq_trans, eq_sym. Qed. - -(** (double) negation rules *) - -Lemma not_neq_eq : forall x y, ~~x==y -> x==y. -Proof. -intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto; - destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. -Qed. - -Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. -Proof. -intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition. -Qed. - -Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x x==y. + Proof. + intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto; + destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. + Qed. + + Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. + Proof. + intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition. + Qed. + + Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x